wip

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

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

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

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
 

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