Merge pull request #20 from kda-community/manage_fork_numbers

Extend ForkHeight to manage Fork numbers

Author: edmundnoble

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