diff --git a/auxx/src/Command/BlockGen.hs b/auxx/src/Command/BlockGen.hs index 05715d2b6ee..af24a358636 100644 --- a/auxx/src/Command/BlockGen.hs +++ b/auxx/src/Command/BlockGen.hs @@ -17,6 +17,7 @@ import Pos.Chain.Genesis as Genesis (Config (..), configBootStakeholders) import Pos.Chain.Txp (TxpConfiguration) import Pos.Client.KeyStorage (getSecretKeysPlain) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Crypto (encToSecret) import Pos.DB.Txp (txpGlobalSettings) import Pos.Generator.Block (BlockGenParams (..), genBlocks, @@ -38,7 +39,8 @@ generateBlocks genesisConfig txpConfig GenBlocksParams{..} = withStateLock HighP seed <- liftIO $ maybe randomIO pure bgoSeed logInfo $ "Generating with seed " <> show seed - allSecrets <- mkAllSecretsSimple . map encToSecret <$> getSecretKeysPlain + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig + allSecrets <- (mkAllSecretsSimple nm) . map encToSecret <$> getSecretKeysPlain let bgenParams = BlockGenParams diff --git a/chain/src/Pos/Chain/Genesis/Generate.hs b/chain/src/Pos/Chain/Genesis/Generate.hs index 6af953e4271..5a90982182f 100644 --- a/chain/src/Pos/Chain/Genesis/Generate.hs +++ b/chain/src/Pos/Chain/Genesis/Generate.hs @@ -40,7 +40,7 @@ import Pos.Core.Common (Address, Coin, IsBootstrapEraAddr (..), coinToInteger, deriveFirstHDAddress, makePubKeyAddressBoot, mkCoin, sumCoins, unsafeIntegerToCoin) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Core.ProtocolConstants (ProtocolConstants, vssMaxTTL, vssMinTTL) import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, RedeemPublicKey, @@ -176,7 +176,7 @@ generateGenesisData pm pc (GenesisInitializer{..}) realAvvmBalances = determinis vssCerts <- mkVssCertificatesMap <$> mapM (generateVssCert pm pc) richmenSecrets - let nm = fixedNM + let nm = makeNetworkMagic pm -- Non AVVM balances ---- Addresses @@ -321,7 +321,3 @@ genTestnetDistribution TestnetBalanceOptions {..} testBalance = getShare :: Double -> Integer -> Integer getShare sh n = round $ sh * fromInteger n - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/chain/src/Pos/Chain/Txp/GenesisUtxo.hs b/chain/src/Pos/Chain/Txp/GenesisUtxo.hs index c362bc8372c..c775f1a2a0b 100644 --- a/chain/src/Pos/Chain/Txp/GenesisUtxo.hs +++ b/chain/src/Pos/Chain/Txp/GenesisUtxo.hs @@ -10,13 +10,14 @@ import Universum import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map -import Pos.Chain.Genesis (GenesisData (..), getGenesisAvvmBalances, +import Pos.Chain.Genesis (GenesisData (..), + GenesisProtocolConstants (..), getGenesisAvvmBalances, getGenesisNonAvvmBalances) import Pos.Chain.Txp.Toil (Utxo, utxoToStakes) import Pos.Chain.Txp.Tx (TxIn (..), TxOut (..)) import Pos.Chain.Txp.TxOutAux (TxOutAux (..)) import Pos.Core (Address, Coin, StakesMap, makeRedeemAddress) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (NetworkMagic, makeNetworkMagic) import Pos.Crypto (unsafeHash) @@ -28,7 +29,9 @@ genesisUtxo :: GenesisData -> Utxo genesisUtxo genesisData = let networkMagic :: NetworkMagic - networkMagic = fixedNM + networkMagic = makeNetworkMagic $ + gpcProtocolMagic $ + gdProtocolConsts genesisData preUtxo :: [(Address, Coin)] preUtxo = @@ -44,6 +47,3 @@ genesisUtxo genesisData = (TxInUtxo (unsafeHash addr) 0, TxOutAux (TxOut addr coin)) in Map.fromList $ utxoEntry <$> preUtxo - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/chain/src/Pos/Chain/Txp/Toil/Logic.hs b/chain/src/Pos/Chain/Txp/Toil/Logic.hs index 3ab302539dd..53ec87fbc2c 100644 --- a/chain/src/Pos/Chain/Txp/Toil/Logic.hs +++ b/chain/src/Pos/Chain/Txp/Toil/Logic.hs @@ -45,7 +45,7 @@ import Pos.Core (AddrAttributes (..), AddrStakeDistribution (..), import Pos.Core.Common (integerToCoin) import qualified Pos.Core.Common as Fee (TxFeePolicy (..), calculateTxSizeLinear) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Crypto (ProtocolMagic, WithHash (..), hash) import Pos.Util (liftEither) @@ -145,7 +145,8 @@ verifyAndApplyTx :: -> ExceptT ToilVerFailure UtxoM TxUndo verifyAndApplyTx pm adoptedBVD lockedAssets curEpoch verifyVersions tx@(_, txAux) = do whenLeft (checkTxAux txAux) (throwError . ToilInconsistentTxAux) - let ctx = Utxo.VTxContext verifyVersions fixedNM + let nm = makeNetworkMagic pm + ctx = Utxo.VTxContext verifyVersions nm vtur@VerifyTxUtxoRes {..} <- Utxo.verifyTxUtxo pm ctx lockedAssets txAux liftEither $ verifyGState adoptedBVD curEpoch txAux vtur lift $ applyTxToUtxo' tx @@ -237,7 +238,3 @@ withTxId aux = (hash (taTx aux), aux) applyTxToUtxo' :: (TxId, TxAux) -> UtxoM () applyTxToUtxo' (i, TxAux tx _) = Utxo.applyTxToUtxo (WithHash tx i) - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/chain/test/Test/Pos/Chain/Block/Arbitrary.hs b/chain/test/Test/Pos/Chain/Block/Arbitrary.hs index b3e6489e552..8c894084e86 100644 --- a/chain/test/Test/Pos/Chain/Block/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Block/Arbitrary.hs @@ -16,6 +16,8 @@ module Test.Pos.Chain.Block.Arbitrary , genMainBlockBody , genMainBlockBodyForSlot , genMainBlock + , genHeaderAndParams + , genStubbedBHL ) where import Universum @@ -48,7 +50,6 @@ import Test.Pos.Chain.Ssc.Arbitrary (SscPayloadDependsOnSlot (..), import Test.Pos.Chain.Txp.Arbitrary (genTxPayload) import Test.Pos.Chain.Update.Arbitrary (genUpdatePayload) import Test.Pos.Core.Arbitrary (genSlotId) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) newtype BodyDependsOnSlot body = BodyDependsOnSlot { genBodyDepsOnSlot :: Core.SlotId -> Gen body @@ -98,8 +99,9 @@ instance Arbitrary Block.GenesisBody where shrink = genericShrink instance Arbitrary Block.GenesisBlock where - arbitrary = Block.mkGenesisBlock dummyProtocolMagic - <$> (maybe (Left dummyGenesisHash) Right <$> arbitrary) + arbitrary = Block.mkGenesisBlock + <$> arbitrary + <*> (maybe (Left dummyGenesisHash) Right <$> arbitrary) <*> arbitrary <*> arbitrary shrink = genericShrink @@ -129,7 +131,8 @@ instance Arbitrary Block.MainBlockHeader where prevHash <- arbitrary difficulty <- arbitrary body <- arbitrary - genMainBlockHeader dummyProtocolMagic prevHash difficulty body + pm <- arbitrary + genMainBlockHeader pm prevHash difficulty body shrink = genericShrink instance Arbitrary Block.MainExtraHeaderData where @@ -197,7 +200,8 @@ instance Arbitrary (BodyDependsOnSlot Block.MainBody) where txPayload <- arbitrary generator <- genPayloadDependsOnSlot <$> arbitrary mpcData <- generator slotId - dlgPayload <- genDlgPayload dummyProtocolMagic $ Core.siEpoch slotId + pm <- arbitrary + dlgPayload <- genDlgPayload pm $ Core.siEpoch slotId mpcUpload <- arbitrary return $ Block.MainBody txPayload mpcData dlgPayload mpcUpload @@ -230,13 +234,14 @@ genMainBlock pm prevHash difficulty = do instance Arbitrary Block.MainBlock where arbitrary = do slot <- arbitrary + pm <- arbitrary bv <- arbitrary sv <- arbitrary prevHeader <- maybe (Left dummyGenesisHash) Right <$> arbitrary sk <- arbitrary BodyDependsOnSlot {..} <- arbitrary :: Gen (BodyDependsOnSlot Block.MainBody) body <- genBodyDepsOnSlot slot - pure $ mkMainBlock dummyProtocolMagic bv sv prevHeader slot sk Nothing body + pure $ mkMainBlock pm bv sv prevHeader slot sk Nothing body shrink = genericShrink instance Buildable (Block.BlockHeader, PublicKey) where @@ -274,13 +279,15 @@ instance Show BlockHeaderList where -- * if an epoch is `n` slots long, every `n+1`-th block will be of the -- genesis kind. recursiveHeaderGen - :: GenesisHash + :: ProtocolMagic + -> GenesisHash -> Bool -- ^ Whether to create genesis block before creating main block for 0th slot -> [Either SecretKey (SecretKey, SecretKey)] -> [Core.SlotId] -> [Block.BlockHeader] -> Gen [Block.BlockHeader] -recursiveHeaderGen gHash +recursiveHeaderGen pm + gHash genesis (eitherOfLeader : leaders) (Core.SlotId{..} : rest) @@ -288,12 +295,12 @@ recursiveHeaderGen gHash | genesis && Core.getSlotIndex siSlot == 0 = do gBody <- arbitrary let pHeader = maybe (Left gHash) Right ((fmap fst . uncons) blockchain) - gHeader = Block.BlockHeaderGenesis $ Block.mkGenesisHeader dummyProtocolMagic pHeader siEpoch gBody + gHeader = Block.BlockHeaderGenesis $ Block.mkGenesisHeader pm pHeader siEpoch gBody mHeader <- genMainHeader (Just gHeader) - recursiveHeaderGen gHash True leaders rest (mHeader : gHeader : blockchain) + recursiveHeaderGen pm gHash True leaders rest (mHeader : gHeader : blockchain) | otherwise = do curHeader <- genMainHeader ((fmap fst . uncons) blockchain) - recursiveHeaderGen gHash True leaders rest (curHeader : blockchain) + recursiveHeaderGen pm gHash True leaders rest (curHeader : blockchain) where genMainHeader prevHeader = do body <- arbitrary @@ -306,13 +313,13 @@ recursiveHeaderGen gHash Left sk -> (sk, Nothing) Right (issuerSK, delegateSK) -> let delegatePK = toPublic delegateSK - proxy = ( createPsk dummyProtocolMagic issuerSK delegatePK (Core.HeavyDlgIndex siEpoch) + proxy = ( createPsk pm issuerSK delegatePK (Core.HeavyDlgIndex siEpoch) , toPublic issuerSK) in (delegateSK, Just proxy) pure $ Block.BlockHeaderMain $ - Block.mkMainHeader dummyProtocolMagic (maybe (Left gHash) Right prevHeader) slotId leader proxySK body extraHData -recursiveHeaderGen _ _ [] _ b = return b -recursiveHeaderGen _ _ _ [] b = return b + Block.mkMainHeader pm (maybe (Left gHash) Right prevHeader) slotId leader proxySK body extraHData +recursiveHeaderGen _ _ _ [] _ b = return b +recursiveHeaderGen _ _ _ _ [] b = return b -- | Maximum start epoch in block header verification tests @@ -341,19 +348,25 @@ bhlEpochs = 2 -- Note that a leader is generated for each slot. -- (Not exactly a leader - see previous comment) instance Arbitrary BlockHeaderList where - arbitrary = do - incompleteEpochSize <- choose (1, dummyEpochSlots - 1) - let slot = Core.SlotId 0 localSlotIndexMinBound - generateBHL dummyGenesisHash True slot (dummyEpochSlots * bhlEpochs + incompleteEpochSize) + arbitrary = arbitrary >>= genStubbedBHL + +genStubbedBHL + :: ProtocolMagic + -> Gen BlockHeaderList +genStubbedBHL pm = do + incompleteEpochSize <- choose (1, dummyEpochSlots - 1) + let slot = Core.SlotId 0 localSlotIndexMinBound + generateBHL pm dummyGenesisHash True slot (dummyEpochSlots * bhlEpochs + incompleteEpochSize) generateBHL - :: GenesisHash + :: ProtocolMagic + -> GenesisHash -> Bool -- ^ Whether to create genesis block before creating main -- block for 0th slot -> Core.SlotId -- ^ Start slot -> Core.SlotCount -- ^ Slot count -> Gen BlockHeaderList -generateBHL gHash createInitGenesis startSlot slotCount = BHL <$> do +generateBHL pm gHash createInitGenesis startSlot slotCount = BHL <$> do let correctLeaderGen :: Gen (Either SecretKey (SecretKey, SecretKey)) correctLeaderGen = -- We don't want to create blocks with self-signed psks @@ -368,6 +381,7 @@ generateBHL gHash createInitGenesis startSlot slotCount = BHL <$> do [Core.flattenSlotId dummyEpochSlots startSlot ..] (, actualLeaders) <$> recursiveHeaderGen + pm gHash createInitGenesis leadersList @@ -383,69 +397,72 @@ newtype HeaderAndParams = HAndP { getHAndP :: (Block.VerifyHeaderParams, Block.BlockHeader) } deriving (Eq, Show) +genHeaderAndParams :: ProtocolMagic -> Gen HeaderAndParams +genHeaderAndParams pm = do + -- This integer is used as a seed to randomly choose a slot down below + seed <- arbitrary :: Gen Int + startSlot <- Core.SlotId <$> choose (0, bhlMaxStartingEpoch) <*> arbitrary + (headers, leaders) <- first reverse . getHeaderList <$> + (generateBHL pm dummyGenesisHash True startSlot =<< choose (1, 2)) + let num = length headers + -- 'skip' is the random number of headers that should be skipped in + -- the header chain. This ensures different parts of it are chosen + -- each time. + skip <- choose (0, num - 1) + let atMost2HeadersAndLeaders = take 2 $ drop skip headers + (prev, header) = + case atMost2HeadersAndLeaders of + [h] -> (Nothing, h) + [h1, h2] -> (Just h1, h2) + _ -> error "[BlockSpec] the headerchain doesn't have enough headers" + -- This binding captures the chosen header's epoch. It is used to + -- drop all all leaders of headers from previous epochs. + thisEpochStartIndex = fromIntegral dummyEpochSlots * + fromIntegral (header ^. Core.epochIndexL) + thisHeadersEpoch = drop thisEpochStartIndex leaders + -- A helper function. Given integers 'x' and 'y', it chooses a + -- random integer in the interval [x, y] + betweenXAndY :: Random a => a -> a -> a + betweenXAndY x y = fst . randomR (x, y) . mkStdGen $ seed + -- One of the fields in the 'VerifyHeaderParams' type is 'Just + -- SlotId'. The following binding is where it is calculated. + randomSlotBeforeThisHeader = + case header of + -- If the header is of the genesis kind, this field is + -- not needed. + Block.BlockHeaderGenesis _ -> Nothing + -- If it's a main blockheader, then a valid "current" + -- SlotId for testing is any with an epoch greater than + -- the header's epoch and with any slot index, or any in + -- the same epoch but with a greater or equal slot index + -- than the header. + Block.BlockHeaderMain h -> -- Nothing {- + let (Core.SlotId e s) = view Block.headerSlotL h + rndEpoch :: Core.EpochIndex + rndEpoch = betweenXAndY e maxBound + rndSlotIdx :: Core.LocalSlotIndex + rndSlotIdx = if rndEpoch > e + then betweenXAndY localSlotIndexMinBound (localSlotIndexMaxBound dummyEpochSlots) + else betweenXAndY s (localSlotIndexMaxBound dummyEpochSlots) + rndSlot = Core.SlotId rndEpoch rndSlotIdx + in Just rndSlot + hasUnknownAttributes = + not . areAttributesKnown $ + case header of + Block.BlockHeaderGenesis h -> h ^. Block.gbhExtra . Block.gehAttributes + Block.BlockHeaderMain h -> h ^. Block.gbhExtra . Block.mehAttributes + params = Block.VerifyHeaderParams + { Block.vhpPrevHeader = prev + , Block.vhpCurrentSlot = randomSlotBeforeThisHeader + , Block.vhpLeaders = nonEmpty $ map Core.addressHash thisHeadersEpoch + , Block.vhpMaxSize = Just (biSize header) + , Block.vhpVerifyNoUnknown = not hasUnknownAttributes + } + return . HAndP $ (params, header) + -- | A lot of the work to generate a valid sequence of blockheaders has -- already been done in the 'Arbitrary' instance of the 'BlockHeaderList' -- type, so it is used here and at most 3 blocks are taken from the generated -- list. instance Arbitrary HeaderAndParams where - arbitrary = do - -- This integer is used as a seed to randomly choose a slot down below - seed <- arbitrary :: Gen Int - startSlot <- Core.SlotId <$> choose (0, bhlMaxStartingEpoch) <*> arbitrary - (headers, leaders) <- first reverse . getHeaderList <$> - (generateBHL dummyGenesisHash True startSlot =<< choose (1, 2)) - let num = length headers - -- 'skip' is the random number of headers that should be skipped in - -- the header chain. This ensures different parts of it are chosen - -- each time. - skip <- choose (0, num - 1) - let atMost2HeadersAndLeaders = take 2 $ drop skip headers - (prev, header) = - case atMost2HeadersAndLeaders of - [h] -> (Nothing, h) - [h1, h2] -> (Just h1, h2) - _ -> error "[BlockSpec] the headerchain doesn't have enough headers" - -- This binding captures the chosen header's epoch. It is used to - -- drop all all leaders of headers from previous epochs. - thisEpochStartIndex = fromIntegral dummyEpochSlots * - fromIntegral (header ^. Core.epochIndexL) - thisHeadersEpoch = drop thisEpochStartIndex leaders - -- A helper function. Given integers 'x' and 'y', it chooses a - -- random integer in the interval [x, y] - betweenXAndY :: Random a => a -> a -> a - betweenXAndY x y = fst . randomR (x, y) . mkStdGen $ seed - -- One of the fields in the 'VerifyHeaderParams' type is 'Just - -- SlotId'. The following binding is where it is calculated. - randomSlotBeforeThisHeader = - case header of - -- If the header is of the genesis kind, this field is - -- not needed. - Block.BlockHeaderGenesis _ -> Nothing - -- If it's a main blockheader, then a valid "current" - -- SlotId for testing is any with an epoch greater than - -- the header's epoch and with any slot index, or any in - -- the same epoch but with a greater or equal slot index - -- than the header. - Block.BlockHeaderMain h -> -- Nothing {- - let (Core.SlotId e s) = view Block.headerSlotL h - rndEpoch :: Core.EpochIndex - rndEpoch = betweenXAndY e maxBound - rndSlotIdx :: Core.LocalSlotIndex - rndSlotIdx = if rndEpoch > e - then betweenXAndY localSlotIndexMinBound (localSlotIndexMaxBound dummyEpochSlots) - else betweenXAndY s (localSlotIndexMaxBound dummyEpochSlots) - rndSlot = Core.SlotId rndEpoch rndSlotIdx - in Just rndSlot - hasUnknownAttributes = - not . areAttributesKnown $ - case header of - Block.BlockHeaderGenesis h -> h ^. Block.gbhExtra . Block.gehAttributes - Block.BlockHeaderMain h -> h ^. Block.gbhExtra . Block.mehAttributes - params = Block.VerifyHeaderParams - { Block.vhpPrevHeader = prev - , Block.vhpCurrentSlot = randomSlotBeforeThisHeader - , Block.vhpLeaders = nonEmpty $ map Core.addressHash thisHeadersEpoch - , Block.vhpMaxSize = Just (biSize header) - , Block.vhpVerifyNoUnknown = not hasUnknownAttributes - } - return . HAndP $ (params, header) + arbitrary = arbitrary >>= genHeaderAndParams diff --git a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs index 89e10c57d1f..8a4a862793c 100644 --- a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs +++ b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs @@ -13,9 +13,9 @@ module Test.Pos.Chain.Block.BlockSpec import Universum import Serokell.Util (isVerSuccess) -import Test.Hspec (Spec, describe, it) +import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Property, (===), (==>)) +import Test.QuickCheck (Gen, Property, (===), (==>)) import Pos.Chain.Block (BlockHeader (..), BlockSignature (..), GenesisBody (..), GenesisConsensusData (..), @@ -30,13 +30,12 @@ import Pos.Chain.Genesis (GenesisHash (..)) import Pos.Core (EpochIndex (..), SlotId (..), difficultyL) import Pos.Core.Attributes (mkAttributes) import Pos.Core.Chrono (NewestFirst (..)) -import Pos.Crypto (ProtocolMagicId (..), ProxySecretKey (pskIssuerPk), - SecretKey, SignTag (..), createPsk, getProtocolMagic, - proxySign, sign, toPublic) +import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), + ProxySecretKey (pskIssuerPk), SecretKey, SignTag (..), + createPsk, getProtocolMagic, proxySign, sign, toPublic) import Test.Pos.Chain.Block.Arbitrary as BT import Test.Pos.Chain.Genesis.Dummy (dummyGenesisHash) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) -- This tests are quite slow, hence max success is at most 20. spec :: Spec @@ -51,7 +50,7 @@ spec = describe "Block properties" $ modifyMaxSuccess (min 20) $ do validateBadProtocolMagicMainHeader describe "verifyHeaders" $ modifyMaxSuccess (const 1) $ do prop verifyHeadersDesc validateGoodHeaderChain - emptyHeaderChain (NewestFirst []) + prop verifyEmptyHsDesc (emptyHeaderChain (NewestFirst [])) where mainHeaderFormationDesc = "Manually generating a main header block and using mkMainHeader is the same" @@ -65,9 +64,10 @@ spec = describe "Block properties" $ modifyMaxSuccess (min 20) $ do verifyEmptyHsDesc = "Successfully validates an empty header chain" emptyHeaderChain :: NewestFirst [] BlockHeader - -> Spec - emptyHeaderChain l = - it verifyEmptyHsDesc $ isVerSuccess $ Block.verifyHeaders dummyProtocolMagic Nothing l + -> ProtocolMagic + -> Bool + emptyHeaderChain l pm = + isVerSuccess $ Block.verifyHeaders pm Nothing l -- | Both of the following tests are boilerplate - they use `mkGenericHeader` to create -- headers and then compare these with manually built headers. @@ -76,19 +76,20 @@ spec = describe "Block properties" $ modifyMaxSuccess (min 20) $ do -- the ensuing failed tests. genesisHeaderFormation - :: Maybe BlockHeader + :: ProtocolMagic + -> Maybe BlockHeader -> EpochIndex -> GenesisBody -> Property -genesisHeaderFormation prevHeader epoch body = header === manualHeader +genesisHeaderFormation pm prevHeader epoch body = header === manualHeader where header = mkGenesisHeader - dummyProtocolMagic + pm (maybe (Left dummyGenesisHash) Right prevHeader) epoch body manualHeader = mkGenericBlockHeaderUnsafe - dummyProtocolMagic + pm h proof (consensus h proof) @@ -102,21 +103,22 @@ genesisHeaderFormation prevHeader epoch body = header === manualHeader } mainHeaderFormation - :: Maybe BlockHeader + :: ProtocolMagic + -> Maybe BlockHeader -> SlotId -> Either SecretKey (SecretKey, SecretKey) -> MainBody -> MainExtraHeaderData -> Property -mainHeaderFormation prevHeader slotId signer body extra = +mainHeaderFormation pm prevHeader slotId signer body extra = correctSigner signer ==> (header === manualHeader) where correctSigner (Left _ ) = True correctSigner (Right (i, d)) = i /= d - header = mkMainHeader dummyProtocolMagic prevHeader' slotId sk pske body extra + header = mkMainHeader pm prevHeader' slotId sk pske body extra manualHeader = mkGenericBlockHeaderUnsafe - dummyProtocolMagic + pm prevHash proof (consensus proof) @@ -128,16 +130,16 @@ mainHeaderFormation prevHeader slotId signer body extra = mkProxySk (issuerSK, delegateSK) = let epoch = siEpoch slotId delegatePK = toPublic delegateSK - proxy = createPsk dummyProtocolMagic issuerSK delegatePK (HeavyDlgIndex epoch) + proxy = createPsk pm issuerSK delegatePK (HeavyDlgIndex epoch) in (delegateSK, Just proxy) pske = pSk >>= \proxy -> Just (proxy, pskIssuerPk proxy) difficulty = maybe 0 (succ . view difficultyL) prevHeader makeSignature toSign psk = - BlockPSignatureHeavy $ proxySign dummyProtocolMagic SignMainBlockHeavy sk psk toSign + BlockPSignatureHeavy $ proxySign pm SignMainBlockHeavy sk psk toSign signature p = let toSign = MainToSign prevHash p slotId difficulty extra in maybe - (BlockSignature (sign dummyProtocolMagic SignMainBlock sk toSign)) + (BlockSignature (sign pm SignMainBlock sk toSign)) (makeSignature toSign) pSk consensus p = @@ -153,20 +155,23 @@ mainHeaderFormation prevHeader slotId signer body extra = -- GenesisBlock ∪ MainBlock ---------------------------------------------------------------------------- -validateGoodMainHeader :: BT.HeaderAndParams -> Bool -validateGoodMainHeader (BT.getHAndP -> (params, header)) = - isVerSuccess $ Block.verifyHeader dummyProtocolMagic params header +validateGoodMainHeader :: ProtocolMagic -> Gen Bool +validateGoodMainHeader pm = do + (BT.getHAndP -> (params, header)) <- BT.genHeaderAndParams pm + pure $ isVerSuccess $ Block.verifyHeader pm params header -- FIXME should sharpen this test to ensure that it fails with the expected -- reason. -validateBadProtocolMagicMainHeader :: BT.HeaderAndParams -> Bool -validateBadProtocolMagicMainHeader (BT.getHAndP -> (params, header)) = - let protocolMagicId' = ProtocolMagicId (getProtocolMagic dummyProtocolMagic + 1) +validateBadProtocolMagicMainHeader :: ProtocolMagic -> Gen Bool +validateBadProtocolMagicMainHeader pm = do + (BT.getHAndP -> (params, header)) <- BT.genHeaderAndParams pm + let protocolMagicId' = ProtocolMagicId (getProtocolMagic pm + 1) header' = case header of BlockHeaderGenesis h -> BlockHeaderGenesis (h & gbhProtocolMagicId .~ protocolMagicId') BlockHeaderMain h -> BlockHeaderMain (h & gbhProtocolMagicId .~ protocolMagicId') - in not $ isVerSuccess $ Block.verifyHeader dummyProtocolMagic params header' + pure $ not $ isVerSuccess $ Block.verifyHeader pm params header' -validateGoodHeaderChain :: BT.BlockHeaderList -> Bool -validateGoodHeaderChain (BT.BHL (l, _)) = - isVerSuccess $ Block.verifyHeaders dummyProtocolMagic Nothing (NewestFirst l) +validateGoodHeaderChain :: ProtocolMagic -> Gen Bool +validateGoodHeaderChain pm = do + BT.BHL (l, _) <- BT.genStubbedBHL pm + pure $ isVerSuccess $ Block.verifyHeaders pm Nothing (NewestFirst l) diff --git a/chain/test/Test/Pos/Chain/Delegation/Arbitrary.hs b/chain/test/Test/Pos/Chain/Delegation/Arbitrary.hs index 40fb58dc490..6c3f374fa40 100644 --- a/chain/test/Test/Pos/Chain/Delegation/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Delegation/Arbitrary.hs @@ -21,7 +21,6 @@ import Pos.Core (EpochIndex) import Pos.Crypto (ProtocolMagic, ProxySecretKey (..), createPsk) import Test.Pos.Core.Arbitrary () -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) genDlgPayload :: ProtocolMagic -> EpochIndex -> Gen DlgPayload genDlgPayload pm epoch = @@ -31,7 +30,10 @@ genDlgPayload pm epoch = genPSK = createPsk pm <$> arbitrary <*> arbitrary <*> pure (HeavyDlgIndex epoch) instance Arbitrary DlgPayload where - arbitrary = arbitrary >>= genDlgPayload dummyProtocolMagic + arbitrary = do + pm <- arbitrary + ei <- arbitrary + genDlgPayload pm ei shrink = genericShrink instance Arbitrary DlgUndo where diff --git a/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs b/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs index 2929ffd8f7f..64c95f82d31 100644 --- a/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Genesis/Arbitrary.hs @@ -29,7 +29,6 @@ import Pos.Util.Util (leftToPanic) import Test.Pos.Chain.Ssc.Arbitrary () import Test.Pos.Chain.Update.Arbitrary () import Test.Pos.Core.Arbitrary () -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Arbitrary (nonrepeating) instance Arbitrary TestnetBalanceOptions where @@ -56,12 +55,13 @@ instance Arbitrary GenesisDelegation where -- because 'nonrepeating' fails when -- we want too many items, because -- life is hard + pm <- arbitrary return $ case secretKeys of [] -> [] - (delegate:issuers) -> mkCert (toPublic delegate) <$> issuers + (delegate:issuers) -> mkCert pm (toPublic delegate) <$> issuers where - mkCert delegatePk issuer = createPsk dummyProtocolMagic issuer delegatePk (HeavyDlgIndex 0) + mkCert pm delegatePk issuer = createPsk pm issuer delegatePk (HeavyDlgIndex 0) instance Arbitrary GenesisWStakeholders where arbitrary = GenesisWStakeholders <$> arbitrary diff --git a/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs b/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs index 74b581903b5..5bab103e80e 100644 --- a/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Ssc/Arbitrary.hs @@ -53,7 +53,6 @@ import Pos.Crypto (ProtocolMagic, SecretKey, deterministic, import Test.Pos.Chain.Genesis.Dummy (dummyK) import Test.Pos.Core.Arbitrary.Unsafe () import Test.Pos.Crypto.Arbitrary (genSignature) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Arbitrary (Nonrepeating (..), sublistN) @@ -141,7 +140,7 @@ genSignedCommitment :: ProtocolMagic -> Gen SignedCommitment genSignedCommitment pm = (,,) <$> arbitrary <*> arbitrary <*> genSignature pm arbitrary instance Arbitrary CommitmentsMap where - arbitrary = genCommitmentsMap dummyProtocolMagic + arbitrary = arbitrary >>= genCommitmentsMap shrink = genericShrink -- | Generates commitment map having commitments from given epoch. @@ -179,7 +178,7 @@ genSscPayload pm = ] instance Arbitrary SscPayload where - arbitrary = genSscPayload dummyProtocolMagic + arbitrary = arbitrary >>= genSscPayload shrink = genericShrink -- | We need the 'ProtocolConstants' because they give meaning to 'SlotId'. @@ -207,7 +206,9 @@ genSscPayloadForSlot pm slot genValidCert SlotId{..} (sk, pk) = mkVssCertificate pm sk pk $ siEpoch + 5 instance Arbitrary SscPayloadDependsOnSlot where - arbitrary = pure $ SscPayloadDependsOnSlot (genSscPayloadForSlot dummyProtocolMagic) + arbitrary = do + pm <- arbitrary + pure $ SscPayloadDependsOnSlot (genSscPayloadForSlot pm) genVssCertificate :: ProtocolMagic -> Gen VssCertificate genVssCertificate pm = @@ -216,7 +217,7 @@ genVssCertificate pm = <*> arbitrary -- EpochIndex instance Arbitrary VssCertificate where - arbitrary = genVssCertificate dummyProtocolMagic + arbitrary = arbitrary >>= genVssCertificate -- The 'shrink' method wasn't implement to avoid breaking the datatype's invariant. genVssCertificatesMap :: ProtocolMagic -> Gen VssCertificatesMap @@ -225,7 +226,7 @@ genVssCertificatesMap pm = do pure $ mkVssCertificatesMapLossy certs instance Arbitrary VssCertificatesMap where - arbitrary = genVssCertificatesMap dummyProtocolMagic + arbitrary = arbitrary >>= genVssCertificatesMap shrink = genericShrink instance Arbitrary VssCertData where diff --git a/chain/test/Test/Pos/Chain/Txp/Arbitrary.hs b/chain/test/Test/Pos/Chain/Txp/Arbitrary.hs index ea5cf9b6efe..d7feea3dba6 100644 --- a/chain/test/Test/Pos/Chain/Txp/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Txp/Arbitrary.hs @@ -21,6 +21,7 @@ module Test.Pos.Chain.Txp.Arbitrary , genTxInWitness , genTxOutDist , genTxPayload + , genGoodTxWithMagic ) where import Universum @@ -164,6 +165,12 @@ newtype GoodTx = GoodTx { getGoodTx :: NonEmpty (Tx, TxIn, TxOutAux, TxInWitness) } deriving (Generic, Show) +genGoodTxWithMagic :: ProtocolMagic -> Gen GoodTx +genGoodTxWithMagic pm = + GoodTx <$> (buildProperTx pm + <$> arbitrary + <*> pure (identity, identity)) + goodTxToTxAux :: GoodTx -> TxAux goodTxToTxAux (GoodTx l) = TxAux tx witness where diff --git a/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs b/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs index 29bf4d67649..296c0cf5276 100644 --- a/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs +++ b/chain/test/Test/Pos/Chain/Txp/Toil/UtxoSpec.hs @@ -21,9 +21,10 @@ import Fmt (blockListF', genericF, nameF, (+|), (|+)) import qualified Formatting.Buildable as B import Serokell.Util (allDistinct) import Test.Hspec (Expectation, Spec, describe, expectationFailure, - it) + it, runIO) import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck (Property, arbitrary, counterexample, (==>)) +import Test.QuickCheck (Property, arbitrary, counterexample, forAll, + generate, (==>)) import Pos.Chain.Script (PlutusError (..), Script) import Pos.Chain.Script.Examples (alwaysSuccessValidator, @@ -41,14 +42,15 @@ import Pos.Core (addressHash, checkPubKeyAddress, makePubKeyAddressBoot, makeScriptAddress, mkCoin, sumCoins) import Pos.Core.Attributes (mkAttributes) -import Pos.Core.NetworkMagic (NetworkMagic (..)) -import Pos.Crypto (SignTag (SignTx), checkSig, fakeSigner, hash, - toPublic, unsafeHash, withHash) +import Pos.Core.NetworkMagic (makeNetworkMagic) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..), + SignTag (SignTx), checkSig, fakeSigner, hash, toPublic, + unsafeHash, withHash) import qualified Pos.Util.Modifier as MM import Test.Pos.Chain.Txp.Arbitrary (BadSigsTx (..), - DoubleInputTx (..), GoodTx (..)) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) + DoubleInputTx (..), GoodTx (..), genGoodTxWithMagic) +import Test.Pos.Crypto.Arbitrary (genProtocolMagicUniformWithRNM) import Test.Pos.Util.QuickCheck.Arbitrary (SmallGenerator (..), nonrepeating, runGen) import Test.Pos.Util.QuickCheck.Property (qcIsLeft, qcIsRight) @@ -57,6 +59,12 @@ import Test.Pos.Util.QuickCheck.Property (qcIsLeft, qcIsRight) -- Spec ---------------------------------------------------------------------------- +runWithMagic :: RequiresNetworkMagic -> (ProtocolMagic -> Spec) -> Spec +runWithMagic rnm specBody = do + pm <- runIO (generate (genProtocolMagicUniformWithRNM rnm)) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + spec :: Spec spec = describe "Txp.Toil.Utxo" $ do describe "utxoGet (no modifier)" $ do @@ -70,7 +78,10 @@ spec = describe "Txp.Toil.Utxo" $ do prop description_doubleInputTx doubleInputTx describe "applyTxToUtxo" $ do prop description_applyTxToUtxoGood applyTxToUtxoGood - scriptTxSpec + + -- Run scriptTxSpec for each `RequiresNetworkMagic` case + runWithMagic RequiresNoMagic scriptTxSpec + runWithMagic RequiresMagic scriptTxSpec where myTxIn = TxInUtxo myHash 0 myHash = unsafeHash @Int32 0 @@ -101,8 +112,8 @@ findTxInUtxo key txO utxo = in (isJust $ utxoGetSimple newUtxo key) && (isNothing $ utxoGetSimple utxo' key) -verifyTxInUtxo :: SmallGenerator GoodTx -> Property -verifyTxInUtxo (SmallGenerator (GoodTx ls)) = +verifyTxInUtxo :: ProtocolMagic -> Property +verifyTxInUtxo pm = forAll (genGoodTxWithMagic overriddenPM) $ \(GoodTx ls) -> let txs = fmap (view _1) ls witness = V.fromList $ toList $ fmap (view _4) ls (ins, outs) = NE.unzip $ map (\(_, tIs, tOs, _) -> (tIs, tOs)) ls @@ -112,44 +123,65 @@ verifyTxInUtxo (SmallGenerator (GoodTx ls)) = let id = hash tx (idx, out) <- zip [0..] (toList _txOutputs) pure ((TxInUtxo id idx), TxOutAux out) - vtxContext = VTxContext False fixedNM + vtxContext = VTxContext False (makeNetworkMagic overriddenPM) txAux = TxAux newTx witness in counterexample ("\n"+|nameF "txs" (blockListF' "-" genericF txs)|+"" +|nameF "transaction" (B.build txAux)|+"") $ - qcIsRight $ verifyTxUtxoSimple vtxContext utxo txAux + qcIsRight $ verifyTxUtxoSimple overriddenPM vtxContext utxo txAux + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm -badSigsTx :: SmallGenerator BadSigsTx -> Property -badSigsTx (SmallGenerator (getBadSigsTx -> ls)) = +badSigsTx :: ProtocolMagic -> SmallGenerator BadSigsTx -> Property +badSigsTx pm (SmallGenerator (getBadSigsTx -> ls)) = let (tx@UnsafeTx {..}, utxo, extendedInputs, txWits) = getTxFromGoodTx ls - ctx = VTxContext False fixedNM + ctx = VTxContext False (makeNetworkMagic overriddenPM) transactionVerRes = - verifyTxUtxoSimple ctx utxo $ TxAux tx txWits + verifyTxUtxoSimple overriddenPM ctx utxo $ TxAux tx txWits notAllSignaturesAreValid = - any (signatureIsNotValid tx) + any (signatureIsNotValid overriddenPM tx) (NE.zip (NE.fromList (toList txWits)) (map (fmap snd) extendedInputs)) in notAllSignaturesAreValid ==> qcIsLeft transactionVerRes + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm -doubleInputTx :: SmallGenerator DoubleInputTx -> Property -doubleInputTx (SmallGenerator (getDoubleInputTx -> ls)) = +doubleInputTx :: ProtocolMagic -> SmallGenerator DoubleInputTx -> Property +doubleInputTx pm (SmallGenerator (getDoubleInputTx -> ls)) = let ((tx@UnsafeTx {..}), utxo, _extendedInputs, txWits) = getTxFromGoodTx ls - ctx = VTxContext False fixedNM + ctx = VTxContext False (makeNetworkMagic overriddenPM) transactionVerRes = - verifyTxUtxoSimple ctx utxo $ TxAux tx txWits + verifyTxUtxoSimple overriddenPM ctx utxo $ TxAux tx txWits someInputsAreDuplicated = not $ allDistinct (toList _txInputs) in someInputsAreDuplicated ==> qcIsLeft transactionVerRes - -validateGoodTx :: SmallGenerator GoodTx -> Property -validateGoodTx (SmallGenerator (getGoodTx -> ls)) = - let quadruple@(tx, utxo, _, txWits) = getTxFromGoodTx ls - ctx = VTxContext False fixedNM - transactionVerRes = - verifyTxUtxoSimple ctx utxo $ TxAux tx txWits - transactionReallyIsGood = individualTxPropertyVerifier quadruple - in transactionReallyIsGood ==> qcIsRight transactionVerRes + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm + +validateGoodTx :: ProtocolMagic -> Property +validateGoodTx pm = + forAll (genGoodTxWithMagic overriddenPM) $ \(GoodTx ls) -> + let quadruple@(tx, utxo, _, txWits) = getTxFromGoodTx ls + ctx = VTxContext False (makeNetworkMagic overriddenPM) + transactionVerRes = + verifyTxUtxoSimple overriddenPM ctx utxo $ TxAux tx txWits + transactionReallyIsGood = individualTxPropertyVerifier overriddenPM quadruple + in transactionReallyIsGood ==> qcIsRight transactionVerRes + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm ---------------------------------------------------------------------------- -- Helpers @@ -159,13 +191,19 @@ utxoGetSimple :: Utxo -> TxIn -> Maybe TxOutAux utxoGetSimple utxo txIn = evalUtxoM mempty (utxoToLookup utxo) (utxoGet txIn) verifyTxUtxoSimple - :: VTxContext + :: ProtocolMagic + -> VTxContext -> Utxo -> TxAux -> Either ToilVerFailure VerifyTxUtxoRes -verifyTxUtxoSimple ctx utxo txAux = +verifyTxUtxoSimple pm ctx utxo txAux = evalUtxoM mempty (utxoToLookup utxo) . runExceptT $ - verifyTxUtxo dummyProtocolMagic ctx mempty txAux + verifyTxUtxo overriddenPM ctx mempty txAux + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm type TxVerifyingTools = (Tx, Utxo, NonEmpty (Maybe (TxIn, TxOutAux)), TxWitness) @@ -202,28 +240,39 @@ getTxFromGoodTx ls = -- * every input is signed properly; -- * every input is a known unspent output. -- It also checks that it has good structure w.r.t. 'verifyTxAlone'. -individualTxPropertyVerifier :: TxVerifyingTools -> Bool -individualTxPropertyVerifier (tx@UnsafeTx{..}, _, extendedInputs, txWits) = +individualTxPropertyVerifier :: ProtocolMagic -> TxVerifyingTools -> Bool +individualTxPropertyVerifier pm (tx@UnsafeTx{..}, _, extendedInputs, txWits) = let hasGoodSum = txChecksum extendedInputs _txOutputs hasGoodInputs = - all (signatureIsValid tx) + all (signatureIsValid overriddenPM tx) (NE.zip (NE.fromList (toList txWits)) (map (fmap snd) extendedInputs)) in hasGoodSum && hasGoodInputs + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm signatureIsValid - :: Tx + :: ProtocolMagic + -> Tx -> (TxInWitness, Maybe TxOutAux) -- ^ input witness + output spent by the input -> Bool -signatureIsValid tx (PkWitness twKey twSig, Just TxOutAux{..}) = +signatureIsValid pm tx (PkWitness twKey twSig, Just TxOutAux{..}) = let txSigData = TxSigData { txSigTxHash = hash tx } in checkPubKeyAddress twKey (txOutAddress toaOut) && - checkSig dummyProtocolMagic SignTx twKey txSigData twSig -signatureIsValid _ _ = False + checkSig overriddenPM SignTx twKey txSigData twSig + where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm +signatureIsValid _ _ _ = False -signatureIsNotValid :: Tx -> (TxInWitness, Maybe TxOutAux) -> Bool +signatureIsNotValid :: ProtocolMagic -> Tx -> (TxInWitness, Maybe TxOutAux) -> Bool signatureIsNotValid = not ... signatureIsValid -- | This function takes a list of resolved inputs from a transaction, that @@ -264,8 +313,8 @@ applyTxToUtxoGood (txIn0, txOut0) txMap txOuts = -- Script Txs spec ---------------------------------------------------------------------------- -scriptTxSpec :: Spec -scriptTxSpec = describe "script transactions" $ do +scriptTxSpec :: ProtocolMagic -> Spec +scriptTxSpec pm = describe "script transactions" $ do describe "good cases" $ do it "goodIntRedeemer + intValidator" $ do txShouldSucceed $ checkScriptTx @@ -329,75 +378,75 @@ scriptTxSpec = describe "script transactions" $ do describe "multisig" $ do describe "1-of-1" $ do - let val = multisigValidator dummyProtocolMagic 1 [addressHash pk1] + let val = multisigValidator overriddenPM 1 [addressHash pk1] it "good (1 provided)" $ do txShouldSucceed $ checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd [Just $ fakeSigner sk1])) + (multisigRedeemer overriddenPM sd [Just $ fakeSigner sk1])) it "bad (0 provided)" $ do let res = checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd [Nothing])) + (multisigRedeemer overriddenPM sd [Nothing])) res `txShouldFailWithPlutus` PlutusReturnedFalse it "bad (1 provided, wrong sig)" $ do let res = checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd [Just $ fakeSigner sk2])) + (multisigRedeemer overriddenPM sd [Just $ fakeSigner sk2])) res `txShouldFailWithPlutus` PlutusReturnedFalse describe "2-of-3" $ do - let val = multisigValidator dummyProtocolMagic 2 (map addressHash [pk1, pk2, pk3]) + let val = multisigValidator overriddenPM 2 (map addressHash [pk1, pk2, pk3]) it "good (2 provided)" $ do txShouldSucceed $ checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd [ Just $ fakeSigner sk1 , Nothing , Just $ fakeSigner sk3])) it "good (3 provided)" $ do txShouldSucceed $ checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd [ Just $ fakeSigner sk1 , Just $ fakeSigner sk2 , Just $ fakeSigner sk3])) it "good (3 provided, 1 wrong)" $ do txShouldSucceed $ checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd [Just $ fakeSigner sk1, Just $ fakeSigner sk4, Just $ fakeSigner sk3])) it "bad (1 provided)" $ do let res = checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd [Just $ fakeSigner sk1, Nothing, Nothing])) res `txShouldFailWithPlutus` PlutusReturnedFalse it "bad (2 provided, length doesn't match)" $ do let res = checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd [Just $ fakeSigner sk1, Just $ fakeSigner sk2])) res `txShouldFailWithPlutus` PlutusReturnedFalse it "bad (3 provided, 2 wrong)" $ do let res = checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd [Just $ fakeSigner sk1, Just $ fakeSigner sk3, Just $ fakeSigner sk2])) res `txShouldFailWithPlutus` PlutusReturnedFalse describe "execution limits" $ do it "5-of-5 multisig is okay" $ do - let val = multisigValidator dummyProtocolMagic 5 (replicate 5 (addressHash pk1)) + let val = multisigValidator overriddenPM 5 (replicate 5 (addressHash pk1)) txShouldSucceed $ checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd (replicate 5 (Just $ fakeSigner sk1)))) it "10-of-10 multisig is bad" $ do - let val = multisigValidator dummyProtocolMagic 10 (replicate 10 (addressHash pk1)) + let val = multisigValidator overriddenPM 10 (replicate 10 (addressHash pk1)) let res = checkScriptTx val (\sd -> ScriptWitness val - (multisigRedeemer dummyProtocolMagic sd + (multisigRedeemer overriddenPM sd (replicate 10 (Just $ fakeSigner sk1)))) res `txShouldFailWithPlutus` PlutusExecutionFailure "Out of petrol." @@ -411,18 +460,24 @@ scriptTxSpec = describe "script transactions" $ do "Out of petrol." it "100 rounds of sigverify is okay" $ do txShouldSucceed $ checkScriptTx idValidator - (\_ -> ScriptWitness idValidator (sigStressRedeemer dummyProtocolMagic 100)) + (\_ -> ScriptWitness idValidator (sigStressRedeemer overriddenPM 100)) it "200 rounds of sigverify is bad" $ do let res = checkScriptTx idValidator - (\_ -> ScriptWitness idValidator (sigStressRedeemer dummyProtocolMagic 200)) + (\_ -> ScriptWitness idValidator (sigStressRedeemer overriddenPM 200)) res `txShouldFailWithPlutus` PlutusExecutionFailure "Out of petrol." where + -- Ensure that `ProtocolMagic` only contains `RequiresNoMagic` + -- until we fully implement logic for `NetworkMagic`. + overriddenPM :: ProtocolMagic + overriddenPM = overridePM pm + + nm = makeNetworkMagic overriddenPM -- Some random stuff we're going to use when building transactions randomPkOutput = runGen $ do key <- arbitrary - return (TxOut (makePubKeyAddressBoot fixedNM key) (mkCoin 1)) + return (TxOut (makePubKeyAddressBoot nm key) (mkCoin 1)) -- Make utxo with a single output; return utxo, the output, and an -- input that can be used to spend that output mkUtxo :: TxOut -> (TxIn, TxOut, Utxo) @@ -431,14 +486,14 @@ scriptTxSpec = describe "script transactions" $ do in (TxInUtxo txid 0, outp, one ((TxInUtxo txid 0), (TxOutAux outp))) -- Do not verify versions - vtxContext = VTxContext False fixedNM + vtxContext = VTxContext False nm -- Try to apply a transaction (with given utxo as context) and say -- whether it applied successfully tryApplyTx :: Utxo -> TxAux -> Either ToilVerFailure () tryApplyTx utxo txa = evalUtxoM mempty (utxoToLookup utxo) . runExceptT $ - () <$ verifyTxUtxo dummyProtocolMagic vtxContext mempty txa + () <$ verifyTxUtxo overriddenPM vtxContext mempty txa -- Test tx1 against tx0. Tx0 will be a script transaction with given -- validator. Tx1 will be a P2PK transaction spending tx0 (with given @@ -448,7 +503,7 @@ scriptTxSpec = describe "script transactions" $ do -> Either ToilVerFailure () checkScriptTx val mkWit = let (inp, _, utxo) = mkUtxo $ - TxOut (makeScriptAddress fixedNM Nothing val) (mkCoin 1) + TxOut (makeScriptAddress nm Nothing val) (mkCoin 1) tx = UnsafeTx (one inp) (one randomPkOutput) $ mkAttributes () txSigData = TxSigData { txSigTxHash = hash tx } txAux = TxAux tx (one (mkWit txSigData)) @@ -483,6 +538,8 @@ txShouldFailWithPlutus res err = case res of "expected: Left ...: " <> show (WitnessScriptError err) <> "\n" <> " but got: " <> show other - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage +-- | Override a provided `ProtocolMagic` such that the value of its +-- `getRequiresNetworkMagic` field is always `RequiresNoMagic`. This will be +-- removed when we fully implement logic for `NetworkMagic`. +overridePM :: ProtocolMagic -> ProtocolMagic +overridePM pm = pm { getRequiresNetworkMagic = RequiresNoMagic } diff --git a/client/src/Pos/Client/Txp/Util.hs b/client/src/Pos/Client/Txp/Util.hs index 12a6818a6d7..b64f77e8ea0 100644 --- a/client/src/Pos/Client/Txp/Util.hs +++ b/client/src/Pos/Client/Txp/Util.hs @@ -79,7 +79,7 @@ import Pos.Core (Address, Coin, SlotCount, StakeholderId, isRedeemAddress, mkCoin, sumCoins, txSizeLinearMinValue, unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Attributes (mkAttributes) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (NetworkMagic, makeNetworkMagic) import Pos.Crypto (ProtocolMagic, RedeemSecretKey, SafeSigner, SignTag (SignRedeemTx, SignTx), deterministicKeyGen, fakeSigner, hash, redeemSign, redeemToPublic, safeSign, @@ -563,8 +563,9 @@ prepareInpsOuts -> TxCreator m (TxOwnedInputs TxOut, TxOutputs) prepareInpsOuts genesisConfig pendingTx utxo outputs addrData = do txRaw@TxRaw {..} <- prepareTxWithFee genesisConfig pendingTx utxo outputs + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig outputsWithRem <- - mkOutputsWithRem fixedNM (configEpochSlots genesisConfig) addrData txRaw + mkOutputsWithRem nm (configEpochSlots genesisConfig) addrData txRaw pure (trInputs, outputsWithRem) prepareInpsOutsForUnsignedTx @@ -826,13 +827,14 @@ stabilizeTxFee genesisConfig pendingTx linearPolicy utxo outputs = do stabilizeTxFeeDo (_, 0) _ = pure Nothing stabilizeTxFeeDo (isSecondStage, attempt) expectedFee = do txRaw <- prepareTxRaw pendingTx utxo outputs expectedFee - fakeChangeAddr <- lift . lift $ getFakeChangeAddress fixedNM $ configEpochSlots + let pm = configProtocolMagic genesisConfig + nm = makeNetworkMagic pm + fakeChangeAddr <- lift . lift $ getFakeChangeAddress nm $ configEpochSlots genesisConfig txMinFee <- txToLinearFee linearPolicy $ createFakeTxFromRawTx - (configProtocolMagic genesisConfig) + pm fakeChangeAddr txRaw - let txRawWithFee = S.Min $ S.Arg expectedFee txRaw let iterateDo step = stabilizeTxFeeDo step txMinFee case expectedFee `compare` txMinFee of @@ -874,7 +876,3 @@ createFakeTxFromRawTx pm fakeAddr TxRaw{..} = (\_ -> Right $ fakeSigner fakeSK) trInputs txOutsWithRem - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/client/test/Test/Pos/Client/Txp/UtilSpec.hs b/client/test/Test/Pos/Client/Txp/UtilSpec.hs index 7f95efa21c7..d6c80336cce 100644 --- a/client/test/Test/Pos/Client/Txp/UtilSpec.hs +++ b/client/test/Test/Pos/Client/Txp/UtilSpec.hs @@ -31,18 +31,17 @@ import Pos.Client.Txp.Util (InputSelectionPolicy (..), TxError (..), import Pos.Core (Address, Coeff (..), TxFeePolicy (..), TxSizeLinear (..), makePubKeyAddressBoot, makeRedeemAddress, unsafeIntegerToCoin) -import Pos.Core.NetworkMagic (NetworkMagic (..)) -import Pos.Crypto (RedeemSecretKey, SafeSigner, SecretKey, decodeHash, - fakeSigner, redeemToPublic, toPublic) +import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) +import Pos.Crypto (ProtocolMagic (..), RedeemSecretKey, SafeSigner, + SecretKey, decodeHash, fakeSigner, redeemToPublic, + toPublic) import Pos.DB (gsAdoptedBVData) import Pos.Util.Util (leftToPanic) -import Test.Pos.Chain.Genesis.Dummy (dummyConfig) import Test.Pos.Client.Txp.Mode (TxpTestMode, TxpTestProperty, withBVData) -import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Crypto.Arbitrary () -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Util.QuickCheck.Arbitrary (nonrepeating) import Test.Pos.Util.QuickCheck.Property (stopProperty) @@ -51,7 +50,7 @@ import Test.Pos.Util.QuickCheck.Property (stopProperty) ---------------------------------------------------------------------------- spec :: Spec -spec = withDefConfigurations $ \_ _ _ -> +spec = describe "Client.Txp.Util" $ do describe "createMTx" $ createMTxSpec @@ -118,8 +117,9 @@ testCreateMTx :: CreateMTxParams -> TxpTestProperty (Either TxError (TxAux, NonEmpty TxOut)) testCreateMTx CreateMTxParams {..} = lift $ - createMTx dummyConfig mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) - cmpOutputs cmpAddrData + withProvidedMagicConfig cmpProtocolMagic $ \genesisConfig _ _ -> + createMTx genesisConfig mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) + cmpOutputs cmpAddrData createMTxWorksWhenWeAreRichSpec :: InputSelectionPolicy @@ -200,7 +200,7 @@ manyAddressesToManySpec inputSelectionPolicy = do redemptionSpec :: TxpTestProperty () redemptionSpec = do forAllM genParams $ \(CreateRedemptionTxParams {..}) -> do - txOrError <- createRedemptionTx dummyProtocolMagic crpUtxo crpRsk crpOutputs + txOrError <- createRedemptionTx crpProtocolMagic crpUtxo crpRsk crpOutputs case txOrError of Left err -> stopProperty $ pretty err Right _ -> return () @@ -208,9 +208,11 @@ redemptionSpec = do genParams = do crpRsk <- arbitrary skTo <- arbitrary + crpProtocolMagic <- arbitrary - let txOutAuxInput = generateRedeemTxOutAux 1 crpRsk - txOutAuxOutput = generateTxOutAux 1 skTo + let nm = makeNetworkMagic crpProtocolMagic + txOutAuxInput = generateRedeemTxOutAux nm 1 crpRsk + txOutAuxOutput = generateTxOutAux nm 1 skTo crpUtxo = one (TxInUtxo (unsafeIntegerToTxId 0) 0, txOutAuxInput) crpOutputs = one txOutAuxOutput @@ -220,20 +222,22 @@ txWithRedeemOutputFailsSpec :: InputSelectionPolicy -> TxpTestProperty () txWithRedeemOutputFailsSpec inputSelectionPolicy = do - forAllM genParams $ \(CreateMTxParams {..}) -> do - txOrError <- - createMTx dummyConfig mempty cmpInputSelectionPolicy cmpUtxo - (getSignerFromList cmpSigners) - cmpOutputs cmpAddrData - case txOrError of - Left (OutputIsRedeem _) -> return () - Left err -> stopProperty $ pretty err - Right _ -> stopProperty $ - sformat ("Transaction to a redeem address was created") + forAllM genParams $ \(CreateMTxParams {..}) -> + withProvidedMagicConfig cmpProtocolMagic $ \genesisConfig _ _ -> do + txOrError <- + createMTx genesisConfig mempty cmpInputSelectionPolicy cmpUtxo + (getSignerFromList cmpSigners) + cmpOutputs cmpAddrData + case txOrError of + Left (OutputIsRedeem _) -> return () + Left err -> stopProperty $ pretty err + Right _ -> stopProperty $ + sformat ("Transaction to a redeem address was created") where genParams = do - txOutAuxOutput <- generateRedeemTxOutAux 1 <$> arbitrary params <- makeManyAddressesToManyParams inputSelectionPolicy 1 1000000 1 1 + let nm = makeNetworkMagic (cmpProtocolMagic params) + txOutAuxOutput <- generateRedeemTxOutAux nm 1 <$> arbitrary pure params{ cmpOutputs = one txOutAuxOutput } feeForManyAddressesSpec @@ -320,14 +324,16 @@ data CreateMTxParams = CreateMTxParams , cmpAddrData :: !(AddrData TxpTestMode) -- ^ Data that is normally used for creation of change addresses. -- In tests, it is always `()`. + , cmpProtocolMagic :: !ProtocolMagic } deriving Show -- | Container for parameters of `createRedemptionTx`. -- The parameters mirror those of `createMTx` almost perfectly. data CreateRedemptionTxParams = CreateRedemptionTxParams - { crpUtxo :: !Utxo - , crpRsk :: !RedeemSecretKey - , crpOutputs :: !TxOutputs + { crpUtxo :: !Utxo + , crpRsk :: !RedeemSecretKey + , crpOutputs :: !TxOutputs + , crpProtocolMagic :: !ProtocolMagic } deriving Show getSignerFromList :: NonEmpty (SafeSigner, Address) -> Address -> Maybe SafeSigner @@ -337,13 +343,15 @@ getSignerFromList (HM.fromList . map swap . toList -> hm) = makeManyUtxoTo1Params :: InputSelectionPolicy -> Int -> Integer -> Integer -> Gen CreateMTxParams makeManyUtxoTo1Params inputSelectionPolicy numFrom amountEachFrom amountTo = do ~[skFrom, skTo] <- nonrepeating 2 - let txOutAuxInput = generateTxOutAux amountEachFrom skFrom - txOutAuxOutput = generateTxOutAux amountTo skTo + cmpProtocolMagic <- arbitrary + let nm = makeNetworkMagic cmpProtocolMagic + let txOutAuxInput = generateTxOutAux nm amountEachFrom skFrom + txOutAuxOutput = generateTxOutAux nm amountTo skTo cmpInputSelectionPolicy = inputSelectionPolicy cmpUtxo = M.fromList [(TxInUtxo (unsafeIntegerToTxId 0) (fromIntegral k), txOutAuxInput) | k <- [0..numFrom-1]] - cmpSigners = one $ makeSigner skFrom + cmpSigners = one $ makeSigner nm skFrom cmpOutputs = one txOutAuxOutput cmpAddrData = () @@ -358,12 +366,14 @@ makeManyAddressesToManyParams -> Gen CreateMTxParams makeManyAddressesToManyParams inputSelectionPolicy numFrom amountEachFrom numTo amountEachTo = do sks <- nonrepeating (numFrom + numTo) + cmpProtocolMagic <- arbitrary + let nm = makeNetworkMagic cmpProtocolMagic let (sksFrom, sksTo) = splitAt numFrom sks - cmpSignersList = map makeSigner sksFrom + cmpSignersList = map (makeSigner nm) sksFrom cmpSigners = NE.fromList cmpSignersList - txOutAuxInputs = map (generateTxOutAux amountEachFrom) sksFrom - txOutAuxOutputs = map (generateTxOutAux amountEachTo) sksTo + txOutAuxInputs = map (generateTxOutAux nm amountEachFrom) sksFrom + txOutAuxOutputs = map (generateTxOutAux nm amountEachTo) sksTo cmpInputSelectionPolicy = inputSelectionPolicy cmpUtxo = M.fromList [(TxInUtxo (unsafeIntegerToTxId $ fromIntegral k) 0, txOutAux) | @@ -401,19 +411,19 @@ makeTxOutAux amount addr = txOut = TxOut addr coin in TxOutAux txOut -generateTxOutAux :: Integer -> SecretKey -> TxOutAux -generateTxOutAux amount sk = - makeTxOutAux amount (secretKeyToAddress sk) +generateTxOutAux :: NetworkMagic -> Integer -> SecretKey -> TxOutAux +generateTxOutAux nm amount sk = + makeTxOutAux amount (secretKeyToAddress nm sk) -generateRedeemTxOutAux :: Integer -> RedeemSecretKey -> TxOutAux -generateRedeemTxOutAux amount rsk = - makeTxOutAux amount (makeRedeemAddress fixedNM $ redeemToPublic rsk) +generateRedeemTxOutAux :: NetworkMagic -> Integer -> RedeemSecretKey -> TxOutAux +generateRedeemTxOutAux nm amount rsk = + makeTxOutAux amount (makeRedeemAddress nm $ redeemToPublic rsk) -secretKeyToAddress :: SecretKey -> Address -secretKeyToAddress = makePubKeyAddressBoot fixedNM . toPublic +secretKeyToAddress :: NetworkMagic -> SecretKey -> Address +secretKeyToAddress nm = makePubKeyAddressBoot nm . toPublic -makeSigner :: SecretKey -> (SafeSigner, Address) -makeSigner sk = (fakeSigner sk, secretKeyToAddress sk) +makeSigner :: NetworkMagic -> SecretKey -> (SafeSigner, Address) +makeSigner nm sk = (fakeSigner sk, secretKeyToAddress nm sk) withTxFeePolicy :: Coeff -> Coeff -> TxpTestProperty () -> TxpTestProperty () @@ -421,7 +431,3 @@ withTxFeePolicy a b action = do let policy = TxFeePolicyTxSizeLinear $ TxSizeLinear a b bvd <- gsAdoptedBVData withBVData bvd{ bvdTxFeePolicy = policy } action - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/core/src/Pos/Core/NetworkMagic.hs b/core/src/Pos/Core/NetworkMagic.hs index b470ec95f84..bce3923f7a7 100644 --- a/core/src/Pos/Core/NetworkMagic.hs +++ b/core/src/Pos/Core/NetworkMagic.hs @@ -44,4 +44,4 @@ instance SafeCopy NetworkMagic where makeNetworkMagic :: ProtocolMagic -> NetworkMagic makeNetworkMagic pm = case getRequiresNetworkMagic pm of RequiresNoMagic -> NetworkMainOrStage - RequiresMagic -> NetworkTestnet (fromIntegral (getProtocolMagic pm)) + RequiresMagic -> NetworkTestnet (getProtocolMagic pm) diff --git a/core/test/Test/Pos/Core/AddressSpec.hs b/core/test/Test/Pos/Core/AddressSpec.hs index 8f83778e1c1..5cbab678cdc 100644 --- a/core/test/Test/Pos/Core/AddressSpec.hs +++ b/core/test/Test/Pos/Core/AddressSpec.hs @@ -9,40 +9,57 @@ import Universum import qualified Data.ByteString as BS import Formatting (formatToString, int, (%)) import Serokell.Data.Memory.Units (Byte, memory) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec (Spec, describe, it, runIO, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck (Gen, arbitrary, counterexample, forAll, - frequency, vectorOf) + frequency, generate, vectorOf) import Pos.Binary.Class (biSize) import Pos.Core (Address, IsBootstrapEraAddr (..), deriveLvl2KeyPair, largestHDAddressBoot, largestPubKeyAddressBoot, largestPubKeyAddressSingleKey, makePubKeyAddress, makePubKeyAddressBoot, makePubKeyHdwAddress) -import Pos.Core.NetworkMagic (NetworkMagic (..)) -import Pos.Crypto (EncryptedSecretKey, PassPhrase, PublicKey, - SecretKey (..), ShouldCheckPassphrase (..), - deterministicKeyGen, emptyPassphrase, mkEncSecretUnsafe, - noPassEncrypt, toPublic) +import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) +import Pos.Crypto (EncryptedSecretKey, PassPhrase, ProtocolMagic (..), + PublicKey, RequiresNetworkMagic (..), SecretKey (..), + ShouldCheckPassphrase (..), deterministicKeyGen, + emptyPassphrase, mkEncSecretUnsafe, noPassEncrypt, + toPublic) import Pos.Crypto.HD (HDAddressPayload (..)) import Test.Pos.Core.Arbitrary () spec :: Spec -spec = describe "Address" $ do +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +-- An attempt to avoid rightward creep +specBody :: ProtocolMagic -> Spec +specBody pm = do + let nm = makeNetworkMagic pm + modifyMaxSuccess (min 10) $ do prop "PK and HDW addresses with same public key are shown differently" - pkAndHdwAreShownDifferently + (pkAndHdwAreShownDifferently nm) describe "Largest addresses" $ do - let genPubKeyAddrBoot = pure . makePubKeyAddressBoot fixedNM . toPublic + let genPubKeyAddrBoot = pure . makePubKeyAddressBoot nm . toPublic + pubKeyAddrBootSize = 43 + networkMagicExtraBytes pm largestAddressProp "PubKey address with BootstrapEra distribution" - genPubKeyAddrBoot (largestPubKeyAddressBoot fixedNM) 43 + genPubKeyAddrBoot (largestPubKeyAddressBoot nm) pubKeyAddrBootSize - let genPubKeyAddrSingleKey = pure . makePubKeyAddress fixedNM + let genPubKeyAddrSingleKey = pure . makePubKeyAddress nm (IsBootstrapEraAddr False) . toPublic + pubKeyAddrSingleKeySize = 78 + networkMagicExtraBytes pm largestAddressProp "PubKey address with SingleKey distribution" - genPubKeyAddrSingleKey (largestPubKeyAddressSingleKey fixedNM) 78 + genPubKeyAddrSingleKey (largestPubKeyAddressSingleKey nm) pubKeyAddrSingleKeySize let genHDAddrBoot :: SecretKey -> Gen Address genHDAddrBoot sk = frequency @@ -53,7 +70,7 @@ spec = describe "Address" $ do genHDAddrBoot' :: PassPhrase -> EncryptedSecretKey -> Word32 -> Word32 -> Address genHDAddrBoot' passphrase esk accIdx addrIdx = case deriveLvl2KeyPair - fixedNM + nm (IsBootstrapEraAddr True) (ShouldCheckPassphrase False) passphrase @@ -72,13 +89,22 @@ spec = describe "Address" $ do esk <- mkEncSecretUnsafe passphrase sk genHDAddrBoot' passphrase esk <$> arbitrary <*> arbitrary + let hdAddrBootSize = 76 + networkMagicExtraBytes pm largestAddressProp "HD address with BootstrapEra distribution" - genHDAddrBoot (largestHDAddressBoot fixedNM) 76 - -pkAndHdwAreShownDifferently :: Bool -> PublicKey -> Bool -pkAndHdwAreShownDifferently isBootstrap pk = - show (makePubKeyAddress fixedNM (IsBootstrapEraAddr isBootstrap) pk) /= - (show @Text (makePubKeyHdwAddress fixedNM (IsBootstrapEraAddr isBootstrap) + genHDAddrBoot (largestHDAddressBoot nm) hdAddrBootSize + +networkMagicExtraBytes :: ProtocolMagic -> Byte +networkMagicExtraBytes pm = case makeNetworkMagic pm of + NetworkMainOrStage -> 0 + -- Encoding size: + -- Map key: 2 bytes (1 for header, 1 for Word8) + -- Map val: 1-5 bytes (1 for header, 0-4 for Int32) + NetworkTestnet v -> 2 + biSize v + +pkAndHdwAreShownDifferently :: NetworkMagic -> Bool -> PublicKey -> Bool +pkAndHdwAreShownDifferently nm isBootstrap pk = + show (makePubKeyAddress nm (IsBootstrapEraAddr isBootstrap) pk) /= + (show @Text (makePubKeyHdwAddress nm (IsBootstrapEraAddr isBootstrap) (HDAddressPayload "pataq") pk)) largestAddressProp :: Text -> (SecretKey -> Gen Address) -> Address -> Byte -> Spec @@ -95,6 +121,3 @@ largestAddressProp addressDescription genAddress largestAddress expectedLargestS in counterexample (formatToString (int % " > " %int) generatedSize expectedLargestSize) (generatedSize <= expectedLargestSize) - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/core/test/Test/Pos/Core/Arbitrary/Txp.hs b/core/test/Test/Pos/Core/Arbitrary/Txp.hs index 13a0c478945..8e51952445c 100644 --- a/core/test/Test/Pos/Core/Arbitrary/Txp.hs +++ b/core/test/Test/Pos/Core/Arbitrary/Txp.hs @@ -18,6 +18,7 @@ module Test.Pos.Chain.Txp.Arbitrary , genTxInWitness , genTxOutDist , genTxPayload + , genGoodTxWithMagic ) where import Universum @@ -39,7 +40,7 @@ import Pos.Core.Attributes (mkAttributes) import Pos.Core.Common (Coin, IsBootstrapEraAddr (..), makePubKeyAddress) import Pos.Core.Merkle (MerkleNode (..), MerkleRoot (..)) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Crypto (Hash, ProtocolMagic, SecretKey, SignTag (SignTx), hash, sign, toPublic) @@ -151,8 +152,9 @@ buildProperTx pm inputList (inCoin, outCoin) = outs = fmap (view _4) txList mkWitness fromSk = PkWitness (toPublic fromSk) (sign pm SignTx fromSk $ TxSigData newTxHash) + nm = makeNetworkMagic pm makeTxOutput s c = - TxOut (makePubKeyAddress fixedNM (IsBootstrapEraAddr True) $ toPublic s) c + TxOut (makePubKeyAddress nm (IsBootstrapEraAddr True) $ toPublic s) c -- | Well-formed transaction 'Tx'. -- @@ -161,6 +163,12 @@ newtype GoodTx = GoodTx { getGoodTx :: NonEmpty (Tx, TxIn, TxOutAux, TxInWitness) } deriving (Generic, Show) +genGoodTxWithMagic :: ProtocolMagic -> Gen GoodTx +genGoodTxWithMagic pm = + GoodTx <$> (buildProperTx pm + <$> arbitrary + <*> pure (identity, identity)) + goodTxToTxAux :: GoodTx -> TxAux goodTxToTxAux (GoodTx l) = TxAux tx witness where @@ -238,7 +246,3 @@ genTxPayload pm = mkTxPayload <$> genTxOutDist pm instance Arbitrary TxPayload where arbitrary = genTxPayload dummyProtocolMagic shrink = genericShrink - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/explorer/src/Pos/Explorer/TestUtil.hs b/explorer/src/Pos/Explorer/TestUtil.hs index 445bb857ea0..82ce0eb3d38 100644 --- a/explorer/src/Pos/Explorer/TestUtil.hs +++ b/explorer/src/Pos/Explorer/TestUtil.hs @@ -399,9 +399,5 @@ produceSecretKeys blocksNumber = liftIO $ secretKeys -- | Factory to create an `Address` -- | Friendly borrowed from `Test.Pos.Client.Txp.UtilSpec` -- | TODO: Remove it as soon as ^ is exposed -secretKeyToAddress :: SecretKey -> Address -secretKeyToAddress = makePubKeyAddressBoot fixedNM . toPublic - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage +secretKeyToAddress :: NetworkMagic -> SecretKey -> Address +secretKeyToAddress nm = makePubKeyAddressBoot nm . toPublic diff --git a/explorer/src/Pos/Explorer/Web/ClientTypes.hs b/explorer/src/Pos/Explorer/Web/ClientTypes.hs index bba9e19bbdf..9215402870a 100644 --- a/explorer/src/Pos/Explorer/Web/ClientTypes.hs +++ b/explorer/src/Pos/Explorer/Web/ClientTypes.hs @@ -461,4 +461,4 @@ instance Show CByteString where -------------------------------------------------------------------------------- instance Arbitrary CAddress where - arbitrary = toCAddress . secretKeyToAddress <$> arbitrary + arbitrary = toCAddress <$> (secretKeyToAddress <$> arbitrary <*> arbitrary) diff --git a/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs b/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs index 80b7e0cdca9..398b8be462f 100644 --- a/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs +++ b/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs @@ -2,6 +2,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Test.Pos.Explorer.Socket.MethodsSpec ( spec ) where @@ -21,6 +23,7 @@ import Test.Hspec.QuickCheck (modifyMaxSize, prop) import Test.QuickCheck (Property, arbitrary, forAll) import Test.QuickCheck.Monadic (assert, monadicIO, run) +import Pos.Core.NetworkMagic (NetworkMagic) import Pos.Crypto (SecretKey) import Pos.Explorer.ExplorerMode (runSubTestMode) import Pos.Explorer.Socket.Holder (ConnectionsState, @@ -49,7 +52,7 @@ import Test.Pos.Explorer.MockFactory (mkTxOut) -- stack test cardano-sl-explorer --fast --test-arguments "-m Test.Pos.Explorer.Socket" spec :: Spec -spec = beforeAll_ setupTestLogging $ +spec = beforeAll_ setupTestLogging $ do describe "Methods" $ do describe "fromCAddressOrThrow" $ it "throws an exception if a given CAddress is invalid" $ @@ -111,11 +114,11 @@ spec = beforeAll_ setupTestLogging $ unsubscribeFullyProp -addressSetByTxsProp :: SecretKey -> Bool -addressSetByTxsProp key = +addressSetByTxsProp :: NetworkMagic -> SecretKey -> Bool +addressSetByTxsProp nm key = let - addrA = secretKeyToAddress key - addrB = secretKeyToAddress key + addrA = secretKeyToAddress nm key + addrB = secretKeyToAddress nm key txA = mkTxOut 2 addrA txB = mkTxOut 3 addrA txC = mkTxOut 4 addrB diff --git a/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs b/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs index 3eb62ce764e..bfdfb77ea45 100644 --- a/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs +++ b/explorer/test/Test/Pos/Explorer/Web/ServerSpec.hs @@ -29,8 +29,8 @@ import Pos.Launcher.Configuration (HasConfigurations) import Pos.Util (divRoundUp) import Test.Pos.Chain.Block.Arbitrary () -import Test.Pos.Chain.Genesis.Dummy (dummyConfig, dummyEpochSlots) -import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Configuration (withDefConfigurations, + withProvidedMagicConfig) ---------------------------------------------------------------- @@ -173,7 +173,7 @@ blocksPageUnitSpec = describe "getBlocksPage" $ modifyMaxSuccess (const 200) $ do prop "block pages total correct && last page non-empty" $ - forAll arbitrary $ \(testParams) -> + forAll arbitrary $ \epochSlots testParams -> forAll generateValidBlocksSlotsNumber $ \(totalBlocksNumber, slotsPerEpoch) -> monadicIO $ do @@ -191,7 +191,7 @@ blocksPageUnitSpec = let blockExecution :: IO (Integer, [CBlockEntry]) blockExecution = runExplorerTestMode testParams extraContext - $ getBlocksPage dummyEpochSlots Nothing (Just 10) + $ getBlocksPage epochSlots Nothing (Just 10) -- We finally run it as @PropertyM@ and check if it holds. pagesTotal <- fst <$> run blockExecution @@ -217,7 +217,7 @@ blocksLastPageUnitSpec = describe "getBlocksLastPage" $ modifyMaxSuccess (const 200) $ do prop "getBlocksLastPage == getBlocksPage Nothing" $ - forAll arbitrary $ \(testParams) -> + forAll arbitrary $ \epochSlots testParams -> forAll generateValidBlocksSlotsNumber $ \(totalBlocksNumber, slotsPerEpoch) -> monadicIO $ do @@ -233,7 +233,7 @@ blocksLastPageUnitSpec = -- a million instances. let blocksLastPageM :: IO (Integer, [CBlockEntry]) blocksLastPageM = - runExplorerTestMode testParams extraContext (getBlocksLastPage dummyEpochSlots) + runExplorerTestMode testParams extraContext (getBlocksLastPage epochSlots) -- We run the function in @BlockTestMode@ so we don't need to define -- a million instances. @@ -241,7 +241,7 @@ blocksLastPageUnitSpec = let blocksPageM :: IO (Integer, [CBlockEntry]) blocksPageM = runExplorerTestMode testParams extraContext - $ getBlocksPage dummyEpochSlots Nothing (Just 10) + $ getBlocksPage epochSlots Nothing (Just 10) -- We finally run it as @PropertyM@ and check if it holds. blocksLastPage <- run blocksLastPageM @@ -256,7 +256,7 @@ epochSlotUnitSpec = do describe "getEpochSlot" $ modifyMaxSuccess (const 200) $ do prop "getEpochSlot(valid epoch) != empty" $ - forAll arbitrary $ \(testParams) -> + forAll arbitrary $ \epochSlots testParams -> forAll generateValidBlocksSlotsNumber $ \(totalBlocksNumber, slotsPerEpoch) -> monadicIO $ do @@ -277,7 +277,7 @@ epochSlotUnitSpec = do epochSlotM = runExplorerTestMode testParams extraContext $ getEpochSlot - dummyEpochSlots + epochSlots (EpochIndex 0) 1 @@ -295,7 +295,7 @@ epochPageUnitSpec = do describe "getEpochPage" $ modifyMaxSuccess (const 200) $ do prop "getEpochPage(valid epoch) != empty" $ - forAll arbitrary $ \(testParams) -> + forAll arbitrary $ \epochSlots testParams -> forAll generateValidBlocksSlotsNumber $ \(totalBlocksNumber, slotsPerEpoch) -> monadicIO $ do @@ -315,7 +315,7 @@ epochPageUnitSpec = do epochPageM = runExplorerTestMode testParams extraContext $ getEpochPage - dummyEpochSlots + epochSlots (EpochIndex 0) Nothing @@ -336,12 +336,13 @@ blocksTotalFunctionalSpec = describe "getBlocksTotalFunctional" $ modifyMaxSuccess (const 200) $ do prop "created blocks means block size >= 0" $ - forAll arbitrary $ \testParams -> + forAll arbitrary $ \pm testParams -> + withProvidedMagicConfig pm $ \genesisConfig _ _ -> monadicIO $ do -- The extra context so we can mock the functions. let extraContext :: ExtraContext - extraContext = makeExtraCtx dummyConfig + extraContext = makeExtraCtx genesisConfig -- We run the function in @ExplorerTestMode@ so we don't need to define -- a million instances. diff --git a/generator/app/VerificationBench.hs b/generator/app/VerificationBench.hs index a1e844e2fc8..1e23d3818c6 100644 --- a/generator/app/VerificationBench.hs +++ b/generator/app/VerificationBench.hs @@ -28,6 +28,7 @@ import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Core (ProtocolConstants (..)) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Core.Slotting (Timestamp (..)) import Pos.Crypto (SecretKey) import Pos.DB.Block (rollbackBlocks, verifyAndApplyBlocks, @@ -78,9 +79,10 @@ generateBlocks :: HasConfigurations -> BlockTestMode (OldestFirst NE Block) generateBlocks genesisConfig secretKeys txpConfig bCount = do g <- liftIO $ newStdGen + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig bs <- flip evalRandT g $ genBlocks genesisConfig txpConfig (BlockGenParams - { _bgpSecrets = mkAllSecretsSimple secretKeys + { _bgpSecrets = mkAllSecretsSimple nm secretKeys , _bgpBlockCount = bCount , _bgpTxGenParams = TxGenParams { _tgpTxCountRange = (0, 2) @@ -208,6 +210,7 @@ main = do , _tpBlockVersionData = configBlockVersionData genesisConfig' , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = TxpConfiguration 200 Set.empty + , _tpProtocolMagic = configProtocolMagic genesisConfig } secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow genesisConfig' runBlockTestMode genesisConfig' tp $ do diff --git a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs index 12d1dfa42c4..d6f8bb88af0 100644 --- a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs +++ b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs @@ -25,6 +25,7 @@ import Pos.Chain.Genesis as Genesis (Config (..), import Pos.Chain.Update (BlockVersionData (..)) import Pos.Core.Chrono (NE, OldestFirst (..), nonEmptyNewestFirst) import Pos.Core.Common (BlockCount (..), unsafeCoinPortionFromDouble) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Core.Slotting (EpochOrSlot (..), SlotId, Timestamp (..), epochIndexL, getEpochOrSlot) import Pos.Crypto (SecretKey) @@ -101,13 +102,14 @@ verifyBlocksBenchmark !genesisConfig !secretKeys !tp !ctx = $ \ ~(curSlot, blocks) -> bench "verifyBlocksPrefix" (verifyBlocksPrefixB curSlot blocks) ] where + nm = makeNetworkMagic $ configProtocolMagic genesisConfig genEnv :: BlockCount -> BlockTestMode (Maybe SlotId, OldestFirst NE Block) genEnv bCount = do initNodeDBs genesisConfig g <- liftIO $ newStdGen bs <- flip evalRandT g $ genBlocks genesisConfig (_tpTxpConfiguration tp) (BlockGenParams - { _bgpSecrets = mkAllSecretsSimple secretKeys + { _bgpSecrets = mkAllSecretsSimple nm secretKeys , _bgpBlockCount = bCount , _bgpTxGenParams = TxGenParams { _tgpTxCountRange = (0, 2) @@ -169,6 +171,7 @@ verifyHeaderBenchmark !genesisConfig !secretKeys !tp = env (runBlockTestMode gen where pm = configProtocolMagic genesisConfig + nm = makeNetworkMagic pm genEnv :: BlockTestMode (Block, VerifyBlockParams) genEnv = do initNodeDBs genesisConfig @@ -176,7 +179,7 @@ verifyHeaderBenchmark !genesisConfig !secretKeys !tp = env (runBlockTestMode gen eos <- getEpochOrSlot <$> getTipHeader let epoch = eos ^. epochIndexL let blockGenParams = BlockGenParams - { _bgpSecrets = mkAllSecretsSimple secretKeys + { _bgpSecrets = mkAllSecretsSimple nm secretKeys , _bgpBlockCount = BlockCount 1 , _bgpTxGenParams = TxGenParams { _tgpTxCountRange = (0, 2) @@ -238,6 +241,7 @@ runBenchmark = do , _tpBlockVersionData = configBlockVersionData genesisConfig , _tpGenesisInitializer = genesisInitializer , _tpTxpConfiguration = txpConfig + , _tpProtocolMagic = configProtocolMagic genesisConfig } secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow genesisConfig runEmulation startTime diff --git a/generator/src/Pos/Generator/Block/Payload.hs b/generator/src/Pos/Generator/Block/Payload.hs index 1210079917d..80d6359c297 100644 --- a/generator/src/Pos/Generator/Block/Payload.hs +++ b/generator/src/Pos/Generator/Block/Payload.hs @@ -34,7 +34,7 @@ import Pos.Client.Txp.Util (InputSelectionPolicy (..), TxError (..), import Pos.Core (AddrSpendingData (..), Address (..), Coin, SlotId (..), addressHash, coinToInteger, makePubKeyAddressBoot, unsafeIntegerToCoin) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Crypto (SecretKey, WithHash (..), fakeSigner, hash, toPublic) import Pos.DB.Txp (MonadTxpLocal (..), getAllPotentiallyHugeUtxo) @@ -141,14 +141,13 @@ genTxPayload genesisConfig txpConfig = do txsN <- fromIntegral <$> getRandomR (a, a + d) replicateM_ txsN genTransaction where - nm = fixedNM + nm = makeNetworkMagic $ configProtocolMagic genesisConfig genTransaction :: StateT GenTxData (BlockGenRandMode ext g m) () genTransaction = do utxo <- use gtdUtxo utxoSize <- uses gtdUtxoKeys V.length when (utxoSize == 0) $ lift $ throwM $ BGInternal "Utxo is empty when trying to create tx payload" - secrets <- unInvSecretsMap <$> view (blockGenParams . asSecretKeys) invAddrSpendingData <- unInvAddrSpendingData <$> view (blockGenParams . asSpendingData) @@ -259,6 +258,3 @@ genPayload -> SlotId -> BlockGenRandMode ext g m () genPayload genesisConfig txpConfig _ = genTxPayload genesisConfig txpConfig - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/generator/src/Test/Pos/Block/Logic/Mode.hs b/generator/src/Test/Pos/Block/Logic/Mode.hs index b9bfa0cea50..cb4454f003a 100644 --- a/generator/src/Test/Pos/Block/Logic/Mode.hs +++ b/generator/src/Test/Pos/Block/Logic/Mode.hs @@ -62,17 +62,19 @@ import Pos.AllSecrets (AllSecrets (..), HasAllSecrets (..), import Pos.Chain.Block (HasSlogGState (..)) import Pos.Chain.Delegation (DelegationVar, HasDlgConfiguration) import Pos.Chain.Genesis as Genesis (Config (..), - GenesisInitializer (..), GenesisSpec (..), - configEpochSlots, configGeneratedSecretsThrow, - gsSecretKeys, mkConfig) + GenesisInitializer (..), GenesisProtocolConstants (..), + GenesisSpec (..), configEpochSlots, + configGeneratedSecretsThrow, gsSecretKeys, mkConfig) import Pos.Chain.Ssc (SscMemTag, SscState) import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Chain.Update (BlockVersionData) import Pos.Core (SlotId, Timestamp (..)) import Pos.Core.Conc (currentTime) +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Core.Reporting (HasMisbehaviorMetrics (..), MonadReporting (..)) import Pos.Core.Slotting (MonadSlotsData) +import Pos.Crypto (ProtocolMagic) import Pos.DB (DBPure, MonadDB (..), MonadDBRead (..), MonadGState (..)) import qualified Pos.DB as DB @@ -134,6 +136,7 @@ data TestParams = TestParams -- ^ 'GenesisInitializer' in 'TestParams' allows one to use custom -- genesis data. , _tpTxpConfiguration :: !TxpConfiguration + , _tpProtocolMagic :: !ProtocolMagic } makeClassy ''TestParams @@ -156,6 +159,7 @@ instance Arbitrary TestParams where let _tpBlockVersionData = defaultTestBlockVersionData let _tpTxpConfiguration = TxpConfiguration 200 Set.empty _tpGenesisInitializer <- genGenesisInitializer + _tpProtocolMagic <- arbitrary return TestParams {..} genGenesisInitializer :: Gen GenesisInitializer @@ -173,9 +177,15 @@ withTestParams :: TestParams -> (Genesis.Config -> r) -> r withTestParams TestParams {..} f = f $ mkConfig _tpStartTime genesisSpec where genesisSpec = defaultTestGenesisSpec - { gsInitializer = _tpGenesisInitializer - , gsBlockVersionData = _tpBlockVersionData + { gsInitializer = _tpGenesisInitializer + , gsBlockVersionData = _tpBlockVersionData + , gsProtocolConstants = + updateGPC (gsProtocolConstants defaultTestGenesisSpec) } + -- + updateGPC :: GenesisProtocolConstants -> GenesisProtocolConstants + updateGPC gpc = gpc { gpcProtocolMagic = _tpProtocolMagic } + ---------------------------------------------------------------------------- -- Init mode with instances @@ -277,7 +287,8 @@ initBlockTestContext genesisConfig tp@TestParams {..} callback = do let btcGState = GS.GStateContext {_gscDB = DB.PureDB dbPureVar, ..} btcDelegation <- mkDelegationVar btcPureDBSnapshots <- PureDBSnapshotsVar <$> newIORef Map.empty - let btcAllSecrets = mkAllSecretsSimple genesisSecretKeys + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig + let btcAllSecrets = mkAllSecretsSimple nm genesisSecretKeys let btCtx = BlockTestContext {btcSystemStart = systemStart, btcSSlottingStateVar = slottingState, ..} liftIO $ flip runReaderT clockVar $ unEmulation $ callback btCtx sudoLiftIO $ runTestInitMode initCtx $ initBlockTestContextDo diff --git a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs index a4c3ec9f29e..4fe9924f5df 100644 --- a/generator/test/Test/Pos/Block/Logic/CreationSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/CreationSpec.hs @@ -19,31 +19,40 @@ import Test.QuickCheck (Gen, Property, Testable, arbitrary, choose, import Pos.Binary.Class (biSize) import Pos.Chain.Block (BlockHeader, MainBlock) import Pos.Chain.Delegation (DlgPayload, ProxySKBlockInfo) +import Pos.Chain.Genesis as Genesis (Config (..), GenesisData (..)) import Pos.Chain.Ssc (SscPayload (..), defaultSscPayload, mkVssCertificatesMapLossy) import Pos.Chain.Txp (TxAux) import Pos.Chain.Update (BlockVersionData (..), HasUpdateConfiguration, UpdatePayload (..)) import qualified Pos.Communication () -import Pos.Core (SlotId (..), localSlotIndexMinBound, - unsafeMkLocalSlotIndex) -import Pos.Crypto (SecretKey) +import Pos.Core (SlotId (..), kEpochSlots, localSlotIndexMinBound, + pcBlkSecurityParam, unsafeMkLocalSlotIndex) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..), + SecretKey) import Pos.DB.Block (RawPayload (..), createMainBlockPure) import Test.Pos.Chain.Block.Arbitrary () import Test.Pos.Chain.Delegation.Arbitrary (genDlgPayload) -import Test.Pos.Chain.Genesis.Dummy (dummyBlockVersionData, - dummyConfig, dummyEpochSlots, dummyK, - dummyProtocolConstants) import Test.Pos.Chain.Ssc.Arbitrary (commitmentMapEpochGen, vssCertificateEpochGen) import Test.Pos.Chain.Txp.Arbitrary (GoodTx, goodTxToTxAux) -import Test.Pos.Configuration (withDefUpdateConfiguration) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Util.QuickCheck (SmallGenerator (..), makeSmall) spec :: Spec -spec = withDefUpdateConfiguration $ +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = withProvidedMagicConfig pm $ \genesisConfig _ _ -> describe "Block.Logic.Creation" $ do -- Sampling the minimum empty block size @@ -54,12 +63,12 @@ spec = withDefUpdateConfiguration $ -- way to get maximum of them. Some settings produce 390b empty -- block, some -- 431b. let emptyBSize0 :: Byte - emptyBSize0 = biSize (noSscBlock infLimit prevHeader0 [] def def sk0) -- in bytes + emptyBSize0 = biSize (noSscBlock genesisConfig infLimit prevHeader0 [] def def sk0) -- in bytes emptyBSize :: Integral n => n emptyBSize = round $ (1.5 * fromIntegral emptyBSize0 :: Double) describe "createMainBlockPure" $ modifyMaxSuccess (const 1000) $ do - prop "empty block size is sane" $ emptyBlk $ \blk0 -> leftToCounter blk0 $ \blk -> + prop "empty block size is sane" $ emptyBlk genesisConfig $ \blk0 -> leftToCounter blk0 $ \blk -> let s = biSize blk in counterexample ("Real block size: " <> show s <> "\n\nBlock: " <> show blk) $ @@ -67,14 +76,14 @@ spec = withDefUpdateConfiguration $ -- bytes; this is *completely* independent of encoding used. -- Empirically, empty blocks don't get bigger than 550 -- bytes. - s <= 550 && s <= bvdMaxBlockSize dummyBlockVersionData + s <= 550 && s <= bvdMaxBlockSize (gdBlockVersionData $ configGenesisData genesisConfig) prop "doesn't create blocks bigger than the limit" $ forAll (choose (emptyBSize, emptyBSize * 10)) $ \(fromBytes -> limit) -> forAll arbitrary $ \(prevHeader, sk, updatePayload) -> - forAll validSscPayloadGen $ \(sscPayload, slotId) -> - forAll (genDlgPayload dummyProtocolMagic (siEpoch slotId)) $ \dlgPayload -> + forAll (validSscPayloadGen genesisConfig) $ \(sscPayload, slotId) -> + forAll (genDlgPayload pm (siEpoch slotId)) $ \dlgPayload -> forAll (makeSmall $ listOf1 genTxAux) $ \txs -> - let blk = producePureBlock limit prevHeader txs Nothing slotId + let blk = producePureBlock genesisConfig limit prevHeader txs Nothing slotId dlgPayload sscPayload updatePayload sk in leftToCounter blk $ \b -> let s = biSize b @@ -84,22 +93,22 @@ spec = withDefUpdateConfiguration $ forAll arbitrary $ \(prevHeader, sk) -> forAll (makeSmall $ listOf1 genTxAux) $ \txs -> forAll (elements [0,0.5,0.9]) $ \(delta :: Double) -> - let blk0 = noSscBlock infLimit prevHeader [] def def sk - blk1 = noSscBlock infLimit prevHeader txs def def sk + let blk0 = noSscBlock genesisConfig infLimit prevHeader [] def def sk + blk1 = noSscBlock genesisConfig infLimit prevHeader txs def def sk in leftToCounter ((,) <$> blk0 <*> blk1) $ \(b0, b1) -> let s = biSize b0 + round ((fromIntegral $ biSize b1 - biSize b0) * delta) - blk2 = noSscBlock s prevHeader txs def def sk + blk2 = noSscBlock genesisConfig s prevHeader txs def def sk in counterexample ("Tested with block size limit: " <> show s) $ leftToCounter blk2 (const True) prop "strips ssc data when necessary" $ forAll arbitrary $ \(prevHeader, sk) -> - forAll validSscPayloadGen $ \(sscPayload, slotId) -> + forAll (validSscPayloadGen genesisConfig) $ \(sscPayload, slotId) -> forAll (elements [0,0.5,0.9]) $ \(delta :: Double) -> - let blk0 = producePureBlock infLimit prevHeader [] Nothing - slotId def (defSscPld slotId) def sk + let blk0 = producePureBlock genesisConfig infLimit prevHeader [] Nothing + slotId def (defSscPld genesisConfig slotId) def sk withPayload lim = - producePureBlock lim prevHeader [] Nothing slotId def sscPayload def sk + producePureBlock genesisConfig lim prevHeader [] Nothing slotId def sscPayload def sk blk1 = withPayload infLimit in leftToCounter ((,) <$> blk0 <*> blk1) $ \(b0,b1) -> let s = biSize b0 + @@ -108,8 +117,10 @@ spec = withDefUpdateConfiguration $ in counterexample ("Tested with block size limit: " <> show s) $ leftToCounter blk2 (const True) where - defSscPld :: SlotId -> SscPayload - defSscPld sId = defaultSscPayload dummyK $ siSlot sId + defSscPld :: Genesis.Config -> SlotId -> SscPayload + defSscPld genesisConfig sId = do + let k = pcBlkSecurityParam $ configProtocolConstants genesisConfig + defaultSscPayload k $ siSlot sId infLimit = convertUnit @Gigabyte @Byte 1 @@ -118,11 +129,12 @@ spec = withDefUpdateConfiguration $ emptyBlk :: (HasUpdateConfiguration, Testable p) - => (Either Text MainBlock -> p) + => Genesis.Config + -> (Either Text MainBlock -> p) -> Property - emptyBlk foo = + emptyBlk genesisConfig foo = forAll arbitrary $ \(prevHeader, sk, slotId) -> - foo $ producePureBlock infLimit prevHeader [] Nothing slotId def (defSscPld slotId) def sk + foo $ producePureBlock genesisConfig infLimit prevHeader [] Nothing slotId def (defSscPld genesisConfig slotId) def sk genTxAux :: Gen TxAux genTxAux = @@ -130,21 +142,25 @@ spec = withDefUpdateConfiguration $ noSscBlock :: HasUpdateConfiguration - => Byte + => Genesis.Config + -> Byte -> BlockHeader -> [TxAux] -> DlgPayload -> UpdatePayload -> SecretKey -> Either Text MainBlock - noSscBlock limit prevHeader txs proxyCerts updatePayload sk = - let neutralSId = SlotId 0 (unsafeMkLocalSlotIndex dummyEpochSlots $ fromIntegral $ dummyK * 2) + noSscBlock genesisConfig limit prevHeader txs proxyCerts updatePayload sk = + let k = pcBlkSecurityParam $ configProtocolConstants genesisConfig + epochSlots = kEpochSlots k + neutralSId = SlotId 0 (unsafeMkLocalSlotIndex epochSlots $ fromIntegral $ k * 2) in producePureBlock - limit prevHeader txs Nothing neutralSId proxyCerts (defSscPld neutralSId) updatePayload sk + genesisConfig limit prevHeader txs Nothing neutralSId proxyCerts (defSscPld genesisConfig neutralSId) updatePayload sk producePureBlock :: HasUpdateConfiguration - => Byte + => Genesis.Config + -> Byte -> BlockHeader -> [TxAux] -> ProxySKBlockInfo @@ -154,20 +170,24 @@ spec = withDefUpdateConfiguration $ -> UpdatePayload -> SecretKey -> Either Text MainBlock - producePureBlock limit prev txs psk slot dlgPay sscPay usPay sk = - createMainBlockPure dummyConfig limit prev psk slot sk $ + producePureBlock genesisConfig limit prev txs psk slot dlgPay sscPay usPay sk = + createMainBlockPure genesisConfig limit prev psk slot sk $ RawPayload txs sscPay dlgPay usPay -validSscPayloadGen :: Gen (SscPayload, SlotId) -validSscPayloadGen = do +validSscPayloadGen :: Genesis.Config -> Gen (SscPayload, SlotId) +validSscPayloadGen genesisConfig = do + let pm = configProtocolMagic genesisConfig + protocolConstants = configProtocolConstants genesisConfig + k = pcBlkSecurityParam protocolConstants + epochSlots = kEpochSlots k vssCerts <- makeSmall $ fmap mkVssCertificatesMapLossy $ listOf $ - vssCertificateEpochGen dummyProtocolMagic dummyProtocolConstants 0 - let mkSlot i = SlotId 0 (unsafeMkLocalSlotIndex dummyEpochSlots (fromIntegral i)) - oneof [ do commMap <- makeSmall $ commitmentMapEpochGen dummyProtocolMagic 0 + vssCertificateEpochGen pm protocolConstants 0 + let mkSlot i = SlotId 0 (unsafeMkLocalSlotIndex epochSlots (fromIntegral i)) + oneof [ do commMap <- makeSmall $ commitmentMapEpochGen pm 0 pure (CommitmentsPayload commMap vssCerts , SlotId 0 localSlotIndexMinBound) , do openingsMap <- makeSmall arbitrary - pure (OpeningsPayload openingsMap vssCerts, mkSlot (4 * dummyK + 1)) + pure (OpeningsPayload openingsMap vssCerts, mkSlot (4 * k + 1)) , do sharesMap <- makeSmall arbitrary - pure (SharesPayload sharesMap vssCerts, mkSlot (8 * dummyK)) - , pure (CertificatesPayload vssCerts, mkSlot (7 * dummyK)) + pure (SharesPayload sharesMap vssCerts, mkSlot (8 * k)) + , pure (CertificatesPayload vssCerts, mkSlot (7 * k)) ] diff --git a/generator/test/Test/Pos/Block/Logic/VarSpec.hs b/generator/test/Test/Pos/Block/Logic/VarSpec.hs index 58a380e9842..de8db5565d7 100644 --- a/generator/test/Test/Pos/Block/Logic/VarSpec.hs +++ b/generator/test/Test/Pos/Block/Logic/VarSpec.hs @@ -26,7 +26,7 @@ import Pos.Chain.Block (Blund, headerHash) import Pos.Chain.Genesis as Genesis (Config (..), configBootStakeholders, configEpochSlots) import Pos.Chain.Txp (TxpConfiguration) -import Pos.Core (ProtocolConstants (..)) +import Pos.Core (ProtocolConstants (..), pcBlkSecurityParam) import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), nonEmptyNewestFirst, nonEmptyOldestFirst, splitAtNewestFirst, toNewestFirst, _NewestFirst) @@ -50,7 +50,6 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..), bpGenBlock, bpGenBlocks, bpGoToArbitraryState, getAllSecrets, satisfySlotCheck) import Test.Pos.Block.Property (blockPropertySpec) -import Test.Pos.Chain.Genesis.Dummy (dummyK, dummyProtocolConstants) import Test.Pos.Configuration (HasStaticConfigurations, withStaticConfigurations) import Test.Pos.Util.QuickCheck.Property (splitIntoChunks, @@ -259,8 +258,10 @@ blockEventSuccessSpec txpConfig = and a few sheets of paper trying to figure out how to write it. -} -genSuccessWithForks :: forall g m . (RandomGen g, Monad m) => BlockEventGenT g m () -genSuccessWithForks = do +genSuccessWithForks :: forall g m . (RandomGen g, Monad m) + => Genesis.Config + -> BlockEventGenT g m () +genSuccessWithForks genesisConfig = do emitBlockApply BlockApplySuccess $ pathSequence mempty ["0"] generateFork "0" [] emitBlockApply BlockApplySuccess $ pathSequence "0" ["1", "2"] @@ -273,7 +274,8 @@ genSuccessWithForks = do generateFork basePath rollbackFork = do let forkLen = length rollbackFork - wiggleRoom = fromIntegral dummyK - forkLen + k = (pcBlkSecurityParam . configProtocolConstants) genesisConfig + wiggleRoom = fromIntegral k - forkLen stopFork <- byChance (if forkLen > 0 then 0.1 else 0) if stopFork then whenJust (nonEmptyNewestFirst rollbackFork) $ @@ -282,7 +284,7 @@ genSuccessWithForks = do needRollback <- -- forkLen=0 => needRollback 0% -- forkLen=blkSecurityParam => needRollback 100% - byChance (realToFrac $ forkLen Ratio.% fromIntegral dummyK) + byChance (realToFrac $ forkLen Ratio.% fromIntegral k) if needRollback then do retreat <- getRandomR (1, forkLen) @@ -328,7 +330,7 @@ blockEventSuccessProp blockEventSuccessProp genesisConfig txpConfig = do scenario <- blockPropertyScenarioGen genesisConfig txpConfig - genSuccessWithForks + (genSuccessWithForks genesisConfig) let (scenario', checkCount) = enrichWithSnapshotChecking scenario when (checkCount <= 0) $ stopProperty $ "No checks were generated, this is a bug in the test suite: " <> @@ -419,15 +421,15 @@ singleForkProp :: HasConfigurations -> ForkDepth -> BlockProperty () singleForkProp genesisConfig txpConfig fd = do - scenario <- blockPropertyScenarioGen genesisConfig txpConfig $ genSingleFork fd + scenario <- blockPropertyScenarioGen genesisConfig txpConfig $ genSingleFork genesisConfig fd runBlockScenarioAndVerify genesisConfig txpConfig scenario data ForkDepth = ForkShort | ForkMedium | ForkDeep genSingleFork :: forall g m . (RandomGen g, Monad m) - => ForkDepth -> BlockEventGenT g m () -genSingleFork fd = do - let k = pcK dummyProtocolConstants + => Genesis.Config -> ForkDepth -> BlockEventGenT g m () +genSingleFork genesisConfig fd = do + let k = pcK (configProtocolConstants genesisConfig) -- 'd' is how deeply in the chain the fork starts. In other words, it's how many -- blocks we're going to rollback (therefore must be >1). d <- getRandomR $ case fd of diff --git a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs index d55cc3f002b..ec54f422c56 100644 --- a/generator/test/Test/Pos/Generator/Block/LrcSpec.hs +++ b/generator/test/Test/Pos/Generator/Block/LrcSpec.hs @@ -17,9 +17,9 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set import Formatting (build, int, sformat, (%)) import Serokell.Util (listJson) -import Test.Hspec (Spec, describe) +import Test.Hspec (Spec, describe, runIO) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Gen, arbitrary, choose) +import Test.QuickCheck (Gen, arbitrary, choose, generate) import Test.QuickCheck.Monadic (pick) import Pos.Binary.Class (serialize') @@ -33,7 +33,8 @@ import Pos.Chain.Genesis as Genesis (Config (..), import qualified Pos.Chain.Lrc as Lrc import Pos.Chain.Txp (TxAux, TxpConfiguration (..), mkTxPayload) import Pos.Core (Coin, EpochIndex, StakeholderId, addressHash, coinF) -import Pos.Crypto (SecretKey, toPublic) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..), + SecretKey, toPublic) import Pos.DB.Block (ShouldCallBListener (..), applyBlocksUnsafe) import qualified Pos.DB.Block as Lrc import qualified Pos.DB.Lrc as LrcDB @@ -48,12 +49,23 @@ import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..), bpGenBlock, bpGenBlocks) import Test.Pos.Block.Property (blockPropertySpec) import Test.Pos.Configuration (defaultTestBlockVersionData, - withStaticConfigurations) + withProvidedMagicConfig) import Test.Pos.Util.QuickCheck (maybeStopProperty, stopProperty) spec :: Spec -spec = withStaticConfigurations $ \txpConfig _ -> +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = withProvidedMagicConfig pm $ \_ txpConfig _ -> describe "Lrc.Worker" $ modifyMaxSuccess (const 4) $ do describe "lrcSingleShot" $ do -- Currently we want to run it only 4 times, because there @@ -89,6 +101,7 @@ genTestParams = do let _tpBlockVersionData = defaultTestBlockVersionData let _tpTxpConfiguration = TxpConfiguration 200 Set.empty _tpGenesisInitializer <- genGenesisInitializer + _tpProtocolMagic <- arbitrary return TestParams {..} genGenesisInitializer :: Gen GenesisInitializer diff --git a/lib/src/Pos/AllSecrets.hs b/lib/src/Pos/AllSecrets.hs index 4c06368a413..785977b665f 100644 --- a/lib/src/Pos/AllSecrets.hs +++ b/lib/src/Pos/AllSecrets.hs @@ -86,14 +86,13 @@ instance Buildable AllSecrets where -- | Make simple 'AllSecrets' assuming that only public key addresses -- with bootstrap era distribution and single key distribution exist -- in the system. -mkAllSecretsSimple :: [SecretKey] -> AllSecrets -mkAllSecretsSimple sks = +mkAllSecretsSimple :: NetworkMagic -> [SecretKey] -> AllSecrets +mkAllSecretsSimple nm sks = AllSecrets { _asSecretKeys = mkInvSecretsMap sks , _asSpendingData = invAddrSpendingData } where - nm = fixedNM pks :: [PublicKey] pks = map toPublic sks spendingDataList = map PubKeyASD pks @@ -103,7 +102,3 @@ mkAllSecretsSimple sks = mkInvAddrSpendingData $ zip addressesNonBoot spendingDataList <> zip addressesBoot spendingDataList - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/lib/src/Test/Pos/Configuration.hs b/lib/src/Test/Pos/Configuration.hs index ac5341bbec4..1f681c8dc34 100644 --- a/lib/src/Test/Pos/Configuration.hs +++ b/lib/src/Test/Pos/Configuration.hs @@ -8,6 +8,7 @@ module Test.Pos.Configuration , HasStaticConfigurations , withDefConfiguration + , withProvidedMagicConfig , withDefNtpConfiguration , withDefNodeConfiguration , withDefSscConfiguration @@ -30,13 +31,15 @@ import Ntp.Client (NtpConfiguration) import Pos.Chain.Block (HasBlockConfiguration, withBlockConfiguration) import Pos.Chain.Delegation (HasDlgConfiguration, withDlgConfiguration) -import Pos.Chain.Genesis as Genesis (Config, GenesisSpec (..), +import Pos.Chain.Genesis as Genesis (Config (..), + GenesisProtocolConstants (..), GenesisSpec (..), StaticConfig (..), mkConfig) import Pos.Chain.Ssc (HasSscConfiguration, withSscConfiguration) import Pos.Chain.Txp (TxpConfiguration (..)) import Pos.Chain.Update (BlockVersionData, HasUpdateConfiguration, withUpdateConfiguration) import Pos.Configuration (HasNodeConfiguration, withNodeConfiguration) +import Pos.Crypto (ProtocolMagic) import Pos.Launcher.Configuration (Configuration (..), HasConfigurations) import Pos.Util.Config (embedYamlConfigCT) @@ -108,3 +111,26 @@ withDefConfigurations -> r withDefConfigurations bardaq = withDefConfiguration $ \genesisConfig -> withStaticConfigurations (bardaq genesisConfig) + +withProvidedMagicConfig + :: ProtocolMagic + -> ( HasConfigurations + => Genesis.Config + -> TxpConfiguration + -> NtpConfiguration + -> r + ) + -> r +withProvidedMagicConfig pm f = withStaticConfigurations (f overriddenGenesisConfig) + where + overriddenGenesisConfig :: Genesis.Config + overriddenGenesisConfig = mkConfig 0 overriddenGenesisSpec + -- + overriddenGenesisSpec :: GenesisSpec + overriddenGenesisSpec = updateGS defaultTestGenesisSpec + -- + updateGS :: GenesisSpec -> GenesisSpec + updateGS gs = gs { gsProtocolConstants = updateGPC (gsProtocolConstants gs) } + -- + updateGPC :: GenesisProtocolConstants -> GenesisProtocolConstants + updateGPC gpc = gpc { gpcProtocolMagic = pm } diff --git a/lib/test/Test/Pos/Cbor/CborSpec.hs b/lib/test/Test/Pos/Cbor/CborSpec.hs index 36be42f7147..466af22708f 100644 --- a/lib/test/Test/Pos/Cbor/CborSpec.hs +++ b/lib/test/Test/Pos/Cbor/CborSpec.hs @@ -19,7 +19,7 @@ import Data.Tagged (Tagged) import System.FileLock (FileLock) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck (Arbitrary (..), arbitrary) import Pos.Binary.Communication () import Pos.Chain.Delegation (DlgPayload, DlgUndo, ProxySKHeavy) @@ -65,7 +65,7 @@ type UpId' = Tagged (U.UpdateProposal, [U.UpdateVote])U.UpId ---------------------------------------- spec :: Spec -spec = do +spec = describe "Cbor.Bi instances" $ do modifyMaxSuccess (const 1000) $ do describe "Lib/core instances" $ do diff --git a/lib/test/Test/Pos/Diffusion/BlockSpec.hs b/lib/test/Test/Pos/Diffusion/BlockSpec.hs index 9ddb65b561c..71434d04995 100644 --- a/lib/test/Test/Pos/Diffusion/BlockSpec.hs +++ b/lib/test/Test/Pos/Diffusion/BlockSpec.hs @@ -16,7 +16,8 @@ import Data.Conduit.Combinators (yieldMany) import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE import Data.Semigroup ((<>)) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec (Spec, describe, it, runIO, shouldBe) +import Test.QuickCheck (arbitrary, generate) import qualified Network.Broadcast.OutboundQueue as OQ import qualified Network.Broadcast.OutboundQueue.Types as OQ @@ -32,8 +33,7 @@ import qualified Pos.Chain.Block as Block (getBlockHeader) import Pos.Chain.Update (BlockVersion (..)) import Pos.Core.Chrono (NewestFirst (..), OldestFirst (..)) import Pos.Core.ProtocolConstants (ProtocolConstants (..)) -import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), - RequiresNetworkMagic (..)) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (Hash, unsafeMkAbstractHash) import Pos.DB.Class (Serialized (..), SerializedBlock) import Pos.Diffusion.Full (FullDiffusionConfiguration (..), @@ -54,9 +54,6 @@ import Test.Pos.Chain.Block.Arbitrary.Generate (generateMainBlock) -- when trying to resolve it. {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} -protocolMagic :: ProtocolMagic -protocolMagic = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic - protocolConstants :: ProtocolConstants protocolConstants = ProtocolConstants { pcK = 2 @@ -119,8 +116,8 @@ clientLogic = pureLogic { getLcaMainChain = \headers -> pure (NewestFirst [], headers) } -withServer :: Transport -> Logic IO -> (NodeId -> IO t) -> IO t -withServer transport logic k = do +withServer :: ProtocolMagic -> Transport -> Logic IO -> (NodeId -> IO t) -> IO t +withServer pm transport logic k = do logTrace <- liftIO $ setupTestTrace -- Morally, the server shouldn't need an outbound queue, but we have to -- give one. @@ -146,7 +143,7 @@ withServer transport logic k = do runFullDiffusionInternals runInternals $ \internals -> k (Node.nodeId (fdiNode internals)) where fdconf = FullDiffusionConfiguration - { fdcProtocolMagic = protocolMagic + { fdcProtocolMagic = pm , fdcProtocolConstants = protocolConstants -- Just like in production. , fdcRecoveryHeadersMessage = 2200 @@ -159,13 +156,14 @@ withServer transport logic k = do -- Like 'withServer' but we must set up the outbound queue so that it will -- contact the server. withClient - :: Word32 + :: ProtocolMagic + -> Word32 -> Transport -> Logic IO -> NodeId -> (Diffusion IO -> IO t) -> IO t -withClient streamWindow transport logic serverAddress@(Node.NodeId _) k = do +withClient pm streamWindow transport logic serverAddress@(Node.NodeId _) k = do -- Morally, the server shouldn't need an outbound queue, but we have to -- give one. oq <- OQ.new @@ -192,7 +190,7 @@ withClient streamWindow transport logic serverAddress@(Node.NodeId _) k = do runFullDiffusionInternals runInternals $ \_ -> k diffusion where fdconf = FullDiffusionConfiguration - { fdcProtocolMagic = protocolMagic + { fdcProtocolMagic = pm , fdcProtocolConstants = protocolConstants -- Just like in production. , fdcRecoveryHeadersMessage = 2200 @@ -226,26 +224,26 @@ blockDownloadStream serverAddress resultIORef streamIORef setStreamIORef ~(block modifyIORef' recvBlocks (\d -> blocks <> d) -- Generate a list of n+1 blocks -generateBlocks :: Int -> NonEmpty Block -generateBlocks blocks = +generateBlocks :: ProtocolMagic -> Int -> NonEmpty Block +generateBlocks pm blocks = let root = doGenerateBlock 0 in root :| (doGenerateBlocks blocks) where doGenerateBlock :: Int -> Block doGenerateBlock seed = let size = 4 in - force $ Right (generateMainBlock protocolMagic seed size) + force $ Right (generateMainBlock pm seed size) doGenerateBlocks :: Int -> [Block] doGenerateBlocks 0 = [] doGenerateBlocks x = do [doGenerateBlock x] ++ (doGenerateBlocks (x-1)) -streamSimple :: Word32 -> Int -> IO Bool -streamSimple streamWindow blocks = do +streamSimple :: ProtocolMagic -> Word32 -> Int -> IO Bool +streamSimple pm streamWindow blocks = do streamIORef <- newIORef [] resultIORef <- newIORef False - let arbitraryBlocks = generateBlocks (blocks - 1) + let arbitraryBlocks = generateBlocks pm (blocks - 1) arbitraryHeaders = NE.map Block.getBlockHeader arbitraryBlocks arbitraryHashes = NE.map blockHeaderHash arbitraryHeaders !arbitraryBlock = NE.head arbitraryBlocks @@ -253,44 +251,52 @@ streamSimple streamWindow blocks = do checkpoints = [tipHash] setStreamIORef = \_ -> writeIORef streamIORef $ NE.tail arbitraryBlocks withTransport $ \transport -> - withServer transport (serverLogic streamIORef arbitraryBlock arbitraryHashes arbitraryHeaders) $ \serverAddress -> - withClient streamWindow transport clientLogic serverAddress $ + withServer pm transport (serverLogic streamIORef arbitraryBlock arbitraryHashes arbitraryHeaders) $ \serverAddress -> + withClient pm streamWindow transport clientLogic serverAddress $ liftIO . blockDownloadStream serverAddress resultIORef streamIORef setStreamIORef (tipHash, checkpoints) readIORef resultIORef -batchSimple :: Int -> IO Bool -batchSimple blocks = do +batchSimple :: ProtocolMagic -> Int -> IO Bool +batchSimple pm blocks = do streamIORef <- newIORef [] - let arbitraryBlocks = generateBlocks (blocks - 1) + let arbitraryBlocks = generateBlocks pm (blocks - 1) arbitraryHeaders = NE.map Block.getBlockHeader arbitraryBlocks arbitraryHashes = NE.map blockHeaderHash arbitraryHeaders arbitraryBlock = NE.head arbitraryBlocks !checkPoints = if blocks == 1 then [someHash] else [someHash' (blocks + 1) []] withTransport $ \transport -> - withServer transport (serverLogic streamIORef arbitraryBlock arbitraryHashes arbitraryHeaders) $ \serverAddress -> - withClient 2048 transport clientLogic serverAddress $ + withServer pm transport (serverLogic streamIORef arbitraryBlock arbitraryHashes arbitraryHeaders) $ \serverAddress -> + withClient pm 2048 transport clientLogic serverAddress $ liftIO . blockDownloadBatch serverAddress (someHash, checkPoints) return True spec :: Spec -spec = describe "Blockdownload" $ do - it "Stream 4 blocks" $ do - r <- streamSimple 2048 4 - r `shouldBe` True - it "Stream 128 blocks" $ do - r <- streamSimple 2048 128 - r `shouldBe` True - it "Stream 4096 blocks" $ do - r <- streamSimple 128 4096 - r `shouldBe` True - it "Streaming dislabed by client" $ do - r <- streamSimple 0 4 - r `shouldBe` False - it "Batch, single block" $ do - r <- batchSimple 1 - r `shouldBe` True - it "Batch of blocks" $ do - r <- batchSimple 2200 - r `shouldBe` True +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + describe "Blockdownload" $ do + it "Stream 4 blocks" $ do + r <- streamSimple pm 2048 4 + r `shouldBe` True + it "Stream 128 blocks" $ do + r <- streamSimple pm 2048 128 + r `shouldBe` True + it "Stream 4096 blocks" $ do + r <- streamSimple pm 128 4096 + r `shouldBe` True + it "Streaming dislabed by client" $ do + r <- streamSimple pm 0 4 + r `shouldBe` False + it "Batch, single block" $ do + r <- batchSimple pm 1 + r `shouldBe` True + it "Batch of blocks" $ do + r <- batchSimple pm 2200 + r `shouldBe` True diff --git a/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs b/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs index cdbc1215f5c..b5669a5efa5 100644 --- a/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs +++ b/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs @@ -27,11 +27,10 @@ import Pos.DB.Lrc (RichmenType (..), findRichmenPure) import Test.Pos.Chain.Lrc.Arbitrary (GenesisMpcThd, InvalidRichmenStakes (..), ValidRichmenStakes (..)) -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Util.QuickCheck.Property (qcIsLeft) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "computeSharesDistr" $ do +spec = describe "computeSharesDistr" $ do prop emptyRichmenStakesDesc emptyRichmenStakes modifyMaxSuccess (const 3) $ prop invalidStakeErrorsDesc invalidStakeErrors diff --git a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs index 5526865523a..4bb45a68ced 100644 --- a/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs +++ b/lib/test/Test/Pos/Ssc/Toss/BaseSpec.hs @@ -36,7 +36,7 @@ import Pos.Chain.Ssc (Commitment, CommitmentSignature, verifyCommitmentSignature, verifyOpening, _vcVssKey) import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), StakeholderId, addressHash, crucialSlot, mkCoin) -import Pos.Crypto (DecShare, PublicKey, SecretKey, +import Pos.Crypto (DecShare, ProtocolMagic, PublicKey, SecretKey, SignTag (SignCommitment), sign, toPublic) import Test.Pos.Chain.Lrc.Arbitrary (GenesisMpcThd, ValidRichmenStakes (..)) @@ -46,7 +46,6 @@ import Test.Pos.Chain.Genesis.Dummy (dummyBlockVersionData, dummyConfig, dummyK) import Test.Pos.Chain.Ssc.Arbitrary (BadCommAndOpening (..), BadSignedCommitment (..), CommitmentOpening (..)) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) spec :: Spec spec = describe "Ssc.Base" $ do @@ -115,18 +114,18 @@ verifiesOkComm :: CommitmentOpening -> Bool verifiesOkComm CommitmentOpening{..} = verifyCommitment coCommitment -verifiesOkCommSig :: SecretKey -> Commitment -> EpochIndex -> Bool -verifiesOkCommSig sk comm epoch = +verifiesOkCommSig :: ProtocolMagic -> SecretKey -> Commitment -> EpochIndex -> Bool +verifiesOkCommSig pm sk comm epoch = let commSig = ( toPublic sk , comm - , sign dummyProtocolMagic SignCommitment sk (epoch, comm) + , sign pm SignCommitment sk (epoch, comm) ) - in verifyCommitmentSignature dummyProtocolMagic epoch commSig + in verifyCommitmentSignature pm epoch commSig -notVerifiesBadCommSig :: BadSignedCommitment -> EpochIndex -> Bool -notVerifiesBadCommSig (getBadSignedC -> badSignedComm) epoch = - not $ verifyCommitmentSignature dummyProtocolMagic epoch badSignedComm +notVerifiesBadCommSig :: ProtocolMagic -> BadSignedCommitment -> EpochIndex -> Bool +notVerifiesBadCommSig pm (getBadSignedC -> badSignedComm) epoch = + not $ verifyCommitmentSignature pm epoch badSignedComm verifiesOkOpening :: CommitmentOpening -> Bool verifiesOkOpening CommitmentOpening{..} = diff --git a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs index d265bae3d22..635c5d979de 100644 --- a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs +++ b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs @@ -13,11 +13,11 @@ import qualified Data.HashSet as HS import Data.List.Extra (nubOrdOn) import qualified Data.Set as S import Data.Tuple (swap) -import Test.Hspec (Spec, describe) +import Test.Hspec (Spec, describe, runIO) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary (..), Gen, Property, choose, - conjoin, counterexample, suchThat, vectorOf, (.&&.), - (==>)) + conjoin, counterexample, generate, suchThat, vectorOf, + (.&&.), (==>)) import Pos.Chain.Ssc (SscGlobalState (..), VssCertData (..), VssCertificate (..), expiryEoS, getCertId, @@ -27,17 +27,27 @@ import qualified Pos.Chain.Ssc as Ssc import Pos.Core (EpochIndex (..), EpochOrSlot (..), SlotId (..)) import Pos.Core.Chrono (NewestFirst (..)) import Pos.Core.Slotting (flattenEpochOrSlot, unflattenSlotId) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Test.Pos.Chain.Genesis.Dummy (dummyEpochSlots, dummySlotSecurityParam) -import Test.Pos.Configuration (withDefConfiguration) import Test.Pos.Core.Arbitrary () -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Infra.Arbitrary.Ssc () import Test.Pos.Util.QuickCheck.Property (qcIsJust) spec :: Spec -spec = withDefConfiguration $ \_ -> describe "Ssc.VssCertData" $ do +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody _pm = describe "Ssc.VssCertData" $ do describe "verifyInsertVssCertData" $ prop description_verifyInsertVssCertData verifyInsertVssCertData describe "verifyDeleteVssCertData" $ @@ -190,7 +200,8 @@ instance Arbitrary RollbackData where thisEpoch <- siEpoch . unflattenSlotId dummyEpochSlots <$> choose (succ lastKEoSWord, rollbackFrom) - return $ mkVssCertificate dummyProtocolMagic sk binVssPK thisEpoch + pm <- arbitrary + return $ mkVssCertificate pm sk binVssPK thisEpoch certsToRollback <- nubOrdOn vcVssKey <$> vectorOf @VssCertificate certsToRollbackN rollbackGen return $ Rollback (SscGlobalState mempty mempty mempty goodVssCertData) diff --git a/tools/src/Pos/Tools/Dbgen/QueryMethods.hs b/tools/src/Pos/Tools/Dbgen/QueryMethods.hs index bc66568fb55..79f5b3fabe5 100644 --- a/tools/src/Pos/Tools/Dbgen/QueryMethods.hs +++ b/tools/src/Pos/Tools/Dbgen/QueryMethods.hs @@ -7,6 +7,7 @@ module Pos.Tools.Dbgen.QueryMethods where import Universum +import Pos.Core.NetworkMagic (NetworkMagic) import Pos.Wallet.Web.Methods.Logic (getWallets) import Text.Printf (printf) @@ -14,15 +15,15 @@ import Pos.Tools.Dbgen.Lib (timed) import Pos.Tools.Dbgen.Rendering (say) import Pos.Tools.Dbgen.Types (Method (..), UberMonad) -queryMethods :: Maybe Method -> UberMonad () -queryMethods Nothing = say "No valid method read from the CLI." -queryMethods (Just method) = case method of - GetWallets -> queryGetWallets +queryMethods :: NetworkMagic -> Maybe Method -> UberMonad () +queryMethods _ Nothing = say "No valid method read from the CLI." +queryMethods nm (Just method) = case method of + GetWallets -> queryGetWallets nm -queryGetWallets :: UberMonad () -queryGetWallets = do - wallets <- timed getWallets +queryGetWallets :: NetworkMagic -> UberMonad () +queryGetWallets nm = do + wallets <- timed (getWallets nm) case wallets of [] -> say "No wallets returned." _ -> say $ printf "%d wallets found." (length wallets) diff --git a/utxo/src/UTxO/Context.hs b/utxo/src/UTxO/Context.hs index 7618cc566a7..6e5a3b80888 100644 --- a/utxo/src/UTxO/Context.hs +++ b/utxo/src/UTxO/Context.hs @@ -299,8 +299,8 @@ data Avvm = Avvm { -------------------------------------------------------------------------------} -- | Compute generated actors -initActors :: CardanoContext -> Actors -initActors CardanoContext{..} = Actors{..} +initActors :: NetworkMagic -> CardanoContext -> Actors +initActors nm CardanoContext{..} = Actors{..} where actorsRich :: Map PublicKey Rich actorsPoor :: Map PublicKey Poor @@ -323,7 +323,7 @@ initActors CardanoContext{..} = Actors{..} richKey = regularKeyPair richSec richAddr :: Address - richAddr = makePubKeyAddressBoot fixedNM (toPublic richSec) + richAddr = makePubKeyAddressBoot nm (toPublic richSec) mkPoor :: PoorSecret -> (PublicKey, Poor) mkPoor (PoorSecret _) = error err @@ -366,7 +366,7 @@ initActors CardanoContext{..} = Actors{..} avvmKey = RedeemKeyPair{..} avvmAddr :: Address - avvmAddr = makeRedeemAddress fixedNM redKpPub + avvmAddr = makeRedeemAddress nm redKpPub Just (redKpPub, redKpSec) = redeemDeterministicKeyGen avvmSeed @@ -439,8 +439,8 @@ data AddrMap = AddrMap { } -- | Compute initial address mapping -initAddrMap :: Actors -> AddrMap -initAddrMap Actors{..} = AddrMap{ +initAddrMap :: NetworkMagic -> Actors -> AddrMap +initAddrMap nm Actors{..} = AddrMap{ addrMap = Map.fromList mkMap , addrRevMap = Map.fromList $ map (swap . second addrInfoCardano) mkMap } @@ -495,7 +495,7 @@ initAddrMap Actors{..} = AddrMap{ -> Word32 -- ^ address index -> (EncKeyPair, Address) deriveHDAddress' esk accIx' addrIx' - = case deriveLvl2KeyPair fixedNM bootstrapEra scp emptyPassphrase esk accIx' addrIx' of + = case deriveLvl2KeyPair nm bootstrapEra scp emptyPassphrase esk accIx' addrIx' of Nothing -> error "impossible" Just (addr, key) -> (encKeyPair key, addr) where @@ -525,11 +525,11 @@ data TransCtxt = TransCtxt { , tcAddrMap :: AddrMap } -initContext :: CardanoContext -> TransCtxt -initContext tcCardano = TransCtxt{..} +initContext :: NetworkMagic -> CardanoContext -> TransCtxt +initContext nm tcCardano = TransCtxt{..} where - tcActors = initActors tcCardano - tcAddrMap = initAddrMap tcActors + tcActors = initActors nm tcCardano + tcAddrMap = initAddrMap nm tcActors -- | All actor addresses present in the translation context transCtxtAddrs :: TransCtxt -> [Addr] @@ -716,6 +716,3 @@ instance Buildable GenesisData where % "}" ) gdBootStakeholders - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/utxo/src/UTxO/Translate.hs b/utxo/src/UTxO/Translate.hs index 534604f39f8..afc84b1b428 100644 --- a/utxo/src/UTxO/Translate.hs +++ b/utxo/src/UTxO/Translate.hs @@ -30,10 +30,13 @@ import Data.Validated import Universum import Pos.Chain.Block +import Pos.Chain.Genesis import Pos.Chain.Txp import Pos.Chain.Update import Pos.Core import Pos.Core.Chrono +import Pos.Core.NetworkMagic (makeNetworkMagic) +import Pos.Crypto (ProtocolMagic) import Pos.DB.Class (MonadGState (..)) import UTxO.Context @@ -50,8 +53,7 @@ import Test.Pos.Chain.Genesis.Dummy (dummyBlockVersionData, configuration.yaml. It is specified by a 'GenesisSpec'. -------------------------------------------------------------------------------} -import Test.Pos.Configuration (withDefConfiguration, - withDefUpdateConfiguration) +import Test.Pos.Configuration (withProvidedMagicConfig) {------------------------------------------------------------------------------- Translation monad @@ -101,13 +103,14 @@ instance Monad m => MonadGState (TranslateT e m) where -- -- NOTE: This uses the default test configuration, and throws any errors as -- pure exceptions. -runTranslateT :: Monad m => Exception e => TranslateT e m a -> m a -runTranslateT (TranslateT ta) = - withDefConfiguration $ \genesisConfig -> - withDefUpdateConfiguration $ - let env :: TranslateEnv +runTranslateT :: Monad m => Exception e + => ProtocolMagic -> TranslateT e m a -> m a +runTranslateT pm (TranslateT ta) = + withProvidedMagicConfig pm $ \genesisConfig _ _ -> + let nm = makeNetworkMagic pm + env :: TranslateEnv env = TranslateEnv { - teContext = initContext (initCardanoContext genesisConfig) + teContext = initContext nm (initCardanoContext genesisConfig) , teUpdate = Dict } in do ma <- runReaderT (runExceptT ta) env @@ -116,15 +119,15 @@ runTranslateT (TranslateT ta) = Right a -> return a -- | Specialised form of 'runTranslateT' when there can be no errors -runTranslateTNoErrors :: Monad m => TranslateT Void m a -> m a +runTranslateTNoErrors :: Monad m => ProtocolMagic -> TranslateT Void m a -> m a runTranslateTNoErrors = runTranslateT -- | Specialization of 'runTranslateT' -runTranslate :: Exception e => Translate e a -> a -runTranslate = runIdentity . runTranslateT +runTranslate :: Exception e => ProtocolMagic -> Translate e a -> a +runTranslate pm = runIdentity . (runTranslateT pm) -- | Specialised form of 'runTranslate' when there can be no errors -runTranslateNoErrors :: Translate Void a -> a +runTranslateNoErrors :: ProtocolMagic -> Translate Void a -> a runTranslateNoErrors = runTranslate -- | Lift functions that want the configuration as type class constraints @@ -215,26 +218,31 @@ verifyBlocksPrefix blocks = validatedFromExceptT . throwError $ VerifyBlocksError "No genesis epoch!" ESRValid genEpoch (OldestFirst succEpochs) -> do CardanoContext{..} <- asks tcCardano - verify $ validateGenEpoch ccHash0 ccInitLeaders genEpoch >>= \genUndos -> do - epochUndos <- sequence $ validateSuccEpoch <$> succEpochs + let pm = ccMagic + verify $ validateGenEpoch pm ccHash0 ccInitLeaders genEpoch >>= \genUndos -> do + epochUndos <- sequence $ validateSuccEpoch pm <$> succEpochs return $ foldl' (\a b -> a <> b) genUndos epochUndos where - validateGenEpoch :: HeaderHash + validateGenEpoch :: ProtocolMagic + -> HeaderHash -> SlotLeaders -> OldestFirst NE MainBlock -> Verify VerifyBlocksException (OldestFirst NE Undo) - validateGenEpoch ccHash0 ccInitLeaders geb = do + validateGenEpoch pm ccHash0 ccInitLeaders geb = do Verify.verifyBlocksPrefix + pm ccHash0 Nothing ccInitLeaders (OldestFirst []) (Right <$> geb :: OldestFirst NE Block) - validateSuccEpoch :: EpochBlocks NE + validateSuccEpoch :: ProtocolMagic + -> EpochBlocks NE -> Verify VerifyBlocksException (OldestFirst NE Undo) - validateSuccEpoch (SuccEpochBlocks ebb emb) = do + validateSuccEpoch pm (SuccEpochBlocks ebb emb) = do Verify.verifyBlocksPrefix + pm (ebb ^. headerHashG) Nothing (ebb ^. gbBody . gbLeaders) diff --git a/utxo/src/UTxO/Verify.hs b/utxo/src/UTxO/Verify.hs index b702a80b59a..353a7f5da6f 100644 --- a/utxo/src/UTxO/Verify.hs +++ b/utxo/src/UTxO/Verify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} + -- | Pure versions of the Cardano verification functions module UTxO.Verify ( @@ -32,6 +33,7 @@ import Pos.Chain.Txp import Pos.Chain.Update import Pos.Core import Pos.Core.Chrono +import Pos.Crypto (ProtocolMagic) import Pos.DB.Block (toTxpBlock) import Pos.DB.Class (MonadGState (..)) import Pos.DB.Txp (TxpBlock) @@ -43,7 +45,6 @@ import Serokell.Util.Verify import Test.Pos.Chain.Genesis.Dummy (dummyBlockVersionData, dummyConfig, dummyEpochSlots, dummyGenesisData, dummyK) -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) {------------------------------------------------------------------------------- Verification environment @@ -227,13 +228,14 @@ mapVerifyErrors f (Verify ma) = Verify $ mapStateT (withExceptT f) ma -- corresponding functions from the Cardano core. This didn't look very easy -- so I skipped it for now. verifyBlocksPrefix - :: HeaderHash -- ^ Expected tip + :: ProtocolMagic -- ^ Protocol magic + -> HeaderHash -- ^ Expected tip -> Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch -> LastBlkSlots -- ^ Last block slots -> OldestFirst NE Block -> Verify VerifyBlocksException (OldestFirst NE Undo) -verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do +verifyBlocksPrefix pm tip curSlot leaders lastSlots blocks = do when (tip /= blocks ^. _Wrapped . _neHead . prevBlockL) $ throwError $ VerifyBlocksError "the first block isn't based on the tip" @@ -251,7 +253,7 @@ verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do -- Verify transactions txUndo <- mapVerifyErrors (VerifyBlocksError . pretty) $ - tgsVerifyBlocks $ map toTxpBlock blocks + tgsVerifyBlocks pm $ map toTxpBlock blocks -- Skip delegation verification {- @@ -355,15 +357,16 @@ slogVerifyBlocks curSlot leaders lastSlots blocks = do -- * We include teh transaction in the failure -- I don't fully grasp the consequences of this. tgsVerifyBlocks - :: OldestFirst NE TxpBlock + :: ProtocolMagic + -> OldestFirst NE TxpBlock -> Verify VerifyBlockFailure (OldestFirst NE TxpUndo) -tgsVerifyBlocks newChain = do +tgsVerifyBlocks pm newChain = do bvd <- gsAdoptedBVData let epoch = NE.last (getOldestFirst newChain) ^. epochIndexL let verifyPure :: [TxAux] -> Verify VerifyBlockFailure TxpUndo verifyPure txs = nat $ withExceptT (verifyBlockFailure txs) $ - verifyToil dummyProtocolMagic bvd mempty epoch dataMustBeKnown txs + verifyToil pm bvd mempty epoch dataMustBeKnown txs mapM (verifyPure . convertPayload) newChain where convertPayload :: TxpBlock -> [TxAux] diff --git a/wallet-new/src/Cardano/Wallet/Action.hs b/wallet-new/src/Cardano/Wallet/Action.hs index 035a88850b4..17236532daf 100644 --- a/wallet-new/src/Cardano/Wallet/Action.hs +++ b/wallet-new/src/Cardano/Wallet/Action.hs @@ -65,7 +65,8 @@ actionWithWallet params genesisConfig walletConfig txpConfig ntpConfig nodeParam , Kernel.dbPathMetadata = dbPath <> "-sqlite.sqlite3" , Kernel.dbRebuild = rebuildDB }) - WalletLayer.Kernel.bracketPassiveWallet dbMode logMessage' keystore nodeState (npFInjects nodeParams) $ \walletLayer passiveWallet -> do + let pm = configProtocolMagic genesisConfig + WalletLayer.Kernel.bracketPassiveWallet pm dbMode logMessage' keystore nodeState (npFInjects nodeParams) $ \walletLayer passiveWallet -> do migrateLegacyDataLayer passiveWallet dbPath (getFullMigrationFlag params) let plugs = plugins (walletLayer, passiveWallet) dbMode @@ -77,15 +78,13 @@ actionWithWallet params genesisConfig walletConfig txpConfig ntpConfig nodeParam walletLayer (runNode genesisConfig txpConfig nodeRes plugs) where - pm = configProtocolMagic genesisConfig - plugins :: (PassiveWalletLayer IO, PassiveWallet) -> Kernel.DatabaseMode -> [ (Text, Plugins.Plugin Kernel.Mode.WalletMode) ] plugins w dbMode = concat [ -- The actual wallet backend server. [ - ("wallet-new api worker", Plugins.apiServer pm params w + ("wallet-new api worker", Plugins.apiServer params w [ faultInjectionHandleIgnoreAPI (npFInjects nodeParams) -- This allows dynamic control of fault injection , throttleMiddleware (ccThrottle walletConfig) -- Throttle requests , withDefaultHeader Headers.applicationJson diff --git a/wallet-new/src/Cardano/Wallet/Kernel.hs b/wallet-new/src/Cardano/Wallet/Kernel.hs index fbfba29dc7d..15f55ed8344 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel.hs @@ -94,18 +94,19 @@ defaultSqlitePath = "./wallet-db-sqlite.sqlite3" -- it shouldn't be too specific. bracketPassiveWallet :: (MonadMask m, MonadIO m) - => DatabaseMode + => ProtocolMagic + -> DatabaseMode -> (Severity -> Text -> IO ()) -> Keystore -> NodeStateAdaptor IO -> FInjects IO -> (PassiveWallet -> m a) -> m a -bracketPassiveWallet mode logMsg keystore node fInjects f = +bracketPassiveWallet pm mode logMsg keystore node fInjects f = bracket (liftIO $ handlesOpen mode) (liftIO . handlesClose mode) (\ handles -> bracket - (liftIO $ initPassiveWallet logMsg keystore handles node fInjects) + (liftIO $ initPassiveWallet pm logMsg keystore handles node fInjects) (\_ -> return ()) f) @@ -151,13 +152,14 @@ handlesClose dbMode (Handles acidDb meta) = do -------------------------------------------------------------------------------} -- | Initialise Passive Wallet -initPassiveWallet :: (Severity -> Text -> IO ()) +initPassiveWallet :: ProtocolMagic + -> (Severity -> Text -> IO ()) -> Keystore -> WalletHandles -> NodeStateAdaptor IO -> FInjects IO -> IO PassiveWallet -initPassiveWallet logMessage keystore handles node fInjects = do +initPassiveWallet pm logMessage keystore handles node fInjects = do pw <- preparePassiveWallet initSubmission pw return pw @@ -173,6 +175,7 @@ initPassiveWallet logMessage keystore handles node fInjects = do _walletLogMessage = logMessage , _walletKeystore = keystore , _wallets = hAcid handles + , _walletProtocolMagic = pm , _walletMeta = hMeta handles , _walletNode = node , _walletSubmission = submission @@ -194,12 +197,10 @@ initPassiveWallet logMessage keystore handles node fInjects = do -- | Initialize the active wallet bracketActiveWallet :: (MonadMask m, MonadIO m) - => ProtocolMagic - -> PassiveWallet + => PassiveWallet -> WalletDiffusion -> (ActiveWallet -> m a) -> m a -bracketActiveWallet walletProtocolMagic - walletPassive +bracketActiveWallet walletPassive walletDiffusion runActiveWallet = do submissionLayerTicker <- liftIO $ async $ diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs b/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs index 6ede39f8547..ee2a4668433 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Addresses.hs @@ -17,7 +17,7 @@ import System.Random.MWC (GenIO, createSystemRandom, uniformR) import Data.Acid (update) import Pos.Core (Address, IsBootstrapEraAddr (..), deriveLvl2KeyPair) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (NetworkMagic, makeNetworkMagic) import Pos.Crypto (EncryptedSecretKey, PassPhrase, ShouldCheckPassphrase (..)) @@ -31,7 +31,7 @@ import Cardano.Wallet.Kernel.DB.HdWallet.Create import Cardano.Wallet.Kernel.DB.HdWallet.Derivation (HardeningMode (..), deriveIndex) import Cardano.Wallet.Kernel.Internal (PassiveWallet, walletKeystore, - wallets) + walletProtocolMagic, wallets) import qualified Cardano.Wallet.Kernel.Keystore as Keystore import Cardano.Wallet.Kernel.Types (AccountId (..), WalletId (..)) import Cardano.Wallet.WalletLayer.Kernel.Conv (toCardanoAddress) @@ -136,7 +136,8 @@ createHdRndAddress spendingPassword esk accId pw = do tryGenerateAddress gen collisions = do newIndex <- deriveIndex (flip uniformR gen) HdAddressIx HardDerivation let hdAddressId = HdAddressId accId newIndex - mbAddr = newHdAddress esk spendingPassword accId hdAddressId + nm = makeNetworkMagic $ pw ^. walletProtocolMagic + mbAddr = newHdAddress nm esk spendingPassword accId hdAddressId case mbAddr of Nothing -> return (Left $ CreateAddressHdRndGenerationFailed accId) Just hdAddress -> do @@ -156,13 +157,14 @@ createHdRndAddress spendingPassword esk accId pw = do -- | Generates a new 'HdAddress' by performing the HD crypto derivation -- underneath. Returns 'Nothing' if the cryptographic derivation fails. -newHdAddress :: EncryptedSecretKey +newHdAddress :: NetworkMagic + -> EncryptedSecretKey -> PassPhrase -> HdAccountId -> HdAddressId -> Maybe HdAddress -newHdAddress esk spendingPassword accId hdAddressId = - let mbAddr = deriveLvl2KeyPair fixedNM +newHdAddress nm esk spendingPassword accId hdAddressId = + let mbAddr = deriveLvl2KeyPair nm (IsBootstrapEraAddr True) (ShouldCheckPassphrase True) spendingPassword @@ -172,6 +174,3 @@ newHdAddress esk spendingPassword accId hdAddressId = in case mbAddr of Nothing -> Nothing Just (newAddress, _) -> Just $ initHdAddress hdAddressId newAddress - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs index abe8c0c32ba..55c1931d435 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs @@ -420,8 +420,16 @@ estimateCardanoFee linearFeePolicy ins outs -- -- NOTE: When the /actual/ size exceeds this bounds, we may underestimate -- tranasction fees and potentially generate invalid transactions. +-- +-- `boundAddrAttrSize` needed to increase due to the inclusion of +-- `NetworkMagic` in `AddrAttributes`. The `Bi` instance of +-- `AddrAttributes` serializes `NetworkTestnet` as [(Word8,Int32)] and +-- `NetworkMainOrStage` as []; this should require a 5 Byte increase in +--`boundAddrAttrSize`. Because encoding in unit tests is not guaranteed +-- to be efficient, it was decided to increase by 7 Bytes to mitigate +-- against potential random test failures in the future. boundAddrAttrSize :: Byte -boundAddrAttrSize = 34 +boundAddrAttrSize = 34 + 7 -- 7 bytes for potential NetworkMagic -- | Size to use for a value of type @Attributes ()@ when estimating -- encoded transaction sizes. The minimum possible value is 2. diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs b/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs index a16db56ac89..e919e7f08f1 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs @@ -13,6 +13,7 @@ module Cardano.Wallet.Kernel.Internal ( , walletKeystore , walletMeta , wallets + , walletProtocolMagic , walletLogMessage , walletNode , walletSubmission @@ -84,6 +85,9 @@ data PassiveWallet = PassiveWallet { -- | An opaque handle to a place where we store the 'EncryptedSecretKey'. , _wallets :: AcidState DB + -- | The protocol magic used by an `ActiveWallet` to make transactions. + , _walletProtocolMagic :: ProtocolMagic + -- | Database handle , _walletMeta :: MetaDBHandle @@ -214,9 +218,7 @@ stopAllRestorations pw = do -- send new transactions. data ActiveWallet = ActiveWallet { -- | The underlying passive wallet - walletPassive :: PassiveWallet + walletPassive :: PassiveWallet -- | The wallet diffusion layer - , walletDiffusion :: WalletDiffusion - -- | The protocol magic used to make transactions. - , walletProtocolMagic :: ProtocolMagic + , walletDiffusion :: WalletDiffusion } diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Transactions.hs b/wallet-new/src/Cardano/Wallet/Kernel/Transactions.hs index 6d7b5a7f850..a53e6209f9b 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Transactions.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Transactions.hs @@ -74,7 +74,7 @@ import Pos.Chain.Txp as Core (TxAttributes, TxAux, TxIn, TxOut, import qualified Pos.Client.Txp.Util as CTxp import Pos.Core (Address, Coin, TxFeePolicy (..), unsafeSubCoin) import qualified Pos.Core as Core -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) import Pos.Crypto (EncryptedSecretKey, PassPhrase, ProtocolMagic, PublicKey, RedeemSecretKey, SafeSigner (..), ShouldCheckPassphrase (..), Signature (..), hash, @@ -400,6 +400,8 @@ newTransaction -- ^ The payees. -> IO (Either NewTransactionError (TxAux, PartialTxMeta, Utxo)) newTransaction aw@ActiveWallet{..} spendingPassword options accountId payees = do + let pm = walletPassive ^. Internal.walletProtocolMagic + nm = makeNetworkMagic pm tx <- newUnsignedTransaction aw options accountId payees case tx of Left e -> return (Left e) @@ -419,8 +421,8 @@ newTransaction aw@ActiveWallet{..} spendingPassword options accountId payees = d let inputs = unsignedTxInputs unsignedTx outputs = unsignedTxOutputs unsignedTx - signAddress = mkSigner spendingPassword mbEsk db - mkTx = mkStdTx walletProtocolMagic shuffleNE signAddress + signAddress = mkSigner nm spendingPassword mbEsk db + mkTx = mkStdTx pm shuffleNE signAddress -- STEP 3: Creates the @signed@ transaction using data from the -- unsigned one. @@ -581,13 +583,14 @@ instance Buildable SignTransactionError where instance Arbitrary SignTransactionError where arbitrary = oneof [] -mkSigner :: PassPhrase +mkSigner :: NetworkMagic + -> PassPhrase -> Maybe EncryptedSecretKey -> DB -> Address -> Either SignTransactionError SafeSigner -mkSigner _ Nothing _ addr = Left (SignTransactionMissingKey addr) -mkSigner spendingPassword (Just esk) snapshot addr = +mkSigner _ _ Nothing _ addr = Left (SignTransactionMissingKey addr) +mkSigner nm spendingPassword (Just esk) snapshot addr = case Getters.lookupCardanoAddress snapshot addr of Left _ -> Left (SignTransactionErrorUnknownAddress addr) Right hdAddr -> @@ -598,7 +601,7 @@ mkSigner spendingPassword (Just esk) snapshot addr = . HD.hdAddressIdParent . HD.hdAccountIdIx . to HD.getHdAccountIx - res = Core.deriveLvl2KeyPair fixedNM + res = Core.deriveLvl2KeyPair nm (Core.IsBootstrapEraAddr True) (ShouldCheckPassphrase False) spendingPassword @@ -677,6 +680,7 @@ redeemAda :: ActiveWallet -> RedeemSecretKey -- ^ Redemption key -> IO (Either RedeemAdaError (Tx, TxMeta)) redeemAda w@ActiveWallet{..} accId pw rsk = runExceptT $ do + let pm = walletPassive ^. Internal.walletProtocolMagic snapshot <- liftIO $ getWalletSnapshot walletPassive _accExists <- withExceptT RedeemAdaUnknownAccountId $ exceptT $ lookupHdAccountId snapshot accId @@ -685,7 +689,7 @@ redeemAda w@ActiveWallet{..} accId pw rsk = runExceptT $ do pw (AccountIdHdRnd accId) walletPassive - (tx, meta) <- mkTx changeAddr + (tx, meta) <- mkTx pm changeAddr withExceptT RedeemAdaNewForeignFailed $ ExceptT $ liftIO $ newForeign w @@ -694,13 +698,14 @@ redeemAda w@ActiveWallet{..} accId pw rsk = runExceptT $ do meta return (taTx tx, meta) where - redeemAddr :: Address - redeemAddr = Core.makeRedeemAddress fixedNM $ redeemToPublic rsk + redeemAddr :: NetworkMagic -> Address + redeemAddr nm = Core.makeRedeemAddress nm $ redeemToPublic rsk -- | Note: we use `getCreationTimestamp` provided by the `NodeStateAdaptor` -- to compute the createdAt timestamp for `TxMeta` - mkTx :: Address -> ExceptT RedeemAdaError IO (TxAux, TxMeta) - mkTx output = do + mkTx :: ProtocolMagic -> Address -> ExceptT RedeemAdaError IO (TxAux, TxMeta) + mkTx pm output = do + let nm = makeNetworkMagic pm now <- liftIO $ Node.getCreationTimestamp (walletPassive ^. walletNode) utxo <- liftIO $ Node.withNodeState (walletPassive ^. walletNode) $ \_lock -> @@ -708,18 +713,18 @@ redeemAda w@ActiveWallet{..} accId pw rsk = runExceptT $ do (inp@(TxInUtxo inHash inIx), coin) <- case utxo of [i] -> return i - [] -> throwError $ RedeemAdaNotAvailable redeemAddr - _:_:_ -> throwError $ RedeemAdaMultipleOutputs redeemAddr + [] -> throwError $ RedeemAdaNotAvailable (redeemAddr nm) + _:_:_ -> throwError $ RedeemAdaMultipleOutputs (redeemAddr nm) let out = TxOutAux $ TxOut output coin txAux = CTxp.makeRedemptionTx - walletProtocolMagic + pm rsk (inp :| []) (out :| []) txMeta = TxMeta { _txMetaId = hash (taTx txAux) , _txMetaAmount = coin - , _txMetaInputs = (inHash, inIx, redeemAddr, coin) :| [] + , _txMetaInputs = (inHash, inIx, redeemAddr nm, coin) :| [] , _txMetaOutputs = (output, coin) :| [] , _txMetaCreationAt = now , _txMetaIsLocal = False -- input does not belong to wallet @@ -731,7 +736,8 @@ redeemAda w@ActiveWallet{..} accId pw rsk = runExceptT $ do where isOutput :: (TxIn, TxOutAux) -> Maybe (TxIn, Coin) isOutput (inp, TxOutAux (TxOut addr coin)) = do - guard $ addr == redeemAddr + let nm = makeNetworkMagic pm + guard $ addr == (redeemAddr nm) return (inp, coin) -- | Generates the list of change outputs from a list of change coins. @@ -800,6 +806,3 @@ mkStdTx pm shuffle hdwSigners inps outs change = do -- 'TxOwnedInputs'. repack :: (Core.TxIn, Core.TxOutAux) -> (Core.TxOut, Core.TxIn) repack (txIn, aux) = (Core.toaOut aux, txIn) - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs b/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs index 8407973f883..f9d3e4d1379 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Wallets.hs @@ -23,6 +23,7 @@ import qualified Formatting.Buildable import Data.Acid.Advanced (update') import Pos.Core (Address, Timestamp) +import Pos.Core.NetworkMagic (NetworkMagic) import Pos.Crypto (EncryptedSecretKey, HDPassphrase, PassPhrase, changeEncPassphrase, checkPassMatches, emptyPassphrase, firstHardened, safeDeterministicKeyGen) @@ -113,7 +114,8 @@ instance Show UpdateWalletPasswordError where -- PRECONDITION: The input 'Mnemonic' should be supplied by the frontend such -- that this is a brand new 'Mnemonic' never used before on the blockchain. For -- other wallets restoration should be used. -createHdWallet :: PassiveWallet +createHdWallet :: NetworkMagic + -> PassiveWallet -> Mnemonic nat -- ^ The set of words (i.e the mnemonic) to generate the initial seed. -- See @@ -132,7 +134,7 @@ createHdWallet :: PassiveWallet -> WalletName -- ^ The name for this wallet. -> IO (Either CreateWalletError HdRoot) -createHdWallet pw mnemonic spendingPassword assuranceLevel walletName = do +createHdWallet nm pw mnemonic spendingPassword assuranceLevel walletName = do -- STEP 1: Generate the 'EncryptedSecretKey' outside any acid-state -- transaction, to not leak it into acid-state's transaction logs. let (_, esk) = safeDeterministicKeyGen (BIP39.mnemonicToSeed mnemonic) spendingPassword @@ -158,7 +160,8 @@ createHdWallet pw mnemonic spendingPassword assuranceLevel walletName = do -- STEP 2.5: Generate the fresh Cardano Address which will be used for the -- companion 'HdAddress' let mbHdAddress = - newHdAddress esk + newHdAddress nm + esk spendingPassword (defaultHdAccountId newRootId) (defaultHdAddressId newRootId) @@ -260,14 +263,15 @@ createWalletHdRnd pw hasSpendingPassword defaultCardanoAddress name assuranceLev -- | Creates a default 'HdAddress' at a fixed derivation path. This is -- useful for tests, but otherwise you may want to use 'defaultHdAddressWith'. -defaultHdAddress :: EncryptedSecretKey +defaultHdAddress :: NetworkMagic + -> EncryptedSecretKey -> PassPhrase -> HD.HdRootId -> Maybe HdAddress -defaultHdAddress esk spendingPassword rootId = +defaultHdAddress nm esk spendingPassword rootId = let hdAccountId = defaultHdAccountId rootId hdAddressId = HdAddressId hdAccountId (HdAddressIx firstHardened) - in newHdAddress esk spendingPassword hdAccountId hdAddressId + in newHdAddress nm esk spendingPassword hdAccountId hdAddressId -- | Given a Cardano 'Address', it returns a default 'HdAddress' at a fixed -- and predictable generation path. diff --git a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs index f148de1a1d7..e9d8a128e3f 100644 --- a/wallet-new/src/Cardano/Wallet/Server/Plugins.hs +++ b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs @@ -48,7 +48,6 @@ import qualified Cardano.Wallet.WalletLayer as WalletLayer import qualified Cardano.Wallet.WalletLayer.Kernel as WalletLayer.Kernel import Pos.Chain.Update (cpsSoftwareVersion) -import Pos.Crypto (ProtocolMagic) import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Infra.Shutdown (HasShutdownContext (shutdownContext), ShutdownContext) @@ -68,15 +67,14 @@ type Plugin m = Diffusion m -> m () -- | A @Plugin@ to start the wallet REST server apiServer - :: ProtocolMagic - -> NewWalletBackendParams + :: NewWalletBackendParams -> (PassiveWalletLayer IO, PassiveWallet) -> [Middleware] -> Plugin Kernel.WalletMode -apiServer protocolMagic (NewWalletBackendParams WalletBackendParams{..}) (passiveLayer, passiveWallet) middlewares diffusion = do +apiServer (NewWalletBackendParams WalletBackendParams{..}) (passiveLayer, passiveWallet) middlewares diffusion = do env <- ask let diffusion' = Kernel.fromDiffusion (lower env) diffusion - WalletLayer.Kernel.bracketActiveWallet protocolMagic passiveLayer passiveWallet diffusion' $ \active _ -> do + WalletLayer.Kernel.bracketActiveWallet passiveLayer passiveWallet diffusion' $ \active _ -> do ctx <- view shutdownContext serveImpl (getApplication active) diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs index d918b33f380..daafe162093 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs @@ -52,14 +52,15 @@ import qualified Cardano.Wallet.WalletLayer.Kernel.Wallets as Wallets -- The passive wallet cannot send new transactions. bracketPassiveWallet :: forall m n a. (MonadIO n, MonadUnliftIO m, MonadMask m) - => Kernel.DatabaseMode + => ProtocolMagic + -> Kernel.DatabaseMode -> (Severity -> Text -> IO ()) -> Keystore -> NodeStateAdaptor IO -> FInjects IO -> (PassiveWalletLayer n -> Kernel.PassiveWallet -> m a) -> m a -bracketPassiveWallet mode logFunction keystore node fInjects f = do - Kernel.bracketPassiveWallet mode logFunction keystore node fInjects $ \w -> do +bracketPassiveWallet pm mode logFunction keystore node fInjects f = do + Kernel.bracketPassiveWallet pm mode logFunction keystore node fInjects $ \w -> do -- For each wallet in a restoration state, re-start the background -- restoration tasks. @@ -156,13 +157,12 @@ bracketPassiveWallet mode logFunction keystore node fInjects f = do -- 'WalletDiffusion' layer in scope. bracketActiveWallet :: forall m n a. (MonadIO m, MonadMask m, MonadIO n) - => ProtocolMagic - -> PassiveWalletLayer n + => PassiveWalletLayer n -> Kernel.PassiveWallet -> WalletDiffusion -> (ActiveWalletLayer n -> Kernel.ActiveWallet -> m a) -> m a -bracketActiveWallet pm walletPassiveLayer passiveWallet walletDiffusion runActiveLayer = - Kernel.bracketActiveWallet pm passiveWallet walletDiffusion $ \w -> do +bracketActiveWallet walletPassiveLayer passiveWallet walletDiffusion runActiveLayer = + Kernel.bracketActiveWallet passiveWallet walletDiffusion $ \w -> do bracket (return (activeWalletLayer w)) (\_ -> return ()) diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs index bcc755e0d91..7a2a98ce9b8 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel/Wallets.hs @@ -20,6 +20,7 @@ import qualified Data.Map.Strict as Map import Pos.Chain.Block (Blund) import Pos.Chain.Txp (Utxo) import Pos.Core (mkCoin) +import Pos.Core.NetworkMagic (NetworkMagic, makeNetworkMagic) import Pos.Core.Slotting (Timestamp) import Pos.Crypto.Signing @@ -33,7 +34,8 @@ import Cardano.Wallet.Kernel.DB.InDb (fromDb) import Cardano.Wallet.Kernel.DB.TxMeta (TxMeta) import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet) import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet -import Cardano.Wallet.Kernel.Internal (walletKeystore, _wriProgress) +import Cardano.Wallet.Kernel.Internal (walletKeystore, + walletProtocolMagic, _wriProgress) import qualified Cardano.Wallet.Kernel.Internal as Kernel import qualified Cardano.Wallet.Kernel.Keystore as Keystore import Cardano.Wallet.Kernel.PrefilterTx (PrefilteredBlock, @@ -55,49 +57,55 @@ createWallet :: MonadIO m -> CreateWallet -> m (Either CreateWalletError V1.Wallet) createWallet wallet newWalletRequest = liftIO $ do + let nm = makeNetworkMagic $ wallet ^. walletProtocolMagic now <- liftIO getCurrentTimestamp case newWalletRequest of CreateWallet newWallet@V1.NewWallet{..} -> case newwalOperation of - V1.RestoreWallet -> restore newWallet now - V1.CreateWallet -> create newWallet now + V1.RestoreWallet -> restore nm newWallet now + V1.CreateWallet -> create nm newWallet now ImportWalletFromESK esk mbSpendingPassword -> - restoreFromESK esk + restoreFromESK nm + esk (spendingPassword mbSpendingPassword) now "Imported Wallet" HD.AssuranceLevelNormal where - create :: V1.NewWallet -> Timestamp -> IO (Either CreateWalletError V1.Wallet) - create newWallet@V1.NewWallet{..} now = runExceptT $ do + create :: NetworkMagic -> V1.NewWallet -> Timestamp -> IO (Either CreateWalletError V1.Wallet) + create nm newWallet@V1.NewWallet{..} now = runExceptT $ do root <- withExceptT CreateWalletError $ ExceptT $ - Kernel.createHdWallet wallet + Kernel.createHdWallet nm + wallet (mnemonic newWallet) (spendingPassword newwalSpendingPassword) (fromAssuranceLevel newwalAssuranceLevel) (HD.WalletName newwalName) return (mkRoot newwalName newwalAssuranceLevel now root) - restore :: V1.NewWallet + restore :: NetworkMagic + -> V1.NewWallet -> Timestamp -> IO (Either CreateWalletError V1.Wallet) - restore newWallet@V1.NewWallet{..} now = do + restore nm newWallet@V1.NewWallet{..} now = do let esk = snd $ safeDeterministicKeyGen (BIP39.mnemonicToSeed (mnemonic newWallet)) (spendingPassword newwalSpendingPassword) - restoreFromESK esk + restoreFromESK nm + esk (spendingPassword newwalSpendingPassword) now newwalName (fromAssuranceLevel newwalAssuranceLevel) - restoreFromESK :: EncryptedSecretKey + restoreFromESK :: NetworkMagic + -> EncryptedSecretKey -> PassPhrase -> Timestamp -> Text -> HD.AssuranceLevel -> IO (Either CreateWalletError V1.Wallet) - restoreFromESK esk pwd now walletName hdAssuranceLevel = runExceptT $ do + restoreFromESK nm esk pwd now walletName hdAssuranceLevel = runExceptT $ do let rootId = HD.eskToHdRootId esk wId = WalletIdHdRnd rootId @@ -106,7 +114,8 @@ createWallet wallet newWalletRequest = liftIO $ do -- Synchronously restore the wallet balance, and begin to -- asynchronously reconstruct the wallet's history. - let mbHdAddress = newHdAddress esk + let mbHdAddress = newHdAddress nm + esk pwd (Kernel.defaultHdAccountId rootId) (Kernel.defaultHdAddressId rootId) diff --git a/wallet-new/test/InternalAPISpec.hs b/wallet-new/test/InternalAPISpec.hs index 1b7e96a4ac6..5554ffd3941 100644 --- a/wallet-new/test/InternalAPISpec.hs +++ b/wallet-new/test/InternalAPISpec.hs @@ -16,17 +16,20 @@ module InternalAPISpec (spec) where import Universum +import Pos.Chain.Genesis as Genesis (Config) import Pos.Client.KeyStorage (getSecretKeysPlain) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.Wallet.Web.Account (genSaveRootKey) import Pos.Launcher (HasConfigurations) import Pos.Util.Wlog (setupTestLogging) import Test.Pos.Util.QuickCheck.Property (assertProperty) -import Test.Hspec (Spec, beforeAll_, describe) +import Test.Hspec (Spec, beforeAll_, describe, runIO) import Test.Hspec.QuickCheck (modifyMaxSuccess) -import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Wallet.Web.Mode (walletPropertySpec) +import Test.QuickCheck (arbitrary, generate) import Cardano.Wallet.API.Internal.LegacyHandlers (resetWalletState) import Cardano.Wallet.Server.CLI (RunMode (..)) @@ -36,14 +39,25 @@ import Servant {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} spec :: Spec -spec = beforeAll_ setupTestLogging $ - withDefConfigurations $ \_ _ _ -> +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = beforeAll_ setupTestLogging $ + withProvidedMagicConfig pm $ \genesisConfig _ _ -> describe "development endpoint" $ - describe "secret-keys" $ modifyMaxSuccess (const 10) deleteAllSecretKeysSpec + describe "secret-keys" $ modifyMaxSuccess (const 10) (deleteAllSecretKeysSpec genesisConfig) -deleteAllSecretKeysSpec :: (HasConfigurations) => Spec -deleteAllSecretKeysSpec = do - walletPropertySpec "does remove all secret keys in debug mode mode" $ do +deleteAllSecretKeysSpec :: (HasConfigurations) => Genesis.Config -> Spec +deleteAllSecretKeysSpec genesisConfig = do + walletPropertySpec genesisConfig "does remove all secret keys in debug mode mode" $ do void $ lift $ genSaveRootKey mempty def sKeys <- lift getSecretKeysPlain assertProperty (not $ null sKeys) @@ -54,7 +68,7 @@ deleteAllSecretKeysSpec = do assertProperty (null sKeys') "Oooops, secret keys not have been deleted in debug mode" - walletPropertySpec "does not delete secret keys in production mode" $ do + walletPropertySpec genesisConfig "does not delete secret keys in production mode" $ do void $ lift $ genSaveRootKey mempty def sKeys <- lift getSecretKeysPlain assertProperty (not $ null sKeys) diff --git a/wallet-new/test/unit/Test/Spec/Accounts.hs b/wallet-new/test/unit/Test/Spec/Accounts.hs index e3925697e98..ac396f1336b 100644 --- a/wallet-new/test/unit/Test/Spec/Accounts.hs +++ b/wallet-new/test/unit/Test/Spec/Accounts.hs @@ -30,6 +30,7 @@ import Control.Monad.Except (runExceptT) import Servant.Server import Pos.Core.Common (mkCoin) +import Pos.Crypto (ProtocolMagic (..)) import Pos.Crypto.HD (firstHardened) import Test.Spec.Fixture (GenPassiveWalletFixture, @@ -61,14 +62,15 @@ prepareFixtures = do Right v1Wallet -> return (Fixture spendingPassword v1Wallet newAccountRq) withFixture :: MonadIO m - => ( Keystore.Keystore + => ProtocolMagic + -> ( Keystore.Keystore -> PassiveWalletLayer m -> Internal.PassiveWallet -> Fixture -> IO a ) -> PropertyM IO a -withFixture cc = withPassiveWalletFixture prepareFixtures cc +withFixture pm cc = withPassiveWalletFixture pm prepareFixtures cc spec :: Spec @@ -77,7 +79,8 @@ spec = describe "Accounts" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do res <- WalletLayer.createAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq @@ -88,7 +91,8 @@ spec = describe "Accounts" $ do wId <- pick arbitrary pwd <- genSpendingPassword request <- genNewAccountRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do res <- WalletLayer.createAccount layer wId request case res of Left (WalletLayer.CreateAccountError (CreateAccountKeystoreNotFound _)) -> @@ -104,7 +108,8 @@ spec = describe "Accounts" $ do prop "works when called from Servant" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let hdl = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq res <- runExceptT . runHandler' $ hdl (bimap identity STB res) `shouldSatisfy` isRight @@ -114,7 +119,8 @@ spec = describe "Accounts" $ do -- addresses. Remember, it's only when we create a new HdRoot that -- we enforce this invariant. monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let hdl = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq res <- runExceptT . runHandler' $ hdl case res of @@ -126,7 +132,8 @@ spec = describe "Accounts" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet (Right V1.Account{..}) <- WalletLayer.createAccount layer wId fixtureNewAccountRq @@ -136,7 +143,8 @@ spec = describe "Accounts" $ do prop "fails if the parent wallet doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do res <- WalletLayer.deleteAccount layer wId (V1.unsafeMkAccountIndex firstHardened) case res of @@ -153,7 +161,8 @@ spec = describe "Accounts" $ do prop "fails if the account doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- Pick the first non-allocated index after 'firstHardened', -- as by defaults each fixture's wallet is created with a -- default account at index 'firstHardened'. @@ -174,7 +183,8 @@ spec = describe "Accounts" $ do prop "works when called from Servant" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let create = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq (Right API.WalletResponse{..}) <- runExceptT . runHandler' $ create let accountIndex = V1.accIndex wrData @@ -189,7 +199,8 @@ spec = describe "Accounts" $ do prop "Servant handler fails if the parent wallet doesn't exist" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do let delete = Handlers.deleteAccount layer wId (V1.unsafeMkAccountIndex 2147483648) @@ -201,7 +212,8 @@ spec = describe "Accounts" $ do prop "Servant handler fails if the account doesn't exist" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- Pick the first non-allocated index after 'firstHardened', -- as by defaults each fixture's wallet is created with a -- default account at index 'firstHardened'. @@ -219,7 +231,8 @@ spec = describe "Accounts" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet (Right V1.Account{..}) <- WalletLayer.createAccount layer wId fixtureNewAccountRq @@ -233,7 +246,8 @@ spec = describe "Accounts" $ do prop "fails if the parent wallet doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do res <- WalletLayer.updateAccount layer wId (V1.unsafeMkAccountIndex 2147483648) @@ -252,7 +266,8 @@ spec = describe "Accounts" $ do prop "fails if the account doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet -- Pick the first non-allocated index after 'firstHardened', -- as by defaults each fixture's wallet is created with a @@ -275,7 +290,8 @@ spec = describe "Accounts" $ do prop "works when called from Servant" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let create = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq (Right API.WalletResponse{..}) <- runExceptT . runHandler' $ create let accountIndex = V1.accIndex wrData @@ -290,7 +306,8 @@ spec = describe "Accounts" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do (Right V1.Account{..}) <- WalletLayer.createAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq @@ -303,7 +320,8 @@ spec = describe "Accounts" $ do prop "fails if the parent wallet doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do res <- WalletLayer.getAccount layer wId (V1.unsafeMkAccountIndex 2147483648) @@ -320,7 +338,8 @@ spec = describe "Accounts" $ do prop "fails if the account doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- Pick the first non-allocated index after 'firstHardened', -- as by defaults each fixture's wallet is created with a -- default account at index 'firstHardened'. @@ -340,7 +359,8 @@ spec = describe "Accounts" $ do prop "works when called from Servant" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let create = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq (Right API.WalletResponse{..}) <- runExceptT . runHandler' $ create let accountIndex = V1.accIndex wrData @@ -354,7 +374,8 @@ spec = describe "Accounts" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. forM_ [1..4] $ \(_i :: Int) -> @@ -368,7 +389,8 @@ spec = describe "Accounts" $ do prop "fails if the parent wallet doesn't exists" $ withMaxSuccess 25 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do res <- WalletLayer.getAccounts layer wId case res of Left (WalletLayer.GetAccountsError (Kernel.UnknownHdRoot _)) -> @@ -383,7 +405,8 @@ spec = describe "Accounts" $ do prop "works when called from Servant" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let create = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. @@ -400,7 +423,8 @@ spec = describe "Accounts" $ do prop "fails if the account doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let params = API.RequestParams (API.PaginationParams (API.Page 1) (API.PerPage 10)) let filters = API.NoFilters -- Pick the first non-allocated index after 'firstHardened', @@ -425,7 +449,8 @@ spec = describe "Accounts" $ do prop "applied to each newly created accounts gives addresses as obtained from GetAccounts" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. forM_ [1..4] $ \(_i :: Int) -> @@ -449,7 +474,8 @@ spec = describe "Accounts" $ do prop "and this also works when called from Servant" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let create = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. @@ -477,7 +503,8 @@ spec = describe "Accounts" $ do prop "applied to accounts that were just updated via address creation is the same as obtained from GetAccounts" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. forM_ [1..4] $ \(_i :: Int) -> @@ -506,7 +533,8 @@ spec = describe "Accounts" $ do prop "gives zero balance for newly created account" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let zero = V1 (mkCoin 0) (Right V1.Account{..}) <- WalletLayer.createAccount layer (V1.walId fixtureV1Wallet) @@ -519,7 +547,8 @@ spec = describe "Accounts" $ do prop "fails if the account doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- Pick the first non-allocated index after 'firstHardened', -- as by defaults each fixture's wallet is created with a -- default account at index 'firstHardened'. @@ -541,7 +570,8 @@ spec = describe "Accounts" $ do prop "applied to each newly created account gives balances as obtained from GetAccounts" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. forM_ [1..4] $ \(_i :: Int) -> @@ -563,7 +593,8 @@ spec = describe "Accounts" $ do prop "and this also works when called from Servant" $ withMaxSuccess 25 $ do monadicIO $ do - withFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ layer _ Fixture{..} -> do let create = Handlers.newAccount layer (V1.walId fixtureV1Wallet) fixtureNewAccountRq -- We create 4 accounts, plus one is created automatically -- by the 'createWallet' endpoint, for a total of 5. diff --git a/wallet-new/test/unit/Test/Spec/Addresses.hs b/wallet-new/test/unit/Test/Spec/Addresses.hs index 25e297f1fdb..cb3b6c26912 100644 --- a/wallet-new/test/unit/Test/Spec/Addresses.hs +++ b/wallet-new/test/unit/Test/Spec/Addresses.hs @@ -18,8 +18,9 @@ import Test.QuickCheck (arbitrary, choose, elements, withMaxSuccess, import Test.QuickCheck.Monadic (PropertyM, monadicIO, pick) import Pos.Core (Address, addrRoot) -import Pos.Crypto (EncryptedSecretKey, emptyPassphrase, firstHardened, - safeDeterministicKeyGen) +import Pos.Core.NetworkMagic (NetworkMagic, makeNetworkMagic) +import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, emptyPassphrase, + firstHardened, safeDeterministicKeyGen) import Cardano.Wallet.API.Request (RequestParams (..)) import Cardano.Wallet.API.Request.Pagination (Page (..), @@ -71,8 +72,8 @@ data AddressFixture = AddressFixture { -- | Prepare some fixtures using the 'PropertyM' context to prepare the data, -- and execute the 'acid-state' update once the 'PassiveWallet' gets into -- scope (after the bracket initialisation). -prepareFixtures :: Fixture.GenPassiveWalletFixture Fixture -prepareFixtures = do +prepareFixtures :: NetworkMagic -> Fixture.GenPassiveWalletFixture Fixture +prepareFixtures nm = do let (_, esk) = safeDeterministicKeyGen (B.pack $ replicate 32 0x42) mempty let newRootId = eskToHdRootId esk newRoot <- initHdRoot <$> pure newRootId @@ -83,7 +84,7 @@ prepareFixtures = do newAccountId <- HdAccountId newRootId <$> deriveIndex (pick . choose) HdAccountIx HardDerivation let accounts = M.singleton newAccountId mempty hdAccountId = Kernel.defaultHdAccountId newRootId - (Just hdAddress) = Kernel.defaultHdAddress esk emptyPassphrase newRootId + (Just hdAddress) = Kernel.defaultHdAddress nm esk emptyPassphrase newRootId return $ \pw -> do void $ liftIO $ update (pw ^. wallets) (CreateHdWallet newRoot hdAccountId hdAddress accounts) @@ -158,17 +159,21 @@ prepareAddressesFixture (DesiredNewAccs acn) (DesiredNewAddrs adn) = do -- one address. return $ (M.fromList res, (acn + 1)*(adn + 1) - acn) -withFixture :: ( Keystore.Keystore +withFixture :: ProtocolMagic + -> ( Keystore.Keystore -> PassiveWalletLayer IO -> PassiveWallet -> Fixture -> IO a ) -> PropertyM IO a -withFixture = Fixture.withPassiveWalletFixture prepareFixtures +withFixture pm = Fixture.withPassiveWalletFixture pm (prepareFixtures nm) + where + nm = makeNetworkMagic pm withAddressFixtures - :: Int -- Number of fixture addresses to create + :: ProtocolMagic + -> Int -- Number of fixture addresses to create -> ( Keystore.Keystore -> PassiveWalletLayer IO -> PassiveWallet @@ -176,12 +181,13 @@ withAddressFixtures -> IO a ) -> PropertyM IO a -withAddressFixtures n = - Fixture.withPassiveWalletFixture $ do +withAddressFixtures pm n = + Fixture.withPassiveWalletFixture pm $ do prepareAddressFixture n withAddressesFixtures - :: DesiredNewAccounts + :: ProtocolMagic + -> DesiredNewAccounts -> DesiredNewAddresses -> ( Keystore.Keystore -> PassiveWalletLayer IO @@ -190,8 +196,8 @@ withAddressesFixtures -> IO a ) -> PropertyM IO a -withAddressesFixtures n m = - Fixture.withPassiveWalletFixture $ do +withAddressesFixtures pm n m = + Fixture.withPassiveWalletFixture pm $ do prepareAddressesFixture n m spec :: Spec @@ -200,7 +206,8 @@ spec = describe "Addresses" $ do describe "Address creation (wallet layer)" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 200 $ monadicIO $ do - withFixture $ \keystore layer _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \keystore layer _ Fixture{..} -> do Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (HdRootId hdRoot) = fixtureHdRootId (AccountIdHdRnd myAccountId) = fixtureAccountId @@ -212,14 +219,16 @@ spec = describe "Addresses" $ do describe "Address creation (kernel)" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 200 $ monadicIO $ do - withFixture $ \keystore _ _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \keystore _ _ Fixture{..} -> do Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore res <- Kernel.createAddress mempty fixtureAccountId fixturePw (bimap STB STB res) `shouldSatisfy` isRight prop "fails if the account has no associated key in the keystore" $ do monadicIO $ do - withFixture $ \_ _ _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \_ _ _ Fixture{..} -> do res <- Kernel.createAddress mempty fixtureAccountId fixturePw case res of (Left (Kernel.CreateAddressKeystoreNotFound acc)) | acc == fixtureAccountId -> return () @@ -227,7 +236,8 @@ spec = describe "Addresses" $ do prop "fails if the parent account doesn't exist" $ do monadicIO $ do - withFixture $ \keystore _ _ Fixture{..} -> do + pm <- pick arbitrary + withFixture pm $ \keystore _ _ Fixture{..} -> do Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (AccountIdHdRnd hdAccountId) = fixtureAccountId void $ update (fixturePw ^. wallets) (DeleteHdAccount hdAccountId) @@ -238,8 +248,9 @@ spec = describe "Addresses" $ do describe "Address creation (Servant)" $ do prop "works as expected in the happy path scenario" $ do - monadicIO $ - withFixture $ \keystore layer _ Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + withFixture pm $ \keystore layer _ Fixture{..} -> do Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (HdRootId hdRoot) = fixtureHdRootId (AccountIdHdRnd myAccountId) = fixtureAccountId @@ -252,10 +263,11 @@ spec = describe "Addresses" $ do describe "Address creation (wallet layer & kernel consistency)" $ do prop "layer & kernel agrees on the result" $ do monadicIO $ do - res1 <- withFixture $ \keystore _ _ Fixture{..} -> do + pm <- pick arbitrary + res1 <- withFixture pm $ \keystore _ _ Fixture{..} -> do Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore Kernel.createAddress mempty fixtureAccountId fixturePw - res2 <- withFixture $ \keystore layer _ Fixture{..} -> do + res2 <- withFixture pm $ \keystore layer _ Fixture{..} -> do Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (HdRootId hdRoot) = fixtureHdRootId (AccountIdHdRnd myAccountId) = fixtureAccountId @@ -276,8 +288,9 @@ spec = describe "Addresses" $ do describe "Address listing (Servant)" $ do prop "0 addresses, page 0, per page 0" $ do - monadicIO $ - withAddressFixtures 0 $ \_ layer _ _ -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 0 $ \_ layer _ _ -> do let pp = PaginationParams (Page 0) (PerPage 0) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -286,8 +299,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "1 addresses, page 0, per page 0" $ do - monadicIO $ - withAddressFixtures 1 $ \_ layer _ _ -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 1 $ \_ layer _ _ -> do let pp = PaginationParams (Page 0) (PerPage 0) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -296,8 +310,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "3 addresses, page 0, per page 0" $ do - monadicIO $ - withAddressFixtures 3 $ \_ layer _ _ -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 3 $ \_ layer _ _ -> do let pp = PaginationParams (Page 0) (PerPage 0) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -306,8 +321,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "3 addresses, page 1, per page 0" $ do - monadicIO $ - withAddressFixtures 3 $ \_ layer _ _ -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 3 $ \_ layer _ _ -> do let pp = PaginationParams (Page 1) (PerPage 0) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -316,8 +332,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "3 addresses, page 1, per page 1" $ do - monadicIO $ - withAddressFixtures 3 $ \_ layer _ [wa0, _, _] -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 3 $ \_ layer _ [wa0, _, _] -> do let pp = PaginationParams (Page 1) (PerPage 1) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -327,8 +344,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "3 addresses, page 1, per page 2" $ do - monadicIO $ - withAddressFixtures 3 $ \_ layer _ [wa0, wa1, _wa2] -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 3 $ \_ layer _ [wa0, wa1, _wa2] -> do let pp = PaginationParams (Page 1) (PerPage 2) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -340,8 +358,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "3 addresses, page 1, per page 3" $ do - monadicIO $ - withAddressFixtures 3 $ \_ layer _ [wa0, wa1, wa2] -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 3 $ \_ layer _ [wa0, wa1, wa2] -> do let pp = PaginationParams (Page 1) (PerPage 3) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -354,8 +373,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "3 addresses, page 2, per page 2" $ do - monadicIO $ - withAddressFixtures 3 $ \_ layer _ [_wa0, _wa1, wa2] -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 3 $ \_ layer _ [_wa0, _wa1, wa2] -> do let pp = PaginationParams (Page 2) (PerPage 2) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -366,8 +386,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "4 addresses, page 2, per page 2" $ do - monadicIO $ - withAddressFixtures 4 $ \_ layer _ [_wa0, _wa1, wa2, wa3] -> do + monadicIO $ do + pm <- pick arbitrary + withAddressFixtures pm 4 $ \_ layer _ [_wa0, _wa1, wa2, wa3] -> do let pp = PaginationParams (Page 2) (PerPage 2) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -383,7 +404,8 @@ spec = describe "Addresses" $ do (rNumOfAddresses :: Int) <- pick $ elements [0..15] (rNumOfPages :: Int) <- pick $ elements [0..15] (rNumPerPage :: Int) <- pick $ elements [0..15] - withAddressFixtures rNumOfAddresses $ \_ layer _ fixtureAddresses -> do + pm <- pick arbitrary + withAddressFixtures pm rNumOfAddresses $ \_ layer _ fixtureAddresses -> do let (!>) = drop . (subtract 1) let ( do + monadicIO $ do + pm <- pick arbitrary + withAddressesFixtures pm (DesiredNewAccs 4) (DesiredNewAddrs 4) $ \_ layer _ _ -> do let pp = PaginationParams (Page 0) (PerPage 0) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -410,8 +433,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "it yields the correct number of results" $ withMaxSuccess 20 $ do - monadicIO $ - withAddressesFixtures (DesiredNewAccs 3) (DesiredNewAddrs 4) $ \_ layer _ (_, total) -> do + monadicIO $ do + pm <- pick arbitrary + withAddressesFixtures pm (DesiredNewAccs 3) (DesiredNewAddrs 4) $ \_ layer _ (_, total) -> do let pp = PaginationParams (Page 1) (PerPage 40) res <- runExceptT $ runHandler' $ do Handlers.listAddresses layer (RequestParams pp) @@ -421,8 +445,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "is deterministic" $ withMaxSuccess 20 $ do - monadicIO $ - withAddressesFixtures (DesiredNewAccs 3) (DesiredNewAddrs 8) $ \_ layer _ (_, expectedTotal) -> do + monadicIO $ do + pm <- pick arbitrary + withAddressesFixtures pm (DesiredNewAccs 3) (DesiredNewAddrs 8) $ \_ layer _ (_, expectedTotal) -> do let ppSplit = quot expectedTotal 3 + 1 mkRequest mypp = Handlers.listAddresses layer (RequestParams mypp) forM_ [(1,40), (1, ppSplit), (2, ppSplit), (3, ppSplit)] $ \(page, perPage) -> do @@ -432,8 +457,9 @@ spec = describe "Addresses" $ do r1 `shouldBe` r2 prop "yields the correct set of resutls" $ withMaxSuccess 20 $ do - monadicIO $ - withAddressesFixtures (DesiredNewAccs 4) (DesiredNewAddrs 8) $ \_ layer _ (_, expectedTotal) -> do + monadicIO $ do + pm <- pick arbitrary + withAddressesFixtures pm (DesiredNewAccs 4) (DesiredNewAddrs 8) $ \_ layer _ (_, expectedTotal) -> do let ppSplit = quot expectedTotal 3 + 1 pp = PaginationParams (Page 1) (PerPage 50) pp1 = PaginationParams (Page 1) (PerPage ppSplit) @@ -457,8 +483,9 @@ spec = describe "Addresses" $ do _ -> fail ("Got " ++ show res) prop "yields the correct ordered resutls when there is one account" $ withMaxSuccess 20 $ do - monadicIO $ - withAddressesFixtures (DesiredNewAccs 0) (DesiredNewAddrs 15) $ \_ layer _ (_, expectedTotal) -> do + monadicIO $ do + pm <- pick arbitrary + withAddressesFixtures pm (DesiredNewAccs 0) (DesiredNewAddrs 15) $ \_ layer _ (_, expectedTotal) -> do let ppSplit = quot expectedTotal 3 + 1 pp = PaginationParams (Page 1) (PerPage 50) pp1 = PaginationParams (Page 1) (PerPage ppSplit) @@ -484,10 +511,11 @@ spec = describe "Addresses" $ do prop "yields the correct ordered resutls" $ withMaxSuccess 20 $ do monadicIO $ do + pm <- pick arbitrary forM_ [(DesiredNewAccs 4,DesiredNewAddrs 8), (DesiredNewAccs 6,DesiredNewAddrs 6), (DesiredNewAccs 5,DesiredNewAddrs 7)] $ \(acc,adr) -> - withAddressesFixtures acc adr $ \_ layer _ (_, expectedTotal) -> do + withAddressesFixtures pm acc adr $ \_ layer _ (_, expectedTotal) -> do forM_ [2..10] $ \k -> do let indexes = [1..k] pagesParams = map (\i -> PaginationParams (Page i) (PerPage (quot expectedTotal k + 1))) @@ -512,14 +540,16 @@ spec = describe "Addresses" $ do prop "works as expected in the happy path scenario (valid address, ours)" $ withMaxSuccess 25 $ monadicIO $ do - withAddressFixtures 1 $ \_ layer _ [af] -> do + pm <- pick arbitrary + withAddressFixtures pm 1 $ \_ layer _ [af] -> do res <- WalletLayer.validateAddress layer (sformat build (V1.unV1 $ V1.addrId $ addressFixtureAddress af)) bimap STB STB res `shouldSatisfy` isRight prop "rejects a malformed address" $ withMaxSuccess 1 $ monadicIO $ do - withAddressFixtures 1 $ \_ layer _ _ -> do + pm <- pick arbitrary + withAddressFixtures pm 1 $ \_ layer _ _ -> do res <- WalletLayer.validateAddress layer "foobar" case res of Left (WalletLayer.ValidateAddressDecodingFailed "foobar") -> return () @@ -529,6 +559,7 @@ spec = describe "Addresses" $ do prop "returns not used/not change for an address which is not ours" $ withMaxSuccess 1 $ do monadicIO $ do (randomAddr :: Address) <- pick arbitrary + pm <- pick arbitrary let expected :: V1.WalletAddress expected = V1.WalletAddress { addrId = V1.V1 randomAddr @@ -536,6 +567,6 @@ spec = describe "Addresses" $ do , addrChangeAddress = False , addrOwnership = V1.V1 V1.AddressAmbiguousOwnership } - withAddressFixtures 1 $ \_ layer _ _ -> do + withAddressFixtures pm 1 $ \_ layer _ _ -> do res <- WalletLayer.validateAddress layer (sformat build randomAddr) bimap STB STB res `shouldBe` bimap STB STB (Right expected) diff --git a/wallet-new/test/unit/Test/Spec/CoinSelection.hs b/wallet-new/test/unit/Test/Spec/CoinSelection.hs index 6fe949dcc09..f19067d0f3d 100644 --- a/wallet-new/test/unit/Test/Spec/CoinSelection.hs +++ b/wallet-new/test/unit/Test/Spec/CoinSelection.hs @@ -30,7 +30,7 @@ import qualified Pos.Chain.Txp as Core import Pos.Core (Coeff (..), TxSizeLinear (..), unsafeIntegerToCoin) import qualified Pos.Core as Core import Pos.Core.Attributes (mkAttributes) -import Pos.Crypto (ProtocolMagic, SecretKey) +import Pos.Crypto (ProtocolMagic (..), SecretKey) import Serokell.Data.Memory.Units (Byte, fromBytes) import Serokell.Util.Text (listJsonIndent) @@ -48,7 +48,7 @@ import Cardano.Wallet.Kernel.Transactions (mkStdTx) import Cardano.Wallet.Kernel.Util.Core (paymentAmount, utxoBalance, utxoRestrictToInputs) import Pos.Crypto.Signing.Safe (fakeSigner) -import Test.Pos.Configuration (withDefConfiguration) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Spec.CoinSelection.Generators (InitialBalance (..), Pay (..), genFiddlyPayees, genFiddlyUtxo, genGroupedUtxo, genPayee, genPayees, genRedeemPayee, @@ -404,8 +404,8 @@ errorWas predicate _ _ (STB hardErr) = -- as many inputs as possible. The @estimator@ parameter is used to compute the -- number of inputs, as a function of the maximum transaction size and the sizes -- of @Attributes AddrAttributes@ and @Attributes ()@. -genMaxInputTx :: (Byte -> Byte -> Byte -> Word64) -> Gen (Either Text (Byte, Byte)) -genMaxInputTx estimator = do +genMaxInputTx :: ProtocolMagic -> (Byte -> Byte -> Byte -> Word64) -> Gen (Either Text (Byte, Byte)) +genMaxInputTx pm estimator = do -- Generate the output and compute the attribute sizes. let genIn = Core.TxInUtxo <$> arbitrary <*> pure maxBound @@ -419,7 +419,7 @@ genMaxInputTx estimator = do -- Now build the transaction, attempting to make the encoded size of the transaction -- as large as possible. bimap pretty ((,maxTxSize) . encodedSize) <$> ( - withDefConfiguration $ \genesisConfig -> do + withProvidedMagicConfig pm $ \genesisConfig _ _ -> do key <- arbitrary inputs <- replicateM maxInputs ((,) <$> genIn <*> genOutAux) mkTx (configProtocolMagic genesisConfig) @@ -483,7 +483,8 @@ mkTx :: ProtocolMagic mkTx pm key = mkStdTx pm return (\_addr -> Right (fakeSigner key)) -payRestrictInputsTo :: Word64 +payRestrictInputsTo :: ProtocolMagic + -> Word64 -> (InitialBalance -> Gen Core.Utxo) -> (Core.Utxo -> Pay -> Gen (NonEmpty Core.TxOut)) -> (Int -> NonEmpty Core.Coin -> Core.Coin) @@ -492,8 +493,8 @@ payRestrictInputsTo :: Word64 -> Pay -> Policy -> Gen RunResult -payRestrictInputsTo maxInputs genU genP feeFunction adjustOptions bal amount policy = - withDefConfiguration $ \genesisConfig -> do +payRestrictInputsTo pm maxInputs genU genP feeFunction adjustOptions bal amount policy = + withProvidedMagicConfig pm $ \genesisConfig _ _ -> do utxo <- genU bal payee <- genP utxo amount key <- arbitrary @@ -513,7 +514,8 @@ payRestrictInputsTo maxInputs genU genP feeFunction adjustOptions bal amount pol change return (utxo, payee, bimap STB identity txAux) -pay :: (InitialBalance -> Gen Core.Utxo) +pay :: ProtocolMagic + -> (InitialBalance -> Gen Core.Utxo) -> (Core.Utxo -> Pay -> Gen (NonEmpty Core.TxOut)) -> (Int -> NonEmpty Core.Coin -> Core.Coin) -> (CoinSelectionOptions -> CoinSelectionOptions) @@ -521,33 +523,36 @@ pay :: (InitialBalance -> Gen Core.Utxo) -> Pay -> Policy -> Gen RunResult -pay = payRestrictInputsTo maxNumInputs +pay pm = payRestrictInputsTo pm maxNumInputs -payOne :: (Int -> NonEmpty Core.Coin -> Core.Coin) +payOne :: ProtocolMagic + -> (Int -> NonEmpty Core.Coin -> Core.Coin) -> (CoinSelectionOptions -> CoinSelectionOptions) -> InitialBalance -> Pay -> Policy -> Gen RunResult -payOne = pay genUtxoWithAtLeast genPayee +payOne pm = pay pm genUtxoWithAtLeast genPayee -- | Like 'payOne', but allows a custom 'Gen' for the payees to be supplied -payOne' :: (Core.Utxo -> Pay -> Gen (NonEmpty Core.TxOut)) +payOne' :: ProtocolMagic + -> (Core.Utxo -> Pay -> Gen (NonEmpty Core.TxOut)) -> (Int -> NonEmpty Core.Coin -> Core.Coin) -> (CoinSelectionOptions -> CoinSelectionOptions) -> InitialBalance -> Pay -> Policy -> Gen RunResult -payOne' payeeGenerator = pay genUtxoWithAtLeast payeeGenerator +payOne' pm payeeGenerator = pay pm genUtxoWithAtLeast payeeGenerator -payBatch :: (Int -> NonEmpty Core.Coin -> Core.Coin) +payBatch :: ProtocolMagic + -> (Int -> NonEmpty Core.Coin -> Core.Coin) -> (CoinSelectionOptions -> CoinSelectionOptions) -> InitialBalance -> Pay -> Policy -> Gen RunResult -payBatch = pay genUtxoWithAtLeast genPayees +payBatch pm = pay pm genUtxoWithAtLeast genPayees receiverPays :: CoinSelectionOptions -> CoinSelectionOptions receiverPays o = o { csoExpenseRegulation = ReceiverPaysFee } @@ -565,66 +570,66 @@ spec :: Spec spec = describe "Coin selection policies unit tests" $ do withMaxSuccess 1000 $ describe "largestFirst" $ do - prop "one payee, SenderPaysFee, fee = 0" $ forAll ( - payOne freeLunch identity (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "one payee, SenderPaysFee, fee = 0" $ \pm -> forAll ( + payOne pm freeLunch identity (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "one payee, ReceiverPaysFee, fee = 0" $ forAll ( - payOne freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "one payee, ReceiverPaysFee, fee = 0" $ \pm -> forAll ( + payOne pm freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "multiple payees, SenderPaysFee, fee = 0" $ forAll ( - payBatch freeLunch identity (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "multiple payees, SenderPaysFee, fee = 0" $ \pm -> forAll ( + payBatch pm freeLunch identity (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "multiple payees, ReceiverPaysFee, fee = 0" $ forAll ( - payBatch freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "multiple payees, ReceiverPaysFee, fee = 0" $ \pm -> forAll ( + payBatch pm freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res -- Minimal fee - prop "one payee, SenderPaysFee, fee = 1 Lovelace" $ forAll ( - payOne minFee identity (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "one payee, SenderPaysFee, fee = 1 Lovelace" $ \pm -> forAll ( + payOne pm minFee identity (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "one payee, ReceiverPaysFee, fee = 1 Lovelace" $ forAll ( - payOne minFee receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "one payee, ReceiverPaysFee, fee = 1 Lovelace" $ \pm -> forAll ( + payOne pm minFee receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "multiple payees, SenderPaysFee, fee = 1 Lovelace" $ forAll ( - payBatch minFee identity (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "multiple payees, SenderPaysFee, fee = 1 Lovelace" $ \pm -> forAll ( + payBatch pm minFee identity (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "multiple payees, ReceiverPaysFee, fee = 1 Lovelace" $ forAll ( - payBatch minFee receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst + prop "multiple payees, ReceiverPaysFee, fee = 1 Lovelace" $ \pm -> forAll ( + payBatch pm minFee receiverPays (InitialLovelace 1000) (PayLovelace 100) largestFirst ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res withMaxSuccess 2000 $ describe "random" $ do - prop "one payee, SenderPaysFee, fee = 0" $ forAll ( - payOne freeLunch identity (InitialLovelace 1000) (PayLovelace 100) random + prop "one payee, SenderPaysFee, fee = 0" $ \pm -> forAll ( + payOne pm freeLunch identity (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "one payee, ReceiverPaysFee, fee = 0" $ forAll ( - payOne freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) random + prop "one payee, ReceiverPaysFee, fee = 0" $ \pm -> forAll ( + payOne pm freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "multiple payees, SenderPaysFee, fee = 0" $ forAll ( - payBatch freeLunch identity (InitialLovelace 1000) (PayLovelace 100) random + prop "multiple payees, SenderPaysFee, fee = 0" $ \pm -> forAll ( + payBatch pm freeLunch identity (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res - prop "multiple payees, ReceiverPaysFee, fee = 0" $ forAll ( - payBatch freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) random + prop "multiple payees, ReceiverPaysFee, fee = 0" $ \pm -> forAll ( + payBatch pm freeLunch receiverPays (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceeded utxo payee res -- minimal fee. It doesn't make sense to use it for 'ReceiverPaysFee', because -- rounding will essentially cause the computed @epsilon@ will be 0 for each -- output. For those cases, we use the 'linear' fee policy. - prop "one payee, SenderPaysFee, fee = 1 Lovelace" $ forAll ( - payOne minFee identity (InitialLovelace 1000) (PayLovelace 100) random + prop "one payee, SenderPaysFee, fee = 1 Lovelace" $ \pm -> forAll ( + payOne pm minFee identity (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed SenderPaysFee] - prop "multiple payees, SenderPaysFee, fee = 1 Lovelace" $ forAll ( - payBatch minFee identity (InitialLovelace 1000) (PayLovelace 100) random + prop "multiple payees, SenderPaysFee, fee = 1 Lovelace" $ \pm -> forAll ( + payBatch pm minFee identity (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed SenderPaysFee] -- linear fee - prop "one payee, ReceiverPaysFee, fee = linear" $ forAll ( - payOne linearFee receiverPays (InitialLovelace 1000) (PayLovelace 100) random + prop "one payee, ReceiverPaysFee, fee = linear" $ \pm -> forAll ( + payOne pm linearFee receiverPays (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed ReceiverPaysFee] - prop "multiple payees, ReceiverPaysFee, fee = linear" $ forAll ( - payBatch linearFee receiverPays (InitialLovelace 1000) (PayLovelace 100) random + prop "multiple payees, ReceiverPaysFee, fee = linear" $ \pm -> forAll ( + payBatch pm linearFee receiverPays (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed ReceiverPaysFee] @@ -633,38 +638,38 @@ spec = -- `estimateCardanoFee` works on "real world estimates" for things -- like attributes, and trying to setup syntetic experiments with -- less than 1ADA (10^6 lovelaces) is probably counter-productive - prop "one payee, SenderPaysFee, fee = cardano" $ forAll ( - payOne cardanoFee identity (InitialADA 1000) (PayADA 100) random + prop "one payee, SenderPaysFee, fee = cardano" $ \pm -> forAll ( + payOne pm cardanoFee identity (InitialADA 1000) (PayADA 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed SenderPaysFee] - prop "multiple payees, SenderPaysFee, fee = cardano" $ forAll ( - payBatch cardanoFee identity (InitialADA 1000) (PayADA 100) random + prop "multiple payees, SenderPaysFee, fee = cardano" $ \pm -> forAll ( + payBatch pm cardanoFee identity (InitialADA 1000) (PayADA 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed SenderPaysFee] - prop "one payee, ReceiverPaysFee, fee = cardano" $ forAll ( - payOne cardanoFee receiverPays (InitialADA 1000) (PayADA 100) random + prop "one payee, ReceiverPaysFee, fee = cardano" $ \pm -> forAll ( + payOne pm cardanoFee receiverPays (InitialADA 1000) (PayADA 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed ReceiverPaysFee] - prop "multiple payees, ReceiverPaysFee, fee = cardano" $ forAll ( - payBatch cardanoFee receiverPays (InitialADA 1000) (PayADA 100) random + prop "multiple payees, ReceiverPaysFee, fee = cardano" $ \pm -> forAll ( + payBatch pm cardanoFee receiverPays (InitialADA 1000) (PayADA 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed ReceiverPaysFee] withMaxSuccess 2000 $ describe "Expected failures" $ do - prop "Paying a redeem address should always be rejected" $ forAll ( - payOne' genRedeemPayee linearFee receiverPays (InitialLovelace 1000) (PayLovelace 100) random + prop "Paying a redeem address should always be rejected" $ \pm -> forAll ( + payOne' pm genRedeemPayee linearFee receiverPays (InitialLovelace 1000) (PayLovelace 100) random ) $ \(utxo, payee, res) -> paymentFailedWith utxo payee res [errorWas outputWasRedeem] - prop "Paying somebody not having enough money should fail" $ forAll ( - payBatch linearFee receiverPays (InitialLovelace 10) (PayLovelace 100) random + prop "Paying somebody not having enough money should fail" $ \pm -> forAll ( + payBatch pm linearFee receiverPays (InitialLovelace 10) (PayLovelace 100) random ) $ \(utxo, payee, res) -> do paymentFailedWith utxo payee res [errorWas notEnoughMoney] - prop "Restricting too much the number of inputs results in an hard error for a single payee" $ forAll ( - payRestrictInputsTo 1 genUtxoWithAtLeast genPayee freeLunch identity (InitialLovelace 200) (PayLovelace 100) random + prop "Restricting too much the number of inputs results in an hard error for a single payee" $ \pm -> forAll ( + payRestrictInputsTo pm 1 genUtxoWithAtLeast genPayee freeLunch identity (InitialLovelace 200) (PayLovelace 100) random ) $ \(utxo, payee, res) -> do paymentFailedWith utxo payee res [errorWas maxInputsReached] - prop "Restricting too much the number of inputs results in an hard error for multiple payees" $ forAll ( - payRestrictInputsTo 1 genUtxoWithAtLeast genPayees freeLunch identity (InitialLovelace 200) (PayLovelace 100) random + prop "Restricting too much the number of inputs results in an hard error for multiple payees" $ \pm -> forAll ( + payRestrictInputsTo pm 1 genUtxoWithAtLeast genPayees freeLunch identity (InitialLovelace 200) (PayLovelace 100) random ) $ \(utxo, payee, res) -> do paymentFailedWith utxo payee res [errorWas maxInputsReached] @@ -673,12 +678,12 @@ spec = -- where coin selection would fail for Addresses of size < 104, which is -- the average in Cardano. withMaxSuccess 200 $ describe "Fiddly Addresses" $ do - prop "multiple payees, SenderPaysFee, fee = cardano" $ forAll ( - pay genFiddlyUtxo genFiddlyPayees cardanoFee identity (InitialADA 1000) (PayADA 100) random + prop "multiple payees, SenderPaysFee, fee = cardano" $ \pm -> forAll ( + pay pm genFiddlyUtxo genFiddlyPayees cardanoFee identity (InitialADA 1000) (PayADA 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed SenderPaysFee] - prop "multiple payees, ReceiverPaysFee, fee = cardano" $ forAll ( - pay genFiddlyUtxo genFiddlyPayees cardanoFee receiverPays (InitialADA 1000) (PayADA 100) random + prop "multiple payees, ReceiverPaysFee, fee = cardano" $ \pm -> forAll ( + pay pm genFiddlyUtxo genFiddlyPayees cardanoFee receiverPays (InitialADA 1000) (PayADA 100) random ) $ \(utxo, payee, res) -> paymentSucceededWith utxo payee res [feeWasPayed ReceiverPaysFee] @@ -693,35 +698,35 @@ spec = -- passed, which allows the coin selection to, if needed, pick all -- the associated inputs paying into the address we just picked. withMaxSuccess 2000 $ describe "Input Grouping" $ do - prop "Require grouping, fee = 0, one big group depletes the Utxo completely" $ forAll ( - pay (genGroupedUtxo 1) genPayee freeLunch requireGrouping (InitialLovelace 1000) (PayLovelace 10) random + prop "Require grouping, fee = 0, one big group depletes the Utxo completely" $ \pm -> forAll ( + pay pm (genGroupedUtxo 1) genPayee freeLunch requireGrouping (InitialLovelace 1000) (PayLovelace 10) random ) $ \(utxo, payee, res) -> do paymentSucceededWith utxo payee res [utxoWasDepleted] - prop "Require grouping, fee = cardano, one big group depletes the Utxo completely" $ forAll ( - pay (genGroupedUtxo 1) genPayee freeLunch requireGrouping (InitialADA 1000) (PayADA 10) random + prop "Require grouping, fee = cardano, one big group depletes the Utxo completely" $ \pm -> forAll ( + pay pm (genGroupedUtxo 1) genPayee freeLunch requireGrouping (InitialADA 1000) (PayADA 10) random ) $ \(utxo, payee, res) -> do paymentSucceededWith utxo payee res [utxoWasDepleted] - prop "Require grouping, fee = 0, several groups allows the payment to be fullfilled" $ forAll ( - pay (genGroupedUtxo 10) genPayee freeLunch requireGrouping (InitialLovelace 1000) (PayLovelace 10) random + prop "Require grouping, fee = 0, several groups allows the payment to be fullfilled" $ \pm -> forAll ( + pay pm (genGroupedUtxo 10) genPayee freeLunch requireGrouping (InitialLovelace 1000) (PayLovelace 10) random ) $ \(utxo, payee, res) -> do paymentSucceeded utxo payee res - prop "Prefer grouping, fee = 0" $ forAll ( - payOne freeLunch preferGrouping (InitialLovelace 1000) (PayLovelace 10) random + prop "Prefer grouping, fee = 0" $ \pm -> forAll ( + payOne pm freeLunch preferGrouping (InitialLovelace 1000) (PayLovelace 10) random ) $ \(utxo, payee, res) -> do paymentSucceeded utxo payee res - prop "IgnoreGrouping, fee = 0 must not deplete the utxo" $ forAll ( - pay (genGroupedUtxo 1) genPayee freeLunch ignoreGrouping (InitialLovelace 1000) (PayLovelace 10) random + prop "IgnoreGrouping, fee = 0 must not deplete the utxo" $ \pm -> forAll ( + pay pm (genGroupedUtxo 1) genPayee freeLunch ignoreGrouping (InitialLovelace 1000) (PayLovelace 10) random ) $ \(utxo, payee, res) -> do paymentSucceededWith utxo payee res [utxoWasNotDepleted] describe "Estimating the maximum number of inputs" $ do - prop "estimateMaxTxInputs yields a lower bound." $ - forAll (genMaxInputTx estimateMaxTxInputsExplicitBounds) $ \case + prop "estimateMaxTxInputs yields a lower bound." $ \pm -> + forAll (genMaxInputTx pm estimateMaxTxInputsExplicitBounds) $ \case Left _err -> False Right (lhs, rhs) -> lhs <= rhs - prop "estimateMaxTxInputs yields a relatively tight bound." $ - forAll (genMaxInputTx $ \x y z -> 1 + estimateHardMaxTxInputsExplicitBounds x y z) $ \case + prop "estimateMaxTxInputs yields a relatively tight bound." $ \pm -> + forAll (genMaxInputTx pm $ \x y z -> 1 + estimateHardMaxTxInputsExplicitBounds x y z) $ \case Left _err -> False Right (lhs, rhs) -> lhs > rhs diff --git a/wallet-new/test/unit/Test/Spec/Fixture.hs b/wallet-new/test/unit/Test/Spec/Fixture.hs index 0b0b3df2430..018c26b9a02 100644 --- a/wallet-new/test/unit/Test/Spec/Fixture.hs +++ b/wallet-new/test/unit/Test/Spec/Fixture.hs @@ -16,10 +16,9 @@ import Universum import Pos.Util.Wlog (Severity) -import Pos.Chain.Genesis (Config (..)) +import Pos.Crypto (ProtocolMagic) import Pos.Infra.InjectFail (mkFInjects) -import Test.Pos.Configuration (withDefConfiguration) import Test.QuickCheck (arbitrary, frequency) import Test.QuickCheck.Monadic (PropertyM, pick) @@ -42,12 +41,14 @@ genSpendingPassword = pick (frequency [(20, pure Nothing), (80, Just <$> arbitrary)]) withLayer :: MonadIO m - => (PassiveWalletLayer m -> PassiveWallet -> IO a) + => ProtocolMagic + -> (PassiveWalletLayer m -> PassiveWallet -> IO a) -> PropertyM IO a -withLayer cc = do +withLayer pm cc = do liftIO $ Keystore.bracketTestKeystore $ \keystore -> do mockFInjects <- mkFInjects mempty WalletLayer.Kernel.bracketPassiveWallet + pm Kernel.UseInMemory devNull keystore @@ -59,14 +60,16 @@ type GenPassiveWalletFixture x = PropertyM IO (PassiveWallet -> IO x) type GenActiveWalletFixture x = PropertyM IO (Keystore.Keystore -> ActiveWallet -> IO x) withPassiveWalletFixture :: MonadIO m - => GenPassiveWalletFixture x + => ProtocolMagic + -> GenPassiveWalletFixture x -> (Keystore.Keystore -> PassiveWalletLayer m -> PassiveWallet -> x -> IO a) -> PropertyM IO a -withPassiveWalletFixture prepareFixtures cc = do +withPassiveWalletFixture pm prepareFixtures cc = do generateFixtures <- prepareFixtures liftIO $ Keystore.bracketTestKeystore $ \keystore -> do mockFInjects <- mkFInjects mempty WalletLayer.Kernel.bracketPassiveWallet + pm Kernel.UseInMemory devNull keystore @@ -77,23 +80,22 @@ withPassiveWalletFixture prepareFixtures cc = do cc keystore layer wallet fixtures withActiveWalletFixture :: MonadIO m - => GenActiveWalletFixture x + => ProtocolMagic + -> GenActiveWalletFixture x -> (Keystore.Keystore -> ActiveWalletLayer m -> ActiveWallet -> x -> IO a) -> PropertyM IO a -withActiveWalletFixture prepareFixtures cc = do +withActiveWalletFixture pm prepareFixtures cc = do generateFixtures <- prepareFixtures liftIO $ Keystore.bracketTestKeystore $ \keystore -> do mockFInjects <- mkFInjects mempty - WalletLayer.Kernel.bracketPassiveWallet Kernel.UseInMemory devNull keystore mockNodeStateDef mockFInjects $ \passiveLayer passiveWallet -> do - withDefConfiguration $ \genesisConfig -> do - WalletLayer.Kernel.bracketActiveWallet - (configProtocolMagic genesisConfig) - passiveLayer - passiveWallet - diffusion - $ \activeLayer activeWallet -> do - fixtures <- generateFixtures keystore activeWallet - cc keystore activeLayer activeWallet fixtures + WalletLayer.Kernel.bracketPassiveWallet pm Kernel.UseInMemory devNull keystore mockNodeStateDef mockFInjects $ \passiveLayer passiveWallet -> do + WalletLayer.Kernel.bracketActiveWallet + passiveLayer + passiveWallet + diffusion + $ \activeLayer activeWallet -> do + fixtures <- generateFixtures keystore activeWallet + cc keystore activeLayer activeWallet fixtures where diffusion :: Kernel.WalletDiffusion diffusion = Kernel.WalletDiffusion { diff --git a/wallet-new/test/unit/Test/Spec/GetTransactions.hs b/wallet-new/test/unit/Test/Spec/GetTransactions.hs index b42daecc89d..f6ec18876cb 100644 --- a/wallet-new/test/unit/Test/Spec/GetTransactions.hs +++ b/wallet-new/test/unit/Test/Spec/GetTransactions.hs @@ -27,9 +27,10 @@ import qualified Pos.Chain.Txp as Core import Pos.Core as Core import Pos.Core (Coin (..), IsBootstrapEraAddr (..), deriveLvl2KeyPair, mkCoin) -import Pos.Core.NetworkMagic (NetworkMagic (..)) -import Pos.Crypto (EncryptedSecretKey, ShouldCheckPassphrase (..), - emptyPassphrase, safeDeterministicKeyGen) +import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) +import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, + ShouldCheckPassphrase (..), emptyPassphrase, + safeDeterministicKeyGen) import Pos.Crypto.HD (firstHardened) import Cardano.Wallet.API.Request @@ -93,9 +94,10 @@ data Fixture = Fixture { -- | Prepare some fixtures using the 'PropertyM' context to prepare the data, -- and execute the 'acid-state' update once the 'PassiveWallet' gets into -- scope (after the bracket initialisation). -prepareFixtures :: InitialBalance +prepareFixtures :: NetworkMagic + -> InitialBalance -> Fixture.GenActiveWalletFixture Fixture -prepareFixtures initialBalance = do +prepareFixtures nm initialBalance = do fixt <- forM [0x11, 0x22] $ \b -> do let (_, esk) = safeDeterministicKeyGen (B.pack $ replicate 32 b) mempty let newRootId = eskToHdRootId esk @@ -111,7 +113,7 @@ prepareFixtures initialBalance = do utxo' <- foldlM (\acc (txIn, (TxOutAux (TxOut _ coin))) -> do newIndex <- deriveIndex (pick . choose) HdAddressIx HardDerivation - let Just (addr, _) = deriveLvl2KeyPair fixedNM + let Just (addr, _) = deriveLvl2KeyPair nm (IsBootstrapEraAddr True) (ShouldCheckPassphrase True) mempty @@ -135,7 +137,7 @@ prepareFixtures initialBalance = do let accounts = Kernel.prefilterUtxo fixtureHdRootId fixtureESK fixtureUtxo hdAccountId = Kernel.defaultHdAccountId fixtureHdRootId - (Just hdAddress) = Kernel.defaultHdAddress fixtureESK emptyPassphrase fixtureHdRootId + (Just hdAddress) = Kernel.defaultHdAddress nm fixtureESK emptyPassphrase fixtureHdRootId void $ liftIO $ update (pw ^. wallets) (CreateHdWallet fixtureHdRoot hdAccountId hdAddress accounts) return $ Fixture { @@ -144,7 +146,8 @@ prepareFixtures initialBalance = do } withFixture :: MonadIO m - => InitialBalance + => ProtocolMagic + -> InitialBalance -> ( Keystore.Keystore -> WalletLayer.ActiveWalletLayer m -> Kernel.ActiveWallet @@ -152,8 +155,10 @@ withFixture :: MonadIO m -> IO a ) -> PropertyM IO a -withFixture initialBalance cc = - Fixture.withActiveWalletFixture (prepareFixtures initialBalance) cc +withFixture pm initialBalance cc = + Fixture.withActiveWalletFixture pm (prepareFixtures nm initialBalance) cc + where + nm = makeNetworkMagic pm -- | Returns the address that is automatically created with the wallet. getFixedAddress :: WalletLayer.ActiveWalletLayer IO -> Fix -> IO Core.Address @@ -210,7 +215,8 @@ spec = do prop "scenario: Layer.CreateAddress -> TxMeta.putTxMeta -> Layer.getTransactions works properly." $ withMaxSuccess 5 $ monadicIO $ do testMetaSTB <- pick genMeta - Addresses.withFixture $ \keystore layer pwallet Addresses.Fixture{..} -> do + pm <- pick arbitrary + Addresses.withFixture pm $ \keystore layer pwallet Addresses.Fixture{..} -> do liftIO $ Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (HdRootId hdRoot) = fixtureHdRootId (AccountIdHdRnd myAccountId) = fixtureAccountId @@ -259,7 +265,8 @@ spec = do prop "scenario: Layer.pay -> Layer.getTransactions works properly. Tx status should be Applying " $ withMaxSuccess 5 $ monadicIO $ do - NewPayment.withFixture @IO (InitialADA 10000) (PayLovelace 25) $ \keystore activeLayer aw NewPayment.Fixture{..} -> do + pm <- pick arbitrary + NewPayment.withFixture @IO pm (InitialADA 10000) (PayLovelace 25) $ \keystore activeLayer aw NewPayment.Fixture{..} -> do liftIO $ Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (AccountIdHdRnd hdAccountId) = fixtureAccountId let (HdRootId (InDb rootAddress)) = fixtureHdRootId @@ -326,8 +333,9 @@ spec = do Right resp -> check resp prop "newTransaction and getTransactions return the same result" $ withMaxSuccess 5 $ do - monadicIO $ - NewPayment.withPayment (InitialADA 10000) (PayLovelace 100) $ \activeLayer newPayment -> do + monadicIO $ do + pm <- pick arbitrary + NewPayment.withPayment pm (InitialADA 10000) (PayLovelace 100) $ \activeLayer newPayment -> do payRes <- liftIO (runExceptT . runHandler' $ Handlers.newTransaction activeLayer newPayment) getTxRes <- WalletLayer.getTransactions (walletPassiveLayer activeLayer) @@ -343,8 +351,9 @@ spec = do _ -> expectationFailure "WalletLayer.getTransactions or Handlers.newTransaction failed" prop "TxMeta from pay has the correct txAmount" $ withMaxSuccess 5 $ - monadicIO $ - NewPayment.withFixture @IO (InitialADA 10000) (PayLovelace 100) $ \_ _ aw NewPayment.Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + NewPayment.withFixture @IO pm (InitialADA 10000) (PayLovelace 100) $ \_ _ aw NewPayment.Fixture{..} -> do -- we use constant fees here, to have predictable txAmount. let (AccountIdHdRnd hdAccountId) = fixtureAccountId (_tx, txMeta) <- payAux aw hdAccountId fixturePayees 200 @@ -352,110 +361,124 @@ spec = do describe "Transactions with multiple wallets" $ do prop "test fixture has all the wanted properies" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do - db <- Kernel.getWalletSnapshot (Kernel.walletPassive aw) - let Right accs1 = Accounts.getAccounts (Kernel.Conv.toRootId $ fixtureHdRootId w1) db - length (IxSet.toList accs1) `shouldBe` 2 - let Right accs2 = Accounts.getAccounts (Kernel.Conv.toRootId $ fixtureHdRootId w2) db - length (IxSet.toList accs2) `shouldBe` 2 - _ <- getFixedAddress layer w1 - _ <- getFixedAddress layer w2 - _ <- getNonFixedAddress layer w1 - _ <- getNonFixedAddress layer w2 - return () + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do + db <- Kernel.getWalletSnapshot (Kernel.walletPassive aw) + let Right accs1 = Accounts.getAccounts (Kernel.Conv.toRootId $ fixtureHdRootId w1) db + length (IxSet.toList accs1) `shouldBe` 2 + let Right accs2 = Accounts.getAccounts (Kernel.Conv.toRootId $ fixtureHdRootId w2) db + length (IxSet.toList accs2) `shouldBe` 2 + _ <- getFixedAddress layer w1 + _ <- getFixedAddress layer w2 + _ <- getNonFixedAddress layer w1 + _ <- getNonFixedAddress layer w2 + return () prop "TxMeta from pay between two wallets has the correct txAmount" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do - let pw = Kernel.walletPassive aw - address <- getFixedAddress layer w2 - let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 - let payees = (NonEmpty.fromList [(address, Coin 100)]) - (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 - txMeta ^. txMetaAmount `shouldBe` Coin 300 - txMeta ^. txMetaIsOutgoing `shouldBe` True - txMeta ^. txMetaIsLocal `shouldBe` False - res <- toTransaction pw txMeta - bimap STB STB res `shouldSatisfy` isRight - let Right tx = res - V1.txStatus tx `shouldBe` V1.Applying - V1.txConfirmations tx `shouldBe` 0 + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do + let pw = Kernel.walletPassive aw + address <- getFixedAddress layer w2 + let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 + let payees = (NonEmpty.fromList [(address, Coin 100)]) + (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 + txMeta ^. txMetaAmount `shouldBe` Coin 300 + txMeta ^. txMetaIsOutgoing `shouldBe` True + txMeta ^. txMetaIsLocal `shouldBe` False + res <- toTransaction pw txMeta + bimap STB STB res `shouldSatisfy` isRight + let Right tx = res + V1.txStatus tx `shouldBe` V1.Applying + V1.txConfirmations tx `shouldBe` 0 prop "as above but now we pay to the explicitely created account" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do - address <- getNonFixedAddress layer w2 - let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 - let payees = (NonEmpty.fromList [(address, Coin 100)]) - (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 - txMeta ^. txMetaAmount `shouldBe` Coin 300 + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do + address <- getNonFixedAddress layer w2 + let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 + let payees = (NonEmpty.fromList [(address, Coin 100)]) + (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 + txMeta ^. txMetaAmount `shouldBe` Coin 300 prop "payment to different wallet changes the balance the same as txAmount" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do - let pw = Kernel.walletPassive aw - -- get the balance before the payment - coinsBefore <- getAccountBalanceNow pw w1 - -- do the payment - let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 - address <- getFixedAddress layer w2 - let payees = (NonEmpty.fromList [(address, Coin 100)]) - (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 - txMeta ^. txMetaAmount `shouldBe` Coin 300 - -- get the balance after the payment - coinsAfter <- getAccountBalanceNow pw w1 - coinsBefore - coinsAfter `shouldBe` 300 + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do + let pw = Kernel.walletPassive aw + -- get the balance before the payment + coinsBefore <- getAccountBalanceNow pw w1 + -- do the payment + let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 + address <- getFixedAddress layer w2 + let payees = (NonEmpty.fromList [(address, Coin 100)]) + (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 + txMeta ^. txMetaAmount `shouldBe` Coin 300 + -- get the balance after the payment + coinsAfter <- getAccountBalanceNow pw w1 + coinsBefore - coinsAfter `shouldBe` 300 prop "as above but now we pay to the explicitely created account" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do - let pw = Kernel.walletPassive aw - let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 - -- get the balance before the payment - coinsBefore <- getAccountBalanceNow pw w1 - -- do the payment - address <- getNonFixedAddress layer w2 - let payees = (NonEmpty.fromList [(address, Coin 100)]) - (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 - txMeta ^. txMetaAmount `shouldBe` Coin 300 - -- get the balance after the payment - coinsAfter <- getAccountBalanceNow pw w1 - coinsBefore - coinsAfter `shouldBe` 300 + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do + let pw = Kernel.walletPassive aw + let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 + -- get the balance before the payment + coinsBefore <- getAccountBalanceNow pw w1 + -- do the payment + address <- getNonFixedAddress layer w2 + let payees = (NonEmpty.fromList [(address, Coin 100)]) + (_tx, txMeta) <- payAux aw hdAccountId1 payees 200 + txMeta ^. txMetaAmount `shouldBe` Coin 300 + -- get the balance after the payment + coinsAfter <- getAccountBalanceNow pw w1 + coinsBefore - coinsAfter `shouldBe` 300 prop "2 consecutive payments" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do - let pw = Kernel.walletPassive aw - -- get the balance before the payment - coinsBefore <- getAccountBalanceNow pw w1 - -- do the payment - let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 - address1 <- getFixedAddress layer w2 - address2 <- getNonFixedAddress layer w2 - let payees1 = (NonEmpty.fromList [(address1, Coin 100)]) - (_, txMeta1) <- payAux aw hdAccountId1 payees1 200 - txMeta1 ^. txMetaAmount `shouldBe` Coin 300 - -- do the second payment - let payees2 = (NonEmpty.fromList [(address2, Coin 400)]) - (_, txMeta2) <- payAux aw hdAccountId1 payees2 800 - txMeta2 ^. txMetaAmount `shouldBe` Coin 1200 - -- get the balance after the payment - coinsAfter <- getAccountBalanceNow pw w1 - coinsBefore - coinsAfter `shouldBe` 1500 + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, w2] _) -> do + let pw = Kernel.walletPassive aw + -- get the balance before the payment + coinsBefore <- getAccountBalanceNow pw w1 + -- do the payment + let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 + address1 <- getFixedAddress layer w2 + address2 <- getNonFixedAddress layer w2 + let payees1 = (NonEmpty.fromList [(address1, Coin 100)]) + (_, txMeta1) <- payAux aw hdAccountId1 payees1 200 + txMeta1 ^. txMetaAmount `shouldBe` Coin 300 + -- do the second payment + let payees2 = (NonEmpty.fromList [(address2, Coin 400)]) + (_, txMeta2) <- payAux aw hdAccountId1 payees2 800 + txMeta2 ^. txMetaAmount `shouldBe` Coin 1200 + -- get the balance after the payment + coinsAfter <- getAccountBalanceNow pw w1 + coinsBefore - coinsAfter `shouldBe` 1500 describe "Transactions with multiple accounts" $ do prop "TxMeta from pay between two accounts of the same wallet has the correct txAmount" $ withMaxSuccess 5 $ - monadicIO $ withFixture @IO (InitialADA 10000) $ \_ layer aw (Fixture [w1, _] _) -> do - let pw = Kernel.walletPassive aw - -- get the balance before the payment - coinsBefore <- getAccountBalanceNow pw w1 - -- do the payment - address <- getFixedAddress layer w1 - let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 - let payees = (NonEmpty.fromList [(address, Coin 100)]) - (_, txMeta) <- payAux aw hdAccountId1 payees 200 - -- this is 200 because the outputs is at the same wallet. - txMeta ^. txMetaAmount `shouldBe` Coin 200 - txMeta ^. txMetaIsOutgoing `shouldBe` True - txMeta ^. txMetaIsLocal `shouldBe` True - -- get the balance after the payment - coinsAfter <- getAccountBalanceNow pw w1 - coinsBefore - coinsAfter `shouldBe` 300 + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) $ \_ layer aw (Fixture [w1, _] _) -> do + let pw = Kernel.walletPassive aw + -- get the balance before the payment + coinsBefore <- getAccountBalanceNow pw w1 + -- do the payment + address <- getFixedAddress layer w1 + let (AccountIdHdRnd hdAccountId1) = fixtureAccountId w1 + let payees = (NonEmpty.fromList [(address, Coin 100)]) + (_, txMeta) <- payAux aw hdAccountId1 payees 200 + -- this is 200 because the outputs is at the same wallet. + txMeta ^. txMetaAmount `shouldBe` Coin 200 + txMeta ^. txMetaIsOutgoing `shouldBe` True + txMeta ^. txMetaIsLocal `shouldBe` True + -- get the balance after the payment + coinsAfter <- getAccountBalanceNow pw w1 + coinsBefore - coinsAfter `shouldBe` 300 payAux :: Kernel.ActiveWallet -> HdAccountId -> NonEmpty (Address, Coin) -> Word64 -> IO (Core.Tx, TxMeta) payAux aw hdAccountId payees fees = do @@ -472,6 +495,3 @@ payAux aw hdAccountId payees fees = do bimap STB STB payRes `shouldSatisfy` isRight let Right t = payRes return t - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/wallet-new/test/unit/Test/Spec/Kernel.hs b/wallet-new/test/unit/Test/Spec/Kernel.hs index 8037455f796..d2e133d9f38 100644 --- a/wallet-new/test/unit/Test/Spec/Kernel.hs +++ b/wallet-new/test/unit/Test/Spec/Kernel.hs @@ -20,12 +20,13 @@ import qualified Cardano.Wallet.Kernel.Read as Kernel import Pos.Chain.Genesis (Config (..)) import Pos.Core (Coeff (..), TxSizeLinear (..)) import Pos.Core.Chrono +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.Infra.InjectFail (mkFInjects) import Data.Validated import Test.Infrastructure.Generator import Test.Infrastructure.Genesis -import Test.Pos.Configuration (withDefConfiguration) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Spec.BlockMetaScenarios import Test.Spec.TxMetaScenarios import Util.Buildable.Hspec @@ -56,6 +57,17 @@ withWithoutWW specWith = do spec :: Spec spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = do describe "test TxMeta insertion" $ do withWithoutWW $ \useWW -> do it "TxMetaScenarioA" $ bracketTxMeta useWW (txMetaScenarioA genesis) @@ -72,19 +84,19 @@ spec = do describe "Compare wallet kernel to pure model" $ do describe "Using hand-written inductive wallets, computes the expected block metadata for" $ do withWithoutWW $ \useWW -> do - it "...blockMetaScenarioA" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioA genesis) - it "...blockMetaScenarioB" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioB genesis) - it "...blockMetaScenarioC" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioC genesis) - it "...blockMetaScenarioD" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioD genesis) - it "...blockMetaScenarioE" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioE genesis) - it "...blockMetaScenarioF" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioF genesis) - it "...blockMetaScenarioG" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioG genesis) - it "...blockMetaScenarioH" $ bracketActiveWallet $ checkBlockMeta' useWW (blockMetaScenarioH genesis) + it "...blockMetaScenarioA" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioA genesis) + it "...blockMetaScenarioB" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioB genesis) + it "...blockMetaScenarioC" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioC genesis) + it "...blockMetaScenarioD" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioD genesis) + it "...blockMetaScenarioE" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioE genesis) + it "...blockMetaScenarioF" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioF genesis) + it "...blockMetaScenarioG" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioG genesis) + it "...blockMetaScenarioH" $ bracketActiveWallet pm $ checkBlockMeta' useWW (blockMetaScenarioH genesis) describe "Using hand-written inductive wallets" $ do withWithoutWW $ \useWW -> it "computes identical results in presence of dependent pending transactions" $ - bracketActiveWallet $ \activeWallet -> do + bracketActiveWallet pm $ \activeWallet -> do checkEquivalent useWW activeWallet (dependentPending genesis) withWithoutWW $ \useWW -> @@ -92,12 +104,12 @@ spec = do forAll (genInductiveUsingModel model) $ \ind -> do conjoin [ shouldBeValidated $ void (inductiveIsValid ind) - , bracketActiveWallet $ \activeWallet -> do + , bracketActiveWallet pm $ \activeWallet -> do checkEquivalent useWW activeWallet ind ] where - transCtxt = runTranslateNoErrors ask + transCtxt = runTranslateNoErrors pm ask boot = bootstrapTransaction transCtxt ourActorIx = 0 @@ -127,7 +139,7 @@ spec = do -> Inductive h Addr -> IO (Validated EquivalenceViolation (IntCtxt h)) evaluate useWW activeWallet ind = do - fmap (fmap snd) $ runTranslateTNoErrors $ do + fmap (fmap snd) $ runTranslateTNoErrors pm $ do equivalentT useWW activeWallet esk (mkWallet ours') ind where esk = deriveRootEsk (IxPoor ourActorIx) @@ -177,7 +189,7 @@ spec = do intCtxt <- evaluate' useWW activeWallet ind -- translate DSL BlockMeta' to Cardano BlockMeta - expected' <- runTranslateT $ intBlockMeta intCtxt blockMeta' + expected' <- runTranslateT pm $ intBlockMeta intCtxt blockMeta' -- grab a snapshot of the wallet state to get the BlockMeta produced by evaluating the inductive snapshot <- liftIO (Kernel.getWalletSnapshot (Kernel.walletPassive activeWallet)) @@ -190,7 +202,7 @@ spec = do -> TxScenarioRet h -> IO () bracketTxMeta useWW (nodeState, ind, check) = - bracketActiveWalletTxMeta nodeState bracketAction + bracketActiveWalletTxMeta pm nodeState bracketAction where bracketAction activeWallet = do _ <- evaluate' useWW activeWallet ind @@ -257,11 +269,12 @@ dependentPending GenesisValues{..} = Inductive { -------------------------------------------------------------------------------} -- | Initialize passive wallet in a manner suitable for the unit tests -bracketPassiveWallet :: (Kernel.PassiveWallet -> IO a) -> IO a -bracketPassiveWallet postHook = do +bracketPassiveWallet :: ProtocolMagic -> (Kernel.PassiveWallet -> IO a) -> IO a +bracketPassiveWallet pm postHook = do Keystore.bracketTestKeystore $ \keystore -> do mockFInjects <- mkFInjects mempty Kernel.bracketPassiveWallet + pm Kernel.UseInMemory logMessage keystore @@ -276,11 +289,10 @@ bracketPassiveWallet postHook = do logMessage _ _ = return () -- | Initialize active wallet in a manner suitable for generator-based testing -bracketActiveWallet :: (Kernel.ActiveWallet -> IO a) -> IO a -bracketActiveWallet test = withDefConfiguration $ \genesisConfig -> do - bracketPassiveWallet $ \passive -> - Kernel.bracketActiveWallet (configProtocolMagic genesisConfig) - passive +bracketActiveWallet :: ProtocolMagic -> (Kernel.ActiveWallet -> IO a) -> IO a +bracketActiveWallet pm test = withProvidedMagicConfig pm $ \genesisConfig _ _ -> do + bracketPassiveWallet (configProtocolMagic genesisConfig) $ \passive -> + Kernel.bracketActiveWallet passive diffusion test diff --git a/wallet-new/test/unit/Test/Spec/Models.hs b/wallet-new/test/unit/Test/Spec/Models.hs index 89dcf51a0c7..a38fbe623ea 100644 --- a/wallet-new/test/unit/Test/Spec/Models.hs +++ b/wallet-new/test/unit/Test/Spec/Models.hs @@ -27,6 +27,7 @@ import qualified Wallet.Rollback.Basic as Roll import qualified Wallet.Rollback.Full as Full import Pos.Core (Coeff (..), TxSizeLinear (..)) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) {------------------------------------------------------------------------------- Pure wallet tests @@ -35,6 +36,17 @@ import Pos.Core (Coeff (..), TxSizeLinear (..)) -- | Test the pure wallet models spec :: Spec spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = describe "Test pure wallets" $ do it "Using simple model" $ forAll (genInductiveUsingModel simpleModel) $ testPureWalletWith @@ -45,7 +57,7 @@ spec = do ourActorIx = 0 allAddrs = transCtxtAddrs transCtxt - transCtxt = runTranslateNoErrors ask + transCtxt = runTranslateNoErrors pm ask boot = bootstrapTransaction transCtxt linearFeePolicy = TxSizeLinear (Coeff 155381) (Coeff 43.946) diff --git a/wallet-new/test/unit/Test/Spec/NewPayment.hs b/wallet-new/test/unit/Test/Spec/NewPayment.hs index aea3da75189..a48400038aa 100644 --- a/wallet-new/test/unit/Test/Spec/NewPayment.hs +++ b/wallet-new/test/unit/Test/Spec/NewPayment.hs @@ -26,9 +26,10 @@ import Formatting (build, formatToString, sformat) import Pos.Chain.Txp (TxOut (..), TxOutAux (..)) import Pos.Core (Address, Coin (..), IsBootstrapEraAddr (..), deriveLvl2KeyPair, mkCoin) -import Pos.Core.NetworkMagic (NetworkMagic (..)) -import Pos.Crypto (EncryptedSecretKey, ShouldCheckPassphrase (..), - emptyPassphrase, safeDeterministicKeyGen) +import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) +import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, + ShouldCheckPassphrase (..), emptyPassphrase, + safeDeterministicKeyGen) import Test.Spec.CoinSelection.Generators (InitialBalance (..), Pay (..), genPayee, genUtxoWithAtLeast) @@ -81,10 +82,11 @@ data Fixture = Fixture { -- | Prepare some fixtures using the 'PropertyM' context to prepare the data, -- and execute the 'acid-state' update once the 'PassiveWallet' gets into -- scope (after the bracket initialisation). -prepareFixtures :: InitialBalance +prepareFixtures :: NetworkMagic + -> InitialBalance -> Pay -> Fixture.GenActiveWalletFixture Fixture -prepareFixtures initialBalance toPay = do +prepareFixtures nm initialBalance toPay = do let (_, esk) = safeDeterministicKeyGen (B.pack $ replicate 32 0x42) mempty let newRootId = eskToHdRootId esk newRoot <- initHdRoot <$> pure newRootId @@ -99,7 +101,7 @@ prepareFixtures initialBalance toPay = do utxo' <- foldlM (\acc (txIn, (TxOutAux (TxOut _ coin))) -> do newIndex <- deriveIndex (pick . choose) HdAddressIx HardDerivation - let Just (addr, _) = deriveLvl2KeyPair fixedNM + let Just (addr, _) = deriveLvl2KeyPair nm (IsBootstrapEraAddr True) (ShouldCheckPassphrase True) mempty @@ -116,7 +118,7 @@ prepareFixtures initialBalance toPay = do let accounts = Kernel.prefilterUtxo newRootId esk utxo' hdAccountId = Kernel.defaultHdAccountId newRootId - (Just hdAddress) = Kernel.defaultHdAddress esk emptyPassphrase newRootId + (Just hdAddress) = Kernel.defaultHdAddress nm esk emptyPassphrase newRootId void $ liftIO $ update (pw ^. wallets) (CreateHdWallet newRoot hdAccountId hdAddress accounts) return $ Fixture { @@ -128,7 +130,8 @@ prepareFixtures initialBalance toPay = do } withFixture :: MonadIO m - => InitialBalance + => ProtocolMagic + -> InitialBalance -> Pay -> ( Keystore.Keystore -> ActiveWalletLayer m @@ -137,8 +140,10 @@ withFixture :: MonadIO m -> IO a ) -> PropertyM IO a -withFixture initialBalance toPay cc = - Fixture.withActiveWalletFixture (prepareFixtures initialBalance toPay) cc +withFixture pm initialBalance toPay cc = + Fixture.withActiveWalletFixture pm (prepareFixtures nm initialBalance toPay) cc + where + nm = makeNetworkMagic pm -- | A constant fee calculation. constantFee :: Int -> NonEmpty Coin -> Coin @@ -146,15 +151,16 @@ constantFee _ _ = mkCoin 10 -- | Helper function to facilitate payments via the Layer or Servant. withPayment :: MonadIO n - => InitialBalance + => ProtocolMagic + -> InitialBalance -- ^ How big the wallet Utxo must be -> Pay -- ^ How big the payment must be -> (ActiveWalletLayer n -> V1.Payment -> IO ()) -- ^ The action to run. -> PropertyM IO () -withPayment initialBalance toPay action = do - withFixture initialBalance toPay $ \keystore activeLayer _ Fixture{..} -> do +withPayment pm initialBalance toPay action = do + withFixture pm initialBalance toPay $ \keystore activeLayer _ Fixture{..} -> do liftIO $ Keystore.insert (WalletIdHdRnd fixtureHdRootId) fixtureESK keystore let (AccountIdHdRnd hdAccountId) = fixtureAccountId let (HdRootId (InDb rootAddress)) = fixtureHdRootId @@ -177,8 +183,9 @@ spec = describe "NewPayment" $ do describe "Generating a new payment (wallet layer)" $ do prop "pay works (realSigner, SenderPaysFee)" $ withMaxSuccess 50 $ do - monadicIO $ - withPayment (InitialADA 10000) (PayLovelace 10) $ \activeLayer newPayment -> do + monadicIO $ do + pm <- pick arbitrary + withPayment pm (InitialADA 10000) (PayLovelace 10) $ \activeLayer newPayment -> do res <- liftIO ((WalletLayer.pay activeLayer) mempty IgnoreGrouping SenderPaysFee @@ -188,8 +195,9 @@ spec = describe "NewPayment" $ do describe "Generating a new payment (kernel)" $ do prop "newTransaction works (real signer, SenderPaysFee)" $ withMaxSuccess 50 $ do - monadicIO $ - withFixture @IO (InitialADA 10000) (PayLovelace 10) $ \_ _ aw Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) (PayLovelace 10) $ \_ _ aw Fixture{..} -> do policy <- Node.getFeePolicy (Kernel.walletPassive aw ^. Kernel.walletNode) let opts = (newOptions (Kernel.cardanoFee policy)) { csoExpenseRegulation = SenderPaysFee @@ -205,8 +213,9 @@ spec = describe "NewPayment" $ do liftIO ((bimap STB (const $ STB ()) res) `shouldSatisfy` isRight) prop "newTransaction works (ReceiverPaysFee)" $ withMaxSuccess 50 $ do - monadicIO $ - withFixture @IO (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do policy <- Node.getFeePolicy (Kernel.walletPassive aw ^. Kernel.walletNode) let opts = (newOptions (Kernel.cardanoFee policy)) { csoExpenseRegulation = ReceiverPaysFee @@ -224,8 +233,9 @@ spec = describe "NewPayment" $ do describe "Generating a new payment (Servant)" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ - monadicIO $ - withPayment (InitialADA 1000) (PayADA 1) $ \activeLayer newPayment -> do + monadicIO $ do + pm <- pick arbitrary + withPayment pm (InitialADA 1000) (PayADA 1) $ \activeLayer newPayment -> do res <- liftIO (runExceptT . runHandler' $ Handlers.newTransaction activeLayer newPayment) liftIO ((bimap identity STB res) `shouldSatisfy` isRight) @@ -234,8 +244,9 @@ spec = describe "NewPayment" $ do describe "Estimating fees (wallet layer)" $ do prop "estimating fees works (SenderPaysFee)" $ withMaxSuccess 50 $ do - monadicIO $ - withPayment (InitialADA 10000) (PayLovelace 10) $ \activeLayer newPayment -> do + monadicIO $ do + pm <- pick arbitrary + withPayment pm (InitialADA 10000) (PayLovelace 10) $ \activeLayer newPayment -> do res <- liftIO ((WalletLayer.estimateFees activeLayer) IgnoreGrouping SenderPaysFee newPayment @@ -247,8 +258,9 @@ spec = describe "NewPayment" $ do describe "Estimating fees (kernel)" $ do prop "estimating fees works (SenderPaysFee)" $ withMaxSuccess 50 $ - monadicIO $ - withFixture @IO (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do let opts = (newOptions constantFee) { csoExpenseRegulation = SenderPaysFee , csoInputGrouping = IgnoreGrouping @@ -266,8 +278,9 @@ spec = describe "NewPayment" $ do Right x -> x `shouldBe` Coin 10 prop "estimating fees works (kernel, ReceiverPaysFee)" $ withMaxSuccess 50 $ - monadicIO $ - withFixture @IO (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do let opts = (newOptions constantFee) { csoExpenseRegulation = SenderPaysFee , csoInputGrouping = IgnoreGrouping @@ -285,8 +298,9 @@ spec = describe "NewPayment" $ do Right x -> x `shouldBe` Coin 10 prop "estimating fees works (kernel, SenderPaysFee, cardanoFee)" $ withMaxSuccess 50 $ - monadicIO $ - withFixture @IO (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do + monadicIO $ do + pm <- pick arbitrary + withFixture @IO pm (InitialADA 10000) (PayADA 1) $ \_ _ aw Fixture{..} -> do policy <- Node.getFeePolicy (Kernel.walletPassive aw ^. Kernel.walletNode) let opts = (newOptions (Kernel.cardanoFee policy)) { csoExpenseRegulation = SenderPaysFee @@ -306,8 +320,9 @@ spec = describe "NewPayment" $ do describe "Estimating fees (Servant)" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ - monadicIO $ - withPayment (InitialADA 1000) (PayADA 1) $ \activeLayer newPayment -> do + monadicIO $ do + pm <- pick arbitrary + withPayment pm (InitialADA 1000) (PayADA 1) $ \activeLayer newPayment -> do res <- liftIO (runExceptT . runHandler' $ Handlers.estimateFees activeLayer newPayment) liftIO ((bimap identity STB res) `shouldSatisfy` isRight) @@ -317,12 +332,10 @@ spec = describe "NewPayment" $ do prop "ignores completely the spending password in Payment" $ withMaxSuccess 50 $ monadicIO $ do randomPass <- pick arbitrary - withPayment (InitialADA 1000) (PayADA 1) $ \activeLayer newPayment -> do + pm <- pick arbitrary + withPayment pm (InitialADA 1000) (PayADA 1) $ \activeLayer newPayment -> do -- mangle the spending password to be something arbitrary, check -- that this doesn't hinder our ability to estimate fees. let pmt = newPayment { V1.pmtSpendingPassword = randomPass } res <- liftIO (runExceptT . runHandler' $ Handlers.estimateFees activeLayer pmt) liftIO ((bimap identity STB res) `shouldSatisfy` isRight) - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/wallet-new/test/unit/Test/Spec/Submission.hs b/wallet-new/test/unit/Test/Spec/Submission.hs index 96925cff857..a01a3a4c569 100644 --- a/wallet-new/test/unit/Test/Spec/Submission.hs +++ b/wallet-new/test/unit/Test/Spec/Submission.hs @@ -4,7 +4,6 @@ -- We are missing (MonadFail Gen), therfore [a,b,c,d] <- vectorOf 4 will trigger a warning with -compat module Test.Spec.Submission ( spec - , dependentTransactions ) where import Universum hiding (elems) @@ -27,15 +26,14 @@ import qualified Formatting as F import Formatting.Buildable (build) import qualified Pos.Chain.Txp as Txp import Pos.Core.Attributes (Attributes (..), UnparsedFields (..)) -import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), - RequiresNetworkMagic (..)) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.Crypto.Hashing (hash) import Pos.Crypto.Signing.Safe (safeDeterministicKeyGen) import Serokell.Util.Text (listJsonIndent) import qualified Test.Pos.Chain.Txp.Arbitrary as Txp import Test.QuickCheck (Gen, Property, arbitrary, choose, conjoin, - forAll, listOf, shuffle, vectorOf, (===)) + forAll, generate, listOf, shuffle, vectorOf, (===)) import Test.QuickCheck.Property (counterexample) import Util.Buildable (ShowThroughBuild (..)) import Util.Buildable.Hspec @@ -88,19 +86,23 @@ genSchedule maxRetries pending (Slot lowerBound) = do e = ScheduleEvents [s] mempty in prependEvents slot e acc -genWalletSubmissionState :: HdAccountId -> MaxRetries -> Gen WalletSubmissionState -genWalletSubmissionState accId maxRetries = do - pending <- M.singleton accId <$> genPending protocolMagic +genWalletSubmissionState :: ProtocolMagic + -> HdAccountId + -> MaxRetries + -> Gen WalletSubmissionState +genWalletSubmissionState pm accId maxRetries = do + pending <- M.singleton accId <$> genPending pm let slot = Slot 0 -- Make the layer always start from 0, to make running the specs predictable. scheduler <- genSchedule maxRetries pending slot return $ WalletSubmissionState pending scheduler slot -genWalletSubmission :: HdAccountId +genWalletSubmission :: ProtocolMagic + -> HdAccountId -> MaxRetries -> ResubmissionFunction -> Gen WalletSubmission -genWalletSubmission accId maxRetries rho = - WalletSubmission <$> pure rho <*> genWalletSubmissionState accId maxRetries +genWalletSubmission pm accId maxRetries rho = + WalletSubmission <$> pure rho <*> genWalletSubmissionState pm accId maxRetries {------------------------------------------------------------------------------- Submission layer tests @@ -171,15 +173,15 @@ instance Buildable LabelledTxAux where -- Generates 4 transactions A, B, C, D such that -- D -> C -> B -> A (C depends on B which depends on A) -dependentTransactions :: Gen (LabelledTxAux, LabelledTxAux, LabelledTxAux, LabelledTxAux) -dependentTransactions = do +dependentTransactions :: ProtocolMagic -> Gen (LabelledTxAux, LabelledTxAux, LabelledTxAux, LabelledTxAux) +dependentTransactions pm = do let emptyAttributes = Attributes () (UnparsedFields mempty) inputForA <- (Txp.TxInUtxo <$> arbitrary <*> arbitrary) outputForA <- (Txp.TxOut <$> arbitrary <*> arbitrary) outputForB <- (Txp.TxOut <$> arbitrary <*> arbitrary) outputForC <- (Txp.TxOut <$> arbitrary <*> arbitrary) outputForD <- (Txp.TxOut <$> arbitrary <*> arbitrary) - [a,b,c,d] <- vectorOf 4 (Txp.genTxAux protocolMagic) + [a,b,c,d] <- vectorOf 4 (Txp.genTxAux pm) let a' = a { Txp.taTx = (Txp.taTx a) { Txp._txInputs = inputForA :| mempty , Txp._txOutputs = outputForA :| mempty @@ -213,14 +215,14 @@ dependentTransactions = do --- --- Pure generators, running in Identity --- -genPureWalletSubmission :: HdAccountId -> Gen (ShowThroughBuild WalletSubmission) -genPureWalletSubmission accId = - STB <$> genWalletSubmission accId 255 constantResubmit - -genPurePair :: Gen (ShowThroughBuild (WalletSubmission, M.Map HdAccountId Pending)) -genPurePair = do - STB layer <- genPureWalletSubmission myAccountId - pending <- genPending protocolMagic +genPureWalletSubmission :: ProtocolMagic -> HdAccountId -> Gen (ShowThroughBuild WalletSubmission) +genPureWalletSubmission pm accId = + STB <$> genWalletSubmission pm accId 255 constantResubmit + +genPurePair :: ProtocolMagic -> Gen (ShowThroughBuild (WalletSubmission, M.Map HdAccountId Pending)) +genPurePair pm = do + STB layer <- genPureWalletSubmission pm myAccountId + pending <- genPending pm let pending' = Pending.delete (toTxIdSet $ layer ^. localPendingSet myAccountId) pending pure $ STB (layer, M.singleton myAccountId pending') @@ -277,12 +279,24 @@ addPending' :: M.Map HdAccountId Pending -> WalletSubmission addPending' m ws = M.foldlWithKey' (\acc k v -> addPending k v acc) ws m + spec :: Spec spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = do describe "Test wallet submission layer" $ do it "supports addition of pending transactions" $ - forAll genPurePair $ \(unSTB -> (submission, toAdd)) -> + forAll (genPurePair pm) $ \(unSTB -> (submission, toAdd)) -> let currentSlot = submission ^. getCurrentSlot submission' = addPending' toAdd submission schedule = submission' ^. getSchedule @@ -294,11 +308,11 @@ spec = do ] it "supports deletion of pending transactions" $ - forAll genPurePair $ \(unSTB -> (submission, toRemove)) -> + forAll (genPurePair pm) $ \(unSTB -> (submission, toRemove)) -> doesNotContainPending toRemove $ remPendingById myAccountId (toTxIdSet' toRemove) submission it "remPending . addPending = id" $ - forAll genPurePair $ \(unSTB -> (submission, pending)) -> + forAll (genPurePair pm) $ \(unSTB -> (submission, pending)) -> let originallyPending = submission ^. localPendingSet myAccountId currentlyPending = view (localPendingSet myAccountId) (remPendingById myAccountId @@ -308,7 +322,7 @@ spec = do in failIf "the two pending set are not equal" ((==) `on` Pending.transactions) originallyPending currentlyPending it "increases its internal slot after ticking" $ do - forAll (genPureWalletSubmission myAccountId) $ \(unSTB -> submission) -> + forAll (genPureWalletSubmission pm myAccountId) $ \(unSTB -> submission) -> let slotNow = submission ^. getCurrentSlot (_, _, ws') = tick submission in failIf "internal slot didn't increase" (==) (ws' ^. getCurrentSlot) (mapSlot succ slotNow) @@ -325,7 +339,7 @@ spec = do ] it "limit retries correctly" $ do - forAll genPurePair $ \(unSTB -> (ws, pending)) -> + forAll (genPurePair pm) $ \(unSTB -> (ws, pending)) -> let ws' = (addPending' pending ws) & wsResubmissionFunction .~ giveUpAfter 3 (evicted1, _, ws1) = tick ws' (evicted2, _, ws2) = tick ws1 @@ -347,8 +361,8 @@ spec = do -- check that if these 4 are all scheduled within the same slot, they -- are all scheduled for submission. it "Given D->C->B->A all in the same slot, they are all sent" $ do - let generator = do (b,c,a,d) <- dependentTransactions - ws <- addPending myAccountId (pendingFromTxs (map labelledTxAux [a,b,c,d])) . unSTB <$> genPureWalletSubmission myAccountId + let generator = do (b,c,a,d) <- dependentTransactions pm + ws <- addPending myAccountId (pendingFromTxs (map labelledTxAux [a,b,c,d])) . unSTB <$> genPureWalletSubmission pm myAccountId txs <- shuffle [b,c,a,d] return $ STB (ws, txs) forAll generator $ \(unSTB -> (submission, txs)) -> @@ -369,8 +383,8 @@ spec = do -- if [A,B,C] are scheduled on slot 2 and [D] on slot 1, we shouldn't -- send anything. it "Given D->C->B->A, if C,B,A are in the future, D is not sent this slot" $ do - let generator = do (b,c,a,d) <- dependentTransactions - ws <- addPending myAccountId (pendingFromTxs (map labelledTxAux [a,b,c])) . unSTB <$> genPureWalletSubmission myAccountId + let generator = do (b,c,a,d) <- dependentTransactions pm + ws <- addPending myAccountId (pendingFromTxs (map labelledTxAux [a,b,c])) . unSTB <$> genPureWalletSubmission pm myAccountId return $ STB (addPending myAccountId (pendingFromTxs (map labelledTxAux [d])) ((\(_,_,s) -> s) . tick $ ws), d) forAll generator $ \(unSTB -> (submission, d)) -> let currentSlot = submission ^. getCurrentSlot @@ -397,8 +411,8 @@ spec = do -- anything and finally on slot 3 we would send [C,D]. it "Given D->C->B->A, can send [A,B] now, [D,C] in the future" $ do let generator :: Gen (ShowThroughBuild (WalletSubmission, [LabelledTxAux])) - generator = do (b,c,a,d) <- dependentTransactions - ws <- addPending myAccountId (pendingFromTxs (map labelledTxAux [a,b])) . unSTB <$> genPureWalletSubmission myAccountId + generator = do (b,c,a,d) <- dependentTransactions pm + ws <- addPending myAccountId (pendingFromTxs (map labelledTxAux [a,b])) . unSTB <$> genPureWalletSubmission pm myAccountId let (_, _, ws') = tick ws let ws'' = addPending myAccountId (pendingFromTxs (map labelledTxAux [d])) ws' return $ STB (ws'', [a,b,c,d]) @@ -435,7 +449,3 @@ spec = do , mustNotIncludeEvents "none of [a,b,c,d] was scheduled" (ScheduleEvents scheduledInSlot2 confirmed2) [a,b,c,d] , includeEvents "[c,d] scheduled slot 3" (ScheduleEvents scheduledInSlot3 confirmed3) [c,d] ] - - -protocolMagic :: ProtocolMagic -protocolMagic = ProtocolMagic (ProtocolMagicId 0) RequiresNoMagic diff --git a/wallet-new/test/unit/Test/Spec/Translation.hs b/wallet-new/test/unit/Test/Spec/Translation.hs index a34b967b1d2..17a5edba2e9 100644 --- a/wallet-new/test/unit/Test/Spec/Translation.hs +++ b/wallet-new/test/unit/Test/Spec/Translation.hs @@ -9,6 +9,7 @@ import qualified Data.Set as Set import Formatting (bprint, build, shown, (%)) import qualified Formatting.Buildable import Pos.Core.Chrono +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Serokell.Util (mapJson) import Test.Hspec.QuickCheck @@ -34,41 +35,52 @@ import UTxO.Translate spec :: Spec spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = do describe "Translation sanity checks" $ do it "can construct and verify empty block" $ - intAndVerifyPure linearFeePolicy emptyBlock `shouldSatisfy` expectValid + intAndVerifyPure pm linearFeePolicy emptyBlock `shouldSatisfy` expectValid it "can construct and verify block with one transaction" $ - intAndVerifyPure linearFeePolicy oneTrans `shouldSatisfy` expectValid + intAndVerifyPure pm linearFeePolicy oneTrans `shouldSatisfy` expectValid it "can construct and verify example 1 from the UTxO paper" $ - intAndVerifyPure linearFeePolicy example1 `shouldSatisfy` expectValid + intAndVerifyPure pm linearFeePolicy example1 `shouldSatisfy` expectValid it "can reject overspending" $ - intAndVerifyPure linearFeePolicy overspend `shouldSatisfy` expectInvalid + intAndVerifyPure pm linearFeePolicy overspend `shouldSatisfy` expectInvalid it "can reject double spending" $ - intAndVerifyPure linearFeePolicy doublespend `shouldSatisfy` expectInvalid + intAndVerifyPure pm linearFeePolicy doublespend `shouldSatisfy` expectInvalid -- There are subtle points near the epoch boundary, so we test from a -- few blocks less to a few blocks more than the length of an epoch prop "can construct and verify chain that spans epochs" $ - let epochSlots = runTranslateNoErrors $ asks (ccEpochSlots . tcCardano) + let epochSlots = runTranslateNoErrors pm $ asks (ccEpochSlots . tcCardano) in forAll (choose ( 1, 3) :: Gen Int) $ \numEpochs -> forAll (choose (-10, 10) :: Gen Int) $ \extraSlots -> let numSlots = numEpochs * fromIntegral epochSlots + extraSlots in shouldSatisfy - (intAndVerifyPure linearFeePolicy (spanEpochs numSlots)) + (intAndVerifyPure pm linearFeePolicy (spanEpochs numSlots)) expectValid describe "Translation QuickCheck tests" $ do prop "can translate randomly generated chains" $ forAll - (intAndVerifyGen (genChainUsingModel . cardanoModel linearFeePolicy ourActorIx allAddrs)) + (intAndVerifyGen pm (genChainUsingModel . cardanoModel linearFeePolicy ourActorIx allAddrs)) expectValid where - transCtxt = runTranslateNoErrors ask + transCtxt = runTranslateNoErrors pm ask allAddrs = transCtxtAddrs transCtxt ourActorIx = 0 @@ -244,27 +256,31 @@ spanEpochs numSlots GenesisValues{..} = OldestFirst $ Verify chain -------------------------------------------------------------------------------} -intAndVerifyPure :: TxSizeLinear +intAndVerifyPure :: ProtocolMagic + -> TxSizeLinear -> (GenesisValues GivenHash Addr -> Chain GivenHash Addr) -> ValidationResult GivenHash Addr -intAndVerifyPure txSizeLinear pc = runIdentity $ intAndVerify (Identity . pc . genesisValues txSizeLinear) +intAndVerifyPure pm txSizeLinear pc = runIdentity $ + intAndVerify pm (Identity . pc . genesisValues txSizeLinear) -- | Specialization of 'intAndVerify' to 'Gen' -intAndVerifyGen :: (Transaction GivenHash Addr -> Gen (Chain GivenHash Addr)) - -> Gen (ValidationResult GivenHash Addr) +intAndVerifyGen :: ProtocolMagic -> (Transaction GivenHash Addr + -> Gen (Chain GivenHash Addr)) -> Gen (ValidationResult GivenHash Addr) intAndVerifyGen = intAndVerify -- | Specialization of 'intAndVerifyChain' to 'GivenHash' intAndVerify :: Monad m - => (Transaction GivenHash Addr -> m (Chain GivenHash Addr)) + => ProtocolMagic + -> (Transaction GivenHash Addr -> m (Chain GivenHash Addr)) -> m (ValidationResult GivenHash Addr) intAndVerify = intAndVerifyChain -- | Interpret and verify a chain. intAndVerifyChain :: (Hash h Addr, Monad m) - => (Transaction h Addr -> m (Chain h Addr)) + => ProtocolMagic + -> (Transaction h Addr -> m (Chain h Addr)) -> m (ValidationResult h Addr) -intAndVerifyChain pc = runTranslateT $ do +intAndVerifyChain pm pc = runTranslateT pm $ do boot <- asks bootstrapTransaction chain <- lift $ pc boot let ledger = chainToLedger boot chain diff --git a/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs b/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs index f2f768bd1e5..ee9ac4d60f0 100644 --- a/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs +++ b/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs @@ -35,13 +35,14 @@ import Pos.Core import Pos.Core.Chrono import Pos.Core.Slotting (EpochIndex (..), LocalSlotIndex (..), SlotId (..)) +import Pos.Crypto (ProtocolMagic) import Pos.Infra.InjectFail (mkFInjects) import Pos.Util (withCompileInfo) import Test.Hspec import Test.Infrastructure.Genesis -import Test.Pos.Configuration (withDefConfiguration, - withDefUpdateConfiguration) +import Test.Pos.Configuration (withDefUpdateConfiguration, + withProvidedMagicConfig) import UTxO.Context import UTxO.DSL import Wallet.Inductive @@ -386,7 +387,6 @@ checkWithTxs check pw = do nodeStParams1 :: MockNodeStateParams nodeStParams1 = - withDefConfiguration $ \_pm -> withDefUpdateConfiguration $ withCompileInfo $ MockNodeStateParams { @@ -401,7 +401,6 @@ nodeStParams1 = nodeStParams2 :: MockNodeStateParams nodeStParams2 = - withDefConfiguration $ \_pm -> withDefUpdateConfiguration $ withCompileInfo $ MockNodeStateParams { @@ -419,21 +418,21 @@ nodeStParams2 = -- the NodeStateParameters. This is important for Transactions, because -- dynamic TxMeta depend on the state of the Node and we want to be flexible -- there for better testing. -bracketActiveWalletTxMeta :: MockNodeStateParams -> (Kernel.ActiveWallet -> IO a) -> IO a -bracketActiveWalletTxMeta stateParams test = - withDefConfiguration $ \genesisConfig -> do - bracketPassiveWalletTxMeta stateParams $ \passive -> - Kernel.bracketActiveWallet (configProtocolMagic genesisConfig) - passive +bracketActiveWalletTxMeta :: ProtocolMagic -> MockNodeStateParams -> (Kernel.ActiveWallet -> IO a) -> IO a +bracketActiveWalletTxMeta pm stateParams test = + withProvidedMagicConfig pm $ \genesisConfig _ _ -> do + bracketPassiveWalletTxMeta (configProtocolMagic genesisConfig) stateParams $ \passive -> + Kernel.bracketActiveWallet passive diffusion $ \active -> test active -- | Initialize passive wallet in a manner suitable for the unit tests -bracketPassiveWalletTxMeta :: MockNodeStateParams -> (Kernel.PassiveWallet -> IO a) -> IO a -bracketPassiveWalletTxMeta stateParams postHook = do +bracketPassiveWalletTxMeta :: ProtocolMagic -> MockNodeStateParams -> (Kernel.PassiveWallet -> IO a) -> IO a +bracketPassiveWalletTxMeta pm stateParams postHook = do Keystore.bracketTestKeystore $ \keystore -> do mockFInjects <- mkFInjects mempty Kernel.bracketPassiveWallet + pm Kernel.UseInMemory logMessage keystore diff --git a/wallet-new/test/unit/Test/Spec/Wallets.hs b/wallet-new/test/unit/Test/Spec/Wallets.hs index 6e6713b6fc3..79f532a260e 100644 --- a/wallet-new/test/unit/Test/Spec/Wallets.hs +++ b/wallet-new/test/unit/Test/Spec/Wallets.hs @@ -17,7 +17,8 @@ import Data.Coerce (coerce) import Formatting (build, formatToString) import Pos.Core (decodeTextAddress) -import Pos.Crypto (emptyPassphrase, hash) +import Pos.Core.NetworkMagic (makeNetworkMagic) +import Pos.Crypto (ProtocolMagic, emptyPassphrase, hash) import Pos.Crypto.HD (firstHardened) import qualified Cardano.Wallet.Kernel.BIP39 as BIP39 @@ -94,14 +95,15 @@ prepareFixtures = do return (Fixture spendingPassword v1Wallet rootId) -- | A 'Fixture' where we already have a new 'Wallet' in scope. -withNewWalletFixture :: ( Keystore.Keystore +withNewWalletFixture :: ProtocolMagic + -> ( Keystore.Keystore -> WalletLayer.PassiveWalletLayer IO -> Internal.PassiveWallet -> Fixture -> IO a ) -> PropertyM IO a -withNewWalletFixture cc = withPassiveWalletFixture prepareFixtures cc +withNewWalletFixture pm cc = withPassiveWalletFixture pm prepareFixtures cc spec :: Spec spec = describe "Wallets" $ do @@ -112,7 +114,8 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword request <- WalletLayer.CreateWallet <$> genNewWalletRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do liftIO $ do res <- WalletLayer.createWallet layer request (bimap STB STB res) `shouldSatisfy` isRight @@ -121,7 +124,8 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword request <- WalletLayer.CreateWallet <$> genNewWalletRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do liftIO $ do -- The first time it must succeed. res1 <- WalletLayer.createWallet layer request @@ -140,7 +144,8 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword request <- genNewWalletRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do let w' = WalletLayer.CreateWallet $ request { V1.newwalName = "İıÀļƒȑĕďŏŨƞįťŢęșťıİ 日本" } liftIO $ do @@ -153,12 +158,15 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword V1.NewWallet{..} <- genNewWalletRq pwd - withLayer @IO $ \_ wallet -> do + pm <- pick arbitrary + withLayer @IO pm $ \_ wallet -> do liftIO $ do let hdAssuranceLevel = case newwalAssuranceLevel of V1.NormalAssurance -> AssuranceLevelNormal V1.StrictAssurance -> AssuranceLevelStrict - res <- Kernel.createHdWallet wallet + nm = makeNetworkMagic pm + res <- Kernel.createHdWallet nm + wallet (V1.unBackupPhrase newwalBackupPhrase) (maybe emptyPassphrase coerce newwalSpendingPassword) hdAssuranceLevel @@ -176,7 +184,8 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword rq <- genNewWalletRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do liftIO $ do res <- runExceptT . runHandler' $ Handlers.newWallet layer rq (bimap identity STB res) `shouldSatisfy` isRight @@ -185,7 +194,8 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword rq <- genNewWalletRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do liftIO $ do let fetchAccount wId = Handlers.getAccount layer wId (V1.unsafeMkAccountIndex firstHardened) @@ -198,7 +208,8 @@ spec = describe "Wallets" $ do monadicIO $ do pwd <- genSpendingPassword rq <- genNewWalletRq pwd - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do liftIO $ do let fetchAccount wId = Handlers.getAccount layer wId (V1.unsafeMkAccountIndex firstHardened) @@ -216,7 +227,8 @@ spec = describe "Wallets" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withNewWalletFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \_ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet liftIO $ do res1 <- WalletLayer.deleteWallet layer wId @@ -227,7 +239,8 @@ spec = describe "Wallets" $ do prop "cascade-deletes all the associated accounts" $ withMaxSuccess 50 $ do monadicIO $ do - withNewWalletFixture $ \_ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \_ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet liftIO $ do let check predicate _ V1.Account{..} = do @@ -252,7 +265,8 @@ spec = describe "Wallets" $ do prop "fails if the wallet doesn't exists" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do liftIO $ do res <- WalletLayer.deleteWallet layer wId case res of @@ -266,7 +280,8 @@ spec = describe "Wallets" $ do describe "Wallet deletion (kernel)" $ do prop "correctly deletes the ESK in the keystore" $ withMaxSuccess 50 $ monadicIO $ do - withNewWalletFixture $ \ks _ wallet Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ks _ wallet Fixture{..} -> do liftIO $ do let wId = WalletIdHdRnd fixtureHdRootId @@ -289,7 +304,8 @@ spec = describe "Wallets" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do newPwd <- pick arbitrary - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do let request = V1.PasswordUpdate fixtureSpendingPassword newPwd let wId = V1.walId fixtureV1Wallet res <- WalletLayer.updateWalletPassword layer wId request @@ -299,7 +315,8 @@ spec = describe "Wallets" $ do monadicIO $ do wrongPwd <- pick (arbitrary `suchThat` ((/=) mempty)) newPwd <- pick arbitrary - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do let request = V1.PasswordUpdate wrongPwd newPwd let wId = V1.walId fixtureV1Wallet res <- WalletLayer.updateWalletPassword layer wId request @@ -314,7 +331,8 @@ spec = describe "Wallets" $ do prop "correctly replaces the ESK in the keystore" $ withMaxSuccess 50 $ monadicIO $ do newPwd <- pick arbitrary - withNewWalletFixture $ \ keystore _ wallet Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ keystore _ wallet Fixture{..} -> do let wid = WalletIdHdRnd fixtureHdRootId oldKey <- Keystore.lookup wid keystore res <- Kernel.updatePassword wallet @@ -332,7 +350,8 @@ spec = describe "Wallets" $ do prop "correctly updates hdRootHasPassword" $ do monadicIO $ do newPwd <- pick arbitrary - withNewWalletFixture $ \ _ _ wallet Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ _ wallet Fixture{..} -> do res <- Kernel.updatePassword wallet fixtureHdRootId (unV1 fixtureSpendingPassword) @@ -351,7 +370,8 @@ spec = describe "Wallets" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do newPwd <- pick arbitrary - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do liftIO $ do let wId = V1.walId fixtureV1Wallet let rq = V1.PasswordUpdate fixtureSpendingPassword newPwd @@ -366,7 +386,8 @@ spec = describe "Wallets" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet res <- WalletLayer.getWallet layer wId (bimap STB STB res) `shouldBe` (Right (STB fixtureV1Wallet)) @@ -374,7 +395,8 @@ spec = describe "Wallets" $ do prop "fails if the wallet doesn't exist" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \ layer _ -> do + pm <- pick arbitrary + withLayer pm $ \ layer _ -> do res <- WalletLayer.getWallet layer wId case res of Left (WalletLayer.GetWalletError (UnknownHdRoot _)) -> @@ -386,7 +408,8 @@ spec = describe "Wallets" $ do describe "Get a specific wallet (Servant)" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do liftIO $ do let wId = V1.walId fixtureV1Wallet res <- runExceptT . runHandler' $ Handlers.getWallet layer wId @@ -395,7 +418,8 @@ spec = describe "Wallets" $ do prop "fails if the wallet doesn't exist" $ withMaxSuccess 50 $ do monadicIO $ do wId <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do let getW = Handlers.getWallet layer wId res <- try . runExceptT . runHandler' $ getW case res of @@ -411,7 +435,8 @@ spec = describe "Wallets" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do let wId = V1.walId fixtureV1Wallet let newLevel = oppositeLevel (V1.walAssuranceLevel fixtureV1Wallet) res <- WalletLayer.updateWallet layer wId (V1.WalletUpdate newLevel "FooBar") @@ -426,7 +451,8 @@ spec = describe "Wallets" $ do wId <- pick arbitrary lvl <- pick arbitrary name <- pick arbitrary - withLayer $ \ layer _ -> do + pm <- pick arbitrary + withLayer pm $ \ layer _ -> do res <- WalletLayer.updateWallet layer wId (V1.WalletUpdate lvl name) case res of Left (WalletLayer.UpdateWalletError (UnknownHdRoot _)) -> @@ -438,7 +464,8 @@ spec = describe "Wallets" $ do describe "Update a wallet (Servant)" $ do prop "works as expected in the happy path scenario" $ withMaxSuccess 50 $ do monadicIO $ do - withNewWalletFixture $ \ _ layer _ Fixture{..} -> do + pm <- pick arbitrary + withNewWalletFixture pm $ \ _ layer _ Fixture{..} -> do liftIO $ do let wId = V1.walId fixtureV1Wallet let newLevel = oppositeLevel (V1.walAssuranceLevel fixtureV1Wallet) @@ -452,10 +479,11 @@ spec = describe "Wallets" $ do prop "fails if the wallet doesn't exist" $ withMaxSuccess 50 $ do monadicIO $ do - wId <- pick arbitrary + wId <- pick arbitrary lvl <- pick arbitrary name <- pick arbitrary - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do let updateW = Handlers.updateWallet layer wId res <- try . runExceptT . runHandler' $ updateW (V1.WalletUpdate lvl name) case res of @@ -474,7 +502,8 @@ spec = describe "Wallets" $ do rqs <- map (\rq -> WalletLayer.CreateWallet $ rq { V1.newwalOperation = V1.CreateWallet }) <$> pick (vectorOf 5 arbitrary) - withLayer $ \layer _ -> do + pm <- pick arbitrary + withLayer pm $ \layer _ -> do forM_ rqs (WalletLayer.createWallet layer) res <- WalletLayer.getWallets layer (IxSet.size res) `shouldBe` 5 @@ -484,7 +513,8 @@ spec = describe "Wallets" $ do monadicIO $ do rqs <- map (\rq -> rq { V1.newwalOperation = V1.CreateWallet }) <$> pick (vectorOf 5 arbitrary) - withLayer $ \ layer _ -> do + pm <- pick arbitrary + withLayer pm $ \ layer _ -> do liftIO $ do forM_ rqs (runExceptT . runHandler' . Handlers.newWallet layer) let params = API.RequestParams (API.PaginationParams (API.Page 1) (API.PerPage 10)) diff --git a/wallet-new/test/unit/Util/Buildable/Hspec.hs b/wallet-new/test/unit/Util/Buildable/Hspec.hs index 8b75bbe73c0..0a647ebbd95 100644 --- a/wallet-new/test/unit/Util/Buildable/Hspec.hs +++ b/wallet-new/test/unit/Util/Buildable/Hspec.hs @@ -22,6 +22,7 @@ module Util.Buildable.Hspec ( , H.it , H.beforeAll , H.parallel + , H.runIO ) where import qualified Test.Hspec as H diff --git a/wallet-new/test/unit/Util/Buildable/QuickCheck.hs b/wallet-new/test/unit/Util/Buildable/QuickCheck.hs index ba2b711a8cc..b67e2a574ec 100644 --- a/wallet-new/test/unit/Util/Buildable/QuickCheck.hs +++ b/wallet-new/test/unit/Util/Buildable/QuickCheck.hs @@ -11,6 +11,8 @@ module Util.Buildable.QuickCheck ( , QC.Gen , QC.conjoin , QC.choose + , QC.generate + , QC.arbitrary ) where import Universum diff --git a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs index 65a25b96c56..f90a22d9b69 100644 --- a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs +++ b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs @@ -28,6 +28,7 @@ import qualified Formatting.Buildable import Pos.Chain.Txp (Utxo, formatUtxo) import Pos.Core (Timestamp (..)) import Pos.Core.Chrono +import Pos.Core.NetworkMagic (makeNetworkMagic) import Pos.Crypto (EncryptedSecretKey, emptyPassphrase) import qualified Cardano.Wallet.Kernel.Addresses as Kernel @@ -47,7 +48,7 @@ import Cardano.Wallet.Kernel.Transactions (toMeta) import Data.Validated import Util.Buildable -import UTxO.Context (Addr) +import UTxO.Context (Addr, CardanoContext (..), TransCtxt (..)) import UTxO.DSL (Hash) import qualified UTxO.DSL as DSL import UTxO.ToCardano.Interpreter @@ -226,7 +227,9 @@ equivalentT useWW activeWallet esk = \mkWallet w -> -> TranslateT EquivalenceViolation m HD.HdAccountId walletBootT ctxt utxo = do let newRootId = HD.eskToHdRootId esk - let (Just defaultAddress) = Kernel.newHdAddress esk + nm <- asks (makeNetworkMagic . ccMagic . tcCardano) + let (Just defaultAddress) = Kernel.newHdAddress nm + esk emptyPassphrase (Kernel.defaultHdAccountId newRootId) (Kernel.defaultHdAddressId newRootId) diff --git a/wallet-new/test/unit/WalletUnitTest.hs b/wallet-new/test/unit/WalletUnitTest.hs index 85da2b5eb84..d3ab038493a 100644 --- a/wallet-new/test/unit/WalletUnitTest.hs +++ b/wallet-new/test/unit/WalletUnitTest.hs @@ -1,9 +1,9 @@ -- | Wallet unit tests + module Main (main) where import Universum -import Formatting (build, sformat) import Test.Hspec (Spec, describe, hspec, parallel) import InputSelection.Evaluation (evalUsingGenData, evalUsingReplay) @@ -11,10 +11,6 @@ import InputSelection.Evaluation.Options (Command (..), evalCommand, getEvalOptions) import InputSelection.Evaluation.Replot (replot) import Test.Pos.Util.Parallel.Parallelize (parallelizeAllCores) -import UTxO.Bootstrap (bootstrapTransaction) -import UTxO.Context (Addr, TransCtxt) -import UTxO.DSL (GivenHash, Transaction) -import UTxO.Translate (runTranslateNoErrors, withConfig) import qualified DeltaCompressionSpecs import qualified Test.Spec.Accounts @@ -42,7 +38,7 @@ main = do case mEvalOptions of Nothing -> do -- _showContext - runTranslateNoErrors $ withConfig $ return $ hspec $ tests + hspec $ tests Just evalOptions -> -- NOTE: The coin selection must be invoked with @eval@ -- Run @wallet-unit-tests eval --help@ for details. @@ -55,14 +51,14 @@ main = do replot evalOptions replotOpts -- | Debugging: show the translation context -_showContext :: IO () -_showContext = do - putStrLn $ runTranslateNoErrors $ withConfig $ - sformat build <$> ask - putStrLn $ runTranslateNoErrors $ - let bootstrapTransaction' :: TransCtxt -> Transaction GivenHash Addr - bootstrapTransaction' = bootstrapTransaction - in sformat build . bootstrapTransaction' <$> ask +-- _showContext :: IO () +-- _showContext = do +-- putStrLn $ runTranslateNoErrors $ withConfig $ +-- sformat build <$> ask +-- putStrLn $ runTranslateNoErrors $ +-- let bootstrapTransaction' :: TransCtxt -> Transaction GivenHash Addr +-- bootstrapTransaction' = bootstrapTransaction +-- in sformat build . bootstrapTransaction' <$> ask {------------------------------------------------------------------------------- Tests proper diff --git a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs index 632e6a6406b..4900dad3777 100644 --- a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs @@ -16,9 +16,11 @@ import Test.QuickCheck (Discard (..), arbitrary) import Test.QuickCheck.Monadic (pick, stop) import Pos.Binary (biSize) +import Pos.Chain.Genesis as Genesis (Config (..)) import Pos.Client.Txp.Addresses (getFakeChangeAddress, getNewAddress) +import Pos.Configuration () import Pos.Core.Common (Address) -import Pos.Core.NetworkMagic (NetworkMagic (..)) +import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) import Pos.Crypto (PassPhrase) import Pos.Util.Wlog (setupTestLogging) @@ -30,7 +32,8 @@ import Pos.Wallet.Web.State (askWalletSnapshot, getWalletAddresses, wamAddress) import Pos.Wallet.Web.Util (decodeCTypeOrFail) import Test.Pos.Chain.Genesis.Dummy (dummyEpochSlots) -import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Configuration (withDefConfigurations, + withProvidedMagicConfig) import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne) import Test.Pos.Wallet.Web.Mode (WalletProperty) import Test.Pos.Wallet.Web.Util (importSingleWallet, @@ -38,26 +41,29 @@ import Test.Pos.Wallet.Web.Util (importSingleWallet, spec :: Spec spec = beforeAll_ setupTestLogging $ - withDefConfigurations $ \_ _ _ -> - describe "Fake address has maximal possible size" $ - modifyMaxSuccess (const 10) $ do - prop "getNewAddress" $ - fakeAddressHasMaxSizeTest changeAddressGenerator - prop "genUniqueAddress" $ - fakeAddressHasMaxSizeTest commonAddressGenerator + withDefConfigurations $ \_ _ _ -> do + describe "Fake address has maximal possible size" $ + modifyMaxSuccess (const 10) $ do + prop "getNewAddress" $ \pm -> + withProvidedMagicConfig pm $ \genesisConfig _ _ -> + fakeAddressHasMaxSizeTest changeAddressGenerator genesisConfig + prop "genUniqueAddress" $ \pm -> + withProvidedMagicConfig pm $ \genesisConfig _ _ -> + fakeAddressHasMaxSizeTest commonAddressGenerator genesisConfig -type AddressGenerator = AccountId -> PassPhrase -> WalletProperty Address +type AddressGenerator = NetworkMagic -> AccountId -> PassPhrase -> WalletProperty Address -fakeAddressHasMaxSizeTest :: AddressGenerator -> Word32 -> WalletProperty () -fakeAddressHasMaxSizeTest generator accSeed = do +fakeAddressHasMaxSizeTest :: AddressGenerator -> Genesis.Config -> Word32 -> WalletProperty () +fakeAddressHasMaxSizeTest generator genesisConfig accSeed = do + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig passphrase <- importSingleWallet mostlyEmptyPassphrases ws <- askWalletSnapshot wid <- expectedOne "wallet addresses" $ getWalletAddresses ws accId <- lift $ decodeCTypeOrFail . caId =<< newAccount (DeterminedSeed accSeed) passphrase (CAccountInit def wid) - address <- generator accId passphrase + address <- generator nm accId passphrase - largeAddress <- lift (getFakeChangeAddress fixedNM dummyEpochSlots) + largeAddress <- lift (getFakeChangeAddress nm dummyEpochSlots) assertProperty (biSize largeAddress >= biSize address) @@ -67,12 +73,12 @@ fakeAddressHasMaxSizeTest generator accSeed = do -- Unfortunatelly, its randomness doesn't depend on QuickCheck seed, -- so another proper generator is helpful. changeAddressGenerator :: AddressGenerator -changeAddressGenerator accId passphrase = - lift $ getNewAddress fixedNM dummyEpochSlots (accId, passphrase) +changeAddressGenerator nm accId passphrase = + lift $ getNewAddress nm dummyEpochSlots (accId, passphrase) -- | Generator which is directly used in endpoints. commonAddressGenerator :: AddressGenerator -commonAddressGenerator accId passphrase = do +commonAddressGenerator _nm accId passphrase = do ws <- askWalletSnapshot addrSeed <- pick arbitrary let genAddress = genUniqueAddress ws (DeterminedSeed addrSeed) passphrase accId @@ -84,7 +90,3 @@ commonAddressGenerator accId passphrase = do seedBusyHandler (InternalError "address generation: this index is already taken") = pure Nothing seedBusyHandler e = throwM e - - -fixedNM :: NetworkMagic -fixedNM = NetworkMainOrStage diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs index 95ad0fc915e..713b26bb621 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs @@ -7,32 +7,45 @@ module Test.Pos.Wallet.Web.Methods.BackupDefaultAddressesSpec import Universum -import Pos.Launcher (HasConfigurations) +import Test.Hspec (Spec, beforeAll_, describe, runIO) +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck (arbitrary, generate) +import Test.QuickCheck.Monadic (pick) +import Pos.Chain.Genesis as Genesis (Config (..)) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) +import Pos.Launcher (HasConfigurations) import Pos.Util.Wlog (setupTestLogging) import Pos.Wallet.Web.ClientTypes (CWallet (..)) import Pos.Wallet.Web.Methods.Restore (restoreWalletFromBackup) -import Test.Hspec (Spec, beforeAll_, describe) -import Test.Hspec.QuickCheck (modifyMaxSuccess) -import Test.Pos.Chain.Genesis.Dummy (dummyConfig) -import Test.Pos.Configuration (withDefConfigurations) + +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Util.QuickCheck.Property (assertProperty) import Test.Pos.Wallet.Web.Mode (walletPropertySpec) -import Test.QuickCheck (Arbitrary (..)) -import Test.QuickCheck.Monadic (pick) spec :: Spec -spec = beforeAll_ setupTestLogging $ - withDefConfigurations $ \_ _ _ -> - describe "restoreAddressFromWalletBackup" $ modifyMaxSuccess (const 10) $ do - restoreWalletAddressFromBackupSpec - -restoreWalletAddressFromBackupSpec :: HasConfigurations => Spec -restoreWalletAddressFromBackupSpec = - walletPropertySpec restoreWalletAddressFromBackupDesc $ do +spec = do + runWithMagic RequiresNoMagic + runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = beforeAll_ setupTestLogging $ + withProvidedMagicConfig pm $ \genesisConfig _ _ -> + describe "restoreAddressFromWalletBackup" $ modifyMaxSuccess (const 10) $ do + restoreWalletAddressFromBackupSpec genesisConfig + +restoreWalletAddressFromBackupSpec :: HasConfigurations => Genesis.Config -> Spec +restoreWalletAddressFromBackupSpec genesisConfig = + walletPropertySpec genesisConfig restoreWalletAddressFromBackupDesc $ do walletBackup <- pick arbitrary restoredWallet <- lift - $ restoreWalletFromBackup dummyConfig walletBackup + $ restoreWalletFromBackup genesisConfig walletBackup let noOfAccounts = cwAccountsNumber restoredWallet assertProperty (noOfAccounts > 0) $ "Exported wallet has no accounts!" where diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs index a359a3cd5ed..7758e52e267 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs @@ -17,11 +17,12 @@ import Control.Exception.Safe (try) import Data.List ((!!), (\\)) import Data.List.NonEmpty (fromList) import Formatting (build, sformat, (%)) -import Test.Hspec (Spec, beforeAll_, describe, shouldBe) +import Test.Hspec (Spec, beforeAll_, describe, runIO, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck (arbitrary, choose, generate) import Test.QuickCheck.Monadic (pick) +import Pos.Chain.Genesis as Genesis (Config (..)) import Pos.Chain.Txp (Tx (..), TxAux (..), TxFee (..), TxpConfiguration, _TxOut) import Pos.Chain.Update (bvdTxFeePolicy) @@ -29,7 +30,8 @@ import Pos.Client.Txp.Balances (getBalance) import Pos.Client.Txp.Util (InputSelectionPolicy (..), txToLinearFee) import Pos.Core (Address, Coin, TxFeePolicy (..), mkCoin, sumCoins, unsafeGetCoin, unsafeSubCoin) -import Pos.Crypto (PassPhrase) +import Pos.Crypto (PassPhrase, ProtocolMagic (..), + RequiresNetworkMagic (..)) import Pos.DB.Class (MonadGState (..)) import Pos.Launcher (HasConfigurations) import Pos.Util.CompileInfo (withCompileInfo) @@ -47,8 +49,7 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow) import Pos.Util.Servant (encodeCType) import Pos.Util.Wlog (setupTestLogging) -import Test.Pos.Chain.Genesis.Dummy (dummyConfig, dummyGenesisData) -import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne, maybeStopProperty, splitWord, stopProperty) import Test.Pos.Wallet.Web.Mode (WalletProperty, getSentTxs, @@ -62,13 +63,22 @@ deriving instance Eq CTx -- TODO remove HasCompileInfo when MonadWalletWebMode will be splitted. spec :: Spec -spec = beforeAll_ setupTestLogging $ - withCompileInfo $ - withDefConfigurations $ \_ txpConfig _ -> - describe "Wallet.Web.Methods.Payment" $ modifyMaxSuccess (const 10) $ do - describe "newPaymentBatch" $ do - describe "Submitting a payment when restoring" (rejectPaymentIfRestoringSpec txpConfig) - describe "One payment" (oneNewPaymentBatchSpec txpConfig) +spec = do + runWithMagic RequiresNoMagic + -- Not running with `RequiresMagic` until `NetworkMagic` logic + -- has been fully implemented. + -- runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = beforeAll_ setupTestLogging $ + withCompileInfo $ do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + withProvidedMagicConfig pm $ \genesisConfig txpConfig _ -> + describe "Wallet.Web.Methods.Payment" $ modifyMaxSuccess (const 10) $ do + describe "newPaymentBatch" $ do + describe "Submitting a payment when restoring" (rejectPaymentIfRestoringSpec genesisConfig txpConfig) + describe "One payment" (oneNewPaymentBatchSpec genesisConfig txpConfig) data PaymentFixture = PaymentFixture { pswd :: PassPhrase @@ -83,8 +93,8 @@ data PaymentFixture = PaymentFixture { } -- | Generic block of code to be reused across all the different payment specs. -newPaymentFixture :: WalletProperty PaymentFixture -newPaymentFixture = do +newPaymentFixture :: Genesis.Config -> WalletProperty PaymentFixture +newPaymentFixture genesisConfig = do passphrases <- importSomeWallets mostlyEmptyPassphrases let l = length passphrases destLen <- pick $ choose (1, l) @@ -103,7 +113,7 @@ newPaymentFixture = do ws <- WS.askWalletSnapshot srcAddr <- getAddress ws srcAccId -- Dunno how to get account's balances without CAccModifier - initBalance <- getBalance dummyGenesisData srcAddr + initBalance <- getBalance (configGenesisData genesisConfig) srcAddr -- `div` 2 to leave money for tx fee let topBalance = unsafeGetCoin initBalance `div` 2 coins <- pick $ map mkCoin <$> splitWord topBalance (fromIntegral destLen) @@ -122,56 +132,59 @@ newPaymentFixture = do -- | Assess that if we try to submit a payment when the wallet is restoring, -- the backend prevents us from doing that. -rejectPaymentIfRestoringSpec :: HasConfigurations => TxpConfiguration -> Spec -rejectPaymentIfRestoringSpec txpConfig = walletPropertySpec "should fail with 403" $ do - PaymentFixture{..} <- newPaymentFixture - res <- lift $ try (newPaymentBatch dummyConfig txpConfig submitTxTestMode pswd batch) - liftIO $ shouldBe res (Left (err403 { errReasonPhrase = "Transaction creation is disabled when the wallet is restoring." })) +rejectPaymentIfRestoringSpec :: HasConfigurations => Genesis.Config -> TxpConfiguration -> Spec +rejectPaymentIfRestoringSpec genesisConfig txpConfig = + walletPropertySpec genesisConfig "should fail with 403" $ do + PaymentFixture{..} <- newPaymentFixture genesisConfig + res <- lift $ try (newPaymentBatch genesisConfig txpConfig submitTxTestMode pswd batch) + liftIO $ shouldBe res (Left (err403 { errReasonPhrase = "Transaction creation is disabled when the wallet is restoring." })) -- | Test one single, successful payment. -oneNewPaymentBatchSpec :: HasConfigurations => TxpConfiguration -> Spec -oneNewPaymentBatchSpec txpConfig = walletPropertySpec oneNewPaymentBatchDesc $ do - PaymentFixture{..} <- newPaymentFixture - - -- Force the wallet to be in a (fake) synced state - db <- WS.askWalletDB - randomSyncTip <- liftIO $ generate arbitrary - WS.setWalletSyncTip db walId randomSyncTip - - void $ lift $ newPaymentBatch dummyConfig txpConfig submitTxTestMode pswd batch - dstAddrs <- lift $ mapM decodeCTypeOrFail dstCAddrs - txLinearPolicy <- lift $ (bvdTxFeePolicy <$> gsAdoptedBVData) <&> \case - TxFeePolicyTxSizeLinear linear -> linear - _ -> error "unknown fee policy" - txAux <- expectedOne "sent TxAux" =<< lift getSentTxs - TxFee fee <- lift (runExceptT $ txToLinearFee txLinearPolicy txAux) >>= \case - Left er -> stopProperty $ "Couldn't compute tx fee by tx, reason: " <> pretty er - Right x -> pure x - let outAddresses = map (fst . view _TxOut) $ toList $ _txOutputs $ taTx txAux - let changeAddrs = outAddresses \\ dstAddrs - assertProperty (length changeAddrs <= 1) $ - "Expected at most one change address" - - -- Validate balances - mapM_ (uncurry expectedAddrBalance) $ zip dstAddrs coins - when (policy == OptimizeForSecurity) $ - expectedAddrBalance srcAddr (mkCoin 0) - changeBalance <- mkCoin . fromIntegral . sumCoins - <$> mapM (getBalance dummyGenesisData) changeAddrs - assertProperty (changeBalance <= initBalance `unsafeSubCoin` fee) $ - "Minimal tx fee isn't satisfied" - - ws' <- WS.askWalletSnapshot - -- Validate that tx meta was added when transaction was processed - forM_ (ordNub $ walId:dstWalIds) $ \wId -> do - txMetas <- maybeStopProperty "Wallet doesn't exist" (WS.getWalletTxHistory ws' wId) - void $ expectedOne "TxMeta for wallet" txMetas - - -- Validate change and used address - -- TODO implement it when access - -- to these addresses will be provided considering mempool - -- expectedUserAddresses - -- expectedChangeAddresses +oneNewPaymentBatchSpec :: HasConfigurations => Genesis.Config -> TxpConfiguration -> Spec +oneNewPaymentBatchSpec genesisConfig txpConfig = + walletPropertySpec genesisConfig oneNewPaymentBatchDesc $ do + PaymentFixture{..} <- newPaymentFixture genesisConfig + + -- Force the wallet to be in a (fake) synced state + db <- WS.askWalletDB + randomSyncTip <- liftIO $ generate arbitrary + WS.setWalletSyncTip db walId randomSyncTip + + void $ lift $ newPaymentBatch genesisConfig txpConfig submitTxTestMode pswd batch + dstAddrs <- lift $ mapM decodeCTypeOrFail dstCAddrs + txLinearPolicy <- lift $ (bvdTxFeePolicy <$> gsAdoptedBVData) <&> \case + TxFeePolicyTxSizeLinear linear -> linear + _ -> error "unknown fee policy" + txAux <- expectedOne "sent TxAux" =<< lift getSentTxs + TxFee fee <- lift (runExceptT $ txToLinearFee txLinearPolicy txAux) >>= \case + Left er -> stopProperty $ "Couldn't compute tx fee by tx, reason: " <> pretty er + Right x -> pure x + let outAddresses = map (fst . view _TxOut) $ toList $ _txOutputs $ taTx txAux + let changeAddrs = outAddresses \\ dstAddrs + assertProperty (length changeAddrs <= 1) $ + "Expected at most one change address" + + -- Validate balances + let genesisData = configGenesisData genesisConfig + mapM_ (uncurry expectedAddrBalance) $ zip dstAddrs coins + when (policy == OptimizeForSecurity) $ + expectedAddrBalance srcAddr (mkCoin 0) + changeBalance <- mkCoin . fromIntegral . sumCoins + <$> mapM (getBalance genesisData) changeAddrs + assertProperty (changeBalance <= initBalance `unsafeSubCoin` fee) $ + "Minimal tx fee isn't satisfied" + + ws' <- WS.askWalletSnapshot + -- Validate that tx meta was added when transaction was processed + forM_ (ordNub $ walId:dstWalIds) $ \wId -> do + txMetas <- maybeStopProperty "Wallet doesn't exist" (WS.getWalletTxHistory ws' wId) + void $ expectedOne "TxMeta for wallet" txMetas + + -- Validate change and used address + -- TODO implement it when access + -- to these addresses will be provided considering mempool + -- expectedUserAddresses + -- expectedChangeAddresses where oneNewPaymentBatchDesc = "Send money from one own address to multiple own addresses; " <> diff --git a/wallet/test/Test/Pos/Wallet/Web/Mode.hs b/wallet/test/Test/Pos/Wallet/Web/Mode.hs index 7784bac5a9e..fb8da20f6e7 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Mode.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Mode.hs @@ -46,6 +46,7 @@ import Pos.AllSecrets (HasAllSecrets (..)) import Pos.Chain.Block (HasSlogGState (..), LastKnownHeader, LastKnownHeaderTag) import Pos.Chain.Delegation (DelegationVar, HasDlgConfiguration) +import Pos.Chain.Genesis as Genesis (Config (..)) import Pos.Chain.Ssc (SscMemTag, SscState) import Pos.Chain.Txp (TxAux) import Pos.Client.KeyStorage (MonadKeys (..), MonadKeysRead (..), @@ -57,7 +58,8 @@ import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) import Pos.Context (ConnectedPeers (..)) -import Pos.Core (Timestamp (..), largestHDAddressBoot) +import Pos.Core (Timestamp (..), largestHDAddressBoot, + pcSlotSecurityParam) import Pos.Core.JsonLog (CanJsonLog (..)) import Pos.Crypto (PassPhrase) import Pos.DB (MonadDB (..), MonadDBRead (..), MonadGState (..)) @@ -121,7 +123,6 @@ import Test.Pos.Block.Logic.Mode (BlockTestContext (..), getCurrentSlotInaccurateTestDefault, getCurrentSlotTestDefault, initBlockTestContext) import Test.Pos.Chain.Genesis.Dummy (dummyConfig) -import Test.Pos.Core.Dummy (dummyEpochSlots) ---------------------------------------------------------------------------- -- Parameters @@ -194,11 +195,12 @@ getSentTxs = atomically . readTVar =<< view wtcSentTxs_L initWalletTestContext :: HasDlgConfiguration - => WalletTestParams + => Genesis.Config + -> WalletTestParams -> (WalletTestContext -> Emulation a) -> Emulation a -initWalletTestContext WalletTestParams {..} callback = - initBlockTestContext dummyConfig _wtpBlockTestParams +initWalletTestContext genesisConfig WalletTestParams {..} callback = + initBlockTestContext genesisConfig _wtpBlockTestParams $ \wtcBlockTestContext -> do wtc <- liftIO $ do wtcWalletState <- openMemState @@ -217,15 +219,16 @@ initWalletTestContext WalletTestParams {..} callback = wtcLastKnownHeader <- STM.newTVarIO Nothing wtcSentTxs <- STM.newTVarIO mempty wtcSyncQueue <- STM.newTBQueueIO 64 - wtcSlottingStateVar <- mkSimpleSlottingStateVar dummyEpochSlots + let epochSlots = pcSlotSecurityParam $ configProtocolConstants genesisConfig + wtcSlottingStateVar <- mkSimpleSlottingStateVar epochSlots pure WalletTestContext {..} callback wtc runWalletTestMode - :: HasDlgConfiguration => WalletTestParams -> WalletTestMode a -> IO a -runWalletTestMode wtp action = + :: HasDlgConfiguration => Genesis.Config -> WalletTestParams -> WalletTestMode a -> IO a +runWalletTestMode genesisConfig wtp action = runEmulation (getTimestamp $ wtp ^. wtpBlockTestParams . tpStartTime) $ - initWalletTestContext wtp $ + initWalletTestContext genesisConfig wtp $ runReaderT action ---------------------------------------------------------------------------- @@ -239,23 +242,25 @@ type WalletProperty = PropertyM WalletTestMode -- 'WalletTestParams'. walletPropertyToProperty :: (HasDlgConfiguration, Testable a) - => Gen WalletTestParams + => Genesis.Config + -> Gen WalletTestParams -> WalletProperty a -> Property -walletPropertyToProperty wtpGen walletProperty = +walletPropertyToProperty genesisConfig wtpGen walletProperty = forAll wtpGen $ \wtp -> - monadic (ioProperty . runWalletTestMode wtp) walletProperty + monadic (ioProperty . (runWalletTestMode genesisConfig) wtp) walletProperty instance (HasDlgConfiguration, Testable a) => Testable (WalletProperty a) where - property = walletPropertyToProperty arbitrary + property = walletPropertyToProperty dummyConfig arbitrary walletPropertySpec :: (HasDlgConfiguration, Testable a) - => String + => Genesis.Config + -> String -> WalletProperty a -> Spec -walletPropertySpec description wp = - prop description (walletPropertyToProperty arbitrary wp) +walletPropertySpec genesisConfig description wp = + prop description (walletPropertyToProperty genesisConfig arbitrary wp) ---------------------------------------------------------------------------- -- Instances derived from BlockTestContext diff --git a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs index 4247c0a2c2c..7df7bc31a27 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs @@ -13,16 +13,18 @@ import qualified Data.HashSet as HS import Data.List (intersect, (\\)) import qualified Data.Set as Set import Pos.Client.KeyStorage (getSecretKeysPlain) -import Test.Hspec (Spec, beforeAll_, describe, xdescribe) +import Test.Hspec (Spec, beforeAll_, describe, runIO, xdescribe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Arbitrary (..), Property, choose, oneof, - sublistOf, suchThat, vectorOf, (===)) +import Test.QuickCheck (Arbitrary (..), Property, choose, generate, + oneof, sublistOf, suchThat, vectorOf, (===)) import Test.QuickCheck.Monadic (pick) +import Pos.Chain.Genesis as Genesis (Config (..)) import Pos.Chain.Txp (TxpConfiguration (..)) -import Pos.Core (Address, BlockCount (..)) +import Pos.Core (Address, pcBlkSecurityParam) import Pos.Core.Chrono (nonEmptyOldestFirst, toNewestFirst) -import Pos.Crypto (emptyPassphrase) +import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..), + emptyPassphrase) import Pos.DB.Block (rollbackBlocks) import Pos.Launcher (HasConfigurations) import Pos.Util.Wlog (setupTestLogging) @@ -42,18 +44,30 @@ import Pos.Wallet.Web.Tracking.Types (newSyncRequest) import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..)) -import Test.Pos.Chain.Genesis.Dummy (dummyConfig, dummyK) -import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Util.QuickCheck.Property (assertProperty) import Test.Pos.Wallet.Arbitrary.Web.ClientTypes () import Test.Pos.Wallet.Web.Mode (walletPropertySpec) import Test.Pos.Wallet.Web.Util (importSomeWallets, wpGenBlocks) spec :: Spec -spec = beforeAll_ setupTestLogging $ - withDefConfigurations $ \_ _ _ -> do +spec = do + runWithMagic RequiresNoMagic + -- Not running with `RequiresMagic` until `NetworkMagic` logic + -- has been fully implemented. + -- runWithMagic RequiresMagic + +runWithMagic :: RequiresNetworkMagic -> Spec +runWithMagic rnm = do + pm <- (\ident -> ProtocolMagic ident rnm) <$> runIO (generate arbitrary) + describe ("(requiresNetworkMagic=" ++ show rnm ++ ")") $ + specBody pm + +specBody :: ProtocolMagic -> Spec +specBody pm = beforeAll_ setupTestLogging $ + withProvidedMagicConfig pm $ \genesisConfig _ _ -> do describe "Pos.Wallet.Web.Tracking.BListener" $ modifyMaxSuccess (const 10) $ do - describe "Two applications and rollbacks" twoApplyTwoRollbacksSpec + describe "Two applications and rollbacks" (twoApplyTwoRollbacksSpec genesisConfig) xdescribe "Pos.Wallet.Web.Tracking.evalChange (pending, CSL-2473)" $ do prop evalChangeDiffAccountsDesc evalChangeDiffAccounts prop evalChangeSameAccountsDesc evalChangeSameAccounts @@ -63,15 +77,16 @@ spec = beforeAll_ setupTestLogging $ evalChangeSameAccountsDesc = "Outgoing transaction from account to the same account." -twoApplyTwoRollbacksSpec :: HasConfigurations => Spec -twoApplyTwoRollbacksSpec = walletPropertySpec twoApplyTwoRollbacksDesc $ do - let k = fromIntegral dummyK :: Word64 +twoApplyTwoRollbacksSpec :: HasConfigurations => Genesis.Config -> Spec +twoApplyTwoRollbacksSpec genesisConfig = walletPropertySpec genesisConfig twoApplyTwoRollbacksDesc $ do + let protocolConstants = configProtocolConstants genesisConfig + k = pcBlkSecurityParam protocolConstants -- During these tests we need to manually switch back to the old synchronous -- way of restoring. void $ importSomeWallets (pure emptyPassphrase) secretKeys <- lift getSecretKeysPlain lift $ forM_ secretKeys $ \sk -> - syncWalletWithBlockchain dummyConfig . newSyncRequest . keyToWalletDecrCredentials $ KeyForRegular sk + syncWalletWithBlockchain genesisConfig . newSyncRequest . keyToWalletDecrCredentials $ KeyForRegular sk -- Testing starts here genesisWalletDB <- lift WS.askWalletSnapshot @@ -79,21 +94,21 @@ twoApplyTwoRollbacksSpec = walletPropertySpec twoApplyTwoRollbacksDesc $ do applyBlocksCnt2 <- pick $ choose (1, k `div` 2) let txpConfig = TxpConfiguration 200 Set.empty blunds1 <- wpGenBlocks txpConfig - (Just $ BlockCount applyBlocksCnt1) + (Just $ applyBlocksCnt1) (EnableTxPayload True) (InplaceDB True) after1ApplyDB <- lift WS.askWalletSnapshot blunds2 <- wpGenBlocks txpConfig - (Just $ BlockCount applyBlocksCnt2) + (Just $ applyBlocksCnt2) (EnableTxPayload True) (InplaceDB True) after2ApplyDB <- lift WS.askWalletSnapshot let toNE = fromMaybe (error "sequence of blocks are empty") . nonEmptyOldestFirst let to1Rollback = toNewestFirst $ toNE blunds2 let to2Rollback = toNewestFirst $ toNE blunds1 - lift $ rollbackBlocks dummyConfig to1Rollback + lift $ rollbackBlocks genesisConfig to1Rollback after1RollbackDB <- lift WS.askWalletSnapshot - lift $ rollbackBlocks dummyConfig to2Rollback + lift $ rollbackBlocks genesisConfig to2Rollback after2RollbackDB <- lift WS.askWalletSnapshot assertProperty (after1RollbackDB == after1ApplyDB) "wallet-db after first apply doesn't equal to wallet-db after first rollback"