Extend ForkHeight to manage Fork numbers

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 blok heights
                     )
                     (HS.toMap (chainIds winningVersion))
             ) fub

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/Version.hs

@@ -37,6 +37,7 @@ module Chainweb.Version
     -- * Properties of Chainweb Version
       Fork(..)
     , ForkHeight(..)
+    , succByHeight
     , _ForkAtBlockHeight
     , _ForkAtGenesis
     , _ForkNever
@@ -322,12 +323,49 @@ 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)
+--   - BlockHeihgt = 0 (unusual case)
+--   - Blockkheight = 1
+--          ..
+--   - BlockHeight = n
+--   - ForkNumber = 1
+--          ..
+--   - ForkNumber = n
+--   - ForkNever
+
 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 +529,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 +542,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

src/Chainweb/Version/Guards.hs

@@ -2,6 +2,9 @@
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+-- TODO Remove this when checkFork' will be used for real
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
 -- |
 -- Module: Chainweb.Version.Guards
 -- Copyright: Copyright © 2023 Kadena LLC.
@@ -70,6 +73,7 @@ import Chainweb.BlockHeight
 import Chainweb.ChainId
 import Chainweb.Pact4.Transaction qualified as Pact4
 import Chainweb.Utils.Rule
+import Chainweb.ForkState
 import Chainweb.Version
 import Control.Lens
 import Data.Word (Word64)
@@ -86,32 +90,33 @@ import Pact.Types.Scheme (PPKScheme(ED25519, WebAuthn))
 getForkHeight :: Fork -> ChainwebVersion -> ChainId -> ForkHeight
 getForkHeight fork v cid = v ^?! versionForks . at fork . _Just . atChain cid
 
+-- Check Fork by height
 checkFork
-    :: (BlockHeight -> ForkHeight -> Bool)
+    :: (ForkHeight -> ForkHeight -> Bool)
     -> Fork -> ChainwebVersion -> ChainId -> BlockHeight -> Bool
-checkFork p f v cid h = p h (getForkHeight f v cid)
+checkFork p f v cid h = p (ForkAtBlockHeight h) (getForkHeight f v cid)
+
+-- CheckFork by forkNumber
+checkFork'
+    :: (ForkHeight -> ForkHeight -> Bool)
+    -> Fork -> ChainwebVersion -> ChainId -> ForkNumber -> Bool
+checkFork' p f v cid fn = p (ForkAtForkNumber fn) (getForkHeight f v cid)
+
 
