Extend ForkHeight to manage Fork numbers

src/Chainweb/BlockHeaderDB/HeaderOracle.hs

@@ -29,14 +29,14 @@ module Chainweb.BlockHeaderDB.HeaderOracle
     where
 
 import Chainweb.BlockHash (BlockHash)
-import Chainweb.BlockHeader (BlockHeader, blockHash, blockHeight, genesisBlockHeader)
+import Chainweb.BlockHeader (BlockHeader, blockHash, blockHeight, blockForkNumber, genesisBlockHeader)
 import Chainweb.BlockHeaderDB (BlockHeaderDb)
 import Chainweb.TreeDB (seekAncestor)
 import Chainweb.TreeDB qualified as TreeDB
 import Chainweb.Version (_chainwebVersion)
 import Chainweb.Version.Guards (minimumBlockHeaderHistory)
 import Control.Exception (Exception(..), throwIO)
-import Control.Lens (view)
+import Control.Lens
 import Numeric.Natural (Natural)
 
 -- | A 'HeaderOracle' is a 'BlockHeaderDb' with a lower and upper bound, and the only
@@ -52,7 +52,7 @@ data HeaderOracle = HeaderOracle
 --   The lower bound of the oracle is determined by the 'spvProofExpirationWindow'.
 createSpv :: BlockHeaderDb -> BlockHeader -> IO HeaderOracle
 createSpv db upperBound = do
-    let mWindow = minimumBlockHeaderHistory (_chainwebVersion upperBound) (view blockHeight upperBound)
+    let mWindow = minimumBlockHeaderHistory (_chainwebVersion upperBound) (upperBound ^. blockForkNumber) (upperBound ^. blockHeight)
     let gh = genesisBlockHeader (_chainwebVersion upperBound) upperBound
     let defaultOracle = create db gh upperBound
 

src/Chainweb/Chainweb.hs

@@ -401,7 +401,7 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re
             (\cid x -> do
                 let mcfg = validatingMempoolConfig cid v (_configBlockGasLimit conf) (_configMinGasPrice conf)
                 -- NOTE: the gas limit may be set based on block height in future, so this approach may not be valid.
-                let maxGasLimit = fromIntegral <$> maxBlockGasLimit v maxBound
+                let maxGasLimit = fromIntegral <$> maxBlockGasLimit v maxBound maxBound
                 case maxGasLimit of
                     Just maxGasLimit'
                         | _configBlockGasLimit conf > maxGasLimit' ->

src/Chainweb/Chainweb/Configuration.hs

@@ -605,10 +605,12 @@ parseVersion = constructVersion
             maybe (_versionUpgrades winningVersion) (\fub' ->
                 OnChains $ HM.mapWithKey
                     (\cid _ ->
-                        case winningVersion ^?! versionForks . at fub' . _Just . atChain cid of
+                        let currentUpgrades =  winningVersion ^?! versionUpgrades . atChain cid
+                        in case winningVersion ^?! versionForks . at fub' . _Just . atChain cid of
                             ForkNever -> error "Chainweb.Chainweb.Configuration.parseVersion: the fork upper bound never occurs in this version."
-                            ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) (winningVersion ^?! versionUpgrades . atChain cid)
+                            ForkAtBlockHeight fubHeight -> HM.filterWithKey (\bh _ -> bh <= fubHeight) currentUpgrades
                             ForkAtGenesis -> winningVersion ^?! versionUpgrades . atChain cid
+                            ForkAtForkNumber _ -> currentUpgrades -- For now, version upgrades were only allowed at block heights
                     )
                     (HS.toMap (chainIds winningVersion))
             ) fub

src/Chainweb/ForkState.hs

@@ -25,6 +25,7 @@ module Chainweb.ForkState
 -- * Fork Number
 , ForkNumber(..)
 , forkNumber
+, pact4ForkNumber
 
 -- * Fork Votes
 , ForkVotes(..)
