From 1d176a09131e42d0a04e866c43fb2902ab22c957 Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Wed, 5 Sep 2018 09:33:34 -0400 Subject: [PATCH 1/3] [CDEC-509] Remove HasCoreConfiguration and dbSerializeVersion --- auxx/Main.hs | 18 ++- auxx/src/Mode.hs | 21 ++- client/src/Pos/Client/Txp/Util.hs | 6 +- client/test/Test/Pos/Client/Txp/Mode.hs | 17 +-- client/test/Test/Pos/Client/Txp/UtilSpec.hs | 39 ++---- core/src/Pos/Core/Configuration.hs | 128 ++++++++---------- core/src/Pos/Core/Configuration/Core.hs | 22 --- core/test/Test/Pos/Core/CborSpec.hs | 4 +- core/test/Test/Pos/Core/Dummy.hs | 36 ++--- db/src/Pos/DB/Block/GState/BlockExtra.hs | 14 +- db/src/Pos/DB/BlockIndex.hs | 5 +- db/src/Pos/DB/Class.hs | 5 +- db/src/Pos/DB/Delegation/Core.hs | 15 +- db/src/Pos/DB/Functions.hs | 79 ++--------- db/src/Pos/DB/GState/Common.hs | 11 +- db/src/Pos/DB/Lrc/Common.hs | 8 +- db/src/Pos/DB/Pure.hs | 3 +- db/src/Pos/DB/Rocks/Functions.hs | 11 +- db/src/Pos/DB/Ssc/GState.hs | 7 +- db/src/Pos/DB/Ssc/Logic/VAR.hs | 6 +- db/src/Pos/DB/Sum.hs | 2 - db/src/Pos/DB/Txp/Logic/Global.hs | 6 +- db/src/Pos/DB/Txp/Stakes.hs | 15 +- db/src/Pos/DB/Txp/Utxo.hs | 11 +- db/src/Pos/DB/Update/GState.hs | 25 ++-- db/src/Pos/DB/Update/Logic/Global.hs | 29 ++-- db/test/Test/Pos/DB/Functions.hs | 50 ++++--- db/test/Test/Pos/DB/Mode.hs | 6 +- explorer/src/Pos/Explorer/BListener.hs | 6 +- explorer/src/Pos/Explorer/DB.hs | 22 +-- explorer/src/Pos/Explorer/ExplorerMode.hs | 6 +- explorer/src/Pos/Explorer/Txp/Global.hs | 4 +- explorer/src/Pos/Explorer/Web/Transform.hs | 11 +- explorer/src/explorer/Main.hs | 6 +- generator/app/VerificationBench.hs | 37 ++--- .../bench/Bench/Pos/Criterion/Block/Logic.hs | 2 +- generator/src/Pos/Generator/Block/Mode.hs | 7 +- generator/src/Test/Pos/Block/Logic/Mode.hs | 49 +++---- .../test/Test/Pos/Block/Logic/VarSpec.hs | 8 +- generator/test/Test/Pos/Block/Property.hs | 4 +- .../test/Test/Pos/Generator/Block/LrcSpec.hs | 2 +- lib/src/Pos/Client/CLI/Util.hs | 86 +----------- lib/src/Pos/Launcher/Configuration.hs | 105 ++++++++++++-- lib/src/Pos/Launcher/Mode.hs | 6 +- lib/src/Pos/Launcher/Resource.hs | 10 +- lib/src/Pos/Logic/Full.hs | 7 +- lib/src/Pos/Web/Mode.hs | 5 +- lib/src/Pos/Web/Server.hs | 7 +- lib/src/Pos/WorkMode.hs | 10 +- lib/src/Pos/WorkMode/Class.hs | 3 +- lib/src/Test/Pos/Configuration.hs | 6 +- lib/test/Test/Pos/Block/CborSpec.hs | 5 +- .../Test/Pos/Launcher/ConfigurationSpec.hs | 3 +- lib/test/Test/Pos/Ssc/VssCertDataSpec.hs | 7 +- node/Main.hs | 16 ++- tools/src/Pos/Tools/Dbgen/Lib.hs | 2 +- tools/src/blockchain-analyser/Main.hs | 17 +-- tools/src/blockchain-analyser/Types.hs | 3 +- tools/src/dbgen/Main.hs | 2 +- tools/src/keygen/Main.hs | 23 ++-- tools/src/launcher/Main.hs | 11 +- wallet-new/server/Main.hs | 52 ++++--- .../Wallet/API/Internal/LegacyHandlers.hs | 3 +- .../Wallet/API/V1/LegacyHandlers/Accounts.hs | 4 +- .../Wallet/API/V1/LegacyHandlers/Info.hs | 4 +- .../Wallet/API/V1/LegacyHandlers/Wallets.hs | 3 +- .../src/Cardano/Wallet/API/V1/Migration.hs | 2 - .../Cardano/Wallet/API/WIP/LegacyHandlers.hs | 6 +- wallet-new/src/Cardano/Wallet/Kernel/Mode.hs | 11 +- .../Cardano/Wallet/Kernel/NodeStateAdaptor.hs | 4 +- .../Cardano/Wallet/Server/LegacyPlugins.hs | 4 +- wallet-new/test/unit/UTxO/Interpreter.hs | 7 +- wallet-new/test/unit/UTxO/Translate.hs | 7 +- .../test/unit/Wallet/Inductive/Cardano.hs | 6 +- wallet/src/Pos/Wallet/Redirect.hs | 5 +- wallet/src/Pos/Wallet/Web/Methods/Logic.hs | 2 - wallet/src/Pos/Wallet/Web/Methods/Misc.hs | 6 +- wallet/src/Pos/Wallet/Web/Methods/Payment.hs | 3 +- wallet/src/Pos/Wallet/Web/Mode.hs | 28 ++-- wallet/src/Pos/Wallet/Web/Pending/Worker.hs | 2 - wallet/src/Pos/Wallet/Web/Server/Runner.hs | 2 +- wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs | 2 - wallet/src/Pos/Wallet/Web/Tracking/Types.hs | 2 - .../test/Test/Pos/Wallet/Web/AddressSpec.hs | 7 +- .../Test/Pos/Wallet/Web/Methods/LogicSpec.hs | 3 +- .../Pos/Wallet/Web/Methods/PaymentSpec.hs | 2 +- wallet/test/Test/Pos/Wallet/Web/Mode.hs | 45 +++--- wallet/test/Test/Pos/Wallet/Web/Util.hs | 16 +-- 88 files changed, 537 insertions(+), 798 deletions(-) diff --git a/auxx/Main.hs b/auxx/Main.hs index 163988028ec..033b763763c 100644 --- a/auxx/Main.hs +++ b/auxx/Main.hs @@ -92,21 +92,25 @@ action opts@AuxxOptions {..} command = do -> handle @_ @ConfigurationException (\_ -> runWithoutNode pa) . handle @_ @ConfigurationError (\_ -> runWithoutNode pa) - $ withConfigurations Nothing conf (runWithConfig pa) + $ withConfigurations Nothing + cnaDumpGenesisDataPath + cnaDumpConfiguration + conf + (runWithConfig pa) Light -> runWithoutNode pa - _ -> withConfigurations Nothing conf (runWithConfig pa) + _ -> withConfigurations Nothing + cnaDumpGenesisDataPath + cnaDumpConfiguration + conf + (runWithConfig pa) where runWithoutNode :: PrintAction IO -> IO () runWithoutNode printAction = printAction "Mode: light" >> rawExec Nothing Nothing Nothing opts Nothing command runWithConfig :: HasConfigurations => PrintAction IO -> Core.Config -> TxpConfiguration -> NtpConfiguration -> IO () - runWithConfig printAction coreConfig txpConfig ntpConfig = do + runWithConfig printAction coreConfig txpConfig _ntpConfig = do printAction "Mode: with-config" - CLI.printInfoOnStart aoCommonNodeArgs - (configGenesisData coreConfig) - ntpConfig - txpConfig (nodeParams, tempDbUsed) <- (correctNodeParams opts . fst) =<< CLI.getNodeParams loggerName cArgs diff --git a/auxx/src/Mode.hs b/auxx/src/Mode.hs index f9f1b674c48..e18bc181700 100644 --- a/auxx/src/Mode.hs +++ b/auxx/src/Mode.hs @@ -39,10 +39,9 @@ import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) import Pos.Context (HasNodeContext (..)) -import Pos.Core (Address, HasConfiguration, HasPrimaryKey (..), - IsBootstrapEraAddr (..), SlotCount, deriveFirstHDAddress, - largestPubKeyAddressBoot, largestPubKeyAddressSingleKey, - makePubKeyAddress, siEpoch) +import Pos.Core (Address, HasPrimaryKey (..), IsBootstrapEraAddr (..), + SlotCount, deriveFirstHDAddress, largestPubKeyAddressBoot, + largestPubKeyAddressSingleKey, makePubKeyAddress, siEpoch) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), MonadReporting (..)) @@ -180,7 +179,7 @@ instance {-# OVERLAPPING #-} HasLoggerName AuxxMode where instance {-# OVERLAPPING #-} CanJsonLog AuxxMode where jsonLog = realModeToAuxx ... jsonLog -instance HasConfiguration => MonadDBRead AuxxMode where +instance MonadDBRead AuxxMode where dbGet = realModeToAuxx ... dbGet dbIterSource tag p = transPipe (transResourceT realModeToAuxx) (dbIterSource tag p) @@ -188,27 +187,26 @@ instance HasConfiguration => MonadDBRead AuxxMode where dbGetSerUndo = realModeToAuxx ... dbGetSerUndo dbGetSerBlund = realModeToAuxx ... dbGetSerBlund -instance HasConfiguration => MonadDB AuxxMode where +instance MonadDB AuxxMode where dbPut = realModeToAuxx ... dbPut dbWriteBatch = realModeToAuxx ... dbWriteBatch dbDelete = realModeToAuxx ... dbDelete dbPutSerBlunds = realModeToAuxx ... dbPutSerBlunds -instance HasConfiguration => MonadGState AuxxMode where +instance MonadGState AuxxMode where gsAdoptedBVData = realModeToAuxx ... gsAdoptedBVData instance MonadBListener AuxxMode where onApplyBlocks = realModeToAuxx ... onApplyBlocks onRollbackBlocks = realModeToAuxx ... onRollbackBlocks -instance HasConfiguration => MonadBalances AuxxMode where +instance MonadBalances AuxxMode where getOwnUtxos genesisData addrs = ifM isTempDbUsed (getOwnUtxosGenesis genesisData addrs) (getFilteredUtxo addrs) getBalance = getBalanceFromUtxo -instance HasConfiguration => - MonadTxHistory AuxxMode where +instance MonadTxHistory AuxxMode where getBlockHistory = getBlockHistoryDefault getLocalHistory = getLocalHistoryDefault saveTx = saveTxDefault @@ -233,8 +231,7 @@ instance MonadKeys AuxxMode where type instance MempoolExt AuxxMode = EmptyMempoolExt -instance HasConfiguration => - MonadTxpLocal AuxxMode where +instance MonadTxpLocal AuxxMode where txpNormalize pm = withReaderT acRealModeContext . txNormalize pm txpProcessTx coreConfig txpConfig = withReaderT acRealModeContext . txProcessTransaction coreConfig txpConfig diff --git a/client/src/Pos/Client/Txp/Util.hs b/client/src/Pos/Client/Txp/Util.hs index 63b30204889..667e585838a 100644 --- a/client/src/Pos/Client/Txp/Util.hs +++ b/client/src/Pos/Client/Txp/Util.hs @@ -76,7 +76,6 @@ import Pos.Core as Core (Address, Coin, Config (..), SlotCount, integerToCoin, isRedeemAddress, mkCoin, sumCoins, txSizeLinearMinValue, unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Attributes (mkAttributes) -import Pos.Core.Configuration (HasConfiguration) import Pos.Core.Update (bvdTxFeePolicy) import Pos.Crypto (ProtocolMagic, RedeemSecretKey, SafeSigner, SignTag (SignRedeemTx, SignTx), deterministicKeyGen, @@ -217,10 +216,7 @@ instance Arbitrary InputSelectionPolicy where arbitrary = elements [minBound .. maxBound] -- | Mode for creating transactions. We need to know fee policy. -type TxDistrMode m - = ( MonadGState m - , HasConfiguration - ) +type TxDistrMode m = MonadGState m type TxCreateMode m = ( TxDistrMode m diff --git a/client/test/Test/Pos/Client/Txp/Mode.hs b/client/test/Test/Pos/Client/Txp/Mode.hs index 3a4cdf58b2d..3a9b9170bad 100644 --- a/client/test/Test/Pos/Client/Txp/Mode.hs +++ b/client/test/Test/Pos/Client/Txp/Mode.hs @@ -7,7 +7,6 @@ module Test.Pos.Client.Txp.Mode ( TxpTestProperty , TxpTestMode - , HasTxpConfigurations , withBVData ) where @@ -17,28 +16,14 @@ import qualified Data.ByteString as BS import Test.QuickCheck (Testable (..), ioProperty) import Test.QuickCheck.Monadic (PropertyM, monadic) -import Pos.Chain.Ssc (HasSscConfiguration) -import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Client.Txp.Addresses (MonadAddresses (..)) -import Pos.Configuration (HasNodeConfiguration) -import Pos.Core (Address, HasConfiguration, makePubKeyAddressBoot) +import Pos.Core (Address, makePubKeyAddressBoot) import Pos.Core.Update (BlockVersionData) import Pos.Crypto (deterministicKeyGen) import Pos.DB (MonadGState (..)) import Test.Pos.Core.Dummy (dummyBlockVersionData) ----------------------------------------------------------------------------- --- Configuration propagation ----------------------------------------------------------------------------- - -type HasTxpConfigurations = - ( HasNodeConfiguration - , HasSscConfiguration - , HasConfiguration - , HasUpdateConfiguration - ) - ---------------------------------------------------------------------------- -- Mock for TxCreateMode ---------------------------------------------------------------------------- diff --git a/client/test/Test/Pos/Client/Txp/UtilSpec.hs b/client/test/Test/Pos/Client/Txp/UtilSpec.hs index e578a4eab06..7f51758b91f 100644 --- a/client/test/Test/Pos/Client/Txp/UtilSpec.hs +++ b/client/test/Test/Pos/Client/Txp/UtilSpec.hs @@ -36,8 +36,8 @@ import Pos.Crypto (RedeemSecretKey, SafeSigner, SecretKey, decodeHash, import Pos.DB (gsAdoptedBVData) import Pos.Util.Util (leftToPanic) -import Test.Pos.Client.Txp.Mode (HasTxpConfigurations, TxpTestMode, - TxpTestProperty, withBVData) +import Test.Pos.Client.Txp.Mode (TxpTestMode, TxpTestProperty, + withBVData) import Test.Pos.Configuration (withDefConfigurations) import Test.Pos.Core.Dummy (dummyConfig) import Test.Pos.Crypto.Arbitrary () @@ -59,7 +59,7 @@ spec = withDefConfigurations $ \_ _ _ -> data TestFunctionWrapper = forall prop. (Testable prop) => TestFunctionWrapper (InputSelectionPolicy -> prop) -createMTxSpec :: HasTxpConfigurations => Spec +createMTxSpec :: Spec createMTxSpec = do let inputSelectionPolicies = [ ("Grouped inputs", OptimizeForSecurity) @@ -114,16 +114,14 @@ createMTxSpec = do "The amount of used inputs is as small as possible" testCreateMTx - :: HasTxpConfigurations - => CreateMTxParams + :: CreateMTxParams -> TxpTestProperty (Either TxError (TxAux, NonEmpty TxOut)) testCreateMTx CreateMTxParams {..} = lift $ createMTx dummyConfig mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) cmpOutputs cmpAddrData createMTxWorksWhenWeAreRichSpec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () createMTxWorksWhenWeAreRichSpec inputSelectionPolicy = forAllM gen $ \txParams@CreateMTxParams{..} -> do @@ -135,8 +133,7 @@ createMTxWorksWhenWeAreRichSpec inputSelectionPolicy = gen = makeManyAddressesToManyParams inputSelectionPolicy 1 1000000 1 1 stabilizationDoesNotFailSpec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () stabilizationDoesNotFailSpec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do @@ -149,8 +146,7 @@ stabilizationDoesNotFailSpec inputSelectionPolicy = do gen = makeManyAddressesToManyParams inputSelectionPolicy 1 200000 1 1 feeIsNonzeroSpec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () feeIsNonzeroSpec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do @@ -165,8 +161,7 @@ feeIsNonzeroSpec inputSelectionPolicy = do gen = makeManyAddressesToManyParams inputSelectionPolicy 1 100000 1 1 manyUtxoTo1Spec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () manyUtxoTo1Spec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do @@ -178,8 +173,7 @@ manyUtxoTo1Spec inputSelectionPolicy = do gen = makeManyUtxoTo1Params inputSelectionPolicy 10 100000 1 manyAddressesTo1Spec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () manyAddressesTo1Spec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do @@ -191,8 +185,7 @@ manyAddressesTo1Spec inputSelectionPolicy = do gen = makeManyAddressesToManyParams inputSelectionPolicy 10 100000 1 1 manyAddressesToManySpec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () manyAddressesToManySpec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do @@ -203,7 +196,7 @@ manyAddressesToManySpec inputSelectionPolicy = do where gen = makeManyAddressesToManyParams inputSelectionPolicy 10 100000 10 1 -redemptionSpec :: HasTxpConfigurations => TxpTestProperty () +redemptionSpec :: TxpTestProperty () redemptionSpec = do forAllM genParams $ \(CreateRedemptionTxParams {..}) -> do txOrError <- createRedemptionTx dummyProtocolMagic crpUtxo crpRsk crpOutputs @@ -223,8 +216,7 @@ redemptionSpec = do pure CreateRedemptionTxParams {..} txWithRedeemOutputFailsSpec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> TxpTestProperty () txWithRedeemOutputFailsSpec inputSelectionPolicy = do forAllM genParams $ \(CreateMTxParams {..}) -> do @@ -244,8 +236,7 @@ txWithRedeemOutputFailsSpec inputSelectionPolicy = do pure params{ cmpOutputs = one txOutAuxOutput } feeForManyAddressesSpec - :: HasTxpConfigurations - => InputSelectionPolicy + :: InputSelectionPolicy -> Bool -> TxpTestProperty () feeForManyAddressesSpec inputSelectionPolicy manyAddrs = @@ -288,7 +279,7 @@ feeForManyAddressesSpec inputSelectionPolicy manyAddrs = | otherwise = makeManyUtxoTo1Params inputSelectionPolicy -groupedPolicySpec :: HasTxpConfigurations => TxpTestProperty () +groupedPolicySpec :: TxpTestProperty () groupedPolicySpec = forAllM gen $ testCreateMTx >=> \case Left err -> stopProperty $ pretty err @@ -300,7 +291,7 @@ groupedPolicySpec = utxoNum = 10 gen = makeManyUtxoTo1Params OptimizeForSecurity (fromIntegral utxoNum) 1000000 1 -ungroupedPolicySpec :: HasTxpConfigurations => TxpTestProperty () +ungroupedPolicySpec :: TxpTestProperty () ungroupedPolicySpec = forAllM gen $ testCreateMTx >=> \case Left err -> stopProperty $ pretty err diff --git a/core/src/Pos/Core/Configuration.hs b/core/src/Pos/Core/Configuration.hs index c159b8f4b1f..45f1c9107c9 100644 --- a/core/src/Pos/Core/Configuration.hs +++ b/core/src/Pos/Core/Configuration.hs @@ -24,9 +24,8 @@ module Pos.Core.Configuration , configFtsSeed , ConfigurationError (..) - , HasConfiguration , withCoreConfigurations - , withGenesisSpec + , mkConfig , canonicalGenesisJson , prettyGenesisJson @@ -134,9 +133,6 @@ configAvvmDistr = gdAvvmDistr . configGenesisData configFtsSeed :: Config -> SharedSeed configFtsSeed = gdFtsSeed . configGenesisData --- | Coarse catch-all configuration constraint for use by depending modules. -type HasConfiguration = HasCoreConfiguration - canonicalGenesisJson :: GenesisData -> (BSL.ByteString, Hash Raw) canonicalGenesisJson theGenesisData = (canonicalJsonBytes, jsonHash) where @@ -162,12 +158,8 @@ prettyGenesisJson theGenesisData = -- If the configuration gives a testnet genesis spec, then a start time must -- be provided, probably sourced from command line arguments. withCoreConfigurations - :: forall m r. - ( MonadThrow m - , MonadIO m - ) + :: (MonadThrow m, MonadIO m) => CoreConfiguration - -> (GenesisData -> GenesisData) -- ^ Update @'GenesisData'@ before passing its parts to @'given'@. -> FilePath -- ^ Directory where 'configuration.yaml' is stored. @@ -177,9 +169,8 @@ withCoreConfigurations -> Maybe Integer -- ^ Optional seed which overrides one from testnet initializer if -- provided. - -> (HasConfiguration => Config -> m r) - -> m r -withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed act = case ccGenesis of + -> m Config +withCoreConfigurations conf confDir mSystemStart mSeed = case ccGenesis conf of -- If a 'GenesisData' source file is given, we check its hash against the -- given expected hash, parse it, and use the GenesisData to fill in all of -- the obligations. @@ -196,7 +187,7 @@ withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed theGenesisData <- case Canonical.fromJSON gdataJSON of Left err -> throwM $ GenesisDataSchemaError err - Right it -> return $ fn it + Right it -> return it let (_, theGenesisHash) = canonicalGenesisJson theGenesisData pc = genesisProtocolConstantsToProtocolConstants (gdProtocolConsts theGenesisData) @@ -205,15 +196,13 @@ withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed throwM $ GenesisHashMismatch (show theGenesisHash) (show expectedHash) - withCoreConfiguration conf $ - act $ - Config - { configProtocolMagic = pm - , configProtocolConstants = pc - , configGeneratedSecrets = Nothing - , configGenesisData = theGenesisData - , configGenesisHash = GenesisHash $ coerce theGenesisHash - } + pure $ Config + { configProtocolMagic = pm + , configProtocolConstants = pc + , configGeneratedSecrets = Nothing + , configGenesisData = theGenesisData + , configGenesisHash = GenesisHash $ coerce theGenesisHash + } -- If a 'GenesisSpec' is given, we ensure we have a start time (needed if -- it's a testnet initializer) and then make a 'GenesisData' from it. @@ -234,58 +223,51 @@ withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed { gsInitializer = overrideSeed newSeed (gsInitializer spec) } - let theConf = conf {ccGenesis = GCSpec theSpec} - - withGenesisSpec theSystemStart theConf fn act + pure $ mkConfig theSystemStart theSpec -withGenesisSpec +mkConfig :: Timestamp - -> CoreConfiguration - -> (GenesisData -> GenesisData) - -> (HasConfiguration => Config -> r) - -> r -withGenesisSpec theSystemStart conf@CoreConfiguration{..} fn val = case ccGenesis of - GCSrc {} -> error "withGenesisSpec called with GCSrc" - GCSpec spec -> - let - -- Generate - GeneratedGenesisData {..} = - generateGenesisData pm pc (gsInitializer spec) (gsAvvmDistr spec) - - -- Unite with generated - finalHeavyDelegation :: GenesisDelegation - finalHeavyDelegation = - leftToPanic "withGenesisSpec" $ mkGenesisDelegation $ - (toList $ gsHeavyDelegation spec) <> toList ggdDelegation - - -- Construct the final value - theGenesisData = fn $ - GenesisData - { gdBootStakeholders = ggdBootStakeholders - , gdHeavyDelegation = finalHeavyDelegation - , gdStartTime = theSystemStart - , gdVssCerts = ggdVssCerts - , gdNonAvvmBalances = ggdNonAvvm - , gdBlockVersionData = gsBlockVersionData spec - , gdProtocolConsts = gsProtocolConstants spec - , gdAvvmDistr = ggdAvvm - , gdFtsSeed = gsFtsSeed spec - } - -- Anything will do for the genesis hash. A hash of "patak" was used - -- before, and so it remains. - theGenesisHash = GenesisHash $ coerce $ unsafeHash @Text "patak" - in withCoreConfiguration conf $ - val $ - Config - { configProtocolMagic = pm - , configProtocolConstants = pc - , configGeneratedSecrets = Just ggdSecrets - , configGenesisData = theGenesisData - , configGenesisHash = theGenesisHash - } - where - pm = gpcProtocolMagic (gsProtocolConstants spec) - pc = genesisProtocolConstantsToProtocolConstants (gsProtocolConstants spec) + -> GenesisSpec + -> Config +mkConfig theSystemStart spec = Config + { configProtocolMagic = pm + , configProtocolConstants = pc + , configGeneratedSecrets = Just ggdSecrets + , configGenesisData = genesisData + , configGenesisHash = genesisHash + } + where + pm = gpcProtocolMagic (gsProtocolConstants spec) + pc = genesisProtocolConstantsToProtocolConstants (gsProtocolConstants spec) + + -- Generate + GeneratedGenesisData {..} = + generateGenesisData pm pc (gsInitializer spec) (gsAvvmDistr spec) + + -- Unite with generated + finalHeavyDelegation :: GenesisDelegation + finalHeavyDelegation = + leftToPanic "mkConfig" + $ mkGenesisDelegation + $ (toList $ gsHeavyDelegation spec) + <> toList ggdDelegation + + -- Construct the final value + genesisData = GenesisData + { gdBootStakeholders = ggdBootStakeholders + , gdHeavyDelegation = finalHeavyDelegation + , gdStartTime = theSystemStart + , gdVssCerts = ggdVssCerts + , gdNonAvvmBalances = ggdNonAvvm + , gdBlockVersionData = gsBlockVersionData spec + , gdProtocolConsts = gsProtocolConstants spec + , gdAvvmDistr = ggdAvvm + , gdFtsSeed = gsFtsSeed spec + } + + -- Anything will do for the genesis hash. A hash of "patak" was used + -- before, and so it remains. + genesisHash = GenesisHash $ coerce $ unsafeHash @Text "patak" data ConfigurationError = -- | A system start time must be given when a testnet genesis is used. diff --git a/core/src/Pos/Core/Configuration/Core.hs b/core/src/Pos/Core/Configuration/Core.hs index b0c285d9350..5a97b95f16e 100644 --- a/core/src/Pos/Core/Configuration/Core.hs +++ b/core/src/Pos/Core/Configuration/Core.hs @@ -1,19 +1,11 @@ {-# LANGUAGE NumDecimals #-} {-# LANGUAGE Rank2Types #-} --- | Global constants, configurable via Data.Reflection. - module Pos.Core.Configuration.Core ( -- * The configuration structure CoreConfiguration(..) , GenesisConfiguration(..) - - , HasCoreConfiguration - , withCoreConfiguration - - , coreConfiguration - , dbSerializeVersion ) where import Prelude @@ -27,7 +19,6 @@ import Data.Aeson.TH (deriveJSON) import Data.Aeson.Types (typeMismatch) import qualified Data.HashMap.Strict as HM import Data.Monoid ((<>)) -import Data.Reflection (Given (..), give) import Pos.Binary.Class (Raw) import Pos.Core.Genesis (GenesisAvvmBalances (..), @@ -119,16 +110,3 @@ data CoreConfiguration = CoreConfiguration deriving (Show, Generic) deriveJSON defaultOptions ''CoreConfiguration - -type HasCoreConfiguration = Given CoreConfiguration - -withCoreConfiguration :: CoreConfiguration -> (HasCoreConfiguration => r) -> r -withCoreConfiguration = give - -coreConfiguration :: HasCoreConfiguration => CoreConfiguration -coreConfiguration = given - --- | DB format version. When serializing items into the node's DB, the values are paired --- with this constant. -dbSerializeVersion :: HasCoreConfiguration => Word8 -dbSerializeVersion = fromIntegral . ccDbSerializeVersion $ coreConfiguration diff --git a/core/test/Test/Pos/Core/CborSpec.hs b/core/test/Test/Pos/Core/CborSpec.hs index 1c90f95e456..4518eb8d0bd 100644 --- a/core/test/Test/Pos/Core/CborSpec.hs +++ b/core/test/Test/Pos/Core/CborSpec.hs @@ -33,7 +33,6 @@ import Pos.Core.Merkle (MerkleTree) import Test.Pos.Binary.Helpers (binaryTest) import Test.Pos.Core.Arbitrary () import Test.Pos.Core.Chrono () -import Test.Pos.Core.Dummy (dummyCoreConfiguration) import Test.Pos.Crypto.Arbitrary () @@ -84,8 +83,7 @@ instance Bi (Attributes X2) where spec :: Spec -spec = withGenesisSpec 0 dummyCoreConfiguration id $ \_ -> - describe "Cbor Bi instances" $ do +spec = describe "Cbor Bi instances" $ do describe "Core.Address" $ do binaryTest @Address binaryTest @Address' diff --git a/core/test/Test/Pos/Core/Dummy.hs b/core/test/Test/Pos/Core/Dummy.hs index dd082f18b6b..ceebd1224fe 100644 --- a/core/test/Test/Pos/Core/Dummy.hs +++ b/core/test/Test/Pos/Core/Dummy.hs @@ -26,15 +26,13 @@ module Test.Pos.Core.Dummy import Universum -import Data.Coerce (coerce) - import Pos.Core (BlockCount, Coeff (..), Config (..), CoreConfiguration (..), EpochIndex (..), GenesisConfiguration (..), GenesisHash (..), ProtocolConstants (..), SharedSeed (..), SlotCount, Timestamp, TxFeePolicy (..), TxSizeLinear (..), VssMaxTTL (..), VssMinTTL (..), kEpochSlots, - kSlotSecurityParam, pcBlkSecurityParam, + kSlotSecurityParam, mkConfig, pcBlkSecurityParam, unsafeCoinPortionFromDouble) import Pos.Core.Genesis (FakeAvvmOptions (..), GeneratedGenesisData (..), GeneratedSecrets (..), @@ -46,7 +44,7 @@ import Pos.Core.Genesis (FakeAvvmOptions (..), gsSecretKeys, gsSecretKeysPoor, gsSecretKeysRich, noGenesisDelegation) import Pos.Core.Update (BlockVersionData (..), SoftforkRule (..)) -import Pos.Crypto (SecretKey, unsafeHash) +import Pos.Crypto (SecretKey) import Test.Pos.Crypto.Dummy (dummyProtocolMagic) @@ -54,13 +52,7 @@ dummyConfig :: Config dummyConfig = dummyConfigStartTime 0 dummyConfigStartTime :: Timestamp -> Config -dummyConfigStartTime systemStart = Config - { configProtocolMagic = dummyProtocolMagic - , configProtocolConstants = dummyProtocolConstants - , configGeneratedSecrets = Just dummyGeneratedSecrets - , configGenesisData = dummyGenesisDataStartTime systemStart - , configGenesisHash = dummyGenesisHash - } +dummyConfigStartTime = flip mkConfig dummyGenesisSpec dummyProtocolConstants :: ProtocolConstants dummyProtocolConstants = ProtocolConstants @@ -103,7 +95,11 @@ dummyGenesisSecretKeysPoor :: [SecretKey] dummyGenesisSecretKeysPoor = gsSecretKeysPoor dummyGeneratedSecrets dummyCoreConfiguration :: CoreConfiguration -dummyCoreConfiguration = CoreConfiguration (GCSpec dummyGenesisSpec) 0 +dummyCoreConfiguration = + CoreConfiguration (GCSpec dummyGenesisSpec) dummyDbSerializeVersion + +dummyDbSerializeVersion :: Word8 +dummyDbSerializeVersion = 0 dummyGenesisSpec :: GenesisSpec dummyGenesisSpec = UnsafeGenesisSpec @@ -151,20 +147,10 @@ dummyGenesisInitializer = GenesisInitializer 0 dummyGenesisData :: GenesisData -dummyGenesisData = dummyGenesisDataStartTime 0 +dummyGenesisData = configGenesisData dummyConfig dummyGenesisDataStartTime :: Timestamp -> GenesisData -dummyGenesisDataStartTime systemStart = GenesisData - { gdBootStakeholders = ggdBootStakeholders dummyGeneratedGenesisData - , gdHeavyDelegation = ggdDelegation dummyGeneratedGenesisData - , gdStartTime = systemStart - , gdVssCerts = ggdVssCerts dummyGeneratedGenesisData - , gdNonAvvmBalances = ggdNonAvvm dummyGeneratedGenesisData - , gdBlockVersionData = dummyBlockVersionData - , gdProtocolConsts = gsProtocolConstants dummyGenesisSpec - , gdAvvmDistr = ggdAvvm dummyGeneratedGenesisData - , gdFtsSeed = dummyFtsSeed - } +dummyGenesisDataStartTime = configGenesisData . dummyConfigStartTime dummyGenesisHash :: GenesisHash -dummyGenesisHash = GenesisHash $ coerce $ unsafeHash @Text "patak" +dummyGenesisHash = configGenesisHash dummyConfig diff --git a/db/src/Pos/DB/Block/GState/BlockExtra.hs b/db/src/Pos/DB/Block/GState/BlockExtra.hs index 2cfcfee19b1..1549d05a7d1 100644 --- a/db/src/Pos/DB/Block/GState/BlockExtra.hs +++ b/db/src/Pos/DB/Block/GState/BlockExtra.hs @@ -29,12 +29,12 @@ 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, GenesisHash (..), HasCoreConfiguration, - SlotCount, slotIdF, unflattenSlotId) +import Pos.Core (FlatSlotId, GenesisHash (..), SlotCount, slotIdF, + unflattenSlotId) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Crypto (shortHashF) import Pos.DB (DBError (..), MonadDB, MonadDBRead (..), - RocksBatchOp (..), dbSerializeValue, getHeader) + RocksBatchOp (..), getHeader) import Pos.DB.Class (MonadBlockDBRead, SerializedBlock, getBlock) import Pos.DB.GState.Common (gsGetBi, gsPutBi) import Pos.Util.Util (maybeThrow) @@ -99,17 +99,17 @@ buildBlockExtraOp epochSlots = later build' bprint ("SetLastSlots: "%listJson) (map (bprint slotIdF . unflattenSlotId epochSlots) slots) -instance HasCoreConfiguration => RocksBatchOp BlockExtraOp where +instance RocksBatchOp BlockExtraOp where toBatchOp (AddForwardLink from to) = - [Rocks.Put (forwardLinkKey from) (dbSerializeValue to)] + [Rocks.Put (forwardLinkKey from) (serialize' to)] toBatchOp (RemoveForwardLink from) = [Rocks.Del $ forwardLinkKey from] toBatchOp (SetInMainChain False h) = [Rocks.Del $ mainChainKey h] toBatchOp (SetInMainChain True h) = - [Rocks.Put (mainChainKey h) (dbSerializeValue ()) ] + [Rocks.Put (mainChainKey h) (serialize' ()) ] toBatchOp (SetLastSlots slots) = - [Rocks.Put lastSlotsKey (dbSerializeValue slots)] + [Rocks.Put lastSlotsKey (serialize' slots)] ---------------------------------------------------------------------------- -- Loops on forward links diff --git a/db/src/Pos/DB/BlockIndex.hs b/db/src/Pos/DB/BlockIndex.hs index ce79496aca9..0c24e013f66 100644 --- a/db/src/Pos/DB/BlockIndex.hs +++ b/db/src/Pos/DB/BlockIndex.hs @@ -13,10 +13,11 @@ import Data.ByteArray (convert) import qualified Database.RocksDB as Rocks +import Pos.Binary.Class (serialize') import Pos.Chain.Block (BlockHeader, HeaderHash, headerHash) import Pos.DB.Class (DBTag (BlockIndexDB), MonadBlockDBRead, MonadDB (..)) -import Pos.DB.Functions (dbGetBi, dbSerializeValue) +import Pos.DB.Functions (dbGetBi) import Pos.DB.GState.Common (getTipSomething) -- | Returns header of block that was requested from Block DB. @@ -33,7 +34,7 @@ getTipHeader = getTipSomething "header" getHeader putHeadersIndex :: (MonadDB m) => [BlockHeader] -> m () putHeadersIndex = dbWriteBatch BlockIndexDB . - map (\h -> Rocks.Put (blockIndexKey $ headerHash h) (dbSerializeValue h)) + map (\h -> Rocks.Put (blockIndexKey $ headerHash h) (serialize' h)) -- | Deletes header from the index db. deleteHeaderIndex :: MonadDB m => HeaderHash -> m () diff --git a/db/src/Pos/DB/Class.hs b/db/src/Pos/DB/Class.hs index 57ee8f92e8d..04f23ca7a86 100644 --- a/db/src/Pos/DB/Class.hs +++ b/db/src/Pos/DB/Class.hs @@ -59,8 +59,7 @@ import Serokell.Data.Memory.Units (Byte) import Pos.Binary.Class (Bi, decodeFull') import Pos.Chain.Block (Block, BlockHeader, HeaderHash) -import Pos.Core (EpochIndex, GenesisHash, HasConfiguration, - isBootstrapEra) +import Pos.Core (EpochIndex, GenesisHash, isBootstrapEra) import Pos.Core.Update (BlockVersionData (..)) import Pos.DB.Error (DBError (DBMalformed)) import Pos.Util.Util (eitherToThrow) @@ -99,7 +98,7 @@ type SerializedUndo = Serialized SerUndo type SerializedBlund = Serialized SerBlund -- | Pure read-only interface to the database. -class (HasConfiguration, MonadThrow m) => MonadDBRead m where +class MonadThrow m => MonadDBRead m where -- | This function takes tag and key and reads value associated -- with given key from DB corresponding to given tag. dbGet :: DBTag -> ByteString -> m (Maybe ByteString) diff --git a/db/src/Pos/DB/Delegation/Core.hs b/db/src/Pos/DB/Delegation/Core.hs index e67098e66ca..cb3c2f027fc 100644 --- a/db/src/Pos/DB/Delegation/Core.hs +++ b/db/src/Pos/DB/Delegation/Core.hs @@ -57,12 +57,11 @@ import UnliftIO (MonadUnliftIO) import Pos.Binary.Class (serialize') import Pos.Chain.Delegation (DlgEdgeAction (..), isRevokePsk) -import Pos.Core (HasCoreConfiguration, StakeholderId, addressHash) +import Pos.Core (StakeholderId, addressHash) import Pos.Core.Delegation (ProxySKHeavy) import Pos.Core.Genesis (GenesisDelegation (..)) import Pos.Crypto (ProxySecretKey (..), PublicKey) -import Pos.DB (RocksBatchOp (..), dbSerializeValue, - encodeWithKeyPrefix) +import Pos.DB (RocksBatchOp (..), encodeWithKeyPrefix) import Pos.DB.Class (DBIteratorClass (..), DBTag (..), MonadDB, MonadDBRead (..)) import Pos.DB.GState.Common (gsGetBi, writeBatchGState) @@ -150,24 +149,24 @@ data DelegationOp -- ^ Remove stakeholderId from postedThisEpoch map. deriving (Show) -instance HasCoreConfiguration => RocksBatchOp DelegationOp where +instance RocksBatchOp DelegationOp where toBatchOp (PskFromEdgeAction (DlgEdgeAdd psk)) | isRevokePsk psk = error $ "RocksBatchOp DelegationOp: malformed " <> "revoke psk in DlgEdgeAdd: " <> pretty psk | otherwise = - [Rocks.Put (pskKey $ addressHash $ pskIssuerPk psk) (dbSerializeValue psk)] + [Rocks.Put (pskKey $ addressHash $ pskIssuerPk psk) (serialize' psk)] toBatchOp (PskFromEdgeAction (DlgEdgeDel issuerPk)) = [Rocks.Del $ pskKey issuerPk] toBatchOp (AddTransitiveDlg iSId dSId) = - [Rocks.Put (transDlgKey iSId) (dbSerializeValue dSId)] + [Rocks.Put (transDlgKey iSId) (serialize' dSId)] toBatchOp (DelTransitiveDlg sId) = [Rocks.Del $ transDlgKey sId] toBatchOp (SetTransitiveDlgRev dSId iSIds) | HS.null iSIds = [Rocks.Del $ transRevDlgKey dSId] - | otherwise = [Rocks.Put (transRevDlgKey dSId) (dbSerializeValue iSIds)] + | otherwise = [Rocks.Put (transRevDlgKey dSId) (serialize' iSIds)] toBatchOp (AddPostedThisEpoch sId) = - [Rocks.Put (postedThisEpochKey sId) (dbSerializeValue ())] + [Rocks.Put (postedThisEpochKey sId) (serialize' ())] toBatchOp (DelPostedThisEpoch sId) = [Rocks.Del (postedThisEpochKey sId)] diff --git a/db/src/Pos/DB/Functions.hs b/db/src/Pos/DB/Functions.hs index 6b5baabf8fd..9fae110ac9e 100644 --- a/db/src/Pos/DB/Functions.hs +++ b/db/src/Pos/DB/Functions.hs @@ -7,13 +7,9 @@ module Pos.DB.Functions ( -- * Encoded putting/getting dbGetBi - , dbGetBiNoVersion , dbPutBi - , dbPutBiNoVersion - , dbSerializeValue -- * Decoding/encoding primitives and iteration related - , dbDecode , encodeWithKeyPrefix , processIterEntry ) where @@ -21,77 +17,30 @@ module Pos.DB.Functions import Universum import qualified Data.ByteString as BS (drop, isPrefixOf) -import Formatting (bprint, builder, sformat, shown, stext, string, - (%)) +import Formatting (sformat, shown, string, (%)) import Pos.Binary.Class (Bi, decodeFull', serialize') -import Pos.Core.Configuration (HasCoreConfiguration, - dbSerializeVersion) import Pos.DB.Class (DBIteratorClass (..), DBTag, IterType, MonadDB (..), MonadDBRead (..)) import Pos.DB.Error (DBError (..)) import Pos.Util.Util (maybeThrow) --- | Read serialized value associated with given key from pure DB. -dbGetBiNoVersion - :: forall v m. - (Bi v, MonadDBRead m) - => DBTag -> ByteString -> m (Maybe v) -dbGetBiNoVersion tag key = do - bytes <- dbGet tag key - traverse (dbDecode . (ToDecodeValue key)) bytes - --- | Write serializable value to DB for given key. -dbPutBiNoVersion :: (Bi v, MonadDB m) => DBTag -> ByteString -> v -> m () -dbPutBiNoVersion tag k v = dbPut tag k (serialize' v) - -- | Read serialized value (with version) associated with given key from pure DB. dbGetBi :: forall v m. (Bi v, MonadDBRead m) => DBTag -> ByteString -> m (Maybe v) -dbGetBi tag key = do - bytes <- dbGet tag key - val <- traverse (dbDecode . (ToDecodeValue key)) bytes - traverse onVersionError val - where - onVersionError :: (Word8, v) -> m v - onVersionError (verTag, v) - | verTag /= dbSerializeVersion = - throwM $ DBUnexpectedVersionTag dbSerializeVersion verTag - | otherwise = pure v +dbGetBi tag key = + dbGet tag key >>= traverse (either throwM pure . dbDecodeIgnoreVersion) -- | Write serializable value to DB for given key. Uses simple versioning. dbPutBi :: (Bi v, MonadDB m) => DBTag -> ByteString -> v -> m () -dbPutBi tag k v = dbPut tag k (dbSerializeValue v) - --- | Version of 'serialize'' function that includes version when serializing a value. -dbSerializeValue :: (HasCoreConfiguration, Bi a) => a -> ByteString -dbSerializeValue = serialize' . (dbSerializeVersion,) +dbPutBi tag k v = dbPut tag k (serialize' v) --- This type describes what we want to decode and contains auxiliary --- data. -data ToDecode - = ToDecodeKey !ByteString -- key - | ToDecodeValue !ByteString -- key - !ByteString -- value - -dbDecode :: forall v m. (Bi v, MonadThrow m) => ToDecode -> m v -dbDecode = - \case - ToDecodeKey key -> - either (onParseError key Nothing) pure . decodeFull' $ key - ToDecodeValue key val -> - either (onParseError key (Just val)) pure . decodeFull' $ val - where - onParseError :: ByteString -> Maybe ByteString -> Text -> m a - onParseError rawKey rawValMaybe errMsg = - let valueBuilder = maybe "" (bprint (", value = " %shown)) rawValMaybe - in throwM $ DBMalformed $ sformat fmtMalformed rawKey valueBuilder errMsg - fmtMalformed = - "A key or value stored in DB is malformed, key = "%shown% - builder% - ", err: "%stext +dbDecodeIgnoreVersion :: forall v . Bi v => ByteString -> Either DBError v +dbDecodeIgnoreVersion bytes = case decodeFull' @v bytes of + Right val -> Right val + Left _ -> bimap DBMalformed snd $ decodeFull' @(Word8, v) bytes dbDecodeMaybe :: (Bi v) => ByteString -> Maybe v dbDecodeMaybe = rightToMaybe . decodeFull' @@ -115,16 +64,15 @@ encodeWithKeyPrefix = (iterKeyPrefix @i <>) . serialize' -- | Given a @(k,v)@ as pair of strings, try to decode both. processIterEntry :: forall i m. - (HasCoreConfiguration, Bi (IterKey i), Bi (IterValue i), MonadThrow m, DBIteratorClass i) + (Bi (IterKey i), Bi (IterValue i), MonadThrow m, DBIteratorClass i) => (ByteString, ByteString) -> m (Maybe (IterType i)) processIterEntry (key,val) | BS.isPrefixOf prefix key = do k <- maybeThrow (DBMalformed $ fmt key "key invalid") (dbDecodeMaybeWP @i key) - (dbVer, v) <- maybeThrow (DBMalformed $ fmt key "value invalid") - (dbDecodeMaybe @(Word8, IterValue i) val) - checkDBVersion dbVer (k ,v) + v <- either throwM pure (dbDecodeIgnoreVersion val) + pure $ Just (k, v) | otherwise = pure Nothing where prefix = iterKeyPrefix @i @@ -133,8 +81,3 @@ processIterEntry (key,val) ("Iterator entry with keyPrefix = "%shown%" is malformed: \ \key = "%shown%", err: " %string) prefix k err - - checkDBVersion :: Word8 -> IterType i -> m (Maybe (IterType i)) - checkDBVersion dbV it - | dbV == dbSerializeVersion = pure (Just it) - | otherwise = throwM $ DBUnexpectedVersionTag dbSerializeVersion dbV diff --git a/db/src/Pos/DB/GState/Common.hs b/db/src/Pos/DB/GState/Common.hs index 8859358c857..7eaeb58ff6b 100644 --- a/db/src/Pos/DB/GState/Common.hs +++ b/db/src/Pos/DB/GState/Common.hs @@ -31,16 +31,15 @@ import qualified Database.RocksDB as Rocks import Formatting (bprint, int, sformat, stext, (%)) import qualified Formatting.Buildable -import Pos.Binary.Class (Bi) +import Pos.Binary.Class (Bi, serialize') import Pos.Chain.Block (HeaderHash) import Pos.Core (ChainDifficulty) -import Pos.Core.Configuration (HasCoreConfiguration) import Pos.Crypto (shortHashF) import Pos.DB.BatchOp (RocksBatchOp (..), dbWriteBatch') import Pos.DB.Class (DBTag (GStateDB), MonadDB (dbDelete), MonadDBRead (..)) import Pos.DB.Error (DBError (DBMalformed)) -import Pos.DB.Functions (dbGetBi, dbPutBi, dbSerializeValue) +import Pos.DB.Functions (dbGetBi, dbPutBi) import Pos.Util.Util (maybeThrow) ---------------------------------------------------------------------------- @@ -99,11 +98,11 @@ instance Buildable CommonOp where build (PutMaxSeenDifficulty d) = bprint ("PutMaxSeenDifficulty ("%int%")") d -instance HasCoreConfiguration => RocksBatchOp CommonOp where +instance RocksBatchOp CommonOp where toBatchOp (PutTip h) = - [Rocks.Put tipKey (dbSerializeValue h)] + [Rocks.Put tipKey (serialize' h)] toBatchOp (PutMaxSeenDifficulty h) = - [Rocks.Put maxSeenDifficultyKey (dbSerializeValue h)] + [Rocks.Put maxSeenDifficultyKey (serialize' h)] ---------------------------------------------------------------------------- -- Initialization diff --git a/db/src/Pos/DB/Lrc/Common.hs b/db/src/Pos/DB/Lrc/Common.hs index 591a7681665..44fb10bb1af 100644 --- a/db/src/Pos/DB/Lrc/Common.hs +++ b/db/src/Pos/DB/Lrc/Common.hs @@ -26,10 +26,8 @@ import Universum import qualified Database.RocksDB as Rocks -import Pos.Binary.Class (Bi) -import Pos.Core.Configuration (HasCoreConfiguration) +import Pos.Binary.Class (Bi, serialize') import Pos.Core.Slotting (EpochIndex) -import Pos.DB (dbSerializeValue) import Pos.DB.Class (DBTag (LrcDB), MonadDB (dbDelete, dbWriteBatch), MonadDBRead (dbGet)) import Pos.DB.Error (DBError (DBMalformed)) @@ -64,9 +62,9 @@ putBatchBi = putBatch . toRocksOps delete :: (MonadDB m) => ByteString -> m () delete = dbDelete LrcDB -toRocksOps :: (HasCoreConfiguration, Bi v) => [(ByteString, v)] -> [Rocks.BatchOp] +toRocksOps :: Bi v => [(ByteString, v)] -> [Rocks.BatchOp] toRocksOps ops = - [Rocks.Put key (dbSerializeValue value) | (key, value) <- ops] + [Rocks.Put key (serialize' value) | (key, value) <- ops] ---------------------------------------------------------------------------- -- Common getters diff --git a/db/src/Pos/DB/Pure.hs b/db/src/Pos/DB/Pure.hs index a44a2a8adb1..f93bdc7bac1 100644 --- a/db/src/Pos/DB/Pure.hs +++ b/db/src/Pos/DB/Pure.hs @@ -48,7 +48,6 @@ import qualified Database.RocksDB as Rocks import Pos.Binary.Class (Bi) import Pos.Chain.Block (HeaderHash) -import Pos.Core (HasCoreConfiguration) import Pos.DB.Class (DBIteratorClass (..), DBTag (..), IterType, iterKeyPrefix) import Pos.DB.Functions (processIterEntry) @@ -119,7 +118,7 @@ dbIterSourcePureDefault :: , DBIteratorClass i , Bi (IterKey i) , Bi (IterValue i) - , HasCoreConfiguration) + ) => DBTag -> Proxy i -> ConduitT () (IterType i) m () diff --git a/db/src/Pos/DB/Rocks/Functions.hs b/db/src/Pos/DB/Rocks/Functions.hs index c5eed5dca2f..a9b87465952 100644 --- a/db/src/Pos/DB/Rocks/Functions.hs +++ b/db/src/Pos/DB/Rocks/Functions.hs @@ -42,11 +42,10 @@ import System.Directory (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive) import System.FilePath (takeDirectory, ()) -import Pos.Binary.Class (Bi) -import Pos.Core.Configuration (HasCoreConfiguration) +import Pos.Binary.Class (Bi, serialize') import Pos.DB.BatchOp (rocksWriteBatch) import Pos.DB.Class (DBIteratorClass (..), DBTag (..), IterType) -import Pos.DB.Functions (dbSerializeValue, processIterEntry) +import Pos.DB.Functions (processIterEntry) import Pos.DB.Rocks.Types (DB (..), MonadRealDB, NodeDBs (..), getDBByTag) import qualified Pos.Util.Concurrent.RWLock as RWL @@ -148,8 +147,8 @@ rocksDelete k DB {..} = Rocks.delete rocksDB rocksWriteOpts k -- garbage, should be abstracted and hidden -- | Write serializable value to RocksDb for given key. -rocksPutBi :: (HasCoreConfiguration, Bi v, MonadIO m) => ByteString -> v -> DB -> m () -rocksPutBi k v = rocksPutBytes k (dbSerializeValue v) +rocksPutBi :: (Bi v, MonadIO m) => ByteString -> v -> DB -> m () +rocksPutBi k v = rocksPutBytes k (serialize' v) ---------------------------------------------------------------------------- -- Snapshot @@ -184,7 +183,6 @@ rocksIterSource :: , DBIteratorClass i , Bi (IterKey i) , Bi (IterValue i) - , HasCoreConfiguration ) => DBTag -> Proxy i @@ -236,7 +234,6 @@ dbIterSourceDefault :: , DBIteratorClass i , Bi (IterKey i) , Bi (IterValue i) - , HasCoreConfiguration ) => DBTag -> Proxy i diff --git a/db/src/Pos/DB/Ssc/GState.hs b/db/src/Pos/DB/Ssc/GState.hs index 2f1b4d83041..f501206cf32 100644 --- a/db/src/Pos/DB/Ssc/GState.hs +++ b/db/src/Pos/DB/Ssc/GState.hs @@ -13,13 +13,12 @@ import qualified Database.RocksDB as Rocks import Formatting (bprint, build, (%)) import qualified Formatting.Buildable +import Pos.Binary.Class (serialize') import Pos.Chain.Ssc (SscGlobalState (..)) import qualified Pos.Chain.Ssc as VCD -import Pos.Core (HasCoreConfiguration) import Pos.Core.Ssc (VssCertificatesMap) import Pos.DB (MonadDB, MonadDBRead, RocksBatchOp (..)) import Pos.DB.Error (DBError (DBMalformed)) -import Pos.DB.Functions (dbSerializeValue) import Pos.DB.GState.Common (gsGetBi, gsPutBi) import Pos.Util.Util (maybeThrow) @@ -46,8 +45,8 @@ data SscOp instance Buildable SscOp where build (PutGlobalState gs) = bprint ("SscOp ("%build%")") gs -instance (HasCoreConfiguration) => RocksBatchOp SscOp where - toBatchOp (PutGlobalState gs) = [Rocks.Put sscKey (dbSerializeValue gs)] +instance RocksBatchOp SscOp where + toBatchOp (PutGlobalState gs) = [Rocks.Put sscKey (serialize' gs)] ---------------------------------------------------------------------------- -- Key diff --git a/db/src/Pos/DB/Ssc/Logic/VAR.hs b/db/src/Pos/DB/Ssc/Logic/VAR.hs index 0dfc3f5a79a..4e0231fd4f2 100644 --- a/db/src/Pos/DB/Ssc/Logic/VAR.hs +++ b/db/src/Pos/DB/Ssc/Logic/VAR.hs @@ -28,8 +28,8 @@ import Pos.Chain.Ssc (HasSscConfiguration, MonadSscMem, runPureTossWithLogger, sscGlobal, sscIsCriticalVerifyError, sscRunGlobalUpdate, supplyPureTossEnv, verifyAndApplySscPayload) -import Pos.Core as Core (Config, HasCoreConfiguration, SlotCount, - configBlockVersionData, epochIndexL, epochOrSlotG) +import Pos.Core as Core (Config, SlotCount, configBlockVersionData, + epochIndexL, epochOrSlotG) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Exception (assertionFailed) import Pos.Core.Reporting (MonadReporting, reportError) @@ -257,5 +257,5 @@ tossToVerifier action = do Right res -> (identity .= newState) $> res -- | Dump global state to DB. -sscGlobalStateToBatch :: (HasCoreConfiguration) => SscGlobalState -> [SomeBatchOp] +sscGlobalStateToBatch :: SscGlobalState -> [SomeBatchOp] sscGlobalStateToBatch = one . SomeBatchOp . DB.sscGlobalStateToBatch diff --git a/db/src/Pos/DB/Sum.hs b/db/src/Pos/DB/Sum.hs index d073c3864bd..3d6bc565434 100644 --- a/db/src/Pos/DB/Sum.hs +++ b/db/src/Pos/DB/Sum.hs @@ -21,7 +21,6 @@ import Data.Conduit (ConduitT, transPipe) import qualified Database.RocksDB as Rocks import Pos.Binary.Class (Bi) -import Pos.Core.Configuration (HasCoreConfiguration) import Pos.DB.Class (DBIteratorClass (..), DBTag, IterType) import Pos.DB.Pure (DBPureVar) import qualified Pos.DB.Pure as DB @@ -57,7 +56,6 @@ dbIterSourceSumDefault , DBIteratorClass i , Bi (IterKey i) , Bi (IterValue i) - , HasCoreConfiguration ) => DBTag -> Proxy i -> ConduitT () (IterType i) m () dbIterSourceSumDefault tag proxy = view (lensOf @DBSum) >>= \case diff --git a/db/src/Pos/DB/Txp/Logic/Global.hs b/db/src/Pos/DB/Txp/Logic/Global.hs index 3973cfbdfec..482dd323a64 100644 --- a/db/src/Pos/DB/Txp/Logic/Global.hs +++ b/db/src/Pos/DB/Txp/Logic/Global.hs @@ -31,8 +31,8 @@ import Pos.Chain.Txp (ExtendedGlobalToilM, GlobalToilEnv (..), defGlobalToilState, flattenTxPayload, gtsUtxoModifier, rollbackToil, runGlobalToilMBase, runUtxoM, utxoToLookup, verifyToil) -import Pos.Core as Core (Config (..), HasCoreConfiguration, - ProtocolMagic, configBootStakeholders, epochIndexL) +import Pos.Core as Core (Config (..), ProtocolMagic, + configBootStakeholders, epochIndexL) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Exception (assertionFailed) import Pos.Core.Genesis (GenesisWStakeholders) @@ -216,7 +216,7 @@ rollbackBlocks bootStakeholders (NewestFirst blunds) = processBlunds ---------------------------------------------------------------------------- -- | Convert 'GlobalToilState' to batch of database operations. -globalToilStateToBatch :: HasCoreConfiguration => GlobalToilState -> SomeBatchOp +globalToilStateToBatch :: GlobalToilState -> SomeBatchOp globalToilStateToBatch GlobalToilState {..} = SomeBatchOp [SomeBatchOp utxoOps, SomeBatchOp stakesOps] where diff --git a/db/src/Pos/DB/Txp/Stakes.hs b/db/src/Pos/DB/Txp/Stakes.hs index e75c1f734db..a47552075cf 100644 --- a/db/src/Pos/DB/Txp/Stakes.hs +++ b/db/src/Pos/DB/Txp/Stakes.hs @@ -33,15 +33,14 @@ import qualified Formatting.Buildable import Serokell.Util (Color (Red), colorize) import UnliftIO (MonadUnliftIO) +import Pos.Binary.Class (serialize') import Pos.Chain.Txp (genesisStakes) -import Pos.Core (Coin, HasCoreConfiguration, StakeholderId, StakesMap, - coinF, mkCoin, sumCoins, unsafeAddCoin, - unsafeIntegerToCoin) +import Pos.Core (Coin, StakeholderId, StakesMap, coinF, mkCoin, + sumCoins, unsafeAddCoin, unsafeIntegerToCoin) import Pos.Core.Genesis (GenesisData (..)) import Pos.Crypto (shortHashF) import Pos.DB (DBError (..), DBTag (GStateDB), IterType, MonadDB, - MonadDBRead, RocksBatchOp (..), dbIterSource, - dbSerializeValue) + MonadDBRead, RocksBatchOp (..), dbIterSource) import Pos.DB.GState.Common (gsPutBi) import Pos.DB.GState.Stakes (StakeIter, ftsStakeKey, ftsSumKey, getRealTotalStake) @@ -61,11 +60,11 @@ instance Buildable StakesOp where build (PutFtsStake ad c) = bprint ("PutFtsStake ("%shortHashF%", "%coinF%")") ad c -instance HasCoreConfiguration => RocksBatchOp StakesOp where - toBatchOp (PutTotalStake c) = [Rocks.Put ftsSumKey (dbSerializeValue c)] +instance RocksBatchOp StakesOp where + toBatchOp (PutTotalStake c) = [Rocks.Put ftsSumKey (serialize' c)] toBatchOp (PutFtsStake ad c) = if c == mkCoin 0 then [Rocks.Del (ftsStakeKey ad)] - else [Rocks.Put (ftsStakeKey ad) (dbSerializeValue c)] + else [Rocks.Put (ftsStakeKey ad) (serialize' c)] ---------------------------------------------------------------------------- -- Initialization diff --git a/db/src/Pos/DB/Txp/Utxo.hs b/db/src/Pos/DB/Txp/Utxo.hs index eb359eb371d..2fa1f72916a 100644 --- a/db/src/Pos/DB/Txp/Utxo.hs +++ b/db/src/Pos/DB/Txp/Utxo.hs @@ -41,14 +41,15 @@ import qualified Formatting.Buildable import Serokell.Util (Color (Red), colorize) import UnliftIO (MonadUnliftIO) +import Pos.Binary.Class (serialize') import Pos.Chain.Txp (TxIn (..), TxOutAux (toaOut), Utxo, addrBelongsToSet, genesisUtxo, txOutStake) -import Pos.Core (Address, Coin, HasCoreConfiguration, coinF, mkCoin, - sumCoins, unsafeAddCoin, unsafeIntegerToCoin) +import Pos.Core (Address, Coin, coinF, mkCoin, sumCoins, + unsafeAddCoin, unsafeIntegerToCoin) import Pos.Core.Genesis (GenesisData (..)) import Pos.DB (DBError (..), DBIteratorClass (..), DBTag (GStateDB), IterType, MonadDB, MonadDBRead, RocksBatchOp (..), - dbIterSource, dbSerializeValue, encodeWithKeyPrefix) + dbIterSource, encodeWithKeyPrefix) import Pos.DB.GState.Common (gsGetBi, writeBatchGState) import Pos.Util.Wlog (WithLogger, logError) @@ -74,9 +75,9 @@ instance Buildable UtxoOp where bprint ("AddTxOut ("%build%", "%build%")") txIn txOutAux -instance HasCoreConfiguration => RocksBatchOp UtxoOp where +instance RocksBatchOp UtxoOp where toBatchOp (AddTxOut txIn txOut) = - [Rocks.Put (txInKey txIn) (dbSerializeValue txOut)] + [Rocks.Put (txInKey txIn) (serialize' txOut)] toBatchOp (DelTxIn txIn) = [Rocks.Del $ txInKey txIn] ---------------------------------------------------------------------------- diff --git a/db/src/Pos/DB/Update/GState.hs b/db/src/Pos/DB/Update/GState.hs index 24d86a72e5c..aa7abedd35e 100644 --- a/db/src/Pos/DB/Update/GState.hs +++ b/db/src/Pos/DB/Update/GState.hs @@ -58,9 +58,9 @@ import Pos.Chain.Update (BlockVersionState (..), cpsSoftwareVersion, genesisBlockVersion, genesisSoftwareVersions, ourAppName, ourSystemTag, psProposal) -import Pos.Core as Core (ChainDifficulty, Config (..), - HasCoreConfiguration, SlotId, StakeholderId, - TimeDiff (..), configBlockVersionData, configEpochSlots) +import Pos.Core as Core (ChainDifficulty, Config (..), SlotId, + StakeholderId, TimeDiff (..), configBlockVersionData, + configEpochSlots) import Pos.Core.Slotting (EpochSlottingData (..), SlottingData, createInitSlottingData) import Pos.Core.Update (ApplicationName, BlockVersion, @@ -68,8 +68,7 @@ import Pos.Core.Update (ApplicationName, BlockVersion, SoftwareVersion (..), UpId, UpdateProposal (..)) import Pos.Crypto (hash) import Pos.DB (DBIteratorClass (..), DBTag (..), IterType, MonadDB, - MonadDBRead (..), RocksBatchOp (..), dbSerializeValue, - encodeWithKeyPrefix) + MonadDBRead (..), RocksBatchOp (..), encodeWithKeyPrefix) import Pos.DB.Error (DBError (DBMalformed)) import Pos.DB.GState.Common (gsGetBi, writeBatchGState) import Pos.Util.Util (maybeThrow) @@ -139,32 +138,32 @@ data UpdateOp | PutSlottingData !SlottingData | PutEpochProposers !(HashSet StakeholderId) -instance HasCoreConfiguration => RocksBatchOp UpdateOp where +instance RocksBatchOp UpdateOp where toBatchOp (PutProposal ps) = - [ Rocks.Put (proposalKey upId) (dbSerializeValue ps)] + [ Rocks.Put (proposalKey upId) (serialize' ps)] where up = psProposal ps upId = hash up toBatchOp (DeleteProposal upId) = [Rocks.Del (proposalKey upId)] toBatchOp (ConfirmVersion sv) = - [Rocks.Put (confirmedVersionKey $ svAppName sv) (dbSerializeValue $ svNumber sv)] + [Rocks.Put (confirmedVersionKey $ svAppName sv) (serialize' $ svNumber sv)] toBatchOp (DelConfirmedVersion app) = [Rocks.Del (confirmedVersionKey app)] toBatchOp (AddConfirmedProposal cps) = - [Rocks.Put (confirmedProposalKey cps) (dbSerializeValue cps)] + [Rocks.Put (confirmedProposalKey cps) (serialize' cps)] toBatchOp (DelConfirmedProposal sv) = [Rocks.Del (confirmedProposalKeySV sv)] toBatchOp (SetAdopted bv bvd) = - [Rocks.Put adoptedBVKey (dbSerializeValue (bv, bvd))] + [Rocks.Put adoptedBVKey (serialize' (bv, bvd))] toBatchOp (SetBVState bv st) = - [Rocks.Put (bvStateKey bv) (dbSerializeValue st)] + [Rocks.Put (bvStateKey bv) (serialize' st)] toBatchOp (DelBV bv) = [Rocks.Del (bvStateKey bv)] toBatchOp (PutSlottingData sd) = - [Rocks.Put slottingDataKey (dbSerializeValue sd)] + [Rocks.Put slottingDataKey (serialize' sd)] toBatchOp (PutEpochProposers proposers) = - [Rocks.Put epochProposersKey (dbSerializeValue proposers)] + [Rocks.Put epochProposersKey (serialize' proposers)] ---------------------------------------------------------------------------- -- Initialization diff --git a/db/src/Pos/DB/Update/Logic/Global.hs b/db/src/Pos/DB/Update/Logic/Global.hs index c5ef698273e..988ef6d98b8 100644 --- a/db/src/Pos/DB/Update/Logic/Global.hs +++ b/db/src/Pos/DB/Update/Logic/Global.hs @@ -24,8 +24,8 @@ import Pos.Chain.Update (BlockVersionState, ConfirmedProposalState, PollT, PollVerFailure, ProposalState, USUndo, execPollT, execRollT, getAdoptedBV, lastKnownBlockVersion, reportUnexpectedError, runPollT) -import Pos.Core as Core (Config, HasCoreConfiguration, StakeholderId, - addressHash, configBlkSecurityParam, epochIndexL) +import Pos.Core as Core (Config, StakeholderId, addressHash, + configBlkSecurityParam, epochIndexL) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Exception (reportFatalError) import Pos.Core.Reporting (MonadReporting) @@ -137,10 +137,7 @@ usRollbackBlocks blunds = -- This function takes a 'PollModifier' corresponding to a sequence of -- blocks, updates in-memory slotting data and converts this modifier -- to '[SomeBatchOp]'. -processModifier :: - forall ctx m. (MonadSlotsData ctx m, HasCoreConfiguration) - => PollModifier - -> m [DB.SomeBatchOp] +processModifier :: MonadSlotsData ctx m => PollModifier -> m [DB.SomeBatchOp] processModifier pm@PollModifier {pmSlottingData = newSlottingData} = modifierToBatch pm <$ whenJust newSlottingData setNewSlottingData where @@ -234,7 +231,7 @@ usCanCreateBlock = -- Conversion to batch ---------------------------------------------------------------------------- -modifierToBatch :: HasCoreConfiguration => PollModifier -> [DB.SomeBatchOp] +modifierToBatch :: PollModifier -> [DB.SomeBatchOp] modifierToBatch PollModifier {..} = concat $ [ bvsModifierToBatch (MM.insertions pmBVs) (MM.deletions pmBVs) @@ -253,8 +250,7 @@ modifierToBatch PollModifier {..} = ] bvsModifierToBatch - :: HasCoreConfiguration - => [(BlockVersion, BlockVersionState)] + :: [(BlockVersion, BlockVersionState)] -> [BlockVersion] -> [DB.SomeBatchOp] bvsModifierToBatch added deleted = addOps ++ delOps @@ -262,13 +258,12 @@ bvsModifierToBatch added deleted = addOps ++ delOps addOps = map (DB.SomeBatchOp . uncurry SetBVState) added delOps = map (DB.SomeBatchOp . DelBV) deleted -lastAdoptedModifierToBatch :: HasCoreConfiguration => Maybe (BlockVersion, BlockVersionData) -> [DB.SomeBatchOp] +lastAdoptedModifierToBatch :: Maybe (BlockVersion, BlockVersionData) -> [DB.SomeBatchOp] lastAdoptedModifierToBatch Nothing = [] lastAdoptedModifierToBatch (Just (bv, bvd)) = [DB.SomeBatchOp $ SetAdopted bv bvd] confirmedVerModifierToBatch - :: HasCoreConfiguration - => [(ApplicationName, NumSoftwareVersion)] + :: [(ApplicationName, NumSoftwareVersion)] -> [ApplicationName] -> [DB.SomeBatchOp] confirmedVerModifierToBatch added deleted = @@ -278,8 +273,7 @@ confirmedVerModifierToBatch added deleted = delOps = map (DB.SomeBatchOp . DelConfirmedVersion) deleted confirmedPropModifierToBatch - :: HasCoreConfiguration - => [(SoftwareVersion, ConfirmedProposalState)] + :: [(SoftwareVersion, ConfirmedProposalState)] -> [SoftwareVersion] -> [DB.SomeBatchOp] confirmedPropModifierToBatch (map snd -> confAdded) confDeleted = @@ -289,8 +283,7 @@ confirmedPropModifierToBatch (map snd -> confAdded) confDeleted = confDelOps = map (DB.SomeBatchOp . DelConfirmedProposal) confDeleted upModifierToBatch - :: HasCoreConfiguration - => [(UpId, ProposalState)] + :: [(UpId, ProposalState)] -> [UpId] -> [DB.SomeBatchOp] upModifierToBatch (map snd -> added) deleted @@ -299,10 +292,10 @@ upModifierToBatch (map snd -> added) deleted addOps = map (DB.SomeBatchOp . PutProposal) added delOps = map (DB.SomeBatchOp . DeleteProposal) deleted -sdModifierToBatch :: HasCoreConfiguration => Maybe SlottingData -> [DB.SomeBatchOp] +sdModifierToBatch :: Maybe SlottingData -> [DB.SomeBatchOp] sdModifierToBatch Nothing = [] sdModifierToBatch (Just sd) = [DB.SomeBatchOp $ PutSlottingData sd] -epModifierToBatch :: HasCoreConfiguration => Maybe (HashSet StakeholderId) -> [DB.SomeBatchOp] +epModifierToBatch :: Maybe (HashSet StakeholderId) -> [DB.SomeBatchOp] epModifierToBatch Nothing = [] epModifierToBatch (Just ep) = [DB.SomeBatchOp $ PutEpochProposers ep] diff --git a/db/test/Test/Pos/DB/Functions.hs b/db/test/Test/Pos/DB/Functions.hs index 349ac37da00..d9cd18f0d58 100644 --- a/db/test/Test/Pos/DB/Functions.hs +++ b/db/test/Test/Pos/DB/Functions.hs @@ -12,11 +12,8 @@ import Universum import Hedgehog import Pos.Binary.Class (Bi) -import Pos.Core (HasConfiguration, withCoreConfiguration) -import Pos.DB (DBTag (..), dbGetBi, dbGetBiNoVersion, dbPutBi, - dbPutBiNoVersion) +import Pos.DB (DBTag (..), dbGetBi, dbPutBi) -import Test.Pos.Core.Dummy (dummyCoreConfiguration) import Test.Pos.Core.ExampleHelpers (exampleBlockVersionData, exampleSscPayload) import Test.Pos.DB.Mode (runTestMode) @@ -26,7 +23,7 @@ import Test.Pos.DB.Mode (runTestMode) -- | Trying to read a missing key results in a @Nothing@ value -- prop_missingKey :: Property -prop_missingKey = withTests 1 $ dbProperty $ do +prop_missingKey = withTests 1 . property $ do result :: Maybe Bool <- liftIO . runTestMode $ dbGetBi MiscDB "test/bool" result === Nothing @@ -35,7 +32,7 @@ prop_missingKey = withTests 1 $ dbProperty $ do -- | We can write values into the database and read them back -- prop_putGet :: Property -prop_putGet = withTests 1 $ dbProperty $ do +prop_putGet = withTests 1 . property $ do putGetProperty "test/bool" True putGetProperty "test/int" (10000 :: Int) putGetProperty "test/bytestring" ("testing" :: ByteString) @@ -47,7 +44,7 @@ prop_putGet = withTests 1 $ dbProperty $ do -- | We can write values with an explicit version and read them back -- prop_putGetExplicitVersion :: Property -prop_putGetExplicitVersion = withTests 1 $ dbProperty $ do +prop_putGetExplicitVersion = withTests 1 . property $ do putGetExplicitVersionProperty "test/bool" True putGetExplicitVersionProperty "test/int" (10000 :: Int) putGetExplicitVersionProperty "test/bytestring" ("testing" :: ByteString) @@ -58,26 +55,24 @@ prop_putGetExplicitVersion = withTests 1 $ dbProperty $ do -------------------------------------------------------------------------------- --- | We can write values with no version and read them back +-- | We can write tuples with @Word8@s and read them back, not interpreting the +-- @Word8@ as a version number -- -prop_putGetNoVersion :: Property -prop_putGetNoVersion = withTests 1 $ dbProperty $ do - putGetNoVersionProperty "test/bool" True - putGetNoVersionProperty "test/int" (10000 :: Int) - putGetNoVersionProperty "test/bytestring" ("testing" :: ByteString) - putGetNoVersionProperty "test/blockversiondata" exampleBlockVersionData - putGetNoVersionProperty "test/sscpayload" exampleSscPayload +prop_putGetWord8Tuple :: Property +prop_putGetWord8Tuple = withTests 1 . property $ do + putGetWord8TupleProperty "test/bool" True + putGetWord8TupleProperty "test/int" (10000 :: Int) + putGetWord8TupleProperty "test/bytestring" ("testing" :: ByteString) + putGetWord8TupleProperty "test/blockversiondata" exampleBlockVersionData + putGetWord8TupleProperty "test/sscpayload" exampleSscPayload -------------------------------------------------------------------------------- -- Hedgehog Helpers -------------------------------------------------------------------------------- -dbProperty :: (HasConfiguration => PropertyT IO ()) -> Property -dbProperty prop = property $ withCoreConfiguration dummyCoreConfiguration prop - putGetProperty - :: (HasConfiguration, Bi a, Eq a, Show a) + :: (Bi a, Eq a, Show a) => ByteString -> a -> PropertyT IO () @@ -88,26 +83,27 @@ putGetProperty k v = do result === Just v putGetExplicitVersionProperty - :: (HasConfiguration, Bi a, Eq a, Show a) + :: (Bi a, Eq a, Show a) => ByteString -> a -> PropertyT IO () putGetExplicitVersionProperty k v = do result <- liftIO . runTestMode $ do - dbPutBiNoVersion MiscDB k (0 :: Word8, v) + dbPutBi MiscDB k (0 :: Word8, v) dbGetBi MiscDB k result === Just v -putGetNoVersionProperty - :: (HasConfiguration, Bi a, Eq a, Show a) +putGetWord8TupleProperty + :: (Bi a, Eq a, Show a) => ByteString -> a -> PropertyT IO () -putGetNoVersionProperty k v = do +putGetWord8TupleProperty k v = do + let v' = (0 :: Word8, v) result <- liftIO . runTestMode $ do - dbPutBiNoVersion MiscDB k v - dbGetBiNoVersion MiscDB k - result === Just v + dbPutBi MiscDB k v' + dbGetBi MiscDB k + result === Just v' -------------------------------------------------------------------------------- diff --git a/db/test/Test/Pos/DB/Mode.hs b/db/test/Test/Pos/DB/Mode.hs index e81ddbc9c8f..114ef4d14ef 100644 --- a/db/test/Test/Pos/DB/Mode.hs +++ b/db/test/Test/Pos/DB/Mode.hs @@ -14,8 +14,6 @@ import Universum import Control.Lens (makeLenses) -import Pos.Core (HasConfiguration) - import Pos.DB (MonadDB (..), MonadDBRead (..), NodeDBs, closeNodeDBs, dbDeleteDefault, dbGetDefault, dbIterSourceDefault, dbPutDefault, dbWriteBatchDefault, deleteNodeDBs, @@ -51,14 +49,14 @@ runTestMode testMode = closeNodeDBs nodeDBs deleteNodeDBs nodeDBs -instance HasConfiguration => MonadDBRead TestMode where +instance MonadDBRead TestMode where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB TestMode where +instance MonadDB TestMode where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault diff --git a/explorer/src/Pos/Explorer/BListener.hs b/explorer/src/Pos/Explorer/BListener.hs index 0ceb18fc6d5..1c200602644 100644 --- a/explorer/src/Pos/Explorer/BListener.hs +++ b/explorer/src/Pos/Explorer/BListener.hs @@ -31,8 +31,8 @@ import UnliftIO (MonadUnliftIO) import Pos.Chain.Block (Block, Blund, HeaderHash, MainBlock, headerHash, mainBlockSlot, mainBlockTxPayload) import Pos.Chain.Txp (Tx, topsortTxs, txpTxs) -import Pos.Core (HasConfiguration, LocalSlotIndex (..), SlotId (..), - difficultyL, epochIndexL, getChainDifficulty) +import Pos.Core (LocalSlotIndex (..), SlotId (..), difficultyL, + epochIndexL, getChainDifficulty) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst) import Pos.Crypto (withHash) @@ -65,7 +65,6 @@ type MonadBListenerT m = , MonadCatch m , MonadDBRead m , MonadUnliftIO m - , HasConfiguration ) -- Explorer implementation for usual node. Combines the operations. @@ -73,7 +72,6 @@ instance ( MonadDBRead m , MonadUnliftIO m , MonadCatch m , WithLogger m - , HasConfiguration ) => MonadBListener (ExplorerBListener m) where onApplyBlocks blunds = onApplyCallGeneral blunds diff --git a/explorer/src/Pos/Explorer/DB.hs b/explorer/src/Pos/Explorer/DB.hs index a17ac52ccba..c40e8684ac2 100644 --- a/explorer/src/Pos/Explorer/DB.hs +++ b/explorer/src/Pos/Explorer/DB.hs @@ -45,12 +45,12 @@ import Pos.Chain.Block (HeaderHash) import Pos.Chain.Txp (Tx, TxId, TxOut (..), TxOutAux (..), genesisUtxo, utxoF, utxoToAddressCoinPairs) import Pos.Core as Core (Address, Coin, Config (..), EpochIndex (..), - HasConfiguration, coinToInteger, unsafeAddCoin) + coinToInteger, unsafeAddCoin) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Genesis (GenesisData) import Pos.DB (DBError (..), DBIteratorClass (..), DBTag (GStateDB), MonadDB, MonadDBRead (dbGet), RocksBatchOp (..), - dbIterSource, dbSerializeValue, encodeWithKeyPrefix) + dbIterSource, encodeWithKeyPrefix) import Pos.DB.DB (initNodeDBs) import Pos.DB.GState.Common (gsGetBi, gsPutBi, writeBatchGState) import Pos.DB.Txp (getAllPotentiallyHugeUtxo, utxoSource) @@ -300,36 +300,36 @@ data ExplorerOp | PutUtxoSum !Integer -instance HasConfiguration => RocksBatchOp ExplorerOp where +instance RocksBatchOp ExplorerOp where toBatchOp (AddTxExtra id extra) = - [Rocks.Put (txExtraPrefix id) (dbSerializeValue extra)] + [Rocks.Put (txExtraPrefix id) (serialize' extra)] toBatchOp (DelTxExtra id) = [Rocks.Del $ txExtraPrefix id] toBatchOp (PutPageBlocks page pageBlocks) = - [Rocks.Put (blockPagePrefix page) (dbSerializeValue pageBlocks)] + [Rocks.Put (blockPagePrefix page) (serialize' pageBlocks)] toBatchOp (PutEpochBlocks epoch page pageBlocks) = - [Rocks.Put (blockEpochPagePrefix epoch page) (dbSerializeValue pageBlocks)] + [Rocks.Put (blockEpochPagePrefix epoch page) (serialize' pageBlocks)] toBatchOp (PutEpochPages epoch page) = - [Rocks.Put (blockEpochMaxPagePrefix epoch) (dbSerializeValue page)] + [Rocks.Put (blockEpochMaxPagePrefix epoch) (serialize' page)] toBatchOp (PutLastTxs lastTxs) = - [Rocks.Put lastTxsPrefix (dbSerializeValue lastTxs)] + [Rocks.Put lastTxsPrefix (serialize' lastTxs)] toBatchOp (UpdateAddrHistory addr txs) | null txs = [Rocks.Del key] - | otherwise = [Rocks.Put key (dbSerializeValue txs)] + | otherwise = [Rocks.Put key (serialize' txs)] where key = addrHistoryKey addr toBatchOp (PutAddrBalance addr coin) = - [Rocks.Put (addrBalanceKey addr) (dbSerializeValue coin)] + [Rocks.Put (addrBalanceKey addr) (serialize' coin)] toBatchOp (DelAddrBalance addr) = [Rocks.Del $ addrBalanceKey addr] toBatchOp (PutUtxoSum utxoSum) = - [Rocks.Put utxoSumPrefix (dbSerializeValue utxoSum)] + [Rocks.Put utxoSumPrefix (serialize' utxoSum)] ---------------------------------------------------------------------------- -- Iteration diff --git a/explorer/src/Pos/Explorer/ExplorerMode.hs b/explorer/src/Pos/Explorer/ExplorerMode.hs index d2af101e568..54d5a477b94 100644 --- a/explorer/src/Pos/Explorer/ExplorerMode.hs +++ b/explorer/src/Pos/Explorer/ExplorerMode.hs @@ -186,7 +186,7 @@ instance HasLens DB.DBPureVar ExplorerTestInitContext DB.DBPureVar where -- Boilerplate ExplorerTestInitMode instances ---------------------------------------------------------------------------- -instance HasConfigurations => DB.MonadDBRead ExplorerTestInitMode where +instance DB.MonadDBRead ExplorerTestInitMode where dbGet = DB.dbGetPureDefault dbIterSource = DB.dbIterSourcePureDefault dbGetSerBlock = const DB.dbGetSerBlockPureDefault @@ -239,7 +239,7 @@ instance HasJsonLogConfig ExplorerTestContext where -- Boilerplate ExplorerTestMode instances ---------------------------------------------------------------------------- -instance HasConfigurations => MonadGState ExplorerTestMode where +instance MonadGState ExplorerTestMode where gsAdoptedBVData = DB.gsAdoptedBVDataDefault instance MonadSlotsData ctx ExplorerTestMode @@ -259,7 +259,7 @@ instance MonadSlotsData ctx ExplorerTestMode Just slot -> pure slot currentTimeSlotting = Slot.currentTimeSlottingSimple -instance HasConfigurations => DB.MonadDBRead ExplorerTestMode where +instance DB.MonadDBRead ExplorerTestMode where dbGet = DB.dbGetPureDefault dbIterSource = DB.dbIterSourcePureDefault dbGetSerBlock = const DB.dbGetSerBlockPureDefault diff --git a/explorer/src/Pos/Explorer/Txp/Global.hs b/explorer/src/Pos/Explorer/Txp/Global.hs index e61f88c9de8..13b31b848e9 100644 --- a/explorer/src/Pos/Explorer/Txp/Global.hs +++ b/explorer/src/Pos/Explorer/Txp/Global.hs @@ -11,7 +11,7 @@ import qualified Data.HashMap.Strict as HM import Pos.Chain.Block (ComponentBlock (..), HeaderHash, headerHash, headerSlotL) import Pos.Chain.Txp (TxAux, TxUndo, TxpConfiguration) -import Pos.Core as Core (Config (..), HasConfiguration, SlotId (..), +import Pos.Core as Core (Config (..), SlotId (..), configBootStakeholders, epochIndexL, localSlotIndexMinBound) import Pos.Core.Chrono (NewestFirst (..)) @@ -96,7 +96,7 @@ applySingle bootStakeholders txpBlund = do let (txAuxesAndUndos, hHash) = blundToAuxNUndoWHash txpBlund return $ eApplyToil bootStakeholders mTxTimestamp txAuxesAndUndos hHash -extraOps :: HasConfiguration => ExplorerExtraModifier -> SomeBatchOp +extraOps :: ExplorerExtraModifier -> SomeBatchOp extraOps (ExplorerExtraModifier em (HM.toList -> histories) balances utxoNewSum) = SomeBatchOp $ map GS.DelTxExtra (MM.deletions em) ++ diff --git a/explorer/src/Pos/Explorer/Web/Transform.hs b/explorer/src/Pos/Explorer/Web/Transform.hs index bfe816417e1..5b0e4ef0e32 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 as Core (Config (..), HasConfiguration) +import Pos.Core as Core (Config (..)) import Pos.DB.Txp (MempoolExt, MonadTxpLocal (..)) import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Infra.Reporting (MonadReporting (..)) @@ -53,13 +53,11 @@ type ExplorerProd = ExtraContextT (ExplorerBListener RealModeE) type instance MempoolExt ExplorerProd = ExplorerExtraModifier -instance HasConfiguration => - MonadTxpLocal RealModeE where +instance MonadTxpLocal RealModeE where txpNormalize = eTxNormalize txpProcessTx = eTxProcessTransaction -instance HasConfiguration => - MonadTxpLocal ExplorerProd where +instance MonadTxpLocal ExplorerProd where txpNormalize pm = lift . lift . txpNormalize pm txpProcessTx coreConfig txpConfig = lift . lift . txpProcessTx coreConfig txpConfig @@ -75,8 +73,7 @@ liftToExplorerProd :: RealModeE a -> ExplorerProd a liftToExplorerProd = lift . lift type HasExplorerConfiguration = - ( HasConfiguration - , HasBlockConfiguration + ( HasBlockConfiguration , HasNodeConfiguration , HasUpdateConfiguration , HasSscConfiguration diff --git a/explorer/src/explorer/Main.hs b/explorer/src/explorer/Main.hs index b5eee2537e1..6abe12b1839 100644 --- a/explorer/src/explorer/Main.hs +++ b/explorer/src/explorer/Main.hs @@ -55,12 +55,8 @@ main = do action :: ExplorerNodeArgs -> IO () action (ExplorerNodeArgs (cArgs@CommonNodeArgs{..}) ExplorerArgs{..}) = - withConfigurations blPath conf $ \coreConfig txpConfig ntpConfig -> + withConfigurations blPath cnaDumpGenesisDataPath cnaDumpConfiguration conf $ \coreConfig txpConfig _ntpConfig -> withCompileInfo $ do - CLI.printInfoOnStart cArgs - (configGenesisData coreConfig) - ntpConfig - txpConfig logInfo $ "Explorer is enabled!" (currentParams, Just sscParams) <- getNodeParams loggerName diff --git a/generator/app/VerificationBench.hs b/generator/app/VerificationBench.hs index 2312b7fabf9..6b9fae42a52 100644 --- a/generator/app/VerificationBench.hs +++ b/generator/app/VerificationBench.hs @@ -19,13 +19,14 @@ import Pos.Binary.Class (decodeFull, serialize) import Pos.Chain.Block (ApplyBlocksException, Block, VerifyBlocksException) import Pos.Chain.Txp (TxpConfiguration (..)) -import Pos.Core as Core (Config (..), configBlockVersionData, - configBootStakeholders, configGeneratedSecretsThrow) +import Pos.Core as Core (Config (..), ProtocolConstants (..), + configBlockVersionData, configBootStakeholders, + configGeneratedSecretsThrow) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) -import Pos.Core.Genesis (FakeAvvmOptions (..), GenesisData (..), - GenesisInitializer (..), GenesisProtocolConstants (..), - TestnetBalanceOptions (..), gsSecretKeys) +import Pos.Core.Genesis (FakeAvvmOptions (..), + GenesisInitializer (..), TestnetBalanceOptions (..), + gsSecretKeys) import Pos.Core.Slotting (Timestamp (..)) import Pos.Crypto (SecretKey) import Pos.DB.Block (rollbackBlocks, verifyAndApplyBlocks, @@ -195,25 +196,27 @@ main = do , cfoKey = baConfigKey args , cfoSystemStart = Just (Timestamp startTime) } - fn :: GenesisData -> GenesisData - fn gd = gd { gdProtocolConsts = (gdProtocolConsts gd) { gpcK = baK args } } withCompileInfo $ - withConfigurationsM (LoggerName "verification-bench") Nothing cfo fn $ \ !coreConfig !txpConfig !_ -> do - let tp = TestParams + withConfigurationsM (LoggerName "verification-bench") Nothing Nothing False cfo $ \ !coreConfig !txpConfig !_ -> do + let coreConfig' = coreConfig + { configProtocolConstants = + (configProtocolConstants coreConfig) { pcK = baK args } + } + tp = TestParams { _tpStartTime = Timestamp (convertUnit startTime) - , _tpBlockVersionData = configBlockVersionData coreConfig + , _tpBlockVersionData = configBlockVersionData coreConfig' , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = TxpConfiguration 200 Set.empty } - secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow coreConfig - runBlockTestMode coreConfig tp $ do + secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow coreConfig' + runBlockTestMode coreConfig' tp $ do -- initialize databasea - initNodeDBs coreConfig + initNodeDBs coreConfig' bs <- case baBlockCache args of Nothing -> do -- generate blocks and evaluate them to normal form logInfo "Generating blocks" - generateBlocks coreConfig secretKeys txpConfig (baBlockCount args) + generateBlocks coreConfig' secretKeys txpConfig (baBlockCount args) Just path -> do fileExists <- liftIO $ doesFileExist path mbs <- if fileExists @@ -223,7 +226,7 @@ main = do Nothing -> do -- generate blocks and evaluate them to normal form logInfo "Generating blocks" - bs <- generateBlocks coreConfig secretKeys txpConfig (baBlockCount args) + bs <- generateBlocks coreConfig' secretKeys txpConfig (baBlockCount args) liftIO $ writeBlocks path bs return bs Just bs -> return bs @@ -235,8 +238,8 @@ main = do $ \(idx, blocks) -> do logInfo $ sformat ("Pass: "%int) idx (if baApply args - then validateAndApply coreConfig txpConfig blocks - else validate coreConfig blocks) + then validateAndApply coreConfig' txpConfig blocks + else validate coreConfig' blocks) let -- drop first three results (if there are more than three results) itimes :: [Float] diff --git a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs index c7e6e7f73ac..b7e2966cb16 100644 --- a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs +++ b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs @@ -229,7 +229,7 @@ runBenchmark = do , cfoSystemStart = Just (Timestamp startTime) } withCompileInfo - $ withConfigurationsM (LoggerName "verifyBenchmark") Nothing cfo id + $ withConfigurationsM (LoggerName "verifyBenchmark") Nothing Nothing False cfo $ \coreConfig txpConfig _ -> do let tp = TestParams { _tpStartTime = Timestamp (convertUnit startTime) diff --git a/generator/src/Pos/Generator/Block/Mode.hs b/generator/src/Pos/Generator/Block/Mode.hs index 084cba5b768..84c105180bd 100644 --- a/generator/src/Pos/Generator/Block/Mode.hs +++ b/generator/src/Pos/Generator/Block/Mode.hs @@ -34,9 +34,9 @@ import Pos.Chain.Ssc (HasSscConfiguration, SscMemTag, SscState) import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Configuration (HasNodeConfiguration) -import Pos.Core (Address, HasConfiguration, HasPrimaryKey (..), - SlotCount, SlotId (..), Timestamp, epochOrSlotToSlot, - getEpochOrSlot, largestPubKeyAddressBoot) +import Pos.Core (Address, HasPrimaryKey (..), SlotCount, SlotId (..), + Timestamp, epochOrSlotToSlot, getEpochOrSlot, + largestPubKeyAddressBoot) import Pos.Core.Exception (reportFatalError) import Pos.Core.Genesis (GenesisWStakeholders (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), @@ -75,7 +75,6 @@ type MonadBlockGenBase m , MonadMask m , MonadIO m , MonadUnliftIO m - , HasConfiguration , HasUpdateConfiguration , HasSscConfiguration , HasNodeConfiguration diff --git a/generator/src/Test/Pos/Block/Logic/Mode.hs b/generator/src/Test/Pos/Block/Logic/Mode.hs index e006125c5ef..f657817f202 100644 --- a/generator/src/Test/Pos/Block/Logic/Mode.hs +++ b/generator/src/Test/Pos/Block/Logic/Mode.hs @@ -63,10 +63,8 @@ import Pos.Chain.Block (HasSlogGState (..)) 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, SlotId, - Timestamp (..), configEpochSlots, - configGeneratedSecretsThrow, withGenesisSpec) +import Pos.Core as Core (Config (..), SlotId, Timestamp (..), + configEpochSlots, configGeneratedSecretsThrow, mkConfig) import Pos.Core.Conc (currentTime) import Pos.Core.Genesis (GenesisInitializer (..), GenesisSpec (..), gsSecretKeys) @@ -103,8 +101,7 @@ import Pos.Infra.Slotting (HasSlottingVar (..), MonadSimpleSlotting, getCurrentSlotInaccurateSimple', getCurrentSlotSimple, getCurrentSlotSimple', mkSimpleSlottingStateVar) import Pos.Infra.Slotting.Types (SlottingData) -import Pos.Launcher.Configuration (Configuration (..), - HasConfigurations) +import Pos.Launcher.Configuration (HasConfigurations) import Pos.Util (newInitFuture, postfixLFields, postfixLFields2) import Pos.Util.CompileInfo (withCompileInfo) import Pos.Util.LoggerName (HasLoggerName' (..), askLoggerNameDefault, @@ -116,7 +113,7 @@ import Pos.WorkMode (EmptyMempoolExt) import Test.Pos.Block.Logic.Emulation (Emulation (..), runEmulation, sudoLiftIO) import Test.Pos.Configuration (defaultTestBlockVersionData, - defaultTestConf, defaultTestGenesisSpec) + defaultTestGenesisSpec) import Test.Pos.Core.Arbitrary () import Test.Pos.Core.Dummy (dummyEpochSlots) @@ -170,14 +167,10 @@ genGenesisInitializer = do -- This function creates 'CoreConfiguration' from 'TestParams' and -- uses it to satisfy 'HasConfiguration'. -withTestParams :: TestParams -> (HasConfiguration => Core.Config -> r) -> r -withTestParams TestParams {..} = withGenesisSpec _tpStartTime coreConfiguration id +withTestParams :: TestParams -> (Core.Config -> r) -> r +withTestParams TestParams {..} f = f $ mkConfig _tpStartTime genesisSpec where - defaultCoreConf :: CoreConfiguration - defaultCoreConf = ccCore defaultTestConf - coreConfiguration :: CoreConfiguration - coreConfiguration = defaultCoreConf { ccGenesis = GCSpec genesisSpec } - genesisSpec = defaultTestGenesisSpec + genesisSpec = defaultTestGenesisSpec { gsInitializer = _tpGenesisInitializer , gsBlockVersionData = _tpBlockVersionData } @@ -242,10 +235,8 @@ instance HasAllSecrets BlockTestContext where -- Initialization ---------------------------------------------------------------------------- -initBlockTestContext :: - ( HasConfiguration - , HasDlgConfiguration - ) +initBlockTestContext + :: HasDlgConfiguration => Core.Config -> TestParams -> (BlockTestContext -> Emulation a) @@ -300,10 +291,8 @@ instance HasLens BlockTestContextTag BlockTestContext BlockTestContext where type BlockTestMode = ReaderT BlockTestContext Emulation -runBlockTestMode :: - ( HasDlgConfiguration - , HasConfiguration - ) +runBlockTestMode + :: HasDlgConfiguration => Core.Config -> TestParams -> BlockTestMode a @@ -323,7 +312,7 @@ type BlockProperty = PropertyM BlockTestMode blockPropertyToProperty :: (HasDlgConfiguration, Testable a) => Gen TestParams - -> (HasConfiguration => Core.Config -> BlockProperty a) + -> (Core.Config -> BlockProperty a) -> Property blockPropertyToProperty tpGen blockProperty = forAll tpGen $ \tp -> withTestParams tp $ \coreConfig -> monadic @@ -344,7 +333,7 @@ blockPropertyToProperty tpGen blockProperty = -- property = blockPropertyToProperty arbitrary blockPropertyTestable :: (HasDlgConfiguration, Testable a) - => (HasConfiguration => Core.Config -> BlockProperty a) + => (Core.Config -> BlockProperty a) -> Property blockPropertyTestable = blockPropertyToProperty arbitrary @@ -365,14 +354,14 @@ instance HasSlottingVar TestInitModeContext where slottingTimestamp = timcSystemStart_L slottingVar = timcSlottingVar_L -instance HasConfiguration => MonadDBRead TestInitMode where +instance MonadDBRead TestInitMode where dbGet = DB.dbGetPureDefault dbIterSource = DB.dbIterSourcePureDefault dbGetSerBlock = const DB.dbGetSerBlockPureDefault dbGetSerUndo = const DB.dbGetSerUndoPureDefault dbGetSerBlund = const DB.dbGetSerBlundPureDefault -instance HasConfiguration => MonadDB TestInitMode where +instance MonadDB TestInitMode where dbPut = DB.dbPutPureDefault dbWriteBatch = DB.dbWriteBatchPureDefault dbDelete = DB.dbDeletePureDefault @@ -499,20 +488,20 @@ instance MonadSlotsData ctx BlockTestMode => MonadSlots ctx BlockTestMode where getCurrentSlotInaccurate = const getCurrentSlotInaccurateTestDefault currentTimeSlotting = currentTimeSlottingTestDefault -instance HasConfiguration => MonadDBRead BlockTestMode where +instance MonadDBRead BlockTestMode where dbGet = DB.dbGetPureDefault dbIterSource = DB.dbIterSourcePureDefault dbGetSerBlock = const DB.dbGetSerBlockPureDefault dbGetSerUndo = const DB.dbGetSerUndoPureDefault dbGetSerBlund = const DB.dbGetSerBlundPureDefault -instance HasConfiguration => MonadDB BlockTestMode where +instance MonadDB BlockTestMode where dbPut = DB.dbPutPureDefault dbWriteBatch = DB.dbWriteBatchPureDefault dbDelete = DB.dbDeletePureDefault dbPutSerBlunds = DB.dbPutSerBlundsPureDefault -instance HasConfiguration => MonadGState BlockTestMode where +instance MonadGState BlockTestMode where gsAdoptedBVData = gsAdoptedBVDataDefault instance MonadBListener BlockTestMode where @@ -525,6 +514,6 @@ instance HasConfigurations => MonadTxpLocal (BlockGenMode EmptyMempoolExt BlockT txpNormalize = withCompileInfo $ txNormalize txpProcessTx = withCompileInfo $ txProcessTransactionNoLock -instance HasConfigurations => MonadTxpLocal BlockTestMode where +instance MonadTxpLocal BlockTestMode where txpNormalize = withCompileInfo $ txNormalize txpProcessTx = withCompileInfo $ txProcessTransactionNoLock diff --git a/generator/test/Test/Pos/Block/Logic/VarSpec.hs b/generator/test/Test/Pos/Block/Logic/VarSpec.hs index 3f35c28ac56..d6c735cf8f3 100644 --- a/generator/test/Test/Pos/Block/Logic/VarSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/VarSpec.hs @@ -24,9 +24,8 @@ import Test.QuickCheck.Random (QCGen) import Pos.Chain.Block (Blund, headerHash) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core as Core (Config (..), HasConfiguration, - ProtocolConstants (..), configBootStakeholders, - configEpochSlots) +import Pos.Core as Core (Config (..), ProtocolConstants (..), + configBootStakeholders, configEpochSlots) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), nonEmptyNewestFirst, nonEmptyOldestFirst, splitAtNewestFirst, toNewestFirst, _NewestFirst) @@ -148,8 +147,7 @@ verifyAndApplyBlocksSpec txpConfig = applyByOneOrAllAtOnce coreConfig txpConfig (applier coreConfig) where applier - :: HasConfiguration - => Core.Config + :: Core.Config -> OldestFirst NE Blund -> BlockTestMode () applier coreConfig blunds = do diff --git a/generator/test/Test/Pos/Block/Property.hs b/generator/test/Test/Pos/Block/Property.hs index 7057964a6a8..7b4e9fc78d5 100644 --- a/generator/test/Test/Pos/Block/Property.hs +++ b/generator/test/Test/Pos/Block/Property.hs @@ -12,7 +12,7 @@ import Test.Hspec (Spec) import Test.Hspec.QuickCheck (prop) import Pos.Chain.Delegation (HasDlgConfiguration) -import Pos.Core as Core (Config, HasConfiguration) +import Pos.Core as Core (Config) import Test.Pos.Block.Logic.Mode (BlockProperty, blockPropertyTestable) @@ -22,6 +22,6 @@ import Test.QuickCheck.Property (Testable) blockPropertySpec :: (HasDlgConfiguration, Testable a) => String - -> (HasConfiguration => Core.Config -> BlockProperty a) + -> (Core.Config -> BlockProperty a) -> Spec blockPropertySpec description bp = prop description (blockPropertyTestable bp) diff --git a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs index 3410a936aa5..980e0b9d1d4 100644 --- a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs +++ b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs @@ -185,7 +185,7 @@ lrcCorrectnessProp coreConfig txpConfig = do checkRichmen coreConfig -checkRichmen :: HasConfigurations => Core.Config -> BlockProperty () +checkRichmen :: Core.Config -> BlockProperty () checkRichmen coreConfig = do checkRichmenStakes =<< getRichmen (lift . LrcDB.tryGetSscRichmen genesisBvd) checkRichmenFull =<< getRichmen (lift . LrcDB.tryGetUSRichmen genesisBvd) diff --git a/lib/src/Pos/Client/CLI/Util.hs b/lib/src/Pos/Client/CLI/Util.hs index 3c7a3af95bb..4146268a541 100644 --- a/lib/src/Pos/Client/CLI/Util.hs +++ b/lib/src/Pos/Client/CLI/Util.hs @@ -3,71 +3,25 @@ -- | Module for command-line utilites, parsers and convenient handlers. module Pos.Client.CLI.Util - ( printFlags - , printInfoOnStart - , attackTypeParser + ( attackTypeParser , attackTargetParser , defaultLoggerConfig , readLoggerConfig , stakeholderIdParser - , dumpGenesisData - , dumpConfiguration ) where import Universum hiding (try) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Yaml as Yaml -import Formatting (sformat, shown, (%)) import Text.Parsec (parserFail, try) import qualified Text.Parsec.Char as P import qualified Text.Parsec.Text as P -import Ntp.Client (NtpConfiguration) -import Pos.Chain.Block (blockConfiguration) -import Pos.Chain.Delegation (dlgConfiguration) import Pos.Chain.Security (AttackTarget (..), AttackType (..)) -import Pos.Chain.Ssc (sscConfiguration) -import Pos.Chain.Txp (TxpConfiguration) -import Pos.Chain.Update (updateConfiguration) -import Pos.Client.CLI.NodeOptions (CommonNodeArgs (..)) -import Pos.Client.CLI.Options (configurationOptions) -import Pos.Configuration (nodeConfiguration) -import Pos.Core (StakeholderId, Timestamp (..)) -import Pos.Core.Conc (currentTime) -import Pos.Core.Configuration (canonicalGenesisJson, - coreConfiguration, prettyGenesisJson) -import Pos.Core.Genesis (GenesisData, gdStartTime) +import Pos.Core (StakeholderId) import Pos.Core.NetworkAddress (addrParser) import Pos.Crypto (decodeAbstractHash) -import Pos.Launcher.Configuration (Configuration (..), - HasConfigurations) -import Pos.Util.AssertMode (inAssertMode) -import Pos.Util.Wlog (LoggerConfig (..), WithLogger, logInfo, - parseLoggerConfig, productionB) - -printFlags :: WithLogger m => m () -printFlags = do - inAssertMode $ logInfo "Asserts are ON" - -printInfoOnStart :: - (HasConfigurations, WithLogger m, MonadIO m) - => CommonNodeArgs - -> GenesisData - -> NtpConfiguration - -> TxpConfiguration - -> m () -printInfoOnStart CommonNodeArgs {..} genesisData ntpConfig txpConfig = do - whenJust cnaDumpGenesisDataPath $ dumpGenesisData genesisData True - when cnaDumpConfiguration $ dumpConfiguration ntpConfig txpConfig - printFlags - t <- currentTime - mapM_ logInfo $ - [ sformat ("System start time is " % shown) $ gdStartTime genesisData - , sformat ("Current time is "%shown) (Timestamp t) - , sformat ("Using configs and genesis:\n"%shown) - (configurationOptions commonArgs) - ] +import Pos.Util.Wlog (LoggerConfig (..), parseLoggerConfig, + productionB) attackTypeParser :: P.Parser AttackType attackTypeParser = P.string "No" >> @@ -94,35 +48,3 @@ defaultLoggerConfig = productionB -- 'defaultLoggerConfig'. readLoggerConfig :: MonadIO m => Maybe FilePath -> m LoggerConfig readLoggerConfig = maybe (return defaultLoggerConfig) parseLoggerConfig - --- | Dump our 'GenesisData' into a file. -dumpGenesisData :: - (MonadIO m, WithLogger m) => GenesisData -> Bool -> FilePath -> m () -dumpGenesisData genesisData canonical path = do - let (canonicalJsonBytes, jsonHash) = canonicalGenesisJson genesisData - let prettyJsonStr = prettyGenesisJson genesisData - logInfo $ sformat ("Writing JSON with hash "%shown%" to "%shown) jsonHash path - liftIO $ case canonical of - True -> BSL.writeFile path canonicalJsonBytes - False -> writeFile path (toText prettyJsonStr) - --- | Dump our configuration into stdout and exit. -dumpConfiguration - :: (HasConfigurations, MonadIO m) - => NtpConfiguration - -> TxpConfiguration - -> m () -dumpConfiguration ntpConfig txpConfig = do - let conf = - Configuration - { ccCore = coreConfiguration - , ccNtp = ntpConfig - , ccUpdate = updateConfiguration - , ccSsc = sscConfiguration - , ccDlg = dlgConfiguration - , ccTxp = txpConfig - , ccBlock = blockConfiguration - , ccNode = nodeConfiguration - } - putText . decodeUtf8 . Yaml.encode $ conf - exitSuccess diff --git a/lib/src/Pos/Launcher/Configuration.hs b/lib/src/Pos/Launcher/Configuration.hs index be436623051..2174a1d191e 100644 --- a/lib/src/Pos/Launcher/Configuration.hs +++ b/lib/src/Pos/Launcher/Configuration.hs @@ -15,6 +15,8 @@ module Pos.Launcher.Configuration , withConfigurations + , dumpGenesisData + -- Exposed mostly for testing. , readAssetLockedSrcAddrs , withConfigurationsM @@ -24,11 +26,14 @@ import Universum import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON, withObject, (.:), (.:?)) +import qualified Data.ByteString.Lazy as BSL import Data.Default (Default (..)) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text import Data.Time.Units (fromMicroseconds) +import qualified Data.Yaml as Yaml +import Formatting (sformat, shown, (%)) import Data.Aeson.Options (defaultOptions) import System.FilePath (takeDirectory) @@ -36,8 +41,10 @@ import System.FilePath (takeDirectory) import Ntp.Client (NtpConfiguration) import Pos.Core (Address, decodeTextAddress) -import Pos.Core.Genesis (GenesisData) +import Pos.Core.Conc (currentTime) +import Pos.Core.Genesis (GenesisData (..)) import Pos.Core.Slotting (Timestamp (..)) +import Pos.Util.AssertMode (inAssertMode) import Pos.Util.Config (parseYamlConfig) import Pos.Util.Wlog (LoggerName, WithLogger, askLoggerName, logInfo, usingLoggerName) @@ -69,8 +76,7 @@ instance ToJSON Configuration where toJSON = genericToJSON defaultOptions type HasConfigurations = - ( HasConfiguration - , HasUpdateConfiguration + ( HasUpdateConfiguration , HasSscConfiguration , HasBlockConfiguration , HasDlgConfiguration @@ -116,26 +122,36 @@ withConfigurationsM :: forall m r. (MonadThrow m, MonadIO m) => LoggerName -> Maybe AssetLockPath + -> Maybe FilePath + -> Bool -> ConfigurationOptions - -> (GenesisData -> GenesisData) - -- ^ change genesis data; this is useful if some parameters are passed as - -- comand line arguments for some tools (profiling executables, benchmarks). -> (HasConfigurations => Core.Config -> TxpConfiguration -> NtpConfiguration -> m r) -> m r -withConfigurationsM logName mAssetLockPath cfo fn act = do +withConfigurationsM logName mAssetLockPath dumpGenesisPath dumpConfig cfo act = do logInfo' ("using configurations: " <> show cfo) cfg <- parseYamlConfig (cfoFilePath cfo) (cfoKey cfo) assetLock <- case mAssetLockPath of Nothing -> pure mempty Just fp -> liftIO $ readAssetLockedSrcAddrs fp let configDir = takeDirectory $ cfoFilePath cfo - withCoreConfigurations (ccCore cfg) fn configDir (cfoSystemStart cfo) (cfoSeed cfo) $ - withUpdateConfiguration (ccUpdate cfg) $ + coreConfig <- withCoreConfigurations (ccCore cfg) + configDir + (cfoSystemStart cfo) + (cfoSeed cfo) + withUpdateConfiguration (ccUpdate cfg) $ withSscConfiguration (ccSsc cfg) $ withDlgConfiguration (ccDlg cfg) $ withBlockConfiguration (ccBlock cfg) $ - withNodeConfiguration (ccNode cfg) $ \ coreConfig -> - act coreConfig (addAssetLock assetLock $ ccTxp cfg) (ccNtp cfg) + withNodeConfiguration (ccNode cfg) $ do + let txpConfig = addAssetLock assetLock $ ccTxp cfg + liftIO . usingLoggerName logName $ printInfoOnStart + dumpGenesisPath + dumpConfig + (configGenesisData coreConfig) + (ccCore cfg) + (ccNtp cfg) + txpConfig + act coreConfig txpConfig (ccNtp cfg) where logInfo' :: Text -> m () @@ -144,12 +160,19 @@ withConfigurationsM logName mAssetLockPath cfo fn act = do withConfigurations :: (WithLogger m, MonadThrow m, MonadIO m) => Maybe AssetLockPath + -> Maybe FilePath + -> Bool -> ConfigurationOptions -> (HasConfigurations => Core.Config -> TxpConfiguration -> NtpConfiguration -> m r) -> m r -withConfigurations mAssetLockPath cfo act = do +withConfigurations mAssetLockPath dumpGenesisPath dumpConfig cfo act = do loggerName <- askLoggerName - withConfigurationsM loggerName mAssetLockPath cfo id act + withConfigurationsM loggerName + mAssetLockPath + dumpGenesisPath + dumpConfig + cfo + act addAssetLock :: Set Address -> TxpConfiguration -> TxpConfiguration addAssetLock bset tcfg = @@ -166,3 +189,59 @@ readAssetLockedSrcAddrs (AssetLockPath fp) = do where keepLine t = not (Text.null t || "#" `Text.isPrefixOf` t) + +printInfoOnStart :: + (HasConfigurations, WithLogger m, MonadIO m) + => Maybe FilePath + -> Bool + -> GenesisData + -> CoreConfiguration + -> NtpConfiguration + -> TxpConfiguration + -> m () +printInfoOnStart dumpGenesisPath dumpConfig genesisData coreConfig ntpConfig txpConfig = do + whenJust dumpGenesisPath $ dumpGenesisData genesisData True + when dumpConfig $ dumpConfiguration coreConfig ntpConfig txpConfig + printFlags + t <- currentTime + mapM_ logInfo $ + [ sformat ("System start time is " % shown) $ gdStartTime genesisData + , sformat ("Current time is "%shown) (Timestamp t) + ] + +printFlags :: WithLogger m => m () +printFlags = do + inAssertMode $ logInfo "Asserts are ON" + +-- | Dump our 'GenesisData' into a file. +dumpGenesisData :: + (MonadIO m, WithLogger m) => GenesisData -> Bool -> FilePath -> m () +dumpGenesisData genesisData canonical path = do + let (canonicalJsonBytes, jsonHash) = canonicalGenesisJson genesisData + let prettyJsonStr = prettyGenesisJson genesisData + logInfo $ sformat ("Writing JSON with hash "%shown%" to "%shown) jsonHash path + liftIO $ case canonical of + True -> BSL.writeFile path canonicalJsonBytes + False -> writeFile path (toText prettyJsonStr) + +-- | Dump our configuration into stdout and exit. +dumpConfiguration + :: (HasConfigurations, MonadIO m) + => CoreConfiguration + -> NtpConfiguration + -> TxpConfiguration + -> m () +dumpConfiguration coreConfig ntpConfig txpConfig = do + let conf = + Configuration + { ccCore = coreConfig + , ccNtp = ntpConfig + , ccUpdate = updateConfiguration + , ccSsc = sscConfiguration + , ccDlg = dlgConfiguration + , ccTxp = txpConfig + , ccBlock = blockConfiguration + , ccNode = nodeConfiguration + } + putText . decodeUtf8 . Yaml.encode $ conf + exitSuccess diff --git a/lib/src/Pos/Launcher/Mode.hs b/lib/src/Pos/Launcher/Mode.hs index 16e1c42b0e6..b0e316ed6b9 100644 --- a/lib/src/Pos/Launcher/Mode.hs +++ b/lib/src/Pos/Launcher/Mode.hs @@ -27,7 +27,7 @@ import Universum import Control.Lens (makeLensesWith) import qualified Control.Monad.Reader as Mtl -import Pos.Core (HasConfiguration, Timestamp) +import Pos.Core (Timestamp) import Pos.Core.Slotting (MonadSlotsData) import Pos.DB (NodeDBs) import Pos.DB.Block (dbGetSerBlockRealDefault, @@ -75,14 +75,14 @@ instance HasSlottingVar InitModeContext where slottingTimestamp = imcSlottingVar_L . _1 slottingVar = imcSlottingVar_L . _2 -instance HasConfiguration => MonadDBRead InitMode where +instance MonadDBRead InitMode where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB InitMode where +instance MonadDB InitMode where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault diff --git a/lib/src/Pos/Launcher/Resource.hs b/lib/src/Pos/Launcher/Resource.hs index 24cdd695102..4e2b7e44557 100644 --- a/lib/src/Pos/Launcher/Resource.hs +++ b/lib/src/Pos/Launcher/Resource.hs @@ -41,8 +41,8 @@ import Pos.Client.CLI.Util (readLoggerConfig) import Pos.Configuration import Pos.Context (ConnectedPeers (..), NodeContext (..), StartTime (..)) -import Pos.Core as Core (Config, HasConfiguration, Timestamp, - configBlkSecurityParam, configEpochSlots, configStartTime) +import Pos.Core as Core (Config, Timestamp, configBlkSecurityParam, + configEpochSlots, configStartTime) import Pos.Core.Reporting (initializeMisbehaviorMetrics) import Pos.DB (MonadDBRead, NodeDBs) import Pos.DB.Block (consolidateWorker, mkSlogContext) @@ -99,7 +99,6 @@ data NodeResources ext = NodeResources allocateNodeResources :: forall ext . ( Default ext - , HasConfiguration , HasNodeConfiguration , HasDlgConfiguration , HasBlockConfiguration @@ -203,7 +202,6 @@ releaseNodeResources NodeResources {..} = do -- resources will be released eventually. bracketNodeResources :: forall ext a. ( Default ext - , HasConfiguration , HasNodeConfiguration , HasDlgConfiguration , HasBlockConfiguration @@ -213,7 +211,7 @@ bracketNodeResources :: forall ext a. -> SscParams -> TxpGlobalSettings -> InitMode () - -> (HasConfiguration => NodeResources ext -> IO a) + -> (NodeResources ext -> IO a) -> IO a bracketNodeResources coreConfig np sp txp initDB action = do let msg = "`NodeResources'" @@ -266,7 +264,7 @@ data AllocateNodeContextData ext = AllocateNodeContextData allocateNodeContext :: forall ext . - (HasConfiguration, HasNodeConfiguration, HasBlockConfiguration) + (HasNodeConfiguration, HasBlockConfiguration) => Core.Config -> AllocateNodeContextData ext -> TxpGlobalSettings diff --git a/lib/src/Pos/Logic/Full.hs b/lib/src/Pos/Logic/Full.hs index 424cea88c81..9b999f98c35 100644 --- a/lib/src/Pos/Logic/Full.hs +++ b/lib/src/Pos/Logic/Full.hs @@ -24,8 +24,8 @@ import Pos.Chain.Ssc (MCCommitment (..), MCOpening (..), import Pos.Chain.Txp (MemPool (..), TxAux (..), TxMsgContents (..), TxpConfiguration) import Pos.Communication (NodeId) -import Pos.Core as Core (Config (..), HasConfiguration, StakeholderId, - addressHash, configBlkSecurityParam, configEpochSlots) +import Pos.Core as Core (Config (..), StakeholderId, addressHash, + configBlkSecurityParam, configEpochSlots) import Pos.Core.Chrono (NE, NewestFirst, OldestFirst) import Pos.Core.Delegation (ProxySKHeavy) import Pos.Core.Ssc (getCertId, getCommitmentsMap, lookupVss) @@ -74,8 +74,7 @@ import Pos.Util.Wlog (WithLogger, logDebug) -- layer which uses the more complicated monad, and vice-versa. type LogicWorkMode ctx m = - ( HasConfiguration - , HasBlockConfiguration + ( HasBlockConfiguration , WithLogger m , MonadReader ctx m , MonadMask m diff --git a/lib/src/Pos/Web/Mode.hs b/lib/src/Pos/Web/Mode.hs index 6183e260624..8c642702151 100644 --- a/lib/src/Pos/Web/Mode.hs +++ b/lib/src/Pos/Web/Mode.hs @@ -13,7 +13,6 @@ import qualified Control.Monad.Reader as Mtl import Pos.Context (HasPrimaryKey (..), HasSscContext (..), NodeContext) -import Pos.Core.Configuration (HasConfiguration) import Pos.DB (NodeDBs) import Pos.DB.Block (dbGetSerBlockRealDefault, dbGetSerBlundRealDefault, dbGetSerUndoRealDefault, @@ -53,14 +52,14 @@ instance HasPrimaryKey (WebModeContext ext) where type WebMode ext = Mtl.ReaderT (WebModeContext ext) IO -instance HasConfiguration => MonadDBRead (WebMode ext) where +instance MonadDBRead (WebMode ext) where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB (WebMode ext) where +instance MonadDB (WebMode ext) where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault diff --git a/lib/src/Pos/Web/Server.hs b/lib/src/Pos/Web/Server.hs index 551d61d87b7..725960c635c 100644 --- a/lib/src/Pos/Web/Server.hs +++ b/lib/src/Pos/Web/Server.hs @@ -46,7 +46,6 @@ import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Context (HasNodeContext (..), HasSscContext (..), NodeContext, getOurPublicKey) import Pos.Core (EpochIndex (..), SlotLeaders) -import Pos.Core.Configuration (HasConfiguration) import Pos.DB (MonadDBRead) import qualified Pos.DB as DB import qualified Pos.DB.Lrc as LrcDB @@ -254,7 +253,7 @@ servantServer = withNat (Proxy @NodeApi) nodeServantHandlers ---------------------------------------------------------------------------- nodeServantHandlers - :: (HasConfiguration, HasUpdateConfiguration, Default ext) + :: (HasUpdateConfiguration, Default ext) => ServerT NodeApi (WebMode ext) nodeServantHandlers = getLeaders @@ -274,7 +273,7 @@ nodeServantHandlers = -- :<|> getOurSecret -- :<|> getSscStage -getLeaders :: HasConfiguration => Maybe EpochIndex -> WebMode ext SlotLeaders +getLeaders :: Maybe EpochIndex -> WebMode ext SlotLeaders getLeaders maybeEpoch = do -- epoch <- maybe (siEpoch <$> getCurrentSlot) pure maybeEpoch epoch <- maybe (pure 0) pure maybeEpoch @@ -282,7 +281,7 @@ getLeaders maybeEpoch = do where err = err404 { errBody = encodeUtf8 ("Leaders are not know for current epoch"::Text) } -getUtxo :: HasConfiguration => WebMode ext [TxOut] +getUtxo :: WebMode ext [TxOut] getUtxo = map toaOut . toList <$> getAllPotentiallyHugeUtxo getLocalTxsNum :: Default ext => WebMode ext Word diff --git a/lib/src/Pos/WorkMode.hs b/lib/src/Pos/WorkMode.hs index 552ffc1241a..83251007e46 100644 --- a/lib/src/Pos/WorkMode.hs +++ b/lib/src/Pos/WorkMode.hs @@ -24,7 +24,6 @@ import Pos.Chain.Delegation (DelegationVar) import Pos.Chain.Ssc (SscMemTag, SscState) import Pos.Context (HasNodeContext (..), HasPrimaryKey (..), HasSscContext (..), NodeContext) -import Pos.Core (HasConfiguration) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..)) import Pos.Core.Slotting (HasSlottingVar (..), MonadSlotsData) @@ -154,17 +153,17 @@ instance MonadSlotsData ctx (RealMode ext) => MonadSlots ctx (RealMode ext) wher getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple currentTimeSlotting = currentTimeSlottingSimple -instance HasConfiguration => MonadGState (RealMode ext) where +instance MonadGState (RealMode ext) where gsAdoptedBVData = gsAdoptedBVDataDefault -instance HasConfiguration => MonadDBRead (RealMode ext) where +instance MonadDBRead (RealMode ext) where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB (RealMode ext) where +instance MonadDB (RealMode ext) where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault @@ -176,8 +175,7 @@ instance MonadBListener (RealMode ext) where type instance MempoolExt (RealMode ext) = ext -instance (HasConfiguration) => - MonadTxpLocal (RealMode ()) where +instance MonadTxpLocal (RealMode ()) where txpNormalize = txNormalize txpProcessTx = txProcessTransaction diff --git a/lib/src/Pos/WorkMode/Class.hs b/lib/src/Pos/WorkMode/Class.hs index 311f92844fa..46f420af445 100644 --- a/lib/src/Pos/WorkMode/Class.hs +++ b/lib/src/Pos/WorkMode/Class.hs @@ -25,7 +25,7 @@ import Pos.Chain.Update (HasUpdateConfiguration, UpdateParams) import Pos.Configuration (HasNodeConfiguration) import Pos.Context (BlockRetrievalQueue, BlockRetrievalQueueTag, HasSscContext, StartTime, TxpGlobalSettings) -import Pos.Core (HasConfiguration, HasPrimaryKey) +import Pos.Core (HasPrimaryKey) import Pos.Core.JsonLog (CanJsonLog) import Pos.Core.Reporting (HasMisbehaviorMetrics, MonadReporting) import Pos.DB.Block (MonadBListener) @@ -92,7 +92,6 @@ type MinWorkMode m , CanJsonLog m , MonadIO m , MonadUnliftIO m - , HasConfiguration , HasUpdateConfiguration , HasNodeConfiguration , HasBlockConfiguration diff --git a/lib/src/Test/Pos/Configuration.hs b/lib/src/Test/Pos/Configuration.hs index 0ebc82b940f..96a511af4af 100644 --- a/lib/src/Test/Pos/Configuration.hs +++ b/lib/src/Test/Pos/Configuration.hs @@ -35,7 +35,7 @@ import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Chain.Update (HasUpdateConfiguration, withUpdateConfiguration) import Pos.Configuration (HasNodeConfiguration, withNodeConfiguration) -import Pos.Core (HasConfiguration, withGenesisSpec) +import Pos.Core (mkConfig) import Pos.Core.Configuration as Core (Config, CoreConfiguration (..), GenesisConfiguration (..)) import Pos.Core.Genesis (GenesisSpec (..)) @@ -90,8 +90,8 @@ withDefBlockConfiguration = withBlockConfiguration (ccBlock defaultTestConf) withDefDlgConfiguration :: (HasDlgConfiguration => r) -> r withDefDlgConfiguration = withDlgConfiguration (ccDlg defaultTestConf) -withDefConfiguration :: (HasConfiguration => Core.Config -> r) -> r -withDefConfiguration = withGenesisSpec 0 (ccCore defaultTestConf) id +withDefConfiguration :: (Core.Config -> r) -> r +withDefConfiguration f = f $ mkConfig 0 defaultTestGenesisSpec withStaticConfigurations :: (HasStaticConfigurations => TxpConfiguration -> NtpConfiguration -> r) -> r withStaticConfigurations patak = diff --git a/lib/test/Test/Pos/Block/CborSpec.hs b/lib/test/Test/Pos/Block/CborSpec.hs index 80db4ac8e4a..3d7a1d70cfc 100644 --- a/lib/test/Test/Pos/Block/CborSpec.hs +++ b/lib/test/Test/Pos/Block/CborSpec.hs @@ -10,18 +10,15 @@ import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess) import qualified Pos.Chain.Block as Block -import Pos.Core.Configuration (withGenesisSpec) import qualified Pos.Network.Block.Types as Block import Test.Pos.Binary.Helpers (binaryTest) import Test.Pos.Block.Arbitrary.Message () import Test.Pos.Core.Arbitrary () -import Test.Pos.Core.Dummy (dummyCoreConfiguration) import Test.Pos.DB.Block.Arbitrary () spec :: Spec -spec = - withGenesisSpec 0 dummyCoreConfiguration id $ \_ -> do +spec = do describe "Block network types" $ modifyMaxSuccess (min 10) $ do binaryTest @Block.MsgGetHeaders binaryTest @Block.MsgGetBlocks diff --git a/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs b/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs index c107ac36aba..9ff507108f0 100644 --- a/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs +++ b/lib/test/Test/Pos/Launcher/ConfigurationSpec.hs @@ -25,7 +25,6 @@ spec = describe "Pos.Launcher.Configuration" $ do let catchFn :: ConfigurationException -> IO (Maybe ConfigurationException) catchFn e = return $ Just e res <- liftIO $ catch - (withConfigurationsM (LoggerName "test") Nothing cfo id (\_ _ _ -> return Nothing)) + (withConfigurationsM (LoggerName "test") Nothing Nothing False cfo (\_ _ _ -> return Nothing)) catchFn res `shouldSatisfy` isNothing - diff --git a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs index 538187a2fa1..fe4a7d68d78 100644 --- a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs +++ b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs @@ -23,8 +23,7 @@ import Pos.Chain.Ssc (SscGlobalState (..), VssCertData (..), expiryEoS, rollbackSsc, runPureToss, setLastKnownSlot, sgsVssCertificates) import qualified Pos.Chain.Ssc as Ssc -import Pos.Core (EpochIndex (..), EpochOrSlot (..), HasConfiguration, - SlotId (..)) +import Pos.Core (EpochIndex (..), EpochOrSlot (..), SlotId (..)) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Slotting (flattenEpochOrSlot, unflattenSlotId) import Pos.Core.Ssc (VssCertificate (..), getCertId, @@ -86,7 +85,7 @@ newtype CorrectVssCertData = CorrectVssCertData { getVssCertData :: VssCertData } deriving (Show) -instance HasConfiguration => Arbitrary CorrectVssCertData where +instance Arbitrary CorrectVssCertData where arbitrary = (CorrectVssCertData <$>) $ do certificatesToAdd <- choose (0, 100) lkeos <- arbitrary :: Gen EpochOrSlot @@ -178,7 +177,7 @@ verifyDeleteAndFilter (getVssCertData -> vcd@VssCertData{..}) = data RollbackData = Rollback SscGlobalState EpochOrSlot [VssCertificate] deriving (Show, Eq) -instance HasConfiguration => Arbitrary RollbackData where +instance Arbitrary RollbackData where arbitrary = do goodVssCertData@(VssCertData {..}) <- getVssCertData <$> arbitrary certsToRollbackN <- choose (0, 100) >>= choose . (0,) diff --git a/node/Main.hs b/node/Main.hs index 561152bc0b7..c486880ddc7 100644 --- a/node/Main.hs +++ b/node/Main.hs @@ -52,8 +52,7 @@ action -> TxpConfiguration -> NtpConfiguration -> IO () -action (SimpleNodeArgs (cArgs@CommonNodeArgs {..}) (nArgs@NodeArgs {..})) coreConfig txpConfig ntpConfig = do - CLI.printInfoOnStart cArgs (configGenesisData coreConfig) ntpConfig txpConfig +action (SimpleNodeArgs (cArgs@CommonNodeArgs {..}) (nArgs@NodeArgs {..})) coreConfig txpConfig _ntpConfig = do logInfo "Wallet is disabled, because software is built w/o it" (currentParams, Just sscParams) <- CLI.getNodeParams loggerName @@ -66,7 +65,12 @@ main :: IO () main = withCompileInfo $ do args@(CLI.SimpleNodeArgs commonNodeArgs _) <- CLI.getSimpleNodeOptions let loggingParams = CLI.loggingParams loggerName commonNodeArgs - let conf = CLI.configurationOptions (CLI.commonArgs commonNodeArgs) - let blPath = AssetLockPath <$> cnaAssetLockPath commonNodeArgs - loggerBracket loggingParams . logException "node" $ - withConfigurations blPath conf $ action args + let conf = CLI.configurationOptions (CLI.commonArgs commonNodeArgs) + let blPath = AssetLockPath <$> cnaAssetLockPath commonNodeArgs + loggerBracket loggingParams + . logException "node" + $ withConfigurations blPath + (cnaDumpGenesisDataPath commonNodeArgs) + (cnaDumpConfiguration commonNodeArgs) + conf + $ action args diff --git a/tools/src/Pos/Tools/Dbgen/Lib.hs b/tools/src/Pos/Tools/Dbgen/Lib.hs index 84628a1c96d..72fb7a0074f 100644 --- a/tools/src/Pos/Tools/Dbgen/Lib.hs +++ b/tools/src/Pos/Tools/Dbgen/Lib.hs @@ -229,7 +229,7 @@ timed action = do return res -fakeSync :: UberMonad () +fakeSync :: WalletWebMode () fakeSync = do say "Faking StateLock syncing..." tip <- getTip diff --git a/tools/src/blockchain-analyser/Main.hs b/tools/src/blockchain-analyser/Main.hs index 0952066e09e..b1bbe565da0 100644 --- a/tools/src/blockchain-analyser/Main.hs +++ b/tools/src/blockchain-analyser/Main.hs @@ -11,7 +11,7 @@ import System.Directory (canonicalizePath, doesDirectoryExist, import Pos.Chain.Block (Block, HeaderHash, Undo, headerHash) import qualified Pos.Client.CLI as CLI -import Pos.Core (Config (..), GenesisHash, HasConfiguration) +import Pos.Core (Config (..), GenesisHash) import Pos.Core.Chrono (NewestFirst (..)) import Pos.DB (closeNodeDBs, openNodeDBs) import Pos.DB.Block (getUndo) @@ -49,8 +49,7 @@ dbSizes root = do -- | Analyse the blockchain, printing useful statistics. analyseBlockchain - :: HasConfiguration - => GenesisHash + :: GenesisHash -> CLIOptions -> HeaderHash -> BlockchainInspector () @@ -60,18 +59,18 @@ analyseBlockchain genesisHash cli tip = else analyseBlockchainLazily genesisHash cli -- | Tries to fetch a `Block` given its `HeaderHash`. -fetchBlock :: HasConfiguration => GenesisHash -> HeaderHash -> BlockchainInspector (Maybe Block) +fetchBlock :: GenesisHash -> HeaderHash -> BlockchainInspector (Maybe Block) fetchBlock = getBlock -- | Tries to fetch an `Undo` for the given `Block`. -fetchUndo :: HasConfiguration => GenesisHash -> Block -> BlockchainInspector (Maybe Undo) +fetchUndo :: GenesisHash -> Block -> BlockchainInspector (Maybe Undo) fetchUndo genesisHash = getUndo genesisHash . headerHash -- | Analyse the blockchain lazily by rendering all the blocks at once, loading the whole -- blockchain into memory. This mode generates very nice-looking tables, but using it for -- big DBs might not be feasible. analyseBlockchainLazily - :: HasConfiguration => GenesisHash -> CLIOptions -> BlockchainInspector () + :: GenesisHash -> CLIOptions -> BlockchainInspector () analyseBlockchainLazily genesisHash cli = do allBlocks <- map (bimap identity Just) . getNewestFirst <$> DB.loadBlundsFromTipWhile @@ -82,8 +81,7 @@ analyseBlockchainLazily genesisHash cli = do -- | Analyse the blockchain eagerly, rendering a block at time, without loading the whole -- blockchain into memory. analyseBlockchainEagerly - :: HasConfiguration - => GenesisHash + :: GenesisHash -> CLIOptions -> HeaderHash -> BlockchainInspector () @@ -99,11 +97,10 @@ analyseBlockchainEagerly genesisHash cli currentTip = do main :: IO () main = do args <- getOptions - CLI.printFlags action args action :: CLIOptions -> IO () -action cli@CLIOptions{..} = withConfigurations Nothing conf $ \coreConfig _ _ -> do +action cli@CLIOptions{..} = withConfigurations Nothing Nothing False conf $ \coreConfig _ _ -> do -- Render the first report sizes <- liftIO (canonicalizePath dbPath >>= dbSizes) liftIO $ putText $ render uom printMode sizes diff --git a/tools/src/blockchain-analyser/Types.hs b/tools/src/blockchain-analyser/Types.hs index 308ccea2b87..868f924433a 100644 --- a/tools/src/blockchain-analyser/Types.hs +++ b/tools/src/blockchain-analyser/Types.hs @@ -18,7 +18,6 @@ import Control.Lens (makeLensesWith) import qualified Control.Monad.Reader as Mtl import Pos.Chain.Block (Block, HeaderHash, prevBlockL) -import Pos.Core (HasConfiguration) import Pos.DB (MonadDBRead (..)) import qualified Pos.DB as DB import qualified Pos.DB.Block as BDB @@ -53,7 +52,7 @@ initBlockchainAnalyser nodeDBs action = do instance HasLens DB.NodeDBs BlockchainInspectorContext DB.NodeDBs where lensOf = bicNodeDBs_L -instance HasConfiguration => MonadDBRead BlockchainInspector where +instance MonadDBRead BlockchainInspector where dbGet = DB.dbGetDefault dbIterSource = DB.dbIterSourceDefault dbGetSerBlock = BDB.dbGetSerBlockRealDefault diff --git a/tools/src/dbgen/Main.hs b/tools/src/dbgen/Main.hs index d2f32d0a90c..1054af51be6 100644 --- a/tools/src/dbgen/Main.hs +++ b/tools/src/dbgen/Main.hs @@ -167,7 +167,7 @@ main = do cli@CLI{..} <- getRecord "DBGen" let cfg = newConfig cli - withConfigurations Nothing cfg $ \coreConfig txpConfig _ -> do + withConfigurations Nothing Nothing False cfg $ \coreConfig txpConfig _ -> do when showStats (showStatsAndExit walletPath) say $ bold "Starting the modification of the wallet..." diff --git a/tools/src/keygen/Main.hs b/tools/src/keygen/Main.hs index 705761cbf70..889e0471604 100644 --- a/tools/src/keygen/Main.hs +++ b/tools/src/keygen/Main.hs @@ -16,18 +16,15 @@ import System.FilePath.Glob (glob) import qualified Text.JSON.Canonical as CanonicalJSON import Pos.Binary (asBinary, serialize') -import qualified Pos.Client.CLI as CLI -import Pos.Core as Core (Config (..), CoreConfiguration (..), - GenesisConfiguration (..), addressHash, ccGenesis, - configGeneratedSecretsThrow, configVssMaxTTL, - coreConfiguration) +import Pos.Core as Core (Config (..), addressHash, + configGeneratedSecretsThrow, configVssMaxTTL) import Pos.Core.Genesis (GeneratedSecrets (..), RichSecrets (..), generateFakeAvvm, generateRichSecrets) import Pos.Core.Ssc (mkVssCertificate, vcSigningKey) import Pos.Crypto (EncryptedSecretKey (..), SecretKey (..), VssKeyPair, fullPublicKeyF, hashHexF, noPassEncrypt, redeemPkB64F, toPublic, toVssPublicKey) -import Pos.Launcher (HasConfigurations, withConfigurations) +import Pos.Launcher (dumpGenesisData, withConfigurations) import Pos.Util.UserSecret (readUserSecret, takeUserSecret, usKeys, usPrimKey, usVss, usWallet, writeUserSecretRelease, wusRootKey) @@ -123,15 +120,11 @@ dumpAvvmSeeds DumpAvvmSeedsOptions{..} = do logInfo $ "Seeds were generated" generateKeysByGenesis - :: (HasConfigurations, MonadIO m, WithLogger m, MonadThrow m) + :: (MonadIO m, WithLogger m, MonadThrow m) => GeneratedSecrets -> GenKeysOptions -> m () generateKeysByGenesis generatedSecrets GenKeysOptions{..} = do - case ccGenesis coreConfiguration of - GCSrc {} -> - error $ "Launched source file conf" - GCSpec {} -> do - dumpGeneratedGenesisData generatedSecrets (gkoOutDir, gkoKeyPattern) - logInfo (toText gkoOutDir <> " generated successfully") + dumpGeneratedGenesisData generatedSecrets (gkoOutDir, gkoKeyPattern) + logInfo (toText gkoOutDir <> " generated successfully") genVssCert :: (WithLogger m, MonadIO m) @@ -163,7 +156,7 @@ main = do KeygenOptions {..} <- getKeygenOptions setupLogging Nothing $ productionB <> termSeveritiesOutB debugPlus usingLoggerName "keygen" - $ withConfigurations Nothing koConfigurationOptions + $ withConfigurations Nothing Nothing False koConfigurationOptions $ \coreConfig _ _ -> do logInfo "Processing command" generatedSecrets <- configGeneratedSecretsThrow coreConfig @@ -175,7 +168,7 @@ main = do DumpAvvmSeeds opts -> dumpAvvmSeeds opts GenerateKeysBySpec gkbg -> generateKeysByGenesis generatedSecrets gkbg - DumpGenesisData dgdPath dgdCanonical -> CLI.dumpGenesisData + DumpGenesisData dgdPath dgdCanonical -> dumpGenesisData (configGenesisData coreConfig) dgdCanonical dgdPath diff --git a/tools/src/launcher/Main.hs b/tools/src/launcher/Main.hs index 5ab00e4ce3d..a14815df661 100644 --- a/tools/src/launcher/Main.hs +++ b/tools/src/launcher/Main.hs @@ -64,8 +64,7 @@ import GHC.IO.Exception (IOErrorType (..), IOException (..)) import Paths_cardano_sl (version) import Pos.Client.CLI (readLoggerConfig) -import Pos.Core (Config (..), HasConfiguration, ProtocolMagic, - Timestamp (..)) +import Pos.Core (Config (..), ProtocolMagic, Timestamp (..)) import Pos.DB.Block (dbGetSerBlockRealDefault, dbGetSerBlundRealDefault, dbGetSerUndoRealDefault, dbPutSerBlundsRealDefault) @@ -256,14 +255,14 @@ type LauncherMode = ReaderT LauncherModeContext IO instance HasLens NodeDBs LauncherModeContext NodeDBs where lensOf = lmcNodeDBs_L -instance HasConfiguration => MonadDBRead LauncherMode where +instance MonadDBRead LauncherMode where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB LauncherMode where +instance MonadDB LauncherMode where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault @@ -311,7 +310,7 @@ main = set Log.ltFiles [Log.HandlerWrap "launcher" Nothing] . set Log.ltSeverity (Just Log.debugPlus) logException loggerName . Log.usingLoggerName loggerName $ - withConfigurations Nothing loConfiguration $ \coreConfig _ _ -> do + withConfigurations Nothing Nothing False loConfiguration $ \coreConfig _ _ -> do -- Generate TLS certificates as needed generateTlsCertificates loConfiguration loX509ToolPath loTlsPath @@ -541,7 +540,7 @@ frontendOnlyScenario ndbp node wallet updater walletLog = do -- | We run the updater and delete the update file if the update was -- successful. -runUpdater :: HasConfigurations => NodeDbPath -> UpdaterData -> M () +runUpdater :: NodeDbPath -> UpdaterData -> M () runUpdater ndbp ud = do let path = udPath ud args = udArgs ud diff --git a/wallet-new/server/Main.hs b/wallet-new/server/Main.hs index 182bd9dc8d6..3f0e5e2b78c 100644 --- a/wallet-new/server/Main.hs +++ b/wallet-new/server/Main.hs @@ -200,44 +200,42 @@ actionWithWallet coreConfig txpConfig sscParams nodeParams ntpConfig params = -- | Runs an edge node plus its wallet backend API. startEdgeNode :: HasCompileInfo => WalletStartupOptions -> IO () startEdgeNode wso = - withConfigurations blPath conf $ \coreConfig txpConfig ntpConfig -> do - (sscParams, nodeParams) <- getParameters coreConfig txpConfig ntpConfig - case wsoWalletBackendParams wso of - WalletLegacy legacyParams -> actionWithLegacyWallet - coreConfig - txpConfig - sscParams - nodeParams - ntpConfig - legacyParams - WalletNew newParams -> actionWithWallet - coreConfig - txpConfig - sscParams - nodeParams - ntpConfig - newParams + withConfigurations blPath dumpGenesisPath dumpConfiguration conf + $ \coreConfig txpConfig ntpConfig -> do + (sscParams, nodeParams) <- getParameters coreConfig + case wsoWalletBackendParams wso of + WalletLegacy legacyParams -> actionWithLegacyWallet + coreConfig + txpConfig + sscParams + nodeParams + ntpConfig + legacyParams + WalletNew newParams -> actionWithWallet coreConfig + txpConfig + sscParams + nodeParams + ntpConfig + newParams where - getParameters :: HasConfigurations - => Core.Config - -> TxpConfiguration - -> NtpConfiguration - -> IO (SscParams, NodeParams) - getParameters coreConfig txpConfig ntpConfig = do + getParameters :: Core.Config -> IO (SscParams, NodeParams) + getParameters coreConfig = do (currentParams, Just gtParams) <- CLI.getNodeParams defaultLoggerName (wsoNodeArgs wso) nodeArgs (configGeneratedSecrets coreConfig) - CLI.printInfoOnStart (wsoNodeArgs wso) - (configGenesisData coreConfig) - ntpConfig - txpConfig logInfo "Wallet is enabled!" return (gtParams, currentParams) + dumpGenesisPath :: Maybe FilePath + dumpGenesisPath = CLI.cnaDumpGenesisDataPath (wsoNodeArgs wso) + + dumpConfiguration :: Bool + dumpConfiguration = CLI.cnaDumpConfiguration (wsoNodeArgs wso) + conf :: ConfigurationOptions conf = CLI.configurationOptions $ CLI.commonArgs (wsoNodeArgs wso) diff --git a/wallet-new/src/Cardano/Wallet/API/Internal/LegacyHandlers.hs b/wallet-new/src/Cardano/Wallet/API/Internal/LegacyHandlers.hs index b2cde6ec140..35ead1a0be8 100644 --- a/wallet-new/src/Cardano/Wallet/API/Internal/LegacyHandlers.hs +++ b/wallet-new/src/Cardano/Wallet/API/Internal/LegacyHandlers.hs @@ -36,7 +36,7 @@ import Cardano.Wallet.Server.CLI (RunMode (..), isDebugMode) -- | Until we depend from V0 logic to implement the each 'Handler' we -- still need the natural transformation here. handlers - :: (HasConfiguration, HasUpdateConfiguration) + :: HasUpdateConfiguration => (forall a. MonadV1 a -> Handler a) -> Core.Config -> RunMode @@ -53,7 +53,6 @@ handlers naturalTransformation coreConfig runMode = hoistServer (Proxy @Internal.API) naturalTransformation handlers' nextUpdate :: ( MonadIO m - , HasConfiguration , MonadThrow m , V0.WalletDbReader ctx m , HasUpdateConfiguration diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Accounts.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Accounts.hs index 1e34185fa78..fca09339662 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Accounts.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Accounts.hs @@ -19,9 +19,7 @@ import Cardano.Wallet.API.V1.Migration import Cardano.Wallet.API.V1.Types import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet -handlers - :: HasConfigurations - => ServerT Accounts.API MonadV1 +handlers :: ServerT Accounts.API MonadV1 handlers = deleteAccount :<|> getAccount diff --git a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Info.hs b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Info.hs index 05a27fb75be..3a85bf04145 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Info.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Info.hs @@ -21,9 +21,7 @@ import qualified Pos.Wallet.Web.ClientTypes.Types as V0 import qualified Pos.Wallet.Web.Methods.Misc as V0 -- | All the @Servant@ handlers for settings-specific operations. -handlers :: ( HasConfigurations - ) - => Diffusion MonadV1 +handlers :: Diffusion MonadV1 -> TVar NtpStatus -> ServerT Info.API MonadV1 handlers = getInfo 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 a56159e1ad3..d626019ff6d 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/LegacyHandlers/Wallets.hs @@ -34,8 +34,7 @@ import Servant -- | All the @Servant@ handlers for wallet-specific operations. -handlers :: HasConfigurations - => Core.Config -> ServerT Wallets.API MonadV1 +handlers :: Core.Config -> ServerT Wallets.API MonadV1 handlers coreConfig = newWallet coreConfig :<|> listWallets :<|> updatePassword diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Migration.hs b/wallet-new/src/Cardano/Wallet/API/V1/Migration.hs index b99457f7056..2030d644f7a 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Migration.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Migration.hs @@ -5,7 +5,6 @@ module Cardano.Wallet.API.V1.Migration ( -- * Configuration re-exports , HasCompileInfo , HasConfigurations - , HasConfiguration , HasSscConfiguration , HasUpdateConfiguration , HasNodeConfiguration @@ -17,6 +16,5 @@ import Cardano.Wallet.API.V1.Migration.Types as Exports import Pos.Chain.Ssc (HasSscConfiguration) import Pos.Chain.Update (HasUpdateConfiguration) import Pos.Configuration (HasNodeConfiguration) -import Pos.Core.Configuration (HasConfiguration) import Pos.Launcher.Configuration (HasConfigurations) import Pos.Util.CompileInfo (HasCompileInfo) diff --git a/wallet-new/src/Cardano/Wallet/API/WIP/LegacyHandlers.hs b/wallet-new/src/Cardano/Wallet/API/WIP/LegacyHandlers.hs index 4556b7953ba..1df07fb11b6 100644 --- a/wallet-new/src/Cardano/Wallet/API/WIP/LegacyHandlers.hs +++ b/wallet-new/src/Cardano/Wallet/API/WIP/LegacyHandlers.hs @@ -37,8 +37,7 @@ import Pos.Wallet.Web.Tracking.Types (SyncQueue) import Pos.Wallet.Web.Util (getWalletAccountIds) import Servant -handlers :: HasConfigurations - => (forall a. MonadV1 a -> Handler a) +handlers :: (forall a. MonadV1 a -> Handler a) -> Core.Config -> TxpConfiguration -> Diffusion MonadV1 @@ -55,8 +54,7 @@ handlers naturalTransformation coreConfig txpConfig diffusion = submitTx = sendTx diffusion -- | All the @Servant@ handlers for wallet-specific operations. -handlersPlain :: HasConfigurations - => Core.Config +handlersPlain :: Core.Config -> TxpConfiguration -> (TxAux -> MonadV1 Bool) -> ServerT WIP.API MonadV1 diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs index 08713648675..b2be64b99c5 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 as Core (Config, HasConfiguration) +import Pos.Core as Core (Config) import Pos.Core.Chrono import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..)) @@ -164,14 +164,14 @@ instance {-# OVERLAPPABLE #-} type instance MempoolExt WalletMode = EmptyMempoolExt -instance HasConfiguration => MonadDBRead WalletMode where +instance MonadDBRead WalletMode where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB WalletMode where +instance MonadDB WalletMode where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault @@ -183,14 +183,13 @@ instance MonadSlotsData ctx WalletMode => MonadSlots ctx WalletMode where getCurrentSlotInaccurate = getCurrentSlotInaccurateSimple currentTimeSlotting = currentTimeSlottingSimple -instance HasConfiguration => MonadGState WalletMode where +instance MonadGState WalletMode where gsAdoptedBVData = gsAdoptedBVDataDefault instance {-# OVERLAPPING #-} CanJsonLog WalletMode where jsonLog = jsonLogDefault -instance HasConfiguration - => MonadTxpLocal WalletMode where +instance MonadTxpLocal WalletMode where txpNormalize = txNormalize txpProcessTx = txProcessTransaction diff --git a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs index b202e3bbe4c..c36ab7ad2f0 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs @@ -75,7 +75,6 @@ import Pos.Core as Core (BlockCount, Config (..), GenesisHash (..), SlotCount, Timestamp (..), TxFeePolicy, configBlockVersionData, configEpochSlots, configK, difficultyL, getChainDifficulty) -import Pos.Core.Configuration (HasConfiguration) import Pos.Core.Slotting (EpochIndex (..), HasSlottingVar (..), LocalSlotIndex (..), MonadSlots (..), SlotId (..)) import qualified Pos.DB.Block as DB @@ -170,8 +169,7 @@ type Lock m = forall a. LockContext -> (HeaderHash -> m a) -> m a -- Using 'NodeConstraints' in such functions isolates these functions from -- changes to the type classes used in the underlying node. type NodeConstraints = ( - HasConfiguration - , HasUpdateConfiguration + HasUpdateConfiguration , HasCompileInfo ) diff --git a/wallet-new/src/Cardano/Wallet/Server/LegacyPlugins.hs b/wallet-new/src/Cardano/Wallet/Server/LegacyPlugins.hs index 62a2d832344..7c71e0e8bea 100644 --- a/wallet-new/src/Cardano/Wallet/Server/LegacyPlugins.hs +++ b/wallet-new/src/Cardano/Wallet/Server/LegacyPlugins.hs @@ -202,11 +202,11 @@ resubmitterPlugin coreConfig txpConfig = [\diffusion -> askWalletDB >>= \db -> startPendingTxsResubmitter coreConfig txpConfig db (sendTx diffusion)] -- | A @Plugin@ to notify frontend via websockets. -notifierPlugin :: HasConfigurations => Plugin WalletWebMode +notifierPlugin :: Plugin WalletWebMode notifierPlugin = [const V0.notifierPlugin] -- | The @Plugin@ responsible for the restoration & syncing of a wallet. -syncWalletWorker :: HasConfigurations => Core.Config -> Plugin WalletWebMode +syncWalletWorker :: Core.Config -> Plugin WalletWebMode syncWalletWorker coreConfig = pure $ const $ modifyLoggerName (const "syncWalletWorker") $ (view (lensOf @SyncQueue) >>= processSyncRequest coreConfig) diff --git a/wallet-new/test/unit/UTxO/Interpreter.hs b/wallet-new/test/unit/UTxO/Interpreter.hs index b97f98069ba..9019d65fe04 100644 --- a/wallet-new/test/unit/UTxO/Interpreter.hs +++ b/wallet-new/test/unit/UTxO/Interpreter.hs @@ -289,8 +289,7 @@ runIntBoot' boot = mapTranslateErrors mustBeLeft . runIntBoot boot -- | Convenience function to list actions in the 'Translate' monad liftTranslateInt :: Monad m - => ( (HasConfiguration, HasUpdateConfiguration) - => TranslateT IntException m a) + => (HasUpdateConfiguration => TranslateT IntException m a) -> IntT h e m a liftTranslateInt ta = IntT $ lift $ mapTranslateErrors Left $ withConfig $ ta @@ -353,7 +352,7 @@ popIntCheckpoint = do -- The function runs in the underlying 'Translate' monad so that it is not tempted -- to use state it shouldn't. pushCheckpoint :: Monad m - => ( (HasConfiguration, HasUpdateConfiguration) + => ( HasUpdateConfiguration => IntCheckpoint -> SlotId -> TranslateT IntException m (IntCheckpoint, a)) @@ -399,7 +398,7 @@ updateStakes :: forall m. MonadError IntException m -> ResolvedBlock -> StakesMap -> m StakesMap updateStakes gs (ResolvedBlock txs _ _) = - foldr (>=>) return $ map go txs + foldr ((>=>) . go) return txs where go :: ResolvedTx -> StakesMap -> m StakesMap go (ResolvedTx ins outs _) = diff --git a/wallet-new/test/unit/UTxO/Translate.hs b/wallet-new/test/unit/UTxO/Translate.hs index c06a787e7f4..2a7809612e2 100644 --- a/wallet-new/test/unit/UTxO/Translate.hs +++ b/wallet-new/test/unit/UTxO/Translate.hs @@ -67,7 +67,6 @@ import Test.Pos.Configuration (withDefConfiguration, -- 'CardanoContext' instead. data TranslateEnv = TranslateEnv { teContext :: TransCtxt - , teConfig :: Dict HasConfiguration , teUpdate :: Dict HasUpdateConfiguration } @@ -108,7 +107,6 @@ runTranslateT (TranslateT ta) = let env :: TranslateEnv env = TranslateEnv { teContext = initContext (initCardanoContext coreConfig) - , teConfig = Dict , teUpdate = Dict } in do ma <- runReaderT (runExceptT ta) env @@ -130,10 +128,9 @@ runTranslateNoErrors = runTranslate -- | Lift functions that want the configuration as type class constraints withConfig :: Monad m - => ((HasConfiguration, HasUpdateConfiguration) => TranslateT e m a) + => (HasUpdateConfiguration => TranslateT e m a) -> TranslateT e m a withConfig f = do - Dict <- TranslateT $ asks teConfig Dict <- TranslateT $ asks teUpdate f @@ -185,7 +182,7 @@ translateGenesisHeader = view gbHeader <$> asks (ccBlock0 . tcCardano) -- | Run the verifier verify :: Monad m - => (HasConfiguration => Verify e a) + => Verify e a -> TranslateT e' m (Validated e (a, Utxo)) verify ma = withConfig $ do utxo <- asks (ccUtxo . tcCardano) diff --git a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs index 1462a8355bf..407155c03ae 100644 --- a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs +++ b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs @@ -23,7 +23,7 @@ import Formatting (bprint, build, formatToString, sformat, (%)) import qualified Formatting.Buildable import Pos.Chain.Txp (Utxo, formatUtxo) -import Pos.Core (HasConfiguration, Timestamp (..)) +import Pos.Core (Timestamp (..)) import Pos.Core.Chrono import Pos.Crypto (EncryptedSecretKey, emptyPassphrase) @@ -66,10 +66,10 @@ data EventCallbacks h m = EventCallbacks { -- The callback is given the translated UTxO of the bootstrap -- transaction (we cannot give it the translated transaction because -- we cannot translate the bootstrap transaction). - walletBootT :: HasConfiguration => InductiveCtxt h -> Utxo -> m HD.HdAccountId + walletBootT :: InductiveCtxt h -> Utxo -> m HD.HdAccountId -- | Apply a block - , walletApplyBlockT :: HasConfiguration => InductiveCtxt h -> HD.HdAccountId -> RawResolvedBlock -> m () + , walletApplyBlockT :: InductiveCtxt h -> HD.HdAccountId -> RawResolvedBlock -> m () -- | Insert new pending transaction , walletNewPendingT :: InductiveCtxt h -> HD.HdAccountId -> RawResolvedTx -> m () diff --git a/wallet/src/Pos/Wallet/Redirect.hs b/wallet/src/Pos/Wallet/Redirect.hs index f05401589f2..58f4a415c8f 100644 --- a/wallet/src/Pos/Wallet/Redirect.hs +++ b/wallet/src/Pos/Wallet/Redirect.hs @@ -31,8 +31,8 @@ import Pos.Chain.Txp (ToilVerFailure, Tx, TxAux (..), TxId, TxUndo, TxpConfiguration) import Pos.Chain.Update (ConfirmedProposalState) import qualified Pos.Context as PC -import Pos.Core as Core (ChainDifficulty, Config, HasConfiguration, - Timestamp, difficultyL, getCurrentTimestamp) +import Pos.Core as Core (ChainDifficulty, Config, Timestamp, + difficultyL, getCurrentTimestamp) import Pos.Crypto (WithHash (..)) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) @@ -71,7 +71,6 @@ type BlockchainInfoEnv ctx m = , HasLens PC.ConnectedPeers ctx PC.ConnectedPeers , MonadIO m , MonadSlots ctx m - , HasConfiguration ) networkChainDifficultyWebWallet diff --git a/wallet/src/Pos/Wallet/Web/Methods/Logic.hs b/wallet/src/Pos/Wallet/Web/Methods/Logic.hs index 902253febff..1137e4a742d 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Logic.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Logic.hs @@ -50,7 +50,6 @@ import Pos.Client.KeyStorage (MonadKeys (..), MonadKeysRead, addSecretKey, deletePublicKeyBy, deleteSecretKeyBy) import Pos.Core (Address, Coin, makePubKeyAddressBoot, mkCoin, sumCoins, unsafeIntegerToCoin) -import Pos.Core.Configuration (HasConfiguration) import Pos.Crypto (PassPhrase, PublicKey, changeEncPassphrase, checkPassMatches, emptyPassphrase, firstHardened) import Pos.DB.Txp (GenericTxpLocalData, MonadTxpMem, getLocalTxs, @@ -99,7 +98,6 @@ type MonadWalletLogicRead ctx m = , MonadKeysRead m , MonadTxpMem WalletMempoolExt ctx m , BlockLockMode ctx m - , HasConfiguration , WalletDbReader ctx m ) diff --git a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs index c0b1fe7b045..8bb43aca575 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs @@ -48,8 +48,7 @@ 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, ProtocolConstants, SlotId, - pcEpochSlots) +import Pos.Core (ProtocolConstants, SlotId, pcEpochSlots) import Pos.Core.Conc (async, delay) import Pos.Core.Update (SoftwareVersion (..)) import Pos.Crypto (hashHexF) @@ -103,7 +102,6 @@ isValidAddress = pure . isRight . cIdToAddress -- | Get last update info nextUpdate :: ( MonadIO m - , HasConfiguration , MonadThrow m , WalletDbReader ctx m , HasUpdateConfiguration @@ -178,7 +176,7 @@ localTimeDifferencePure NtpSyncPending = Nothing localTimeDifferencePure NtpSyncUnavailable = Nothing localTimeDifference :: MonadIO m => TVar NtpStatus -> m (Maybe Integer) -localTimeDifference ntpStatus = localTimeDifferencePure <$> (atomically $ readTVar ntpStatus) +localTimeDifference ntpStatus = localTimeDifferencePure <$> readTVarIO ntpStatus ---------------------------------------------------------------------------- -- Reset diff --git a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs index 55a9223e9a7..1af296bbf66 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs @@ -31,7 +31,7 @@ import Pos.Client.Txp.Network (prepareMTx) import Pos.Client.Txp.Util (InputSelectionPolicy (..), computeTxFee, runTxCreator) import Pos.Configuration (walletTxCreationDisabled) -import Pos.Core as Core (Address, Coin, Config (..), HasConfiguration, +import Pos.Core as Core (Address, Coin, Config (..), getCurrentTimestamp) import Pos.Core.Conc (concurrently, delay) import Pos.Core.Genesis (GenesisData) @@ -114,7 +114,6 @@ type MonadFees ctx m = , MonadAddresses m , MonadBalances m , MonadIO m - , HasConfiguration ) getTxFee diff --git a/wallet/src/Pos/Wallet/Web/Mode.hs b/wallet/src/Pos/Wallet/Web/Mode.hs index 265fbd204b8..f679f481aa7 100644 --- a/wallet/src/Pos/Wallet/Web/Mode.hs +++ b/wallet/src/Pos/Wallet/Web/Mode.hs @@ -43,8 +43,8 @@ import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) import Pos.Context (HasNodeContext (..)) -import Pos.Core (Address, Coin, HasConfiguration, HasPrimaryKey (..), - isRedeemAddress, largestHDAddressBoot, mkCoin) +import Pos.Core (Address, Coin, HasPrimaryKey (..), isRedeemAddress, + largestHDAddressBoot, mkCoin) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), MonadReporting (..), Reporter (..)) @@ -71,7 +71,6 @@ import Pos.Infra.Slotting.Impl (currentTimeSlottingSimple, import Pos.Infra.StateLock (StateLock) import Pos.Infra.Util.JsonLog.Events (HasJsonLogConfig (..), jsonLogDefault) -import Pos.Launcher (HasConfigurations) import Pos.Recovery () import Pos.Util (postfixLFields) import Pos.Util.LoggerName (HasLoggerName' (..), askLoggerNameDefault, @@ -252,24 +251,23 @@ instance {-# OVERLAPPING #-} HasLoggerName WalletWebMode where instance {-# OVERLAPPING #-} CanJsonLog WalletWebMode where jsonLog = jsonLogDefault -instance HasConfiguration => MonadDBRead WalletWebMode where +instance MonadDBRead WalletWebMode where dbGet = dbGetDefault dbIterSource = dbIterSourceDefault dbGetSerBlock = dbGetSerBlockRealDefault dbGetSerUndo = dbGetSerUndoRealDefault dbGetSerBlund = dbGetSerBlundRealDefault -instance HasConfiguration => MonadDB WalletWebMode where +instance MonadDB WalletWebMode where dbPut = dbPutDefault dbWriteBatch = dbWriteBatchDefault dbDelete = dbDeleteDefault dbPutSerBlunds = dbPutSerBlundsRealDefault -instance HasConfiguration => MonadGState WalletWebMode where +instance MonadGState WalletWebMode where gsAdoptedBVData = gsAdoptedBVDataDefault -instance (HasConfiguration) - => MonadBListener WalletWebMode where +instance MonadBListener WalletWebMode where onApplyBlocks = onApplyBlocksWebWallet onRollbackBlocks = onRollbackBlocksWebWallet @@ -277,8 +275,7 @@ instance MonadUpdates WalletWebMode where waitForUpdate = waitForUpdateWebWallet applyLastUpdate = applyLastUpdateWebWallet -instance (HasConfiguration) => - MonadBlockchainInfo WalletWebMode where +instance MonadBlockchainInfo WalletWebMode where networkChainDifficulty = networkChainDifficultyWebWallet localChainDifficulty = localChainDifficultyWebWallet connectedPeers = connectedPeersWebWallet @@ -321,20 +318,18 @@ getBalanceDefault addr = do HM.lookup addr $ applyUtxoModToAddrCoinMap updates balancesAndUtxo -instance HasConfiguration => MonadBalances WalletWebMode where +instance MonadBalances WalletWebMode where getOwnUtxos = const $ getOwnUtxosDefault getBalance = const $ getBalanceDefault -instance (HasConfiguration) - => MonadTxHistory WalletWebMode where +instance MonadTxHistory WalletWebMode where getBlockHistory = getBlockHistoryDefault getLocalHistory = getLocalHistoryDefault saveTx = saveTxDefault type instance MempoolExt WalletWebMode = WalletMempoolExt -instance HasConfiguration => - MonadTxpLocal WalletWebMode where +instance MonadTxpLocal WalletWebMode where txpNormalize = txpNormalizeWebWallet txpProcessTx = txpProcessTxWebWallet @@ -354,8 +349,7 @@ getNewAddressWebWallet (accId, passphrase) = do cAddrMeta <- newAddress_ ws RandomSeed passphrase accId return $ cAddrMeta ^. wamAddress -instance (HasConfigurations) - => MonadAddresses Pos.Wallet.Web.Mode.WalletWebMode where +instance MonadAddresses Pos.Wallet.Web.Mode.WalletWebMode where type AddrData Pos.Wallet.Web.Mode.WalletWebMode = (AccountId, PassPhrase) -- We rely on the fact that Daedalus always uses HD addresses with -- BootstrapEra distribution. diff --git a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs index 8b4e0ba2493..3c4428d8064 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs @@ -24,7 +24,6 @@ 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 qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import Pos.Infra.Recovery.Info (MonadRecoveryInfo) @@ -54,7 +53,6 @@ type MonadPendings ctx m = , MonadReporting m , HasShutdownContext ctx , MonadSlots ctx m - , HasConfiguration , HasNodeConfiguration ) diff --git a/wallet/src/Pos/Wallet/Web/Server/Runner.hs b/wallet/src/Pos/Wallet/Web/Server/Runner.hs index e59f1aeb86a..92380af0e00 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Runner.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Runner.hs @@ -119,7 +119,7 @@ convertHandler wwmc handler = excHandlers = [E.Handler catchServant] catchServant = throwError -notifierPlugin :: (HasConfigurations) => WalletWebMode () +notifierPlugin :: WalletWebMode () notifierPlugin = do wwmc <- walletWebModeContext launchNotifier (convertHandler wwmc) diff --git a/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs b/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs index db3ab68f60e..dd0d8ef1b0e 100644 --- a/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs +++ b/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs @@ -16,7 +16,6 @@ import Control.Concurrent.Async (mapConcurrently) import Control.Lens ((.=)) import Data.Default (Default (def)) import Data.Time.Units (Microsecond, Second) -import Pos.Core (HasConfiguration) import Pos.DB (MonadGState (..)) import Pos.Util.Wlog (WithLogger, logDebug) import Pos.Wallet.WalletMode (MonadBlockchainInfo (..), @@ -36,7 +35,6 @@ type MonadNotifier ctx m = , MonadBlockchainInfo m , MonadUpdates m , MonadGState m - , HasConfiguration ) -- FIXME: this is really inefficient. Temporary solution diff --git a/wallet/src/Pos/Wallet/Web/Tracking/Types.hs b/wallet/src/Pos/Wallet/Web/Tracking/Types.hs index 0b1d25f0b71..8b2435be8f2 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Types.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Types.hs @@ -17,7 +17,6 @@ import Universum import Control.Concurrent.STM (TQueue, writeTQueue) -import Pos.Core (HasConfiguration) import Pos.DB.Class (MonadDBRead (..)) import Pos.Infra.Slotting (MonadSlotsData) import Pos.Infra.StateLock (StateLock) @@ -42,7 +41,6 @@ type WalletTrackingEnv ctx m = ( WS.WalletDbReader ctx m , MonadSlotsData ctx m , WithLogger m - , HasConfiguration , MonadThrow m , MonadDBRead m , BlockLockMode ctx m diff --git a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs index 8150f7d7db6..79183374f14 100644 --- a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs @@ -19,7 +19,6 @@ import Pos.Binary (biSize) import Pos.Client.Txp.Addresses (getFakeChangeAddress, getNewAddress) import Pos.Core.Common (Address) import Pos.Crypto (PassPhrase) -import Pos.Launcher (HasConfigurations) import Pos.Wallet.Web.Account (GenSeed (..), genUniqueAddress) import Pos.Wallet.Web.ClientTypes (AccountId, CAccountInit (..), caId) @@ -46,9 +45,7 @@ spec = withDefConfigurations $ \_ _ _ -> type AddressGenerator = AccountId -> PassPhrase -> WalletProperty Address -fakeAddressHasMaxSizeTest - :: HasConfigurations - => AddressGenerator -> Word32 -> WalletProperty () +fakeAddressHasMaxSizeTest :: AddressGenerator -> Word32 -> WalletProperty () fakeAddressHasMaxSizeTest generator accSeed = do passphrase <- importSingleWallet mostlyEmptyPassphrases ws <- askWalletSnapshot @@ -66,7 +63,7 @@ fakeAddressHasMaxSizeTest generator accSeed = do -- | Addresses generator used in 'MonadAddresses' to create change addresses. -- Unfortunatelly, its randomness doesn't depend on QuickCheck seed, -- so another proper generator is helpful. -changeAddressGenerator :: HasConfigurations => AddressGenerator +changeAddressGenerator :: AddressGenerator changeAddressGenerator accId passphrase = lift $ getNewAddress dummyEpochSlots (accId, passphrase) diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs index 3edbade57c6..086a18d6e83 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs @@ -10,7 +10,6 @@ import Universum import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) -import Pos.Launcher (HasConfigurations) import Pos.Wallet.Web.Methods.Logic (getAccounts, getWallets) import Test.Pos.Configuration (withDefConfigurations) @@ -25,7 +24,7 @@ spec = withDefConfigurations $ \_ _ _ -> where emptyWalletOnStarts = "wallet must be empty on start" -emptyWallet :: HasConfigurations => WalletProperty () +emptyWallet :: WalletProperty () emptyWallet = do wallets <- lift getWallets unless (null wallets) $ diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs index 913cfabcbed..34a88eddb9f 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs @@ -81,7 +81,7 @@ data PaymentFixture = PaymentFixture { } -- | Generic block of code to be reused across all the different payment specs. -newPaymentFixture :: HasConfigurations => WalletProperty PaymentFixture +newPaymentFixture :: WalletProperty PaymentFixture newPaymentFixture = do passphrases <- importSomeWallets mostlyEmptyPassphrases let l = length passphrases diff --git a/wallet/test/Test/Pos/Wallet/Web/Mode.hs b/wallet/test/Test/Pos/Wallet/Web/Mode.hs index fdc78597518..3966d5aadbf 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Mode.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Mode.hs @@ -57,8 +57,7 @@ import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) import Pos.Context (ConnectedPeers (..)) -import Pos.Core (HasConfiguration, Timestamp (..), - largestHDAddressBoot) +import Pos.Core (Timestamp (..), largestHDAddressBoot) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Crypto (PassPhrase) import Pos.DB (MonadDB (..), MonadDBRead (..), MonadGState (..)) @@ -191,10 +190,8 @@ getSentTxs = atomically . readTVar =<< view wtcSentTxs_L -- Initialization ---------------------------------------------------------------------------- -initWalletTestContext :: - ( HasConfiguration - , HasDlgConfiguration - ) +initWalletTestContext + :: HasDlgConfiguration => WalletTestParams -> (WalletTestContext -> Emulation a) -> Emulation a @@ -222,13 +219,8 @@ initWalletTestContext WalletTestParams {..} callback = pure WalletTestContext {..} callback wtc -runWalletTestMode :: - ( HasConfiguration - , HasDlgConfiguration - ) - => WalletTestParams - -> WalletTestMode a - -> IO a +runWalletTestMode + :: HasDlgConfiguration => WalletTestParams -> WalletTestMode a -> IO a runWalletTestMode wtp action = runEmulation (getTimestamp $ wtp ^. wtpBlockTestParams . tpStartTime) $ initWalletTestContext wtp $ @@ -244,7 +236,7 @@ type WalletProperty = PropertyM WalletTestMode -- | Convert 'WalletProperty' to 'Property' using given generator of -- 'WalletTestParams'. walletPropertyToProperty - :: (HasConfiguration, HasDlgConfiguration, Testable a) + :: (HasDlgConfiguration, Testable a) => Gen WalletTestParams -> WalletProperty a -> Property @@ -252,14 +244,13 @@ walletPropertyToProperty wtpGen walletProperty = forAll wtpGen $ \wtp -> monadic (ioProperty . runWalletTestMode wtp) walletProperty -instance (HasConfiguration, HasDlgConfiguration, Testable a) - => Testable (WalletProperty a) where +instance (HasDlgConfiguration, Testable a) => Testable (WalletProperty a) where property = walletPropertyToProperty arbitrary walletPropertySpec :: - (HasConfiguration, HasDlgConfiguration, Testable a) + (HasDlgConfiguration, Testable a) => String - -> (HasConfiguration => WalletProperty a) + -> WalletProperty a -> Spec walletPropertySpec description wp = prop description (walletPropertyToProperty arbitrary wp) @@ -336,20 +327,20 @@ instance {-# OVERLAPPING #-} HasLoggerName WalletTestMode where askLoggerName = askLoggerNameDefault modifyLoggerName = modifyLoggerNameDefault -instance HasConfiguration => MonadDBRead WalletTestMode where +instance MonadDBRead WalletTestMode where dbGet = DB.dbGetPureDefault dbIterSource = DB.dbIterSourcePureDefault dbGetSerBlock = const DB.dbGetSerBlockPureDefault dbGetSerUndo = const DB.dbGetSerUndoPureDefault dbGetSerBlund = const DB.dbGetSerBlundPureDefault -instance HasConfiguration => MonadDB WalletTestMode where +instance MonadDB WalletTestMode where dbPut = DB.dbPutPureDefault dbWriteBatch = DB.dbWriteBatchPureDefault dbDelete = DB.dbDeletePureDefault dbPutSerBlunds = DB.dbPutSerBlundsPureDefault -instance HasConfiguration => MonadGState WalletTestMode where +instance MonadGState WalletTestMode where gsAdoptedBVData = gsAdoptedBVDataDefault ---------------------------------------------------------------------------- @@ -389,7 +380,7 @@ instance HasLens (StateLockMetrics MemPoolModifyReason) WalletTestContext (State -- This never made any sense. WalletDbReader is a type synonym. -- instance WalletDbReader WalletTestContext WalletTestMode -instance HasConfigurations => MonadAddresses WalletTestMode where +instance MonadAddresses WalletTestMode where type AddrData WalletTestMode = (AccountId, PassPhrase) getNewAddress _ = getNewAddressWebWallet getFakeChangeAddress _ = pure largestHDAddressBoot @@ -402,12 +393,12 @@ instance MonadKeys WalletTestMode where modifyPublic = modifyPublicPureDefault modifySecret = modifySecretPureDefault -instance (HasConfigurations) => MonadTxHistory WalletTestMode where +instance MonadTxHistory WalletTestMode where getBlockHistory = getBlockHistoryDefault getLocalHistory = getLocalHistoryDefault saveTx = saveTxDefault -instance HasConfiguration => MonadBalances WalletTestMode where +instance MonadBalances WalletTestMode where getOwnUtxos = const $ getOwnUtxosDefault getBalance = const $ getBalanceDefault @@ -415,11 +406,11 @@ instance MonadUpdates WalletTestMode where waitForUpdate = waitForUpdateWebWallet applyLastUpdate = applyLastUpdateWebWallet -instance (HasConfigurations) => MonadBListener WalletTestMode where +instance MonadBListener WalletTestMode where onApplyBlocks = onApplyBlocksWebWallet onRollbackBlocks = onRollbackBlocksWebWallet -instance HasConfiguration => MonadBlockchainInfo WalletTestMode where +instance MonadBlockchainInfo WalletTestMode where networkChainDifficulty = networkChainDifficultyWebWallet localChainDifficulty = localChainDifficultyWebWallet blockchainSlotDuration = blockchainSlotDurationWebWallet @@ -433,7 +424,7 @@ instance (HasConfigurations) txpProcessTx = txProcessTransactionNoLock -instance (HasConfigurations) => MonadTxpLocal WalletTestMode where +instance MonadTxpLocal WalletTestMode where txpNormalize = txpNormalizeWebWallet txpProcessTx = txpProcessTxWebWallet diff --git a/wallet/test/Test/Pos/Wallet/Web/Util.hs b/wallet/test/Test/Pos/Wallet/Web/Util.hs index 09f1ff6a177..20e8dc4d07d 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Util.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Util.hs @@ -42,7 +42,7 @@ import Pos.Chain.Txp (TxIn, TxOut (..), TxOutAux (..), TxpConfiguration, Utxo) import Pos.Client.KeyStorage (getSecretKeysPlain) import Pos.Client.Txp.Balances (getBalance) -import Pos.Core (Address, BlockCount, Coin, HasConfiguration) +import Pos.Core (Address, BlockCount, Coin) import Pos.Core.Chrono (OldestFirst (..)) import Pos.Core.Common (IsBootstrapEraAddr (..), deriveLvl2KeyPair) import Pos.Core.Genesis (poorSecretToEncKey) @@ -109,9 +109,7 @@ wpGenBlock txpConfig = fmap (Data.List.head . toList) ... wpGenBlocks txpConfig -- | Import some nonempty set, but not bigger than given number of elements, of genesis secrets. -- Returns corresponding passphrases. -importWallets - :: HasConfigurations - => Int -> Gen PassPhrase -> WalletProperty [PassPhrase] +importWallets :: Int -> Gen PassPhrase -> WalletProperty [PassPhrase] importWallets numLimit passGen = do let secrets = map poorSecretToEncKey dummyGenesisSecretsPoor (encSecrets, passphrases) <- pick $ do @@ -125,14 +123,10 @@ importWallets numLimit passGen = do assertProperty (not (null skeys)) "Empty set of imported keys" pure passphrases -importSomeWallets - :: HasConfigurations - => Gen PassPhrase -> WalletProperty [PassPhrase] +importSomeWallets :: Gen PassPhrase -> WalletProperty [PassPhrase] importSomeWallets = importWallets 10 -importSingleWallet - :: HasConfigurations - => Gen PassPhrase -> WalletProperty PassPhrase +importSingleWallet :: Gen PassPhrase -> WalletProperty PassPhrase importSingleWallet passGen = fromMaybe (error "No wallets imported") . (fmap fst . uncons) <$> importWallets 1 passGen @@ -213,7 +207,7 @@ genWalletUtxo sk psw size = -- Useful properties -- | Checks that balance of address is positive and returns it. -expectedAddrBalance :: HasConfiguration => Address -> Coin -> WalletProperty () +expectedAddrBalance :: Address -> Coin -> WalletProperty () expectedAddrBalance addr expected = do balance <- lift $ getBalance dummyGenesisData addr assertProperty (balance == expected) $ From 7f871d7f498a97f91d03bcc671e687535db8aa88 Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Wed, 5 Sep 2018 13:53:28 -0400 Subject: [PATCH 2/3] Remove GenesisVssCertificatesMap newtype --- core/cardano-sl-core.cabal | 1 - core/src/Pos/Core/Configuration.hs | 4 +- core/src/Pos/Core/Genesis.hs | 2 - core/src/Pos/Core/Genesis/Data.hs | 6 +-- core/src/Pos/Core/Genesis/Generate.hs | 13 +++---- .../Pos/Core/Genesis/VssCertificatesMap.hs | 39 ------------------- core/test/Test/Pos/Core/Arbitrary.hs | 2 +- 7 files changed, 11 insertions(+), 56 deletions(-) delete mode 100644 core/src/Pos/Core/Genesis/VssCertificatesMap.hs diff --git a/core/cardano-sl-core.cabal b/core/cardano-sl-core.cabal index 5e05b4e825a..9a86e949e93 100644 --- a/core/cardano-sl-core.cabal +++ b/core/cardano-sl-core.cabal @@ -114,7 +114,6 @@ library Pos.Core.Genesis.NonAvvmBalances Pos.Core.Genesis.ProtocolConstants Pos.Core.Genesis.Spec - Pos.Core.Genesis.VssCertificatesMap Pos.Core.Genesis.WStakeholders -- Slotting diff --git a/core/src/Pos/Core/Configuration.hs b/core/src/Pos/Core/Configuration.hs index 45f1c9107c9..6970c09ec9c 100644 --- a/core/src/Pos/Core/Configuration.hs +++ b/core/src/Pos/Core/Configuration.hs @@ -51,7 +51,7 @@ import Pos.Core.Genesis (GeneratedSecrets, GenesisAvvmBalances, GenesisData (..), GenesisDelegation, GenesisInitializer (..), GenesisNonAvvmBalances, GenesisProtocolConstants (..), GenesisSpec (..), - GenesisVssCertificatesMap (..), GenesisWStakeholders, + GenesisWStakeholders, genesisProtocolConstantsToProtocolConstants, mkGenesisDelegation) import Pos.Core.Genesis.Generate (GeneratedGenesisData (..), @@ -116,7 +116,7 @@ configStartTime :: Config -> Timestamp configStartTime = gdStartTime . configGenesisData configVssCerts :: Config -> VssCertificatesMap -configVssCerts = getGenesisVssCertificatesMap . gdVssCerts . configGenesisData +configVssCerts = gdVssCerts . configGenesisData configNonAvvmBalances :: Config -> GenesisNonAvvmBalances configNonAvvmBalances = gdNonAvvmBalances . configGenesisData diff --git a/core/src/Pos/Core/Genesis.hs b/core/src/Pos/Core/Genesis.hs index a8a2ee8208f..212aedbd00a 100644 --- a/core/src/Pos/Core/Genesis.hs +++ b/core/src/Pos/Core/Genesis.hs @@ -8,7 +8,6 @@ module Pos.Core.Genesis , module Pos.Core.Genesis.NonAvvmBalances , module Pos.Core.Genesis.ProtocolConstants , module Pos.Core.Genesis.Spec - , module Pos.Core.Genesis.VssCertificatesMap , module Pos.Core.Genesis.WStakeholders ) where @@ -21,5 +20,4 @@ import Pos.Core.Genesis.Initializer import Pos.Core.Genesis.NonAvvmBalances import Pos.Core.Genesis.ProtocolConstants import Pos.Core.Genesis.Spec -import Pos.Core.Genesis.VssCertificatesMap import Pos.Core.Genesis.WStakeholders diff --git a/core/src/Pos/Core/Genesis/Data.hs b/core/src/Pos/Core/Genesis/Data.hs index f2dccf092db..238b63fe854 100644 --- a/core/src/Pos/Core/Genesis/Data.hs +++ b/core/src/Pos/Core/Genesis/Data.hs @@ -11,13 +11,13 @@ import Text.JSON.Canonical (FromJSON (..), ReportSchemaErrors, import Pos.Core.Common (SharedSeed) import Pos.Core.Slotting (Timestamp) +import Pos.Core.Ssc (VssCertificatesMap) import Pos.Core.Update (BlockVersionData) import Pos.Core.Genesis.AvvmBalances import Pos.Core.Genesis.Delegation import Pos.Core.Genesis.NonAvvmBalances import Pos.Core.Genesis.ProtocolConstants -import Pos.Core.Genesis.VssCertificatesMap import Pos.Core.Genesis.WStakeholders import Pos.Util.Json.Canonical () @@ -28,7 +28,7 @@ data GenesisData = GenesisData { gdBootStakeholders :: !GenesisWStakeholders , gdHeavyDelegation :: !GenesisDelegation , gdStartTime :: !Timestamp - , gdVssCerts :: !GenesisVssCertificatesMap + , gdVssCerts :: !VssCertificatesMap , gdNonAvvmBalances :: !GenesisNonAvvmBalances , gdBlockVersionData :: !BlockVersionData , gdProtocolConsts :: !GenesisProtocolConstants @@ -57,7 +57,7 @@ instance (ReportSchemaErrors m) => FromJSON m GenesisData where gdStartTime <- fromJSField obj "startTime" -- note that we don't need to validate this map explicitly because -- the FromJSON instance of 'VssCertificatesMap' already does this - gdVssCerts <- GenesisVssCertificatesMap <$> fromJSField obj "vssCerts" + gdVssCerts <- fromJSField obj "vssCerts" gdNonAvvmBalances <- fromJSField obj "nonAvvmBalances" gdBlockVersionData <- fromJSField obj "blockVersionData" gdProtocolConsts <- fromJSField obj "protocolConsts" diff --git a/core/src/Pos/Core/Genesis/Generate.hs b/core/src/Pos/Core/Genesis/Generate.hs index 4e1cb104e75..19ea54082b3 100644 --- a/core/src/Pos/Core/Genesis/Generate.hs +++ b/core/src/Pos/Core/Genesis/Generate.hs @@ -38,8 +38,8 @@ import Pos.Core.Common (Address, Coin, IsBootstrapEraAddr (..), import Pos.Core.Delegation (HeavyDlgIndex (..), ProxySKHeavy) import Pos.Core.ProtocolConstants (ProtocolConstants, vssMaxTTL, vssMinTTL) -import Pos.Core.Ssc (VssCertificate, mkVssCertificate, - mkVssCertificatesMap) +import Pos.Core.Ssc (VssCertificate, VssCertificatesMap, + mkVssCertificate, mkVssCertificatesMap) import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, RedeemPublicKey, SecretKey, VssKeyPair, createPsk, deterministic, emptyPassphrase, encToSecret, keyGen, noPassEncrypt, @@ -53,8 +53,6 @@ import Pos.Core.Genesis.Delegation (GenesisDelegation (..), import Pos.Core.Genesis.Initializer (FakeAvvmOptions (..), GenesisInitializer (..), TestnetBalanceOptions (..)) import Pos.Core.Genesis.NonAvvmBalances (GenesisNonAvvmBalances (..)) -import Pos.Core.Genesis.VssCertificatesMap - (GenesisVssCertificatesMap (..)) import Pos.Core.Genesis.WStakeholders (GenesisWStakeholders (..)) -- | Data generated by @generateGenesisData@ using genesis-spec. @@ -65,7 +63,7 @@ data GeneratedGenesisData = GeneratedGenesisData -- ^ Avvm balances (fake and real). , ggdBootStakeholders :: !GenesisWStakeholders -- ^ Set of boot stakeholders (richmen addresses or custom addresses) - , ggdVssCerts :: !GenesisVssCertificatesMap + , ggdVssCerts :: !VssCertificatesMap -- ^ Genesis vss data (vss certs of richmen) , ggdDelegation :: !GenesisDelegation -- ^ Genesis heavyweight delegation certificates (empty if @@ -172,9 +170,8 @@ generateGenesisData pm pc (GenesisInitializer{..}) realAvvmBalances = determinis map ((,1) . addressHash . toPublic) bootSecrets -- VSS certificates - vssCertsList <- mapM (generateVssCert pm pc) richmenSecrets - let toVss = mkVssCertificatesMap - vssCerts = GenesisVssCertificatesMap $ toVss vssCertsList + vssCerts <- mkVssCertificatesMap + <$> mapM (generateVssCert pm pc) richmenSecrets -- Non AVVM balances ---- Addresses diff --git a/core/src/Pos/Core/Genesis/VssCertificatesMap.hs b/core/src/Pos/Core/Genesis/VssCertificatesMap.hs deleted file mode 100644 index 84ca9580263..00000000000 --- a/core/src/Pos/Core/Genesis/VssCertificatesMap.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE CPP #-} -module Pos.Core.Genesis.VssCertificatesMap - ( GenesisVssCertificatesMap (..) - ) where - -import Universum - -import qualified Data.Aeson as Aeson (FromJSON (..), ToJSON (..)) -import Data.Semigroup (Semigroup) -import Formatting (bprint, (%)) -import qualified Formatting.Buildable as Buildable -import Serokell.Util (mapJson) -import Text.JSON.Canonical (ToJSON (..)) - -import Pos.Core.Ssc (VssCertificatesMap, getVssCertificatesMap) -import Pos.Util.Json.Canonical () - --- | Predefined balances of non avvm entries. -newtype GenesisVssCertificatesMap = GenesisVssCertificatesMap - { getGenesisVssCertificatesMap :: VssCertificatesMap - } -#if MIN_VERSION_base(4,9,0) - deriving (Show, Eq, Semigroup, Monoid) -#else - deriving (Show, Eq, Monoid) -#endif - -instance Buildable GenesisVssCertificatesMap where - build (GenesisVssCertificatesMap m) = - bprint ("GenesisVssCertificatesMap: "%mapJson) (getVssCertificatesMap m) - -instance Monad m => ToJSON m GenesisVssCertificatesMap where - toJSON = toJSON . getGenesisVssCertificatesMap - -instance Aeson.ToJSON GenesisVssCertificatesMap where - toJSON = Aeson.toJSON . getGenesisVssCertificatesMap - -instance Aeson.FromJSON GenesisVssCertificatesMap where - parseJSON val = GenesisVssCertificatesMap <$> Aeson.parseJSON val diff --git a/core/test/Test/Pos/Core/Arbitrary.hs b/core/test/Test/Pos/Core/Arbitrary.hs index de3322c9956..40cc4fbb493 100644 --- a/core/test/Test/Pos/Core/Arbitrary.hs +++ b/core/test/Test/Pos/Core/Arbitrary.hs @@ -576,7 +576,7 @@ instance Arbitrary G.GenesisData where hasKnownFeePolicy BlockVersionData {bvdTxFeePolicy = TxFeePolicyTxSizeLinear {}} = True hasKnownFeePolicy _ = False - arbitraryVssCerts = G.GenesisVssCertificatesMap . mkVssCertificatesMapLossy <$> arbitrary + arbitraryVssCerts = mkVssCertificatesMapLossy <$> arbitrary ---------------------------------------------------------------------------- -- Arbitrary miscellaneous types ---------------------------------------------------------------------------- From 35051604d70064316d54830224c9298154775ffe Mon Sep 17 00:00:00 2001 From: Rupert Horlick Date: Thu, 6 Sep 2018 11:45:20 -0400 Subject: [PATCH 3/3] [CDEC-509] Remove CoreConfiguration --- core/src/Pos/Core/Configuration.hs | 16 ++---- core/src/Pos/Core/Configuration/Core.hs | 19 +------ core/test/Test/Pos/Core/Dummy.hs | 16 +----- core/test/Test/Pos/Core/Gen.hs | 14 +---- lib/src/Pos/Launcher/Configuration.hs | 75 +++++++++++++++---------- lib/src/Test/Pos/Configuration.hs | 9 ++- 6 files changed, 62 insertions(+), 87 deletions(-) diff --git a/core/src/Pos/Core/Configuration.hs b/core/src/Pos/Core/Configuration.hs index 6970c09ec9c..0199fdfc2cb 100644 --- a/core/src/Pos/Core/Configuration.hs +++ b/core/src/Pos/Core/Configuration.hs @@ -24,7 +24,7 @@ module Pos.Core.Configuration , configFtsSeed , ConfigurationError (..) - , withCoreConfigurations + , configFromGenesisConfig , mkConfig , canonicalGenesisJson @@ -157,11 +157,9 @@ prettyGenesisJson theGenesisData = -- -- If the configuration gives a testnet genesis spec, then a start time must -- be provided, probably sourced from command line arguments. -withCoreConfigurations +configFromGenesisConfig :: (MonadThrow m, MonadIO m) - => CoreConfiguration - -- ^ Update @'GenesisData'@ before passing its parts to @'given'@. - -> FilePath + => FilePath -- ^ Directory where 'configuration.yaml' is stored. -> Maybe Timestamp -- ^ Optional system start time. @@ -169,8 +167,9 @@ withCoreConfigurations -> Maybe Integer -- ^ Optional seed which overrides one from testnet initializer if -- provided. + -> GenesisConfiguration -> m Config -withCoreConfigurations conf confDir mSystemStart mSeed = case ccGenesis conf of +configFromGenesisConfig confDir mSystemStart mSeed = \case -- If a 'GenesisData' source file is given, we check its hash against the -- given expected hash, parse it, and use the GenesisData to fill in all of -- the obligations. @@ -225,10 +224,7 @@ withCoreConfigurations conf confDir mSystemStart mSeed = case ccGenesis conf of pure $ mkConfig theSystemStart theSpec -mkConfig - :: Timestamp - -> GenesisSpec - -> Config +mkConfig :: Timestamp -> GenesisSpec -> Config mkConfig theSystemStart spec = Config { configProtocolMagic = pm , configProtocolConstants = pc diff --git a/core/src/Pos/Core/Configuration/Core.hs b/core/src/Pos/Core/Configuration/Core.hs index 5a97b95f16e..90a08b2d42f 100644 --- a/core/src/Pos/Core/Configuration/Core.hs +++ b/core/src/Pos/Core/Configuration/Core.hs @@ -2,10 +2,7 @@ {-# LANGUAGE Rank2Types #-} module Pos.Core.Configuration.Core - ( - -- * The configuration structure - CoreConfiguration(..) - , GenesisConfiguration(..) + ( GenesisConfiguration(..) ) where import Prelude @@ -15,7 +12,6 @@ import Data.Aeson (FromJSON, ToJSON, Value (..), genericToEncoding, pairs, parseJSON, toEncoding, (.:)) import Data.Aeson.Encoding (pairStr) import Data.Aeson.Options (defaultOptions) -import Data.Aeson.TH (deriveJSON) import Data.Aeson.Types (typeMismatch) import qualified Data.HashMap.Strict as HM import Data.Monoid ((<>)) @@ -97,16 +93,3 @@ instance FromJSON GenesisConfiguration where | otherwise = fail "Incorrect JSON encoding for GenesisConfiguration" parseJSON invalid = typeMismatch "GenesisConfiguration" invalid - -data CoreConfiguration = CoreConfiguration - { - -- | Specifies the genesis - ccGenesis :: !GenesisConfiguration - - -- | Versioning for values in node's DB - , ccDbSerializeVersion :: !Word8 - - } - deriving (Show, Generic) - -deriveJSON defaultOptions ''CoreConfiguration diff --git a/core/test/Test/Pos/Core/Dummy.hs b/core/test/Test/Pos/Core/Dummy.hs index ceebd1224fe..27e53c8e651 100644 --- a/core/test/Test/Pos/Core/Dummy.hs +++ b/core/test/Test/Pos/Core/Dummy.hs @@ -16,7 +16,6 @@ module Test.Pos.Core.Dummy , dummyGenesisSecretKeysPoor , dummyGenesisSecretsRich , dummyGenesisSecretsPoor - , dummyCoreConfiguration , dummyGenesisSpec , dummyBlockVersionData , dummyGenesisData @@ -26,11 +25,9 @@ module Test.Pos.Core.Dummy import Universum -import Pos.Core (BlockCount, Coeff (..), Config (..), - CoreConfiguration (..), EpochIndex (..), - GenesisConfiguration (..), GenesisHash (..), - ProtocolConstants (..), SharedSeed (..), SlotCount, - Timestamp, TxFeePolicy (..), TxSizeLinear (..), +import Pos.Core (BlockCount, Coeff (..), Config (..), EpochIndex (..), + GenesisHash (..), ProtocolConstants (..), SharedSeed (..), + SlotCount, Timestamp, TxFeePolicy (..), TxSizeLinear (..), VssMaxTTL (..), VssMinTTL (..), kEpochSlots, kSlotSecurityParam, mkConfig, pcBlkSecurityParam, unsafeCoinPortionFromDouble) @@ -94,13 +91,6 @@ dummyGenesisSecretKeysRich = gsSecretKeysRich dummyGeneratedSecrets dummyGenesisSecretKeysPoor :: [SecretKey] dummyGenesisSecretKeysPoor = gsSecretKeysPoor dummyGeneratedSecrets -dummyCoreConfiguration :: CoreConfiguration -dummyCoreConfiguration = - CoreConfiguration (GCSpec dummyGenesisSpec) dummyDbSerializeVersion - -dummyDbSerializeVersion :: Word8 -dummyDbSerializeVersion = 0 - dummyGenesisSpec :: GenesisSpec dummyGenesisSpec = UnsafeGenesisSpec dummyGenesisAvvmBalances diff --git a/core/test/Test/Pos/Core/Gen.hs b/core/test/Test/Pos/Core/Gen.hs index 458a4b2171f..f9c5800e65e 100644 --- a/core/test/Test/Pos/Core/Gen.hs +++ b/core/test/Test/Pos/Core/Gen.hs @@ -24,7 +24,6 @@ module Test.Pos.Core.Gen -- Pos.Core.Configuration Generators , genGenesisConfiguration - , genCoreConfiguration -- Pos.Core.Delegation Generators , genDlgPayload @@ -137,8 +136,8 @@ import Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..), StakesMap, TxFeePolicy (..), TxSizeLinear (..), coinPortionDenominator, makeAddress, maxCoinVal, mkMultiKeyDistr) -import Pos.Core.Configuration (CoreConfiguration (..), - GenesisConfiguration (..), GenesisHash (..)) +import Pos.Core.Configuration (GenesisConfiguration (..), + GenesisHash (..)) import Pos.Core.Delegation (DlgPayload (..), HeavyDlgIndex (..), LightDlgIndices (..), ProxySKBlockInfo, ProxySKHeavy) import Pos.Core.Genesis (FakeAvvmOptions (..), @@ -337,12 +336,6 @@ genGenesisConfiguration pm = , GCSpec <$> genGenesisSpec pm ] -genCoreConfiguration :: ProtocolMagic -> Gen CoreConfiguration -genCoreConfiguration pm = - CoreConfiguration - <$> genGenesisConfiguration pm - <*> genWord8 - ---------------------------------------------------------------------------- -- Pos.Core.Delegation Generators ---------------------------------------------------------------------------- @@ -776,9 +769,6 @@ genMicrosecond = fromMicroseconds <$> Gen.integral (Range.constant 0 1000000) genWord32 :: Gen Word32 genWord32 = Gen.word32 Range.constantBounded -genWord8 :: Gen Word8 -genWord8 = Gen.word8 Range.constantBounded - genWord16 :: Gen Word16 genWord16 = Gen.word16 Range.constantBounded diff --git a/lib/src/Pos/Launcher/Configuration.hs b/lib/src/Pos/Launcher/Configuration.hs index 2174a1d191e..e5ea77c3f4b 100644 --- a/lib/src/Pos/Launcher/Configuration.hs +++ b/lib/src/Pos/Launcher/Configuration.hs @@ -24,10 +24,11 @@ module Pos.Launcher.Configuration import Universum -import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, - genericToJSON, withObject, (.:), (.:?)) +import Data.Aeson (FromJSON (..), ToJSON (..), genericToJSON, + withObject, (.:), (.:?)) import qualified Data.ByteString.Lazy as BSL import Data.Default (Default (..)) +import qualified Data.HashMap.Strict as HM import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as Text @@ -59,21 +60,35 @@ import Pos.Core.Configuration as Core -- | Product of all configurations required to run a node. data Configuration = Configuration - { ccCore :: !CoreConfiguration - , ccNtp :: !NtpConfiguration - , ccUpdate :: !UpdateConfiguration - , ccSsc :: !SscConfiguration - , ccDlg :: !DlgConfiguration - , ccTxp :: !TxpConfiguration - , ccBlock :: !BlockConfiguration - , ccNode :: !NodeConfiguration + { ccGenesis :: !GenesisConfiguration + , ccNtp :: !NtpConfiguration + , ccUpdate :: !UpdateConfiguration + , ccSsc :: !SscConfiguration + , ccDlg :: !DlgConfiguration + , ccTxp :: !TxpConfiguration + , ccBlock :: !BlockConfiguration + , ccNode :: !NodeConfiguration } deriving (Show, Generic) instance FromJSON Configuration where - parseJSON = genericParseJSON defaultOptions + parseJSON = withObject "Configuration" $ \o -> do + ccGenesis <- if + | HM.member "genesis" o -> o .: "genesis" + | HM.member "core" o -> do + coreO <- o .: "core" + coreO .: "genesis" + | otherwise -> fail "Incorrect JSON encoding for Configuration" + ccNtp <- o .: "ntp" + ccUpdate <- o .: "update" + ccSsc <- o .: "ssc" + ccDlg <- o .: "dlg" + ccTxp <- o .: "txp" + ccBlock <- o .: "block" + ccNode <- o .: "node" + pure $ Configuration {..} instance ToJSON Configuration where - toJSON = genericToJSON defaultOptions + toJSON = genericToJSON defaultOptions type HasConfigurations = ( HasUpdateConfiguration @@ -134,10 +149,11 @@ withConfigurationsM logName mAssetLockPath dumpGenesisPath dumpConfig cfo act = Nothing -> pure mempty Just fp -> liftIO $ readAssetLockedSrcAddrs fp let configDir = takeDirectory $ cfoFilePath cfo - coreConfig <- withCoreConfigurations (ccCore cfg) - configDir - (cfoSystemStart cfo) - (cfoSeed cfo) + coreConfig <- configFromGenesisConfig + configDir + (cfoSystemStart cfo) + (cfoSeed cfo) + (ccGenesis cfg) withUpdateConfiguration (ccUpdate cfg) $ withSscConfiguration (ccSsc cfg) $ withDlgConfiguration (ccDlg cfg) $ @@ -148,7 +164,7 @@ withConfigurationsM logName mAssetLockPath dumpGenesisPath dumpConfig cfo act = dumpGenesisPath dumpConfig (configGenesisData coreConfig) - (ccCore cfg) + (ccGenesis cfg) (ccNtp cfg) txpConfig act coreConfig txpConfig (ccNtp cfg) @@ -167,12 +183,13 @@ withConfigurations -> m r withConfigurations mAssetLockPath dumpGenesisPath dumpConfig cfo act = do loggerName <- askLoggerName - withConfigurationsM loggerName - mAssetLockPath - dumpGenesisPath - dumpConfig - cfo - act + withConfigurationsM + loggerName + mAssetLockPath + dumpGenesisPath + dumpConfig + cfo + act addAssetLock :: Set Address -> TxpConfiguration -> TxpConfiguration addAssetLock bset tcfg = @@ -195,13 +212,13 @@ printInfoOnStart :: => Maybe FilePath -> Bool -> GenesisData - -> CoreConfiguration + -> GenesisConfiguration -> NtpConfiguration -> TxpConfiguration -> m () -printInfoOnStart dumpGenesisPath dumpConfig genesisData coreConfig ntpConfig txpConfig = do +printInfoOnStart dumpGenesisPath dumpConfig genesisData genesisConfig ntpConfig txpConfig = do whenJust dumpGenesisPath $ dumpGenesisData genesisData True - when dumpConfig $ dumpConfiguration coreConfig ntpConfig txpConfig + when dumpConfig $ dumpConfiguration genesisConfig ntpConfig txpConfig printFlags t <- currentTime mapM_ logInfo $ @@ -227,14 +244,14 @@ dumpGenesisData genesisData canonical path = do -- | Dump our configuration into stdout and exit. dumpConfiguration :: (HasConfigurations, MonadIO m) - => CoreConfiguration + => GenesisConfiguration -> NtpConfiguration -> TxpConfiguration -> m () -dumpConfiguration coreConfig ntpConfig txpConfig = do +dumpConfiguration genesisConfig ntpConfig txpConfig = do let conf = Configuration - { ccCore = coreConfig + { ccGenesis = genesisConfig , ccNtp = ntpConfig , ccUpdate = updateConfiguration , ccSsc = sscConfiguration diff --git a/lib/src/Test/Pos/Configuration.hs b/lib/src/Test/Pos/Configuration.hs index 96a511af4af..83e4da2d0c3 100644 --- a/lib/src/Test/Pos/Configuration.hs +++ b/lib/src/Test/Pos/Configuration.hs @@ -36,7 +36,7 @@ import Pos.Chain.Update (HasUpdateConfiguration, withUpdateConfiguration) import Pos.Configuration (HasNodeConfiguration, withNodeConfiguration) import Pos.Core (mkConfig) -import Pos.Core.Configuration as Core (Config, CoreConfiguration (..), +import Pos.Core.Configuration as Core (Config, GenesisConfiguration (..)) import Pos.Core.Genesis (GenesisSpec (..)) import Pos.Core.Update (BlockVersionData) @@ -54,10 +54,9 @@ defaultTestConf = case J.fromJSON $ J.Object jobj of jobj = $(embedYamlConfigCT (Proxy @J.Object) "configuration.yaml" "configuration.yaml" "test") defaultTestGenesisSpec :: GenesisSpec -defaultTestGenesisSpec = - case ccGenesis (ccCore defaultTestConf) of - GCSpec spec -> spec - _ -> error "unexpected genesis type in test" +defaultTestGenesisSpec = case ccGenesis defaultTestConf of + GCSpec spec -> spec + _ -> error "unexpected genesis type in test" defaultTestBlockVersionData :: BlockVersionData defaultTestBlockVersionData = gsBlockVersionData defaultTestGenesisSpec