remove feature flags logic

Author: larskuhtz

src/Chainweb/BlockHeader.hs

@@ -36,12 +36,6 @@ module Chainweb.BlockHeader
 , I.decodeEpochStartTime
 , I.epochStart
 
--- * FeatureFlags
-, I.FeatureFlags
-, I.mkFeatureFlags
-, I.encodeFeatureFlags
-, I.decodeFeatureFlags
-
 -- * POW Target
 , I.powTarget
 
@@ -95,6 +89,8 @@ module Chainweb.BlockHeader
 , I.forkEpochLength
 , I.isForkCountBlock
 , I.isForkVoteBlock
+, I.newForkState
+, I.genesisForkState
 
 -- * IsBlockHeader
 , I.IsBlockHeader(..)
@@ -130,7 +126,7 @@ import Chainweb.Payload (BlockPayloadHash)
 import Chainweb.Version (ChainwebVersionCode)
 import Control.Lens (Getter)
 
-blockFlags :: Getter I.BlockHeader I.FeatureFlags
+blockFlags :: Getter I.BlockHeader ForkState
 blockFlags = I.blockFlags
 
 blockCreationTime :: Getter I.BlockHeader BlockCreationTime

src/Chainweb/BlockHeader/Internal.hs

@@ -67,12 +67,6 @@ module Chainweb.BlockHeader.Internal
 , decodeEpochStartTime
 , epochStart
 
--- * FeatureFlags
-, FeatureFlags
-, mkFeatureFlags
-, encodeFeatureFlags
-, decodeFeatureFlags
-
 -- * POW Target
 , powTarget
 
@@ -143,6 +137,7 @@ module Chainweb.BlockHeader.Internal
 , isForkVoteBlock
 , newForkState
 , isLastForkEpochBlock
+, genesisForkState
 
 -- * CAS Constraint
 , BlockHeaderCas
@@ -258,28 +253,28 @@ decodeEpochStartTime :: Get EpochStartTime
 decodeEpochStartTime = EpochStartTime <$> decodeTime
 
 -- -----------------------------------------------------------------------------
--- Feature Flags
+-- [Deprecated] Feature Flags
 --
 -- Deprecated: renamed into 'blockForkState'
 
-newtype FeatureFlags = FeatureFlags Word64
-    deriving stock (Show, Eq, Generic)
-    deriving anyclass (NFData)
-    deriving newtype (ToJSON, FromJSON)
-
-encodeFeatureFlags :: FeatureFlags -> Put
-encodeFeatureFlags (FeatureFlags ff) = putWord64le ff
-
-decodeFeatureFlags :: Get FeatureFlags
-decodeFeatureFlags = FeatureFlags <$> getWord64le
-
-instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag FeatureFlags where
-    type Tag FeatureFlags = 'FeatureFlagsTag
-    toMerkleNode = encodeMerkleInputNode encodeFeatureFlags
-    fromMerkleNode = decodeMerkleInputNode decodeFeatureFlags
-
-mkFeatureFlags :: FeatureFlags
-mkFeatureFlags = FeatureFlags 0x0
+-- newtype FeatureFlags = FeatureFlags Word64
+--     deriving stock (Show, Eq, Generic)
+--     deriving anyclass (NFData)
+--     deriving newtype (ToJSON, FromJSON)
+--
+-- encodeFeatureFlags :: FeatureFlags -> Put
+-- encodeFeatureFlags (FeatureFlags ff) = putWord64le ff
+--
+-- decodeFeatureFlags :: Get FeatureFlags
+-- decodeFeatureFlags = FeatureFlags <$> getWord64le
+--
+-- instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag FeatureFlags where
+--     type Tag FeatureFlags = 'ForkStateTag
+--     toMerkleNode = encodeMerkleInputNode encodeFeatureFlags
+--     fromMerkleNode = decodeMerkleInputNode decodeFeatureFlags
+--
+-- mkFeatureFlags :: FeatureFlags
+-- mkFeatureFlags = FeatureFlags 0x0
 
 -- -------------------------------------------------------------------------- --
 -- Block Header
@@ -302,9 +297,10 @@ mkFeatureFlags = FeatureFlags 0x0
 --
 data BlockHeader :: Type where
     BlockHeader ::
