Fix stupid Serokell property tests

chain/test/Test/Pos/Chain/Block/Arbitrary.hs

@@ -331,7 +331,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
@@ -406,8 +406,9 @@ generateBHL pm era 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 -> ConsensusEra -> Gen HeaderAndParams
@@ -480,7 +481,7 @@ genHeaderAndParams pm era = do
             , Block.vhpVerifyNoUnknown = not hasUnknownAttributes
             , Block.vhpConsensusEra = era
             }
-    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'

chain/test/Test/Pos/Chain/Block/BlockSpec.hs

@@ -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 (..),
@@ -156,23 +156,34 @@ mainHeaderFormation pm prevHeader slotId signer body extra =
 -- GenesisBlock ∪ MainBlock
 ----------------------------------------------------------------------------
 
-validateGoodMainHeader :: ProtocolMagic -> ConsensusEra -> Gen Bool
-    (params, header) <- BT.getHAndP <$> BT.genHeaderAndParams pm era
-    pure $ isVerSuccess $ Block.verifyHeader pm params header
+validateGoodMainHeader :: ProtocolMagic -> ConsensusEra -> Property
+validateGoodMainHeader pm era =
+    forAll (BT.genHeaderAndParams pm era) $ \ 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 -> ConsensusEra -> Gen Bool
-validateBadProtocolMagicMainHeader :: ProtocolMagic -> Gen Bool
-validateBadProtocolMagicMainHeader pm = do
-    (params, header) <- BT.getHAndP <$> BT.genHeaderAndParams pm era
-    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 -> ConsensusEra -> Property
+validateBadProtocolMagicMainHeader pm era =
+    forAll (BT.genHeaderAndParams pm era) $ \ 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 -> ConsensusEra -> Gen Bool
-validateGoodHeaderChain pm era = do
-    BT.BHL (l, _) <- BT.genStubbedBHL pm era
-    pure $ isVerSuccess $ Block.verifyHeaders pm era 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 -> ConsensusEra -> Property
+validateGoodHeaderChain pm era =
+    forAll (BT.genStubbedBHL pm era) $ \ (BT.BHL (l, _)) ->
+        Block.verifyHeaders pm era Nothing (NewestFirst l) === VerSuccess