Permalink
Browse files

Fix stupid Serokell property tests

  • Loading branch information...
erikd committed Feb 11, 2019
1 parent 4279869 commit e4f4d86903c74077a05c143fcbeddf8663ba1b4c
Showing with 37 additions and 23 deletions.
  1. +8 −5 chain/test/Test/Pos/Chain/Block/Arbitrary.hs
  2. +29 −18 chain/test/Test/Pos/Chain/Block/BlockSpec.hs
@@ -324,7 +324,7 @@ recursiveHeaderGen _ _ _ _ [] b = return b

-- | Maximum start epoch in block header verification tests
bhlMaxStartingEpoch :: Integral a => a
bhlMaxStartingEpoch = 1000000
bhlMaxStartingEpoch = 200

-- | Amount of full epochs in block header verification tests
bhlEpochs :: Integral a => a
@@ -393,8 +393,9 @@ generateBHL pm gHash createInitGenesis startSlot slotCount = BHL <$> do
-- 'Pos.Types.Blocks.Functions.verifyHeader', the blockheaders that may be
-- part of the verification parameters are guaranteed to be valid, as are the
-- slot leaders and the current slot.
newtype HeaderAndParams = HAndP
{ getHAndP :: (Block.VerifyHeaderParams, Block.BlockHeader)
data HeaderAndParams = HeaderAndParams
{ hapParams :: Block.VerifyHeaderParams
, hapHeader :: Block.BlockHeader
} deriving (Eq, Show)

genHeaderAndParams :: ProtocolMagic -> Gen HeaderAndParams
@@ -454,11 +455,13 @@ genHeaderAndParams pm = do
params = Block.VerifyHeaderParams
{ Block.vhpPrevHeader = prev
, Block.vhpCurrentSlot = randomSlotBeforeThisHeader
, Block.vhpLeaders = nonEmpty $ map Core.addressHash thisHeadersEpoch
, Block.vhpLeaders =
-- trace ("\n" <> show (Core.getSlotCount dummyEpochSlots, thisEpochStartIndex, thisHeadersEpoch) <> "\n" :: Text) .
nonEmpty $ map Core.addressHash thisHeadersEpoch
, Block.vhpMaxSize = Just (biSize header)
, Block.vhpVerifyNoUnknown = not hasUnknownAttributes
}
return . HAndP $ (params, header)
return $ HeaderAndParams 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'
@@ -11,10 +11,10 @@ module Test.Pos.Chain.Block.BlockSpec

import Universum

import Serokell.Util (isVerSuccess)
import Serokell.Util (VerificationRes (..), isVerSuccess)
import Test.Hspec (Spec, describe)
import Test.Hspec.QuickCheck (modifyMaxSuccess, prop)
import Test.QuickCheck (Gen, Property, (===), (==>))
import Test.QuickCheck (Property, counterexample, forAll, (===), (==>))

import Pos.Chain.Block (BlockHeader (..), BlockSignature (..),
GenesisBody (..), GenesisConsensusData (..),
@@ -154,23 +154,34 @@ mainHeaderFormation pm prevHeader slotId signer body extra =
-- GenesisBlock ∪ MainBlock
----------------------------------------------------------------------------

validateGoodMainHeader :: ProtocolMagic -> Gen Bool
validateGoodMainHeader pm = do
(params, header) <- BT.getHAndP <$> BT.genHeaderAndParams pm
pure $ isVerSuccess $ Block.verifyHeader pm params header
validateGoodMainHeader :: ProtocolMagic -> Property
validateGoodMainHeader pm =
forAll (BT.genHeaderAndParams pm) $ \ hap ->
Block.verifyHeader pm (hapParams hap) (hapHeader hap) === VerSuccess

-- FIXME should sharpen this test to ensure that it fails with the expected
-- reason.
validateBadProtocolMagicMainHeader :: ProtocolMagic -> Gen Bool
validateBadProtocolMagicMainHeader pm = do
(params, header) <- BT.getHAndP <$> 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')
pure $ not $ isVerSuccess $ Block.verifyHeader pm params header'
validateBadProtocolMagicMainHeader :: ProtocolMagic -> Property
validateBadProtocolMagicMainHeader pm =
forAll (BT.genHeaderAndParams pm) $ \ hap -> do
let protocolMagicId' = ProtocolMagicId (getProtocolMagic pm + 1)
header' = case hapHeader hap of
BlockHeaderGenesis h -> BlockHeaderGenesis (h & gbhProtocolMagicId .~ protocolMagicId')
BlockHeaderMain h -> BlockHeaderMain (h & gbhProtocolMagicId .~ protocolMagicId')
Block.verifyHeader pm (hapParams hap) header' =/= VerSuccess

validateGoodHeaderChain :: ProtocolMagic -> Gen Bool
validateGoodHeaderChain pm = do
BT.BHL (l, _) <- BT.genStubbedBHL pm
pure $ isVerSuccess $ Block.verifyHeaders pm Nothing (NewestFirst l)
-- Cargo cult this from QuickCheck because the version we are using
-- doesn't have this operator.
infix 4 =/=
(=/=) :: (Eq a, Show a) => a -> a -> Property
x =/= y =
counterexample (show x ++ interpret res ++ show y) res
where
res = x /= y
interpret True = " /= "
interpret False = " == "

validateGoodHeaderChain :: ProtocolMagic -> Property
validateGoodHeaderChain pm =
forAll (BT.genStubbedBHL pm) $ \ (BT.BHL (l, _)) ->
Block.verifyHeaders pm Nothing (NewestFirst l) === VerSuccess

0 comments on commit e4f4d86

Please sign in to comment.