-after :: BlockHeight -> ForkHeight -> Bool
-after bh (ForkAtBlockHeight bh') = bh > bh'
-after _ ForkAtGenesis = True
-after _ ForkNever = False
+after :: ForkHeight -> ForkHeight -> Bool
+after = (>)
 
-atOrAfter :: BlockHeight -> ForkHeight -> Bool
-atOrAfter bh (ForkAtBlockHeight bh') = bh >= bh'
-atOrAfter _ ForkAtGenesis = True
-atOrAfter _ ForkNever = False
+atOrAfter :: ForkHeight -> ForkHeight -> Bool
+atOrAfter = (>=)
 
-before :: BlockHeight -> ForkHeight -> Bool
-before bh (ForkAtBlockHeight bh') = bh < bh'
-before _ ForkAtGenesis = False
-before _ ForkNever = True
+before :: ForkHeight -> ForkHeight -> Bool
+before = (<)
 
 -- Intended for forks that intend to run upgrades at exactly one height, and so
 -- can't be "pre-activated" for genesis.
-atNotGenesis :: BlockHeight -> ForkHeight -> Bool
-atNotGenesis bh (ForkAtBlockHeight bh') = bh == bh'
+atNotGenesis :: ForkHeight -> ForkHeight -> Bool
 atNotGenesis _ ForkAtGenesis = error "fork cannot be at genesis"
-atNotGenesis _ ForkNever = False
+atNotGenesis fh fh' = fh == fh'
 
 -- -------------------------------------------------------------------------- --
 -- Header Validation Guards
@@ -332,11 +337,11 @@ pact4ParserVersion v cid bh
 
 maxBlockGasLimit :: ChainwebVersion -> BlockHeight -> Maybe Natural
 maxBlockGasLimit v bh = snd $ ruleZipperHere $ snd
-    $ ruleSeek (\h _ -> bh >= h) (_versionMaxBlockGasLimit v)
+    $ ruleSeek (\h _ -> ForkAtBlockHeight bh >= h) (_versionMaxBlockGasLimit v)
 
 minimumBlockHeaderHistory :: ChainwebVersion -> BlockHeight -> Maybe Word64
 minimumBlockHeaderHistory v bh = snd $ ruleZipperHere $ snd
-    $ ruleSeek (\h _ -> bh >= h) (_versionSpvProofRootValidWindow v)
+    $ ruleSeek (\h _ -> ForkAtBlockHeight bh >= h) (_versionSpvProofRootValidWindow v)
 
 -- | Different versions of Chainweb allow different PPKSchemes.
 --

src/Chainweb/Version/Mainnet.hs

@@ -164,11 +164,11 @@ mainnet = ChainwebVersion
     , _versionWindow = WindowWidth 120
     , _versionHeaderBaseSizeBytes = 318 - 110
     , _versionMaxBlockGasLimit =
-        (succ $ mainnet ^?! versionForks . at Chainweb216Pact . _Just . atChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 180_000) `Above`
+        (succByHeight $ mainnet ^?! versionForks . at Chainweb216Pact . _Just . atChain (unsafeChainId 0), Just 180_000) `Above`
         Bottom (minBound, Nothing)
     , _versionSpvProofRootValidWindow =
-        (succ $ mainnet ^?! versionForks . at Chainweb31 . _Just . atChain (unsafeChainId 0) . _ForkAtBlockHeight, Nothing) `Above`
-        (succ $ mainnet ^?! versionForks . at Chainweb231Pact . _Just . atChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 20_000) `Above`
+        (succByHeight $ mainnet ^?! versionForks . at Chainweb31 . _Just . atChain (unsafeChainId 0), Nothing) `Above`
+        (succByHeight $ mainnet ^?! versionForks . at Chainweb231Pact . _Just . atChain (unsafeChainId 0) , Just 20_000) `Above`
         Bottom (minBound, Nothing)
     , _versionBootstraps = domainAddr2PeerInfo mainnetBootstrapHosts
     , _versionGenesis = VersionGenesis
@@ -223,7 +223,7 @@ mainnet = ChainwebVersion
         , _disableMempoolSync = False
         }
     , _versionVerifierPluginNames = AllChains $
-        (4_577_530, Set.fromList [VerifierName "hyperlane_v3_message"]) `Above`
+        (ForkAtBlockHeight $ BlockHeight 4_577_530, Set.fromList [VerifierName "hyperlane_v3_message"]) `Above`
         Bottom (minBound, mempty)
     , _versionQuirks = VersionQuirks
         { _quirkGasFees = onChains

src/Chainweb/Version/RecapDevelopment.hs

@@ -124,7 +124,7 @@ recapDevnet = ChainwebVersion
         , _disableMempoolSync = False
         }
     , _versionVerifierPluginNames = AllChains $
-        (600, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow", "signed_list"]) `Above`
+        (ForkAtBlockHeight $ BlockHeight 600, Set.fromList $ map VerifierName ["hyperlane_v3_message", "allow", "signed_list"]) `Above`
         Bottom (minBound, mempty)
     , _versionQuirks = noQuirks
     , _versionForkNumber = 0

src/Chainweb/Version/Testnet04.hs

@@ -144,10 +144,10 @@ testnet04 = ChainwebVersion
     , _versionWindow = WindowWidth 120
     , _versionHeaderBaseSizeBytes = 318 - 110
     , _versionMaxBlockGasLimit =
-        (succ $ testnet04 ^?! versionForks . at Chainweb216Pact . _Just . atChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 180_000) `Above`
+        (succByHeight $ testnet04 ^?! versionForks . at Chainweb216Pact . _Just . atChain (unsafeChainId 0) , Just 180_000) `Above`
         Bottom (minBound, Nothing)
     , _versionSpvProofRootValidWindow =
-        (succ $ testnet04 ^?! versionForks . at Chainweb231Pact . _Just . atChain (unsafeChainId 0) . _ForkAtBlockHeight, Just 20_000) `Above`
+        (succByHeight $ testnet04 ^?! versionForks . at Chainweb231Pact . _Just . atChain (unsafeChainId 0) , Just 20_000) `Above`
         Bottom (minBound, Nothing)
     , _versionBootstraps = domainAddr2PeerInfo testnet04BootstrapHosts
     , _versionGenesis = VersionGenesis
@@ -190,7 +190,7 @@ testnet04 = ChainwebVersion
         { _disablePeerValidation = False
         , _disableMempoolSync = False
         }
-    , _versionVerifierPluginNames = AllChains $ (4_100_681, Set.fromList [VerifierName "hyperlane_v3_message"]) `Above`
+    , _versionVerifierPluginNames = AllChains $ (ForkAtBlockHeight $ BlockHeight $ 4_100_681, Set.fromList [VerifierName "hyperlane_v3_message"]) `Above`
         Bottom (minBound, mempty)
     , _versionQuirks = VersionQuirks
         { _quirkGasFees = onChains

src/Chainweb/Version/Utils.hs

@@ -466,7 +466,7 @@ verifiersAt v cid bh =
         = snd
         $ ruleZipperHere
         $ snd
-        $ ruleSeek (\h _ -> bh >= h)
+        $ ruleSeek (\h _ -> ForkAtBlockHeight bh >= h)
         $ _versionVerifierPluginNames v ^?! atChain cid
 
 -- the mappings from names to verifier plugins is global. the list of verifier

test/lib/Chainweb/Test/TestVersions.hs

@@ -529,7 +529,7 @@ pact5InstantCpmTestVersionExpiryDisabled g = buildTestVersion $ \v -> v
             )
         )
     & versionSpvProofRootValidWindow .~
-        ( (BlockHeight 5, Nothing) `Above`
+        ( (ForkAtBlockHeight $ BlockHeight 5, Nothing) `Above`
             Bottom (minBound, Just 20)
         )