Fork state header validation

Author: larskuhtz

cabal.project

@@ -95,14 +95,14 @@ package yet-another-logger
 source-repository-package
     type: git
     location: https://github.com/kadena-io/pact.git
-    tag: d4f03045df6ba5178a76e534d619b6233ad1c659
-    --sha256: 1q4b3i606davn6iyk6az2q7cw5f7llxjhkbqyzw4bsxhrkah7fch
+    tag: 4208012e3f2fdf1721c24cdcb97de5f64fd5f58a
+    --sha256: 1al11csqr291avfwbb7hcrfxapz9sx0iclv3j5ipnli287h52cvs
 
 source-repository-package
     type: git
     location: https://github.com/kadena-io/pact-5.git
-    tag: 6c81f4cf0631a4087f8350230bd9b7c3714f9751
-    --sha256: sha256-7SttW6Aexh+sQLdT1JZ4sZIhRXJ5G4q23aBvRh0sEK0=
+    tag: bfc5310c462aaefabe7c512407ac6dab87fc8c42
+    --sha256: 05xp1vwxkvjxrn8pij9z4g1hadbkb8hrgziwzs408yxxxmkcv6kq
 
 source-repository-package
     type: git

chainweb.cabal

@@ -194,6 +194,7 @@ library
         , Chainweb.CutDB.RestAPI.Server
         , Chainweb.CutDB.Sync
         , Chainweb.Difficulty
+        , Chainweb.ForkState
         , Chainweb.Graph
         , Chainweb.HostAddress
         , Chainweb.Logger

src/Chainweb/BlockHeader.hs

@@ -47,6 +47,7 @@ module Chainweb.BlockHeader
 
 -- * BlockHeader
 , I.BlockHeader
+
 -- ** Getters
 , blockFlags
 , blockCreationTime
@@ -61,6 +62,10 @@ module Chainweb.BlockHeader
 , blockEpochStart
 , blockNonce
 , blockHash
+, blockForkState
+, blockForkVotes
+, blockForkNumber
+
 -- ** Utilities
 , I._blockPow
 , I.blockPow
@@ -85,6 +90,12 @@ module Chainweb.BlockHeader
 , I.adjacentChainIds
 , I.absBlockHeightDiff
 
+-- ** Fork State
+, I.isForkEpochStart
+, I.forkEpochLength
+, I.isForkCountBlock
+, I.isForkVoteBlock
+
 -- * IsBlockHeader
 , I.IsBlockHeader(..)
 
@@ -107,15 +118,16 @@ module Chainweb.BlockHeader
 )
 where
 
-import Chainweb.ChainId (ChainId)
-import Chainweb.BlockWeight (BlockWeight)
-import Chainweb.BlockHeight (BlockHeight)
-import Chainweb.Version (ChainwebVersionCode)
-import Chainweb.Payload (BlockPayloadHash)
-import Chainweb.Difficulty (HashTarget)
+import Chainweb.ForkState (ForkState, ForkVotes, ForkNumber)
+import Chainweb.BlockCreationTime (BlockCreationTime)
 import Chainweb.BlockHash (BlockHash, BlockHashRecord)
 import Chainweb.BlockHeader.Internal qualified as I
-import Chainweb.BlockCreationTime (BlockCreationTime)
+import Chainweb.BlockHeight (BlockHeight)
+import Chainweb.BlockWeight (BlockWeight)
+import Chainweb.ChainId (ChainId)
+import Chainweb.Difficulty (HashTarget)
+import Chainweb.Payload (BlockPayloadHash)
+import Chainweb.Version (ChainwebVersionCode)
 import Control.Lens (Getter)
 
 blockFlags :: Getter I.BlockHeader I.FeatureFlags
@@ -156,3 +168,12 @@ blockNonce = I.blockNonce
 
 blockHash :: Getter I.BlockHeader BlockHash
 blockHash = I.blockHash
+
+blockForkState :: Getter I.BlockHeader ForkState
+blockForkState = I.blockForkState
+
+blockForkVotes :: Getter I.BlockHeader ForkVotes
+blockForkVotes = I.blockForkVotes
+
+blockForkNumber :: Getter I.BlockHeader ForkNumber
+blockForkNumber = I.blockForkNumber

src/Chainweb/BlockHeader/Internal.hs

@@ -92,6 +92,7 @@ module Chainweb.BlockHeader.Internal
 , blockEpochStart
 , blockNonce
 , blockHash
+
 -- ** Utilities
 , _blockPow
 , blockPow
@@ -130,6 +131,19 @@ module Chainweb.BlockHeader.Internal
 -- * Create a new BlockHeader
 , newBlockHeader
 
+-- * Fork State
+, blockForkState
+, _blockForkNumber
+, blockForkNumber
+, _blockForkVotes
+, blockForkVotes
+, forkEpochLength
+, isForkEpochStart
+, isForkCountBlock
+, isForkVoteBlock
+, newForkState
+, isLastForkEpochBlock
+
 -- * CAS Constraint
 , BlockHeaderCas
 
@@ -186,6 +200,7 @@ import Numeric.AffineSpace
 import Numeric.Natural
 import System.IO.Unsafe
 import Text.Read (readEither)
+import Chainweb.ForkState
 
 -- -------------------------------------------------------------------------- --
 -- Nonce