@@ -132,6 +133,11 @@ forkNumber = lens _forkNumber $ \(ForkState w) v -> ForkState
     $ (w .&. 0xFFFFFFFF00000000)
     .|. (fromIntegral v .&. 0xFFFFFFFF)
 
+
+-- Pact4 -> Pact5 transition happened during ForkNumber=0 era.
+pact4ForkNumber :: ForkNumber
+pact4ForkNumber = 0
+
 -- ---------------------------------------------------------------------------
 -- Fork Votes
 

src/Chainweb/Pact/Backend/Compaction.hs

@@ -68,7 +68,7 @@ import "yet-another-logger" System.Logger hiding (Logger)
 import "yet-another-logger" System.Logger qualified as YAL
 import "yet-another-logger" System.Logger.Backend.ColorOption (useColor)
 import Chainweb.BlockHash
-import Chainweb.BlockHeader (blockHeight, blockHash, blockPayloadHash)
+import Chainweb.BlockHeader (blockHeight, blockForkNumber, blockHash, blockPayloadHash)
 import Chainweb.BlockHeaderDB.Internal (BlockHeaderDb(..), RankedBlockHeader(..))
 import Chainweb.BlockHeight (BlockHeight(..))
 import Chainweb.Cut.CutHashes (cutIdToText)
@@ -762,7 +762,7 @@ doCompactRocksDb logger cwVersion cids minBlockHeight srcDb targetDb = do
         iterLast it
         iterValue it >>= \case
           Nothing -> exitLog logger "Missing final payload. This is likely due to a corrupted database."
-          Just rbh -> pure (_getRankedBlockHeader rbh ^. blockHeight)
+          Just rbh -> pure $ _getRankedBlockHeader rbh
 
       -- The header that we start at depends on whether or not
       -- we have a minimal block header history window.
@@ -772,7 +772,10 @@ doCompactRocksDb logger cwVersion cids minBlockHeight srcDb targetDb = do
       --
       -- On new enough chainweb versions, we want to only copy over
       -- the minimal number of block headers.
-      case minimumBlockHeaderHistory cwVersion latestHeader of
+      -- Note, this behaviour may be dangerous in case of changes on the minimum block history.
+      --
+      -- TODO = Option to prune headers history to the minimum should be enabled by flag.
+      case minimumBlockHeaderHistory cwVersion (latestHeader ^. blockForkNumber) (latestHeader ^. blockHeight) of
         -- Go to the earliest possible entry. We migrate all BlockHeaders, for now.
         -- They are needed for SPV.
         --
@@ -791,16 +794,18 @@ doCompactRocksDb logger cwVersion cids minBlockHeight srcDb targetDb = do
       earliestHeader <- do
         iterValue it >>= \case
           Nothing -> exitLog logger "Missing first payload. This is likely due to a corrupted database."
-          Just rbh -> pure (_getRankedBlockHeader rbh ^. blockHeight)
+          Just rbh -> pure $ _getRankedBlockHeader rbh
 
       -- Ensure that we log progress 100 times per chain
       -- I just made this number up as something that felt somewhat sensible
-      let offset = (latestHeader - earliestHeader) `div` 100
-      let headerProgressPoints = [earliestHeader + i * offset | i <- [1..100]]
+      let latestHeight = latestHeader ^. blockHeight
+          earliestHeight = earliestHeader ^. blockHeight
+          offset = (latestHeight - earliestHeight) `div` 100
+      let headerProgressPoints = [earliestHeight + i * offset | i <- [1..100]]
 
       let logHeaderProgress bHeight = do
             when (bHeight `elem` headerProgressPoints) $ do
-              let percentDone = sshow $ 100 * fromIntegral @_ @Double (bHeight - earliestHeader) / fromIntegral @_ @Double (latestHeader - earliestHeader)
+              let percentDone = sshow $ 100 * fromIntegral @_ @Double (bHeight - earliestHeight) / fromIntegral @_ @Double (latestHeight - earliestHeight)
               log' LL.Info $ percentDone <> "% done."
 
       let go = do