-        { _blockFlags :: {-# UNPACK #-} !FeatureFlags
-            -- ^ An 8-byte bitmask reserved for the future addition of boolean
-            -- "feature flags".
+        { _blockFlags :: {-# UNPACK #-} !ForkState
+            -- ^ Fork state of the block. This used to be called "feature
+            -- flags". The old name is still used in textual encodings (e.g.
+            -- JSON).
 
         , _blockCreationTime :: {-# UNPACK #-} !BlockCreationTime
             -- ^ The time when the block was creates as recorded by the miner
@@ -739,7 +735,7 @@ makeGenesisBlockHeader' v p ct@(BlockCreationTime t) n =
     cid = _chainId p
 
     mlog = newMerkleLog
-        $ mkFeatureFlags
+        $ genesisForkState
         :+: ct
         :+: genesisParentBlockHash v cid
         :+: (v ^?! versionGenesis . genesisBlockTarget . atChain cid)
@@ -781,7 +777,7 @@ instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader wh
 
     -- /IMPORTANT/ a types must occur at most once in this list
     type MerkleLogHeader BlockHeader =
-        '[ FeatureFlags
+        '[ ForkState
         , BlockCreationTime
         , BlockHash
         , HashTarget
@@ -849,7 +845,7 @@ instance HasMerkleLog ChainwebMerkleHashAlgorithm ChainwebHashTag BlockHeader wh
 
 encodeBlockHeaderWithoutHash :: BlockHeader -> Put
 encodeBlockHeaderWithoutHash b = do
-    encodeFeatureFlags (_blockFlags b)
+    encodeForkState (_blockFlags b)
     encodeBlockCreationTime (_blockCreationTime b)
     encodeBlockHash (_blockParent b)
     encodeBlockHashRecord (_blockAdjacentHashes b)
@@ -897,7 +893,7 @@ decodeBlockHeaderCheckedChainId p = do
 --
 decodeBlockHeaderWithoutHash :: Get BlockHeader
 decodeBlockHeaderWithoutHash = do
-    a0 <- decodeFeatureFlags
+    a0 <- decodeForkState
     a1 <- decodeBlockCreationTime
     a2 <- decodeBlockHash -- parent hash
     a3 <- decodeBlockHashRecord
@@ -929,7 +925,7 @@ decodeBlockHeaderWithoutHash = do
 --
 decodeBlockHeader :: Get BlockHeader
 decodeBlockHeader = BlockHeader
-    <$> decodeFeatureFlags
+    <$> decodeForkState
     <*> decodeBlockCreationTime
     <*> decodeBlockHash -- parent hash
     <*> decodeBlockHashRecord
@@ -1107,16 +1103,6 @@ isForkCountBlock hdr = not (isForkVoteBlock hdr)
 
 -- | New Fork State computation
 --
--- The Boolean parameter indicates whether the block votes "yes" (True) to
--- increasing the fork number.
---
--- Callers of this function must not just unconditionally vote "yes". Instead,
--- they should vote "yes" only if the current fork number is less than the
--- maximum fork number that the version of the code supports.
---
--- TODO: replace the Boolean parameter with a 'maxSupportedForkNumber'
--- parameter.
---
 -- * isForkEpochStart -> forkNumber is deterministically increased
 -- * isForkEpochStart -> forkVote is nondeterministically reset to 0 or forkStep
 -- * forkVoteBlock && not isForkVoteStart -> forkVotes are non-deterministically monotonicly increasing
@@ -1127,13 +1113,14 @@ newForkState
         -- ^ Adjacent parent headers
     -> ParentHeader
         -- Parent block header
-    -> Bool
-        -- ^ Non-deterministcally selected vote (True = yes, False = no)
+    -> ForkNumber
+        -- ^ Target fork number. Vote "yes" to increase fork number, if the fork
+        -- number of the parent header is less than this value.
     -> ForkState
-newForkState as p vote
+newForkState as p targetFork
     | isLastForkEpochBlock (view parentHeader p) = cur
         -- reset votes and vote
-        & forkVotes .~ (if vote then addVote else id) resetVotes
+        & forkVotes .~ (if vote then addVote resetVotes else resetVotes)
         -- based on current vote count decide whether to increase fork number
         & forkNumber %~ (if decideVotes curVotes then succ else id)
     | isForkVoteBlock (view parentHeader p) = cur
@@ -1143,10 +1130,15 @@ newForkState as p vote
         -- do one vote counting step
         & forkVotes .~ countVotes allParentVotes
   where
+    vote = curNumber < targetFork
     cur = view (parentHeader . blockForkState) p
+    curNumber = view (parentHeader . blockForkNumber) p
     curVotes = view (parentHeader . blockForkVotes ) p
     allParentVotes = view (parentHeader . blockForkVotes) <$> (p : HM.elems as)
 
+genesisForkState :: ForkState
+genesisForkState = ForkState 0
+
 -- -------------------------------------------------------------------------- --
 -- IsBlockHeader
 
@@ -1196,7 +1188,7 @@ newBlockHeader
     -> BlockHeader
 newBlockHeader adj pay nonce t p@(ParentHeader b) =
     fromLog @ChainwebMerkleHashAlgorithm $ newMerkleLog
-        $ mkFeatureFlags
+        $ newForkState adj p (_blockForkNumber b)
         :+: t
         :+: _blockHash b
         :+: target

src/Chainweb/BlockHeader/Validation.hs

@@ -77,7 +77,7 @@ module Chainweb.BlockHeader.Validation
 , prop_block_genesis_parent
 , prop_block_genesis_target
 , prop_block_target
-, prop_block_featureFlags
+, prop_block_forkVotesReset
 
 -- * Inductive BlockHeader Properties
 , prop_block_epoch
@@ -88,6 +88,9 @@ module Chainweb.BlockHeader.Validation
 , prop_block_creationTime
 , prop_block_adjacent_chainIds
 , prop_block_adjacent_parents_version
+, prop_block_forkNumber
+, prop_block_forkVote
+, prop_block_forkVoteCount
 ) where
 
 import Control.Lens
@@ -650,7 +653,6 @@ validateIntrinsic t b = concat
     , [ IncorrectGenesisParent | not (prop_block_genesis_parent b)]
     , [ IncorrectGenesisTarget | not (prop_block_genesis_target b)]
     , [ BlockInTheFuture | not (prop_block_current t b)]
-    , [ InvalidFeatureFlags | not (prop_block_featureFlags b)]
     , [ AdjacentChainMismatch | not (prop_block_adjacent_chainIds b) ]
     , [ InvalidForkVotes | not (prop_block_forkVotesReset b) ]
     ]
@@ -723,14 +725,14 @@ prop_block_genesis_target b = isGenesisBlockHeader b
 prop_block_current :: Time Micros -> BlockHeader -> Bool
 prop_block_current t b = BlockCreationTime t >= view blockCreationTime b
 
-prop_block_featureFlags :: BlockHeader -> Bool
-prop_block_featureFlags b
-    | skipFeatureFlagValidationGuard v cid h = True
-    | otherwise = view blockFlags b == mkFeatureFlags
-  where
-    v = _chainwebVersion b
-    h = view blockHeight b
-    cid = _chainId b
+-- prop_block_featureFlags :: BlockHeader -> Bool
+-- prop_block_featureFlags b
+--     | skipFeatureFlagValidationGuard v cid h = True
+--     | otherwise = view blockFlags b == mkFeatureFlags
+--   where
+--     v = _chainwebVersion b
+--     h = view blockHeight b
+--     cid = _chainId b
 
 -- | Verify that the adjacent hashes of the block are for the correct set of
 -- chain ids.

src/Chainweb/ForkState.hs

@@ -3,6 +3,10 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- |
 -- Module: Chainweb.ForkState
@@ -35,6 +39,8 @@ module Chainweb.ForkState
 ) where
 
 import Data.Word
+import Chainweb.Crypto.MerkleLog
+import Chainweb.MerkleUniverse
 import Chainweb.Utils
 import Chainweb.Utils.Serialization (Put, Get, putWord64le, getWord64le)
 import Control.DeepSeq (NFData)
@@ -90,8 +96,9 @@ import Numeric.Natural
 -- released that proposes a fork.
 --
 newtype ForkState = ForkState { _forkState :: Word64 }
-    deriving (Eq, Ord, Generic)
+    deriving (Show, Eq, Ord, Generic)
     deriving anyclass (NFData)
+    deriving newtype (ToJSON, FromJSON)
 
 -- | Little endian encoding of the fork state.
 --
@@ -103,6 +110,11 @@ encodeForkState (ForkState h) = putWord64le h
 decodeForkState :: Get ForkState
 decodeForkState = ForkState <$> getWord64le
 
+instance MerkleHashAlgorithm a => IsMerkleLogEntry a ChainwebHashTag ForkState where
+    type Tag ForkState = 'ForkStateTag
+    toMerkleNode = encodeMerkleInputNode encodeForkState
+    fromMerkleNode = decodeMerkleInputNode decodeForkState
+
 -- ---------------------------------------------------------------------------
 -- Fork Number
 

src/Chainweb/MerkleUniverse.hs

@@ -90,7 +90,7 @@ data ChainwebHashTag
     | MinerDataTag
     | CoinbaseOutputTag
     | EpochStartTimeTag
-    | FeatureFlagsTag
+    | ForkStateTag
 
     -- Event Proofs
     | OutputEventsTag
@@ -106,7 +106,7 @@ instance MerkleUniverse ChainwebHashTag where
     type MerkleTagVal ChainwebHashTag 'BlockHeightTag = 0x0003
     type MerkleTagVal ChainwebHashTag 'BlockWeightTag = 0x0004
     type MerkleTagVal ChainwebHashTag 'BlockPayloadHashTag = 0x0005
-    type MerkleTagVal ChainwebHashTag 'FeatureFlagsTag = 0x0006
+    type MerkleTagVal ChainwebHashTag 'ForkStateTag = 0x0006
     type MerkleTagVal ChainwebHashTag 'BlockCreationTimeTag = 0x0007
     type MerkleTagVal ChainwebHashTag 'ChainwebVersionTag = 0x0008
     type MerkleTagVal ChainwebHashTag 'PowHashTag = 0x0009

test/lib/Chainweb/Test/Orphans/Internal.hs

@@ -166,6 +166,7 @@ import P2P.Test.Orphans ()
 import System.Logger.Types
 
 import Utils.Logging
+import Chainweb.ForkState
 
 -- -------------------------------------------------------------------------- --
 -- Utils
@@ -327,8 +328,8 @@ instance Arbitrary BlockCreationTime where
 instance Arbitrary EpochStartTime where
     arbitrary = EpochStartTime <$> arbitrary
 
-instance Arbitrary FeatureFlags where
-    arbitrary = return mkFeatureFlags
+instance Arbitrary ForkState where
+    arbitrary = ForkState <$> arbitrary
 
 instance Arbitrary BlockHeader where
     arbitrary = arbitrary >>= arbitraryBlockHeaderVersion
@@ -849,7 +850,7 @@ instance Arbitrary MiningConfig where
 arbitraryEventPactValue :: Gen PactValue
 arbitraryEventPactValue = oneof
     [ PLiteral . LString <$> arbitrary
-    , PLiteral . LInteger <$> (int256ToInteger <$> arbitrary)
+    , PLiteral . LInteger . int256ToInteger <$> arbitrary
     ]
 
 -- | Arbitrary Pact events that are supported in events proofs

test/lib/Chainweb/Test/Utils.hs

@@ -500,13 +500,16 @@ trunk g h = do
 
 -- | Generate some new `BlockHeader` based on a parent.
 --
+-- Adjacent headers are ignored, which means that the resultting header is
+-- valid only in a singleton Chainweb.
+--
 header :: BlockHeader -> Gen BlockHeader
 header p = do
     nonce <- Nonce <$> chooseAny
     return
         . fromLog @ChainwebMerkleHashAlgorithm
         . newMerkleLog
-        $ mkFeatureFlags
+        $ newForkState mempty (ParentHeader p) (view blockForkNumber p)
             :+: t'
             :+: view blockHash p
             :+: target
@@ -527,7 +530,7 @@ header p = do
 -- | get arbitrary value for seed.
 -- > getArbitrary @BlockHash 0
 getArbitrary :: Arbitrary a => Int -> a
-getArbitrary seed = unGen arbitrary (mkQCGen 0) seed
+getArbitrary = unGen arbitrary (mkQCGen 0)
 
 -- -------------------------------------------------------------------------- --
 -- Test Chain Database Configurations
@@ -701,7 +704,7 @@ withChainwebTestServer shouldValidateSpec tls v app =
             let
                 settings =
                     W.setBeforeMainLoop (putMVar readyVar ()) $
-                    W.setOnExceptionResponse verboseOnExceptionResponse $
+                    W.setOnExceptionResponse verboseOnExceptionResponse
                     W.defaultSettings
             if
                 | tls -> do