@@ -244,6 +259,8 @@ decodeEpochStartTime = EpochStartTime <$> decodeTime
 
 -- -----------------------------------------------------------------------------
 -- Feature Flags
+--
+-- Deprecated: renamed into 'blockForkState'
 
 newtype FeatureFlags = FeatureFlags Word64
     deriving stock (Show, Eq, Generic)
@@ -600,7 +617,7 @@ epochStart ph@(ParentHeader p) adj (BlockCreationTime bt)
     --
     -- The result is guaranteed to be non-empty
     --
-    adjCreationTimes = fmap (_blockCreationTime)
+    adjCreationTimes = fmap _blockCreationTime
         $ HM.insert cid (_parentHeader ph)
         $ HM.filter (not . isGenesisBlockHeader)
         $ fmap _parentHeader adj
@@ -693,7 +710,7 @@ genesisBlockHeaders = \v ->
     testnetGenesisHeaders = makeGenesisBlockHeaders testnet04
 
 genesisBlockHeader :: (HasCallStack, HasChainId p) => ChainwebVersion -> p -> BlockHeader
-genesisBlockHeader v p = genesisBlockHeaders v ^?! at (_chainId p) . _Just
+genesisBlockHeader v p = genesisBlockHeaders v ^?! ix (_chainId p)
 
 makeGenesisBlockHeaders :: ChainwebVersion -> HashMap ChainId BlockHeader
 makeGenesisBlockHeaders v = HM.fromList [ (cid, makeGenesisBlockHeader v cid) | cid <- HS.toList (chainIds v)]
@@ -1049,6 +1066,87 @@ instance FromJSON (ObjectEncoded BlockHeader) where
         $ fmap ObjectEncoded . parseBlockHeaderObject
     {-# INLINE parseJSON #-}
 
+-- -------------------------------------------------------------------------- --
+-- Fork State
+
+blockForkState :: Lens' BlockHeader ForkState
+blockForkState = blockFlags . coerced
+
+_blockForkNumber :: BlockHeader -> ForkNumber
+_blockForkNumber = view (blockForkState . forkNumber)
+
+_blockForkVotes :: BlockHeader -> ForkVotes
+_blockForkVotes = view (blockForkState . forkVotes)
+
+blockForkNumber :: Lens' BlockHeader ForkNumber
+blockForkNumber = blockForkState . forkNumber
+
+blockForkVotes :: Lens' BlockHeader ForkVotes
+blockForkVotes = blockForkState . forkVotes
+
+-- | Returns whether a block is the first block in a fork epoch.
+--
+isForkEpochStart :: BlockHeader -> Bool
+isForkEpochStart hdr =
+    rem (int $ view blockHeight hdr) forkEpochLength == 0
+
+isLastForkEpochBlock :: BlockHeader -> Bool
+isLastForkEpochBlock hdr =
+    rem (1 + int (view blockHeight hdr)) forkEpochLength == 0
+
+-- | Returns whether a block is at a height at which voting occurs.
+--
+isForkVoteBlock :: BlockHeader -> Bool
+isForkVoteBlock hdr =
+    rem (int $ view blockHeight hdr) forkEpochLength < (forkEpochLength - 120)
+
+-- | Returns whether a block is at a height at which vote couting occurs.
+--
+isForkCountBlock :: BlockHeader -> Bool
+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
+-- * forkCountBlock -> forkVotes are deterministically set
+--
+newForkState
+    :: HM.HashMap ChainId ParentHeader
+        -- ^ Adjacent parent headers
+    -> ParentHeader
+        -- Parent block header
+    -> Bool
+        -- ^ Non-deterministcally selected vote (True = yes, False = no)
+    -> ForkState
+newForkState as p vote
+    | isLastForkEpochBlock (view parentHeader p) = cur
+        -- reset votes and vote
+        & forkVotes .~ (if vote then addVote else id) 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
+        -- vote
+        & forkVotes %~ (if vote then addVote else id)
+    | otherwise = cur
+        -- do one vote counting step
+        & forkVotes .~ countVotes allParentVotes
+  where
+    cur = view (parentHeader . blockForkState) p
+    curVotes = view (parentHeader . blockForkVotes ) p
+    allParentVotes = view (parentHeader . blockForkVotes) <$> (p : HM.elems as)
+
 -- -------------------------------------------------------------------------- --
 -- IsBlockHeader
 
@@ -1114,7 +1212,7 @@ newBlockHeader adj pay nonce t p@(ParentHeader b) =
     cid = _chainId p
     v = _chainwebVersion p
     target = powTarget p adj t
-    adjHashes = BlockHashRecord $ (_blockHash . _parentHeader) <$> adj
+    adjHashes = BlockHashRecord $ _blockHash . _parentHeader <$> adj
 
 -- -------------------------------------------------------------------------- --
 -- TreeDBEntry instance
@@ -1141,7 +1239,8 @@ instance TreeDbEntry BlockHeader where
 -- on the graph of the parent.
 --
 headerSizes :: ChainwebVersion -> Rule BlockHeight Natural
-headerSizes v = fmap (\g -> _versionHeaderBaseSizeBytes v + 36 * degree g + 2) $ _versionGraphs v
+headerSizes v = (\g -> _versionHeaderBaseSizeBytes v + 36 * degree g + 2)
+    <$> _versionGraphs v
 
 -- | The size of the serialized block header.
 --