src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs

@@ -95,6 +95,7 @@ import Chainweb.Payload.PayloadStore
 import Chainweb.Time
 import Chainweb.Utils hiding (check)
 import Chainweb.Version
+import Chainweb.ForkState (pact4ForkNumber)
 import Chainweb.Version.Guards
 import Chainweb.Pact4.Backend.ChainwebPactDb
 import Data.Coerce
@@ -163,7 +164,7 @@ execBlock currHeader payload = do
     return (totalGasUsed, pwo)
   where
     blockGasLimit =
-      fromIntegral <$> maxBlockGasLimit v (view blockHeight currHeader)
+      fromIntegral <$> maxBlockGasLimit v pact4ForkNumber (view blockHeight currHeader)
 
     logInitCache = liftPactServiceM $ do
       mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache

src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs

@@ -577,7 +577,7 @@ execExistingBlock
   -> CheckablePayload
   -> PactBlockM logger tbl (P.Gas, PayloadWithOutputs)
 execExistingBlock currHeader payload = do
-  parentBlockHeader <- view psParentHeader
+  parentBlockHeader <- _parentHeader <$> view psParentHeader
   let plData = checkablePayloadToPayloadData payload
   miner :: Miner <- decodeStrictOrThrow (_minerData $ view payloadDataMiner plData)
   txs <- liftIO $ pact5TransactionsFromPayload plData
@@ -590,7 +590,7 @@ execExistingBlock currHeader payload = do
   isGenesis <- view psIsGenesis
   blockHandlePreCoinbase <- use pbBlockHandle
   let
-    txValidationTime = ParentCreationTime (view blockCreationTime $ _parentHeader parentBlockHeader)
+    txValidationTime = ParentCreationTime (parentBlockHeader ^. blockCreationTime)
   errors <- liftIO $ flip foldMap txs $ \tx -> do
     errorOrSuccess <- runExceptT $
       validateParsedChainwebTx logger v cid db blockHandlePreCoinbase txValidationTime
@@ -612,7 +612,7 @@ execExistingBlock currHeader payload = do
   postCoinbaseBlockHandle <- use pbBlockHandle
 
   let blockGasLimit =
-        Pact5.GasLimit . Pact5.Gas . fromIntegral <$> maxBlockGasLimit v (view blockHeight currHeader)
+        Pact5.GasLimit . Pact5.Gas . fromIntegral <$> maxBlockGasLimit v (parentBlockHeader ^. blockForkNumber) (currHeader ^. blockHeight)
 
   env <- ask
   (V.fromList -> results, (finalHandle, _finalBlockGasLimit)) <-

src/Chainweb/Pact4/ModuleCache.hs

@@ -72,3 +72,4 @@ cleanModuleCache v cid bh =
         ForkAtBlockHeight bh' -> bh == bh'
         ForkAtGenesis -> bh == genesisHeight v cid
         ForkNever -> False
+        ForkAtForkNumber _ -> error "ChainWeb217Pact is not supposed to be indexed by a ForkNumber"

src/Chainweb/Pact4/TransactionExec.hs

@@ -144,6 +144,7 @@ import qualified Pact.Utils.StableHashMap as SHM
 
 import Chainweb.BlockHeader
 import Chainweb.BlockHeight
+import Chainweb.ForkState (pact4ForkNumber)
 import Chainweb.Logger
 import qualified Chainweb.ChainId as Chainweb
 import Chainweb.Mempool.Mempool (pact4RequestKeyToTransactionHash)
@@ -371,7 +372,7 @@ applyCmd v logger gasLogger txFailuresCounter pdbenv miner gasModel txCtx txIdxI
     chainweb217Pact' = guardCtx chainweb217Pact txCtx
     chainweb219Pact' = guardCtx chainweb219Pact txCtx
     chainweb223Pact' = guardCtx chainweb223Pact txCtx
