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 c69cc83400c..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, @@ -42,13 +43,14 @@ import Pos.Core (addressHash, checkPubKeyAddress, sumCoins) import Pos.Core.Attributes (mkAttributes) import Pos.Core.NetworkMagic (makeNetworkMagic) -import Pos.Crypto (SignTag (SignTx), checkSig, fakeSigner, hash, - toPublic, unsafeHash, withHash) +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 (makeNetworkMagic dummyProtocolMagic) + 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 (makeNetworkMagic dummyProtocolMagic) + 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 (makeNetworkMagic dummyProtocolMagic) + 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 (makeNetworkMagic dummyProtocolMagic) - 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,15 +460,20 @@ 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 - nm = makeNetworkMagic dummyProtocolMagic + -- 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 @@ -439,7 +493,7 @@ scriptTxSpec = describe "script transactions" $ do 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 @@ -483,3 +537,9 @@ txShouldFailWithPlutus res err = case res of other -> expectationFailure $ "expected: Left ...: " <> show (WitnessScriptError err) <> "\n" <> " but got: " <> show other + +-- | 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 06633fe4489..b64f77e8ea0 100644 --- a/client/src/Pos/Client/Txp/Util.hs +++ b/client/src/Pos/Client/Txp/Util.hs @@ -562,8 +562,8 @@ prepareInpsOuts -> AddrData m -> TxCreator m (TxOwnedInputs TxOut, TxOutputs) prepareInpsOuts genesisConfig pendingTx utxo outputs addrData = do - let nm = makeNetworkMagic $ configProtocolMagic genesisConfig txRaw@TxRaw {..} <- prepareTxWithFee genesisConfig pendingTx utxo outputs + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig outputsWithRem <- mkOutputsWithRem nm (configEpochSlots genesisConfig) addrData txRaw pure (trInputs, outputsWithRem) @@ -826,15 +826,15 @@ stabilizeTxFee genesisConfig pendingTx linearPolicy utxo outputs = do -> TxCreator m $ Maybe (S.ArgMin TxFee TxRaw) stabilizeTxFeeDo (_, 0) _ = pure Nothing stabilizeTxFeeDo (isSecondStage, attempt) expectedFee = do - let nm = makeNetworkMagic $ configProtocolMagic genesisConfig txRaw <- prepareTxRaw pendingTx utxo outputs expectedFee + 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 diff --git a/client/test/Test/Pos/Client/Txp/UtilSpec.hs b/client/test/Test/Pos/Client/Txp/UtilSpec.hs index bf157808041..d6c80336cce 100644 --- a/client/test/Test/Pos/Client/Txp/UtilSpec.hs +++ b/client/test/Test/Pos/Client/Txp/UtilSpec.hs @@ -15,10 +15,10 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified Data.Set as S import Formatting (build, hex, left, sformat, shown, (%), (%.)) -import Test.Hspec (Spec, describe, runIO) +import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Discard (..), Gen, Testable, arbitrary, - choose, generate) + choose) import Test.QuickCheck.Monadic (forAllM, stop) import Pos.Chain.Txp (Tx (..), TxAux (..), TxId, TxIn (..), @@ -32,13 +32,12 @@ import Pos.Core (Address, Coeff (..), TxFeePolicy (..), TxSizeLinear (..), makePubKeyAddressBoot, makeRedeemAddress, unsafeIntegerToCoin) import Pos.Core.NetworkMagic (NetworkMagic (..), makeNetworkMagic) -import Pos.Crypto (ProtocolMagic (..), RedeemSecretKey, - RequiresNetworkMagic (..), SafeSigner, SecretKey, - decodeHash, fakeSigner, redeemToPublic, toPublic) +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 (withProvidedMagicConfig) @@ -51,18 +50,7 @@ import Test.Pos.Util.QuickCheck.Property (stopProperty) ---------------------------------------------------------------------------- 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 = withProvidedMagicConfig pm $ \_ _ _ -> +spec = describe "Client.Txp.Util" $ do describe "createMTx" $ createMTxSpec @@ -129,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 @@ -233,16 +222,17 @@ 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 params <- makeManyAddressesToManyParams inputSelectionPolicy 1 1000000 1 1 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/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs b/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs index 751c802c2ae..398b8be462f 100644 --- a/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs +++ b/explorer/test/Test/Pos/Explorer/Socket/MethodsSpec.hs @@ -59,8 +59,8 @@ spec = beforeAll_ setupTestLogging $ do fromCAddressOrThrow (CAddress "invalid" ) `shouldThrow` anyException describe "addressSetByTxs" $ modifyMaxSize (const 200) $ - prop "creates a Set of Addresses by given txs" $ - \nm -> addressSetByTxsProp nm + prop "creates a Set of Addresses by given txs" + addressSetByTxsProp describe "addrSubParam" $ it "stores a given SocketId into SubscriptionParam of address subscribers" $ do let socketId = BS.pack "any-id" -- SocketId diff --git a/generator/app/VerificationBench.hs b/generator/app/VerificationBench.hs index 491a4331fde..1e23d3818c6 100644 --- a/generator/app/VerificationBench.hs +++ b/generator/app/VerificationBench.hs @@ -78,8 +78,8 @@ generateBlocks :: HasConfigurations -> BlockCount -> BlockTestMode (OldestFirst NE Block) generateBlocks genesisConfig secretKeys txpConfig bCount = do - let nm = makeNetworkMagic $ configProtocolMagic genesisConfig g <- liftIO $ newStdGen + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig bs <- flip evalRandT g $ genBlocks genesisConfig txpConfig (BlockGenParams { _bgpSecrets = mkAllSecretsSimple nm secretKeys diff --git a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs index 8851e251323..d6f8bb88af0 100644 --- a/generator/bench/Bench/Pos/Criterion/Block/Logic.hs +++ b/generator/bench/Bench/Pos/Criterion/Block/Logic.hs @@ -102,10 +102,10 @@ 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 - let nm = makeNetworkMagic $ configProtocolMagic genesisConfig g <- liftIO $ newStdGen bs <- flip evalRandT g $ genBlocks genesisConfig (_tpTxpConfiguration tp) (BlockGenParams @@ -171,12 +171,12 @@ verifyHeaderBenchmark !genesisConfig !secretKeys !tp = env (runBlockTestMode gen where pm = configProtocolMagic genesisConfig + nm = makeNetworkMagic pm genEnv :: BlockTestMode (Block, VerifyBlockParams) genEnv = do initNodeDBs genesisConfig g <- liftIO $ newStdGen eos <- getEpochOrSlot <$> getTipHeader - let nm = makeNetworkMagic $ configProtocolMagic genesisConfig let epoch = eos ^. epochIndexL let blockGenParams = BlockGenParams { _bgpSecrets = mkAllSecretsSimple nm secretKeys diff --git a/generator/src/Pos/Generator/Block/Payload.hs b/generator/src/Pos/Generator/Block/Payload.hs index ba838bac401..80d6359c297 100644 --- a/generator/src/Pos/Generator/Block/Payload.hs +++ b/generator/src/Pos/Generator/Block/Payload.hs @@ -148,7 +148,6 @@ genTxPayload genesisConfig txpConfig = do 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) diff --git a/generator/src/Test/Pos/Block/Logic/Mode.hs b/generator/src/Test/Pos/Block/Logic/Mode.hs index b5e83777a54..cb4454f003a 100644 --- a/generator/src/Test/Pos/Block/Logic/Mode.hs +++ b/generator/src/Test/Pos/Block/Logic/Mode.hs @@ -262,8 +262,7 @@ initBlockTestContext genesisConfig tp@TestParams {..} callback = do let epochSlots = configEpochSlots genesisConfig slottingState <- mkSimpleSlottingStateVar epochSlots genesisSecretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow genesisConfig - let nm = makeNetworkMagic $ configProtocolMagic genesisConfig - initCtx = + let initCtx = TestInitModeContext dbPureVar futureSlottingVar @@ -288,6 +287,7 @@ initBlockTestContext genesisConfig tp@TestParams {..} callback = do let btcGState = GS.GStateContext {_gscDB = DB.PureDB dbPureVar, ..} btcDelegation <- mkDelegationVar btcPureDBSnapshots <- PureDBSnapshotsVar <$> newIORef Map.empty + let nm = makeNetworkMagic $ configProtocolMagic genesisConfig let btcAllSecrets = mkAllSecretsSimple nm genesisSecretKeys let btCtx = BlockTestContext {btcSystemStart = systemStart, btcSSlottingStateVar = slottingState, ..} liftIO $ flip runReaderT clockVar $ unEmulation $ callback btCtx 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/lib/test/Test/Pos/Cbor/CborSpec.hs b/lib/test/Test/Pos/Cbor/CborSpec.hs index 1c18a8c0155..466af22708f 100644 --- a/lib/test/Test/Pos/Cbor/CborSpec.hs +++ b/lib/test/Test/Pos/Cbor/CborSpec.hs @@ -17,9 +17,9 @@ import Universum import qualified Cardano.Crypto.Wallet as CC import Data.Tagged (Tagged) import System.FileLock (FileLock) -import Test.Hspec (Spec, describe, runIO) +import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Arbitrary (..), arbitrary, generate) +import Test.QuickCheck (Arbitrary (..), arbitrary) import Pos.Binary.Communication () import Pos.Chain.Delegation (DlgPayload, DlgUndo, ProxySKHeavy) @@ -32,7 +32,6 @@ import qualified Pos.Communication as C import Pos.Communication.Limits (mlOpening, mlUpdateVote, mlVssCertificate) import Pos.Core (StakeholderId) -import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.Crypto.Signing (EncryptedSecretKey) import Pos.Infra.Communication.Limits.Instances (mlDataMsg, mlInvMsg, mlMempoolMsg, mlReqMsg) @@ -50,7 +49,6 @@ import Test.Pos.Cbor.Arbitrary.UserSecret () import Test.Pos.Chain.Delegation.Arbitrary () import Test.Pos.Chain.Ssc.Arbitrary () import Test.Pos.Chain.Update.Arbitrary () -import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Core.Arbitrary () import Test.Pos.Crypto.Arbitrary () import Test.Pos.DB.Update.Arbitrary () @@ -67,18 +65,7 @@ type UpId' = Tagged (U.UpdateProposal, [U.UpdateVote])U.UpId ---------------------------------------- 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 = withProvidedMagicConfig pm $ \_ _ _ -> do +spec = describe "Cbor.Bi instances" $ do modifyMaxSuccess (const 1000) $ do describe "Lib/core instances" $ do diff --git a/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs b/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs index 3493529197d..b5669a5efa5 100644 --- a/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs +++ b/lib/test/Test/Pos/Ssc/ComputeSharesSpec.hs @@ -11,9 +11,9 @@ import Universum import qualified Data.HashMap.Strict as HM import Data.Reflection (Reifies (..)) -import Test.Hspec (Expectation, Spec, describe, runIO, shouldBe) +import Test.Hspec (Expectation, Spec, describe, shouldBe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Property, arbitrary, generate, (.&&.), (===)) +import Test.QuickCheck (Property, (.&&.), (===)) import Pos.Chain.Lrc (RichmenStakes) import Pos.Chain.Ssc (SharesDistribution, SscVerifyError, @@ -23,27 +23,14 @@ import Pos.Core (Coin, CoinPortion, StakeholderId, mkCoin, unsafeAddressHash, unsafeCoinPortionFromDouble, unsafeGetCoin, unsafeSubCoin) import Pos.Core.Common (applyCoinPortionDown, sumCoins) -import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Pos.DB.Lrc (RichmenType (..), findRichmenPure) import Test.Pos.Chain.Lrc.Arbitrary (GenesisMpcThd, InvalidRichmenStakes (..), ValidRichmenStakes (..)) -import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Util.QuickCheck.Property (qcIsLeft) 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 = withProvidedMagicConfig pm $ \_ _ _ -> 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 43a6f617c01..635c5d979de 100644 --- a/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs +++ b/lib/test/Test/Pos/Ssc/VssCertDataSpec.hs @@ -31,9 +31,7 @@ import Pos.Crypto (ProtocolMagic (..), RequiresNetworkMagic (..)) import Test.Pos.Chain.Genesis.Dummy (dummyEpochSlots, dummySlotSecurityParam) -import Test.Pos.Configuration (withProvidedMagicConfig) import Test.Pos.Core.Arbitrary () -import Test.Pos.Crypto.Dummy (dummyProtocolMagic) import Test.Pos.Infra.Arbitrary.Ssc () import Test.Pos.Util.QuickCheck.Property (qcIsJust) @@ -49,7 +47,7 @@ runWithMagic rnm = do specBody pm specBody :: ProtocolMagic -> Spec -specBody pm = withProvidedMagicConfig pm $ \_ _ _ -> describe "Ssc.VssCertData" $ do +specBody _pm = describe "Ssc.VssCertData" $ do describe "verifyInsertVssCertData" $ prop description_verifyInsertVssCertData verifyInsertVssCertData describe "verifyDeleteVssCertData" $ @@ -202,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/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs b/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs index a2a10222e22..e919e7f08f1 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Internal.hs @@ -86,7 +86,6 @@ data PassiveWallet = PassiveWallet { , _wallets :: AcidState DB -- | The protocol magic used by an `ActiveWallet` to make transactions. - -- TODO @intricate: is it suitable to move this here from `ActiveWallet`? , _walletProtocolMagic :: ProtocolMagic -- | Database handle diff --git a/wallet-new/test/InternalAPISpec.hs b/wallet-new/test/InternalAPISpec.hs index 722a29ebb46..5554ffd3941 100644 --- a/wallet-new/test/InternalAPISpec.hs +++ b/wallet-new/test/InternalAPISpec.hs @@ -16,6 +16,7 @@ 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) @@ -50,13 +51,13 @@ runWithMagic rnm = do specBody :: ProtocolMagic -> Spec specBody pm = beforeAll_ setupTestLogging $ - withProvidedMagicConfig pm $ \_ _ _ -> + 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) @@ -67,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 ce8c6320790..ac396f1336b 100644 --- a/wallet-new/test/unit/Test/Spec/Accounts.hs +++ b/wallet-new/test/unit/Test/Spec/Accounts.hs @@ -30,8 +30,7 @@ import Control.Monad.Except (runExceptT) import Servant.Server import Pos.Core.Common (mkCoin) -import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), - RequiresNetworkMagic (..)) +import Pos.Crypto (ProtocolMagic (..)) import Pos.Crypto.HD (firstHardened) import Test.Spec.Fixture (GenPassiveWalletFixture, @@ -63,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 (ProtocolMagic (ProtocolMagicId 1337) RequiresNoMagic) prepareFixtures cc +withFixture pm cc = withPassiveWalletFixture pm prepareFixtures cc spec :: Spec @@ -79,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 @@ -107,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 @@ -117,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 @@ -129,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 @@ -157,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'. @@ -178,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 @@ -206,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'. @@ -224,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 @@ -258,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 @@ -281,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 @@ -296,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 @@ -327,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'. @@ -347,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 @@ -361,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) -> @@ -391,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. @@ -408,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', @@ -433,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) -> @@ -457,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. @@ -485,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) -> @@ -514,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) @@ -527,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'. @@ -549,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) -> @@ -571,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/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 9b5e584c3fb..018c26b9a02 100644 --- a/wallet-new/test/unit/Test/Spec/Fixture.hs +++ b/wallet-new/test/unit/Test/Spec/Fixture.hs @@ -19,7 +19,6 @@ import Pos.Util.Wlog (Severity) import Pos.Crypto (ProtocolMagic) import Pos.Infra.InjectFail (mkFInjects) -import Test.Pos.Configuration (withProvidedMagicConfig) import Test.QuickCheck (arbitrary, frequency) import Test.QuickCheck.Monadic (PropertyM, pick) @@ -90,14 +89,13 @@ withActiveWalletFixture pm prepareFixtures cc = do liftIO $ Keystore.bracketTestKeystore $ \keystore -> do mockFInjects <- mkFInjects mempty WalletLayer.Kernel.bracketPassiveWallet pm Kernel.UseInMemory devNull keystore mockNodeStateDef mockFInjects $ \passiveLayer passiveWallet -> do - withProvidedMagicConfig pm $ \_ _ _ -> do - WalletLayer.Kernel.bracketActiveWallet - passiveLayer - passiveWallet - diffusion - $ \activeLayer activeWallet -> do - fixtures <- generateFixtures keystore activeWallet - cc keystore activeLayer activeWallet fixtures + 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/Kernel.hs b/wallet-new/test/unit/Test/Spec/Kernel.hs index 0cae75d1eae..d2e133d9f38 100644 --- a/wallet-new/test/unit/Test/Spec/Kernel.hs +++ b/wallet-new/test/unit/Test/Spec/Kernel.hs @@ -57,7 +57,7 @@ withWithoutWW specWith = do spec :: Spec spec = do - -- runWithMagic RequiresNoMagic + runWithMagic RequiresNoMagic runWithMagic RequiresMagic runWithMagic :: RequiresNetworkMagic -> Spec @@ -70,16 +70,16 @@ specBody :: ProtocolMagic -> Spec specBody pm = do describe "test TxMeta insertion" $ do withWithoutWW $ \useWW -> do - it "TxMetaScenarioA" $ bracketTxMeta useWW (txMetaScenarioA pm genesis) - it "TxMetaScenarioB" $ bracketTxMeta useWW (txMetaScenarioB pm genesis) - it "TxMetaScenarioC" $ bracketTxMeta useWW (txMetaScenarioC pm genesis) - it "TxMetaScenarioD" $ bracketTxMeta useWW (txMetaScenarioD pm genesis) - it "TxMetaScenarioE" $ bracketTxMeta useWW (txMetaScenarioE pm genesis) - it "TxMetaScenarioF" $ bracketTxMeta useWW (txMetaScenarioF pm genesis) + it "TxMetaScenarioA" $ bracketTxMeta useWW (txMetaScenarioA genesis) + it "TxMetaScenarioB" $ bracketTxMeta useWW (txMetaScenarioB genesis) + it "TxMetaScenarioC" $ bracketTxMeta useWW (txMetaScenarioC genesis) + it "TxMetaScenarioD" $ bracketTxMeta useWW (txMetaScenarioD genesis) + it "TxMetaScenarioE" $ bracketTxMeta useWW (txMetaScenarioE genesis) + it "TxMetaScenarioF" $ bracketTxMeta useWW (txMetaScenarioF genesis) it "TxMetaScenarioG" $ bracketTxMeta useWW (txMetaScenarioG genesis) - it "TxMetaScenarioH" $ bracketTxMeta useWW (txMetaScenarioH pm genesis) - it "TxMetaScenarioI" $ bracketTxMeta useWW (txMetaScenarioI pm genesis) - it "TxMetaScenarioJ" $ bracketTxMeta useWW (txMetaScenarioJ pm genesis) + it "TxMetaScenarioH" $ bracketTxMeta useWW (txMetaScenarioH genesis) + it "TxMetaScenarioI" $ bracketTxMeta useWW (txMetaScenarioI genesis) + it "TxMetaScenarioJ" $ bracketTxMeta useWW (txMetaScenarioJ genesis) describe "Compare wallet kernel to pure model" $ do describe "Using hand-written inductive wallets, computes the expected block metadata for" $ do 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/TxMetaScenarios.hs b/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs index 4bc3e4a2375..ee9ac4d60f0 100644 --- a/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs +++ b/wallet-new/test/unit/Test/Spec/TxMetaScenarios.hs @@ -41,8 +41,8 @@ import Pos.Util (withCompileInfo) import Test.Hspec import Test.Infrastructure.Genesis -import Test.Pos.Configuration (withDefConfiguration, - withDefUpdateConfiguration, withProvidedMagicConfig) +import Test.Pos.Configuration (withDefUpdateConfiguration, + withProvidedMagicConfig) import UTxO.Context import UTxO.DSL import Wallet.Inductive @@ -145,10 +145,9 @@ type TxScenarioRet h = (MockNodeStateParams, Inductive h Addr, PassiveWallet -> -- | Scenario A -- Empty case -txMetaScenarioA :: ProtocolMagic - -> GenesisValues h Addr +txMetaScenarioA :: GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioA pm GenesisValues{..} = (nodeStParams1 pm, ind, lengthCheck 0) +txMetaScenarioA GenesisValues{..} = (nodeStParams1, ind, lengthCheck 0) where ind = Inductive { inductiveBoot = boot @@ -160,10 +159,9 @@ txMetaScenarioA pm GenesisValues{..} = (nodeStParams1 pm, ind, lengthCheck 0) -- | Scenario B -- A single pending payment. txMetaScenarioB :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioB pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioB genVals@GenesisValues{..} = (nodeStParams1, ind, check) where t0 = paymentWithChangeFromP0ToP1 genVals ind = Inductive { @@ -182,10 +180,9 @@ txMetaScenarioB pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) -- | Scenario C -- A single pending payment and then confirmation. txMetaScenarioC :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioC pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioC genVals@GenesisValues{..} = (nodeStParams1, ind, check) where t0 = paymentWithChangeFromP0ToP1 genVals ind = Inductive { @@ -205,10 +202,9 @@ txMetaScenarioC pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) -- | Scenario D -- Two confirmed payments from P0 to P1, using `change` addresses P0 and P0b respectively txMetaScenarioD :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioD pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioD genVals@GenesisValues{..} = (nodeStParams1, ind, check) where (t0,t1) = repeatPaymentWithChangeFromP0ToP1 genVals p0b ind = Inductive { @@ -234,10 +230,9 @@ txMetaScenarioD pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) -- -- This scenario exercises Rollback behaviour. txMetaScenarioE :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioE pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioE genVals@GenesisValues{..} = (nodeStParams1, ind, check) where (t0,t1) = repeatPaymentWithChangeFromP0ToP1 genVals p0b ind = Inductive { @@ -264,10 +259,9 @@ txMetaScenarioE pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) -- A payment from P1 to P0's single address. -- This should create IncomingTransactions. txMetaScenarioF :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioF pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioF genVals@GenesisValues{..} = (nodeStParams1, ind, check) where t0 = paymentWithChangeFromP1ToP0 genVals ind = Inductive { @@ -309,10 +303,9 @@ txMetaScenarioG genVals@GenesisValues{..} = (nodeStParams2, ind, check) -- A single pending payment to itself and then confirmation. -- This should be a Local Tx. txMetaScenarioH :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioH pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioH genVals@GenesisValues{..} = (nodeStParams1, ind, check) where t0 = paymentWithChangeFromP0ToP0 genVals ind = Inductive { @@ -332,10 +325,9 @@ txMetaScenarioH pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) -- | Scenario I. This is like Scenario C with rollbacks. -- results should not change. txMetaScenarioI :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioI pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioI genVals@GenesisValues{..} = (nodeStParams1, ind, check) where t0 = paymentWithChangeFromP0ToP1 genVals ind = Inductive { @@ -359,10 +351,9 @@ txMetaScenarioI pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) -- | Scenario J -- A single payment with 4 outputs. txMetaScenarioJ :: forall h. Hash h Addr - => ProtocolMagic - -> GenesisValues h Addr + => GenesisValues h Addr -> TxScenarioRet h -txMetaScenarioJ pm genVals@GenesisValues{..} = (nodeStParams1 pm, ind, check) +txMetaScenarioJ genVals@GenesisValues{..} = (nodeStParams1, ind, check) where t0 = bigPaymentWithChange genVals ind = Inductive { @@ -394,9 +385,8 @@ checkWithTxs check pw = do return $ fromRight (error ("Account not found")) eiTxs check txs -nodeStParams1 :: ProtocolMagic -> MockNodeStateParams -nodeStParams1 pm = - withProvidedMagicConfig pm $ \_ _ _ -> +nodeStParams1 :: MockNodeStateParams +nodeStParams1 = withDefUpdateConfiguration $ withCompileInfo $ MockNodeStateParams { @@ -411,7 +401,6 @@ nodeStParams1 pm = nodeStParams2 :: MockNodeStateParams nodeStParams2 = - withDefConfiguration $ \_pm -> withDefUpdateConfiguration $ withCompileInfo $ MockNodeStateParams { diff --git a/wallet-new/test/unit/WalletUnitTest.hs b/wallet-new/test/unit/WalletUnitTest.hs index 7f0a0bce232..d3ab038493a 100644 --- a/wallet-new/test/unit/WalletUnitTest.hs +++ b/wallet-new/test/unit/WalletUnitTest.hs @@ -1,7 +1,5 @@ -- | Wallet unit tests -{-# OPTIONS_GHC -fno-warn-unused-imports #-} - module Main (main) where import Universum @@ -13,10 +11,6 @@ import InputSelection.Evaluation.Options (Command (..), evalCommand, getEvalOptions) import InputSelection.Evaluation.Replot (replot) import Test.Pos.Util.Parallel.Parallelize (parallelizeAllCores) -import UTxO.Translate (runTranslateNoErrors, withConfig) - -import Pos.Crypto (ProtocolMagic (..), ProtocolMagicId (..), - RequiresNetworkMagic (..)) import qualified DeltaCompressionSpecs import qualified Test.Spec.Accounts diff --git a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs index bac029186a7..4900dad3777 100644 --- a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs @@ -16,10 +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) @@ -31,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, @@ -39,18 +41,21 @@ 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 = NetworkMagic -> AccountId -> PassPhrase -> WalletProperty Address -fakeAddressHasMaxSizeTest :: AddressGenerator -> Word32 -> NetworkMagic -> WalletProperty () -fakeAddressHasMaxSizeTest generator accSeed nm = 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 diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs index ee36c96eb72..713b26bb621 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs @@ -42,7 +42,7 @@ specBody pm = beforeAll_ setupTestLogging $ restoreWalletAddressFromBackupSpec :: HasConfigurations => Genesis.Config -> Spec restoreWalletAddressFromBackupSpec genesisConfig = - walletPropertySpec restoreWalletAddressFromBackupDesc $ do + walletPropertySpec genesisConfig restoreWalletAddressFromBackupDesc $ do walletBackup <- pick arbitrary restoredWallet <- lift $ restoreWalletFromBackup genesisConfig walletBackup diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs index 3c1b5a38fde..7758e52e267 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs @@ -22,6 +22,7 @@ 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) @@ -48,7 +49,6 @@ 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 (withProvidedMagicConfig) import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne, maybeStopProperty, splitWord, stopProperty) @@ -65,18 +65,20 @@ deriving instance Eq CTx spec :: Spec spec = do runWithMagic RequiresNoMagic - runWithMagic RequiresMagic + -- 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 $ \_ txpConfig _ -> + withProvidedMagicConfig pm $ \genesisConfig 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) + describe "Submitting a payment when restoring" (rejectPaymentIfRestoringSpec genesisConfig txpConfig) + describe "One payment" (oneNewPaymentBatchSpec genesisConfig txpConfig) data PaymentFixture = PaymentFixture { pswd :: PassPhrase @@ -91,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) @@ -111,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) @@ -130,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 0b3b1832ae9..7df7bc31a27 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs @@ -53,7 +53,9 @@ import Test.Pos.Wallet.Web.Util (importSomeWallets, wpGenBlocks) spec :: Spec spec = do runWithMagic RequiresNoMagic - runWithMagic RequiresMagic + -- Not running with `RequiresMagic` until `NetworkMagic` logic + -- has been fully implemented. + -- runWithMagic RequiresMagic runWithMagic :: RequiresNetworkMagic -> Spec runWithMagic rnm = do @@ -76,7 +78,7 @@ specBody pm = beforeAll_ setupTestLogging $ "Outgoing transaction from account to the same account." twoApplyTwoRollbacksSpec :: HasConfigurations => Genesis.Config -> Spec -twoApplyTwoRollbacksSpec genesisConfig = walletPropertySpec twoApplyTwoRollbacksDesc $ do +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