Add Pact 5 gas quirks

We don't have a use for these yet, but this does establish the way they can work in future. Change-Id: Id0000000988f8d89c77367f877e8e103aa2dade6
kadena-io · Jan 7, 2025 · 31d2cff · 31d2cff
1 parent 95afc71
commit 31d2cff
Show file tree

Hide file tree

Showing 10 changed files with 223 additions and 33 deletions.
diff --git a/chainweb.cabal b/chainweb.cabal
@@ -143,6 +143,8 @@ library
         , Chainweb.BlockHeader.Genesis.InstantTimedCPM1to9Payload
         , Chainweb.BlockHeader.Genesis.Pact5InstantTimedCPM0Payload
         , Chainweb.BlockHeader.Genesis.Pact5InstantTimedCPM1to9Payload
+        , Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM0Payload
+        , Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM1to9Payload
         , Chainweb.BlockHeader.Genesis.Pact5Development0Payload
         , Chainweb.BlockHeader.Genesis.Pact5Development1to19Payload
         , Chainweb.BlockHeader.Genesis.Testnet040Payload

diff --git a/cwtools/ea/Ea.hs b/cwtools/ea/Ea.hs
@@ -84,6 +84,7 @@ main = do
       , fastnet
       , instantnet
       , pact5Instantnet
+      , quirkedPact5Instantnet
       , testnet04
       , testnet05
       , mainnet
@@ -111,6 +112,7 @@ main = do
     fastnet = mkPayloads [fastTimedCPM0, fastTimedCPMN]
     instantnet = mkPayloads [instantCPM0, instantCPMN]
     pact5Instantnet = mkPayloads [pact5InstantCPM0, pact5InstantCPMN]
+    quirkedPact5Instantnet = mkPayloads [quirkedPact5InstantCPM0, quirkedPact5InstantCPMN]
     testnet04 = mkPayloads [testnet040, testnet04N]
     testnet05 = mkPayloads [testnet050, testnet05N]
     mainnet = mkPayloads

diff --git a/cwtools/ea/Ea/Genesis.hs b/cwtools/ea/Ea/Genesis.hs
@@ -28,6 +28,8 @@ module Ea.Genesis
 , instantCPMN
 , pact5InstantCPM0
 , pact5InstantCPMN
+, quirkedPact5InstantCPM0
+, quirkedPact5InstantCPMN
 
   -- * Testnet Genesis txs
 , testnet040
@@ -290,6 +292,23 @@ pact5InstantCPMN = pact5InstantCPM0
   & txChainIds .~ mkChainIdRange 1 9
   & coinbase ?~ fastNGrants
 