-    allVerifiers = verifiersAt v cid currHeight
+    allVerifiers = verifiersAt v cid pact4ForkNumber currHeight
     toEmptyPactError (PactError errty _ _ _) = PactError errty noInfo [] mempty
 
     toOldListErr pe = pe { peDoc = listErrMsg }
@@ -671,7 +672,8 @@ applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig =
     currHeight = ctxCurrentBlockHeight txCtx
     cid = V._chainId txCtx
     v = _chainwebVersion txCtx
-    allVerifiers = verifiersAt v cid currHeight
+
+    allVerifiers = verifiersAt v cid pact4ForkNumber currHeight
     -- Note [Throw out verifier proofs eagerly]
     !verifiersWithNoProof =
         (fmap . fmap) (\_ -> ()) verifiers

src/Chainweb/Pact5/TransactionExec.hs

@@ -183,7 +183,7 @@ runVerifiers txCtx cmd = do
       gasUsed <- liftIO . readIORef . _geGasRef . _txEnvGasEnv =<< ask
       let initGasRemaining = MilliGas $ case (gasToMilliGas (gasLimit ^. _GasLimit), gasUsed) of
             (MilliGas gasLimitMilliGasWord, MilliGas gasUsedMilliGasWord) -> gasLimitMilliGasWord - gasUsedMilliGasWord
