From bcb7e7795a34da5b68dc7aa16d6f464410556f9e Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Tue, 12 Feb 2019 20:19:36 +1100 Subject: [PATCH] wip --- chain/src/Pos/Chain/Block/Header.hs | 6 ++ chain/test/Test/Pos/Chain/Block/Arbitrary.hs | 81 +++++++++++++++++++- chain/test/Test/Pos/Chain/Block/BlockSpec.hs | 6 +- chain/test/test.hs | 2 +- stack.yaml | 2 +- 5 files changed, 92 insertions(+), 5 deletions(-) diff --git a/chain/src/Pos/Chain/Block/Header.hs b/chain/src/Pos/Chain/Block/Header.hs index 52b73f8d13e..7fe2da3007d 100644 --- a/chain/src/Pos/Chain/Block/Header.hs +++ b/chain/src/Pos/Chain/Block/Header.hs @@ -11,6 +11,7 @@ module Pos.Chain.Block.Header , _BlockHeaderGenesis , _BlockHeaderMain , verifyBlockHeader + , headerLeaderKey , HeaderHash , headerHashF @@ -675,6 +676,11 @@ mainHeaderSlot = gbhConsensus . mcdSlot mainHeaderLeaderKey :: Lens' MainBlockHeader PublicKey mainHeaderLeaderKey = gbhConsensus . mcdLeaderKey +headerLeaderKey :: BlockHeader -> Maybe PublicKey +headerLeaderKey = \case + BlockHeaderGenesis _ -> Nothing + BlockHeaderMain mbh -> Just $ view mainHeaderLeaderKey mbh + -- | Lens from 'MainBlockHeader' to 'ChainDifficulty'. mainHeaderDifficulty :: Lens' MainBlockHeader ChainDifficulty mainHeaderDifficulty = gbhConsensus . mcdDifficulty diff --git a/chain/test/Test/Pos/Chain/Block/Arbitrary.hs b/chain/test/Test/Pos/Chain/Block/Arbitrary.hs index 191c28dfb0d..7c294511936 100644 --- a/chain/test/Test/Pos/Chain/Block/Arbitrary.hs +++ b/chain/test/Test/Pos/Chain/Block/Arbitrary.hs @@ -17,6 +17,7 @@ module Test.Pos.Chain.Block.Arbitrary , genMainBlockBodyForSlot , genMainBlock , genHeaderAndParams + , genHeaderAndParams2 , genStubbedBHL ) where @@ -34,7 +35,8 @@ import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, import Pos.Binary.Class (biSize) import Pos.Chain.Block (ConsensusEraLeaders (..), HeaderHash, - mkMainBlock, mkMainBlockExplicit) + GenericBlockHeader (..), MainConsensusData (..), + mainHeaderLeaderKey, mkMainBlock, mkMainBlockExplicit) import qualified Pos.Chain.Block as Block import qualified Pos.Chain.Delegation as Core import Pos.Chain.Genesis (GenesisHash (..)) @@ -485,6 +487,83 @@ genHeaderAndParams pm era = do } return $ HeaderAndParams params header +genHeaderAndParams2 :: ProtocolMagic -> ConsensusEra -> Gen HeaderAndParams +genHeaderAndParams2 pm era = 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 + slotCount <- choose (1, 2) + (headers, _leaders) <- first reverse . getHeaderList <$> + (generateBHL pm era dummyGenesisHash True startSlot slotCount) + let num = + trace ("\n" + <> show headers <> "\n" + <> show _leaders <> "\n" + <> show (map Block.headerLeaderKey headers :: [Maybe PublicKey]) <> "\n" :: Text) $ + 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" + -- 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 + + thisEpochLeaderSchedule :: Maybe (NonEmpty (Core.AddressHash PublicKey)) + thisEpochLeaderSchedule = nonEmpty (mapMaybe (fmap Core.addressHash . Block.headerLeaderKey) atMost2HeadersAndLeaders) + params = Block.VerifyHeaderParams + { Block.vhpPrevHeader = prev + , Block.vhpCurrentSlot = randomSlotBeforeThisHeader + , Block.vhpLeaders = + -- trace ("\n" <> show (Core.getSlotCount dummyEpochSlots, thisEpochStartIndex, leaders) <> "\n" :: Text) . + case era of + Original -> OriginalLeaders <$> thisEpochLeaderSchedule + OBFT ObftStrict -> ObftStrictLeaders <$> thisEpochLeaderSchedule + OBFT ObftLenient -> do + ls <- thisEpochLeaderSchedule + pure $ ObftLenientLeaders (Set.fromList (toList ls)) + (Core.BlockCount 5) + (OldestFirst []) + , Block.vhpMaxSize = Just (biSize header) + , Block.vhpVerifyNoUnknown = not hasUnknownAttributes + , Block.vhpConsensusEra = era + } + 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' -- type, so it is used here and at most 3 blocks are taken from the generated diff --git a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs index 5e9612b82af..70fe4ddd0b1 100644 --- a/chain/test/Test/Pos/Chain/Block/BlockSpec.hs +++ b/chain/test/Test/Pos/Chain/Block/BlockSpec.hs @@ -27,7 +27,7 @@ import Pos.Chain.Block (BlockHeader (..), BlockSignature (..), import qualified Pos.Chain.Block as Block import Pos.Chain.Delegation (HeavyDlgIndex (..)) import Pos.Chain.Genesis (GenesisHash (..)) -import Pos.Chain.Update (ConsensusEra (..)) +import Pos.Chain.Update (ConsensusEra (..), ObftConsensusStrictness (..)) import Pos.Core (EpochIndex (..), SlotId (..), difficultyL) import Pos.Core.Attributes (mkAttributes) import Pos.Core.Chrono (NewestFirst (..)) @@ -73,7 +73,9 @@ spec = describe "Block properties" $ modifyMaxSuccess (min 20) $ do spec2 :: Spec spec2 = describe "Slot leaders" $ modifyMaxSuccess (min 20) $ - prop "Successfully verifies a correct main block header" $ \ b -> b === (b :: Bool) + prop "Successfully verifies a correct main block header" $ \ pm -> + forAll (BT.genHeaderAndParams2 pm (OBFT ObftStrict)) $ \ hap -> + Block.verifyHeader pm (hapParams hap) (hapHeader hap) === VerSuccess -- | Both of the following tests are boilerplate - they use `mkGenericHeader` to create diff --git a/chain/test/test.hs b/chain/test/test.hs index 79cd6df2f27..39c52ddb322 100644 --- a/chain/test/test.hs +++ b/chain/test/test.hs @@ -18,7 +18,7 @@ import Test.Pos.Chain.Block.BlockSpec (spec2) main :: IO () main = - if True + if False then existingTests else hspec spec2 diff --git a/stack.yaml b/stack.yaml index 94a507c468c..8cda7ba08d0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -242,7 +242,7 @@ ghc-options: cardano-sl-auxx: -Wall -Werror -Wcompat -fwarn-redundant-constraints cardano-sl-binary: -Wall -Werror -Wcompat -fwarn-redundant-constraints cardano-sl-binary-test: -Wall -Werror -Wcompat -fwarn-redundant-constraints - cardano-sl-chain: -Wall -Werror -Wcompat -fwarn-redundant-constraints + cardano-sl-chain: -fwarn-redundant-constraints cardano-sl-chain-test: -Wall -Werror -Wcompat -fwarn-redundant-constraints cardano-sl-client: -Wall -Werror -Wcompat -fwarn-redundant-constraints cardano-sl-core: -Wall -Werror -Wcompat -fwarn-redundant-constraints