+quirkedPact5InstantCPM0 :: Genesis
+quirkedPact5InstantCPM0 = Genesis
+    { _version = quirkedGasPact5InstantCpmTestVersion petersonChainGraph
+    , _tag = "QuirkedGasPact5InstantTimedCPM"
+    , _txChainIds = onlyChainId 0
+    , _coinbase = Just fast0Grants
+    , _keysets = Just fastKeysets
+    , _allocations = Just fastAllocations
+    , _namespaces = Just devNs2
+    , _coinContract = [fungibleAssetV1, fungibleXChainV1, fungibleAssetV2, installCoinContractV6, gasPayer]
+    }
+
+quirkedPact5InstantCPMN :: Genesis
+quirkedPact5InstantCPMN = quirkedPact5InstantCPM0
+  & txChainIds .~ mkChainIdRange 1 9
+  & coinbase ?~ fastNGrants
+
 fastTimedCPM0 :: Genesis
 fastTimedCPM0 = Genesis
     { _version = fastForkingCpmTestVersion petersonChainGraph

diff --git a/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM0Payload.hs b/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM0Payload.hs
diff --git a/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM1to9Payload.hs b/src/Chainweb/BlockHeader/Genesis/QuirkedGasPact5InstantTimedCPM1to9Payload.hs
diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs
@@ -866,7 +866,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
                                         Pact5.pactTransaction Nothing (\dbEnv ->
                                             Pact5.applyCmd
                                                 _psLogger _psGasLogger dbEnv
-                                                txCtx spvSupport initialGas (view Pact5.payloadObj <$> pact5Cmd)
+                                                txCtx (TxBlockIdx 0) spvSupport initialGas (view Pact5.payloadObj <$> pact5Cmd)
                                                 ) >>= \case
                                             Left err ->
                                                 return $ LocalPact5PreflightResult Pact5.CommandResult

diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs
@@ -12,6 +12,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Chainweb.Pact.PactService.Pact5.ExecBlock
     ( runCoinbase
@@ -280,7 +281,7 @@ continueBlock mpAccess blockInProgress = do
         isGenesis <- view psIsGenesis
         ((txResults, timedOut), (finalBlockHandle, Identity finalRemainingGas)) <-
           liftIO $ flip runStateT (startBlockHandle, Identity p5RemainingGas) $ foldr
-            (\tx rest -> StateT $ \s -> do
+            (\(txIdxInBlock, tx) rest -> StateT $ \s -> do
               let logger = addLabel ("transactionHash", sshow (Pact5._cmdHash tx)) logger'
               let env' = env & psServiceEnv . psLogger .~ logger
               let timeoutFunc runTx =
@@ -291,7 +292,7 @@ continueBlock mpAccess blockInProgress = do
                     else
                       newTimeout (fromIntegral @Micros @Int timeLimit) runTx
               m <- liftIO $ timeoutFunc
-                $ runExceptT $ runStateT (applyPactCmd env' miner tx) s
+                $ runExceptT $ runStateT (applyPactCmd env' miner (TxBlockIdx txIdxInBlock) tx) s
               case m of
                 Nothing -> do
                   logFunctionJson logger Warn $ Aeson.object
@@ -313,7 +314,7 @@ continueBlock mpAccess blockInProgress = do
                   return ((Right (tx, a):as, timedOut), s'')
               )
               (return ([], False))
-              txs
+              (zip [0..] (V.toList txs))
         pbBlockHandle .= finalBlockHandle
         let (invalidTxHashes, completedTxs) = partitionEithers txResults
         let p4FinalRemainingGas = fromIntegral @Pact5.SatWord @Pact4.GasLimit $ finalRemainingGas ^. Pact5._GasLimit . to Pact5._gas
@@ -344,12 +345,12 @@ type InvalidTransactions = [Pact5.RequestKey]
 applyPactCmd
   :: (Traversable t, Logger logger)
   => PactBlockEnv logger Pact5 tbl
-  -> Miner -> Pact5.Transaction
+  -> Miner -> TxIdxInBlock -> Pact5.Transaction
   -> StateT
     (BlockHandle, t P.GasLimit)
     (ExceptT Pact5GasPurchaseFailure IO)
     (Pact5.CommandResult [Pact5.TxLog ByteString] (Pact5.PactError Pact5.Info))
-applyPactCmd env miner tx = StateT $ \(blockHandle, blockGasRemaining) -> do
+applyPactCmd env miner txIdxInBlock tx = StateT $ \(blockHandle, blockGasRemaining) -> do
   -- we set the command gas limit to the minimum of its original value and the remaining gas in the block
   -- this way Pact never uses more gas than remains in the block, and the tx fails otherwise
   let alteredTx = (view payloadObj <$> tx) & Pact5.cmdPayload . Pact5.pMeta . pmGasLimit %~ maybe id min (blockGasRemaining ^? traversed)
@@ -418,7 +419,7 @@ applyPactCmd env miner tx = StateT $ \(blockHandle, blockGasRemaining) -> do
               -- pretend that genesis commands can throw non-fatal errors,
               -- to make types line up
               Right res -> return (Right (absurd <$> res))
-          else applyCmd logger gasLogger pactDb txCtx spv initialGas cmd
+          else applyCmd logger gasLogger pactDb txCtx txIdxInBlock spv initialGas cmd
     liftIO $ case resultOrError of
       -- unknown exceptions are logged specially, because they indicate bugs in Pact or chainweb
       Right
@@ -601,12 +602,12 @@ execExistingBlock currHeader payload = do
         Pact5.GasLimit . Pact5.Gas . fromIntegral <$> maxBlockGasLimit v (view blockHeight currHeader)
 
   env <- ask
-  (results, (finalHandle, _finalBlockGasLimit)) <-
+  (V.fromList -> results, (finalHandle, _finalBlockGasLimit)) <-
     liftIO $ flip runStateT (postCoinbaseBlockHandle, blockGasLimit) $
-      forM txs $ \tx ->
+      forM (zip [0..] (V.toList txs)) $ \(txIdxInBlock, tx) ->
         (tx,) <$> mapStateT
           (either (throwM . Pact5BuyGasFailure) return <=< runExceptT)
-          (applyPactCmd env miner tx)
+          (applyPactCmd env miner (TxBlockIdx txIdxInBlock) tx)
   -- incorporate the final state of the transactions into the block state
   pbBlockHandle .= finalHandle
 

diff --git a/src/Chainweb/Pact5/TransactionExec.hs b/src/Chainweb/Pact5/TransactionExec.hs
@@ -245,7 +245,9 @@ applyLocal logger maybeGasLogger coreDb txCtx spvSupport cmd = do
   let
     gasLimitGas :: Gas = cmd ^. cmdPayload . pMeta . pmGasLimit . _GasLimit
   gasEnv <- mkTableGasEnv (MilliGasLimit (gasToMilliGas gasLimitGas)) gasLogsEnabled
-  let runLocal = runVerifiers txCtx cmd *> runPayload Local localFlags coreDb spvSupport [] managedNamespacePolicy gasEnv txCtx cmd
+  let runLocal = do
+        runVerifiers txCtx cmd
+        runPayload Local localFlags coreDb spvSupport [] managedNamespacePolicy gasEnv txCtx (TxBlockIdx 0) cmd
   let txEnv = TransactionEnv
         { _txEnvGasEnv = gasEnv
         , _txEnvLogger = logger
@@ -309,14 +311,15 @@ applyCmd
       -- ^ Pact db environment
     -> TxContext
       -- ^ tx metadata
+    -> TxIdxInBlock
     -> SPVSupport
       -- ^ SPV support (validates cont proofs)
     -> Gas
       -- ^ initial gas cost
     -> Command (Payload PublicMeta ParsedCode)
       -- ^ command with payload to execute
     -> IO (Either Pact5GasPurchaseFailure (CommandResult [TxLog ByteString] (Pact5.PactError Info)))
-applyCmd logger maybeGasLogger db txCtx spv initialGas cmd = do
+applyCmd logger maybeGasLogger db txCtx txIdxInBlock spv initialGas cmd = do
   logDebug_ logger $ "applyCmd: " <> sshow (_cmdHash cmd)
   let flags = Set.fromList
         [ FlagDisableRuntimeRTC
@@ -340,7 +343,7 @@ applyCmd logger maybeGasLogger db txCtx spv initialGas cmd = do
         runVerifiers txCtx cmd
 
         liftIO $ dumpGasLogs "applyCmd.paidFor.beforeRunPayload" (_cmdHash cmd) maybeGasLogger gasEnv
-        evalResult <- runPayload Transactional flags db spv [] managedNamespacePolicy gasEnv txCtx cmd
+        evalResult <- runPayload Transactional flags db spv [] managedNamespacePolicy gasEnv txCtx txIdxInBlock cmd
         liftIO $ dumpGasLogs "applyCmd.paidFor.afterRunPayload" (_cmdHash cmd) maybeGasLogger gasEnv
         return evalResult
 
@@ -561,6 +564,7 @@ runGenesisPayload logger db spv ctx cmd = do
           SimpleNamespacePolicy
           freeGasEnv
           ctx
+          (TxBlockIdx 0)
           cmd <&> \evalResult ->
             CommandResult
               { _crReqKey = RequestKey (_cmdHash cmd)
@@ -586,19 +590,20 @@ runPayload
     -> NamespacePolicy
     -> GasEnv CoreBuiltin Info
     -> TxContext
+    -> TxIdxInBlock
     -> Command (Payload PublicMeta ParsedCode)
     -> TransactionM logger EvalResult
-runPayload execMode execFlags db spv specialCaps namespacePolicy gasModel txCtx cmd = do
+runPayload execMode execFlags db spv specialCaps namespacePolicy gasEnv txCtx txIdxInBlock cmd = do
     -- Note [Throw out verifier proofs eagerly]
   let !verifiersWithNoProof =
           (fmap . fmap) (\_ -> ()) verifiers
           `using` (traverse . traverse) rseq
 
-  (either throwError return =<<) $ liftIO $
+  result <- (either throwError return =<<) $ liftIO $
     case payload ^. pPayload of
       Exec ExecMsg {..} ->
         evalExec (RawCode (_pcCode _pmCode)) execMode
-          db spv gasModel execFlags namespacePolicy
+          db spv gasEnv execFlags namespacePolicy
           (ctxToPublicData publicMeta txCtx)
           MsgData
             { mdHash = _cmdHash cmd
@@ -613,7 +618,7 @@ runPayload execMode execFlags db spv specialCaps namespacePolicy gasModel txCtx
           (_pcExps _pmCode)
       Continuation ContMsg {..} ->
         evalContinuation execMode
-          db spv gasModel execFlags namespacePolicy
+          db spv gasEnv execFlags namespacePolicy
           (ctxToPublicData publicMeta txCtx)
           MsgData
             { mdHash = _cmdHash cmd
@@ -629,12 +634,22 @@ runPayload execMode execFlags db spv specialCaps namespacePolicy gasModel txCtx
               , _cRollback = _cmRollback
               , _cProof = _cmProof
               }
+
+  case maybeQuirkGasFee of
+    Nothing -> return result
+    Just quirkGasFee -> do
+      let convertedQuirkGasFee = Gas $ fromIntegral quirkGasFee
+      liftIO $ writeIORef (_geGasRef gasEnv) $ gasToMilliGas convertedQuirkGasFee
+      return result { _erGas = convertedQuirkGasFee }
+
   where
     payload = cmd ^. cmdPayload
     verifiers = payload ^. pVerifiers . _Just
     signers = payload ^. pSigners
-    -- chash = toUntypedHash $ _cmdHash cmd
     publicMeta = cmd ^. cmdPayload . pMeta
+    v = _chainwebVersion txCtx
+    cid = _chainId txCtx
+    maybeQuirkGasFee = v ^? versionQuirks . quirkGasFees . ixg cid . ix (ctxCurrentBlockHeight txCtx, txIdxInBlock)
 
 runUpgrade
     :: (Logger logger)

diff --git a/test/lib/Chainweb/Test/TestVersions.hs b/test/lib/Chainweb/Test/TestVersions.hs
@@ -13,6 +13,7 @@ module Chainweb.Test.TestVersions
     , noBridgeCpmTestVersion
     , slowForkingCpmTestVersion
     , quirkedGasInstantCpmTestVersion
+    , quirkedGasPact5InstantCpmTestVersion
     , timedConsensusVersion
     , instantCpmTestVersion
     , pact5InstantCpmTestVersion
@@ -32,6 +33,8 @@ import qualified Chainweb.BlockHeader.Genesis.InstantTimedCPM0Payload as IN0
 import qualified Chainweb.BlockHeader.Genesis.InstantTimedCPM1to9Payload as INN
 import qualified Chainweb.BlockHeader.Genesis.Pact5InstantTimedCPM0Payload as PIN0
 import qualified Chainweb.BlockHeader.Genesis.Pact5InstantTimedCPM1to9Payload as PINN
+import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM0Payload as QPIN0
+import qualified Chainweb.BlockHeader.Genesis.QuirkedGasPact5InstantTimedCPM1to9Payload as QPINN
 
 import System.IO.Unsafe
 
@@ -118,6 +121,9 @@ testVersions = _versionName <$> concat
     , [ quirkedGasInstantCpmTestVersion (knownChainGraph g)
       | g :: KnownGraph <- [minBound..maxBound]
       ]
+    , [ quirkedGasPact5InstantCpmTestVersion (knownChainGraph g)
+      | g :: KnownGraph <- [minBound..maxBound]
+      ]
     , [ instantCpmTestVersion (knownChainGraph g)
       | g :: KnownGraph <- [minBound..maxBound]
       ]
@@ -144,7 +150,6 @@ testVersionTemplate v = v
     & versionMaxBlockGasLimit .~ Bottom (minBound, Just 2_000_000)
     & versionBootstraps .~ [testBootstrapPeerInfos]
     & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty))
-    & versionQuirks .~ noQuirks
     & versionServiceDate .~ Nothing
 
 -- | A test version without Pact or PoW, with only one chain graph.
@@ -170,6 +175,7 @@ barebonesTestVersion g = buildTestVersion $ \v ->
             , _genesisTime = AllChains $ BlockCreationTime epoch
             }
         & versionForks .~ HM.fromList [ (f, AllChains ForkAtGenesis) | f <- [minBound..maxBound] ]
+        & versionQuirks .~ noQuirks
         & versionUpgrades .~ AllChains HM.empty
 
 -- | A test version without Pact or PoW, with a chain graph upgrade at block height 8.
@@ -184,6 +190,7 @@ timedConsensusVersion g1 g2 = buildTestVersion $ \v -> v
         -- pact is disabled, we don't care about pact forks
         _ -> AllChains ForkAtGenesis
     )
+    & versionQuirks .~ noQuirks
     & versionUpgrades .~ AllChains HM.empty
     & versionGraphs .~ (BlockHeight 8, g2) `Above` Bottom (minBound, g1)
     & versionCheats .~ VersionCheats
@@ -215,6 +222,7 @@ pact5CheckpointerTestVersion g1 = buildTestVersion $ \v -> v
         -- pact is disabled, we don't care about pact forks
         _ -> AllChains ForkAtGenesis
     )
+    & versionQuirks .~ noQuirks
     & versionUpgrades .~ AllChains HM.empty
     & versionGraphs .~ Bottom (minBound, g1)
     & versionCheats .~ VersionCheats
@@ -346,6 +354,7 @@ slowForkingCpmTestVersion g = buildTestVersion $ \v -> v
     & versionForks .~ slowForks
     & versionVerifierPluginNames .~ AllChains
         (Bottom (minBound, Set.fromList $ map VerifierName ["allow", "hyperlane_v3_announcement", "hyperlane_v3_message"]))
+    & versionQuirks .~ noQuirks
 
 -- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled,
 -- and with a gas fee quirk.
@@ -356,8 +365,10 @@ quirkedGasInstantCpmTestVersion g = buildTestVersion $ \v -> v
     & versionForks .~ tabulateHashMap (\case
         Pact5Fork -> AllChains ForkNever
         _ -> AllChains ForkAtGenesis)
-    & versionQuirks .~
-        VersionQuirks { _quirkGasFees = onChain (unsafeChainId 0) $ HM.singleton (BlockHeight 2, TxBlockIdx 0) (P.Gas 1) }
+    & versionQuirks .~ VersionQuirks
+        { _quirkGasFees = onChain (unsafeChainId 0)
+            $ HM.singleton (BlockHeight 2, TxBlockIdx 0) (P.Gas 1)
+        }
     & versionGenesis .~ VersionGenesis
         { _genesisBlockPayload = onChains $
             (unsafeChainId 0, IN0.payloadBlock) :
@@ -368,12 +379,35 @@ quirkedGasInstantCpmTestVersion g = buildTestVersion $ \v -> v
     & versionUpgrades .~ AllChains mempty
     & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty))
 
+-- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled,
+-- and with a gas fee quirk.
+quirkedGasPact5InstantCpmTestVersion :: ChainGraph -> ChainwebVersion
+quirkedGasPact5InstantCpmTestVersion g = buildTestVersion $ \v -> v
+    & cpmTestVersion g
+    & versionName .~ ChainwebVersionName ("quirked-pact5-instant-CPM-" <> toText g)
+    & versionForks .~ tabulateHashMap (\case
+        _ -> AllChains ForkAtGenesis)
+    & versionQuirks .~ VersionQuirks
+        { _quirkGasFees = onChain (unsafeChainId 0)
+            $ HM.singleton (BlockHeight 1, TxBlockIdx 0) (P.Gas 1)
+        }
+    & versionGenesis .~ VersionGenesis
+        { _genesisBlockPayload = onChains $
+            (unsafeChainId 0, QPIN0.payloadBlock) :
+            [(n, QPINN.payloadBlock) | n <- HS.toList (unsafeChainId 0 `HS.delete` graphChainIds g)]
+        , _genesisBlockTarget = AllChains maxTarget
+        , _genesisTime = AllChains $ BlockCreationTime epoch
+        }
+    & versionUpgrades .~ AllChains mempty
+    & versionVerifierPluginNames .~ AllChains (Bottom (minBound, mempty))
+
 -- | CPM version (see `cpmTestVersion`) with forks and upgrades quickly enabled.
 fastForkingCpmTestVersion :: ChainGraph -> ChainwebVersion
 fastForkingCpmTestVersion g = buildTestVersion $ \v -> v
     & cpmTestVersion g
     & versionName .~ ChainwebVersionName ("fastfork-CPM-" <> toText g)
     & versionForks .~ fastForks
+    & versionQuirks .~ noQuirks
 
 -- | CPM version (see `cpmTestVersion`) with forks and upgrades quickly enabled
 -- but with no SPV bridge.
@@ -382,6 +416,7 @@ noBridgeCpmTestVersion g = buildTestVersion $ \v -> v
     & cpmTestVersion g
     & versionName .~ ChainwebVersionName ("nobridge-CPM-" <> toText g)
     & versionForks .~ (fastForks & at SPVBridge ?~ AllChains ForkNever)
+    & versionQuirks .~ noQuirks
 
 -- | CPM version (see `cpmTestVersion`) with forks and upgrades instantly enabled
 -- at genesis EXCEPT Pact 5.
@@ -394,6 +429,7 @@ instantCpmTestVersion g = buildTestVersion $ \v -> v
         Pact5Fork -> AllChains ForkNever
         _ -> AllChains ForkAtGenesis
         )
+    & versionQuirks .~ noQuirks
     & versionGenesis .~ VersionGenesis
         { _genesisBlockPayload = onChains $
             (unsafeChainId 0, IN0.payloadBlock) :
@@ -418,6 +454,7 @@ pact5InstantCpmTestVersion g = buildTestVersion $ \v -> v
         SPVBridge -> AllChains ForkNever
         _ -> AllChains ForkAtGenesis
         )
+    & versionQuirks .~ noQuirks
     & versionGenesis .~ VersionGenesis
         { _genesisBlockPayload = onChains $
             (unsafeChainId 0, PIN0.payloadBlock) :
@@ -447,6 +484,7 @@ pact5SlowCpmTestVersion g = buildTestVersion $ \v -> v
         SPVBridge -> AllChains ForkNever
         _ -> AllChains ForkAtGenesis
         )
+    & versionQuirks .~ noQuirks
     & versionGenesis .~ VersionGenesis
         { _genesisBlockPayload = onChains $
             (unsafeChainId 0, IN0.payloadBlock) :