-      let allVerifiers = verifiersAt v (_chainId txCtx) (ctxCurrentBlockHeight txCtx)
+      let allVerifiers = verifiersAt v (_chainId txCtx) (ctxParentForkNumber txCtx) (ctxCurrentBlockHeight txCtx)
       let toModuleName m =
             Pact4.ModuleName
                     { Pact4._mnName = _mnName m

src/Chainweb/Pact5/Types.hs

@@ -11,6 +11,7 @@ module Chainweb.Pact5.Types
     ( TxContext(..)
     , guardCtx
     , ctxCurrentBlockHeight
+    , ctxParentForkNumber
     , GasSupply(..)
     , PactBlockM(..)
     , PactBlockState(..)
@@ -34,6 +35,7 @@ import Chainweb.BlockHeader
 import Chainweb.Miner.Pact (Miner)
 import Chainweb.BlockHeight
 import Chainweb.Version
+import Chainweb.ForkState
 import Chainweb.Pact.Types
 import qualified Chainweb.ChainId
 import Control.Lens
@@ -84,6 +86,14 @@ ctxBlockHeader = _parentHeader . _tcParentHeader
 ctxCurrentBlockHeight :: TxContext -> BlockHeight
 ctxCurrentBlockHeight = succ . view blockHeight . ctxBlockHeader
 
+-- We use the parent fork number in Pact, so when the fork
+-- number is incremented, only that block's descendents will
+-- have the forking behavior active. We do this because computing
+-- the "currently active fork number" requires information from adjacent 
+-- headers, which is not actually available yet when we execute a new Pact payload.
+ctxParentForkNumber :: TxContext -> ForkNumber
+ctxParentForkNumber = view blockForkNumber . ctxBlockHeader
+
 ctxChainId :: TxContext -> Chainweb.ChainId.ChainId
 ctxChainId = _chainId . ctxBlockHeader
 

src/Chainweb/Version.hs

@@ -37,6 +37,7 @@ module Chainweb.Version
     -- * Properties of Chainweb Version
       Fork(..)
     , ForkHeight(..)
+    , succByHeight
     , _ForkAtBlockHeight
     , _ForkAtGenesis
     , _ForkNever
@@ -322,12 +323,54 @@ instance FromJSON Fork where
 instance FromJSONKey Fork where
     fromJSONKey = FromJSONKeyTextParser $ either fail return . eitherFromText
 
-data ForkHeight = ForkAtBlockHeight !BlockHeight | ForkAtGenesis | ForkNever
-    deriving stock (Generic, Eq, Ord, Show)
+data ForkHeight =  ForkAtForkNumber !ForkNumber | ForkAtBlockHeight !BlockHeight | ForkAtGenesis | ForkNever
+    deriving stock (Generic, Eq, Show)
     deriving anyclass (Hashable, NFData)
 
+instance Bounded ForkHeight where
+    minBound = ForkAtGenesis
+    maxBound = ForkNever
+
+instance Ord ForkHeight where
+    compare ForkAtGenesis ForkAtGenesis = EQ
+    compare ForkNever ForkNever = EQ
+    compare (ForkAtForkNumber a) (ForkAtForkNumber b) = compare a b
+    compare (ForkAtBlockHeight a)  (ForkAtBlockHeight b) = compare a b
+    compare ForkAtGenesis  _ = LT
+    compare _ ForkAtGenesis = GT
+    compare ForkNever _ = GT
+    compare _ ForkNever = LT
+    compare (ForkAtForkNumber fn) (ForkAtBlockHeight _)
+        | fn == 0 = LT
+        | otherwise = GT
+    compare (ForkAtBlockHeight _) (ForkAtForkNumber fn)
+        | fn == 0 = GT
+        | otherwise = LT
+
+-- We consider the following ordering for Forks:
+--   - ForkAtGenesis
+--   - ForkNumber = 0  (unusual case)
+--   - BlockHeight = 0 (unusual case)
+--   - BlockHeight = 1
+--          ..
+--   - BlockHeight = n
+--   - ForkNumber = 1
+--          ..
+--   - ForkNumber = n
+--   - ForkNever
+--
+-- During the LLC era, forks were triggered by block heights, with a fork number of 0 (called feature flag).
+-- After version 3.1, forks are ONLY triggered by fork numbers, as soon as the fork number becomes equal to 1.
+-- So the fork heights are sorted chronologically: first block heights, then fork numbers.
+
+
 makePrisms ''ForkHeight
 
+succByHeight :: ForkHeight -> ForkHeight
+succByHeight (ForkAtBlockHeight x) = ForkAtBlockHeight $ succ x
+succByHeight ForkNever = ForkNever
+succByHeight _ = error "Only a Blockheight defined fork can be succ'ed"
+
 newtype ChainwebVersionName =
     ChainwebVersionName { getChainwebVersionName :: T.Text }
     deriving stock (Generic, Eq, Ord)
@@ -491,9 +534,9 @@ data ChainwebVersion
         --
         -- NOTE: This is internal. For the actual size of the serialized header
         -- use 'headerSizeBytes'.
-    , _versionMaxBlockGasLimit :: Rule BlockHeight (Maybe Natural)
+    , _versionMaxBlockGasLimit :: Rule ForkHeight (Maybe Natural)
         -- ^ The maximum gas limit for an entire block.
-    , _versionSpvProofRootValidWindow :: Rule BlockHeight (Maybe Word64)
+    , _versionSpvProofRootValidWindow :: Rule ForkHeight (Maybe Word64)
         -- ^ The minimum number of block headers a chainweb node should
         -- retain in its history at all times.
     , _versionBootstraps :: [PeerInfo]
@@ -504,7 +547,7 @@ data ChainwebVersion
         -- ^ Whether to disable any core functionality.
     , _versionDefaults :: VersionDefaults
         -- ^ Version-specific defaults that can be overridden elsewhere.
-    , _versionVerifierPluginNames :: ChainMap (Rule BlockHeight (Set VerifierName))
+    , _versionVerifierPluginNames :: ChainMap (Rule ForkHeight (Set VerifierName))
         -- ^ Verifier plugins that can be run to verify transaction contents.
     , _versionQuirks :: VersionQuirks
         -- ^ Modifications to behavior at particular blockheights