Extend ForkHeight to manage by ForkNumber

Author: kdafriend

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

@@ -322,10 +322,38 @@ 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 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
 
 newtype ChainwebVersionName =

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