add quirks to apply in ChainwebVersion

Change-Id: I42f6687e298c61b7c01632c7e2db0a0b0881090f

src/Chainweb/Pact/PactService.hs

@@ -992,7 +992,7 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do
                   [ P.FlagDisableModuleInstall
                   , P.FlagDisableHistoryInTransactionalMode ] ++
                   disableReturnRTC (_chainwebVersion pd) (_chainId pd) (ctxCurrentBlockHeight pd)
-            return $! TransactionEnv P.Transactional (_cpPactDbEnv dbEnv) l Nothing (ctxToPublicData pd) spv nid gp rk gl ec
+            return $! TransactionEnv P.Transactional (_cpPactDbEnv dbEnv) l Nothing (ctxToPublicData pd) spv nid gp rk gl ec Nothing
           where
             !nid = networkIdOf cmd
             !rk = P.cmdToRequestKey cmd

src/Chainweb/Pact/TransactionExec.hs

@@ -197,6 +197,7 @@ applyCmd v logger gasLogger pdbenv miner gasModel txCtx spv cmd initialGas mcach
       | chainweb217Pact' = gasModel
       | otherwise = _geGasModel freeGasEnv
     txst = TransactionState mcache0 mempty 0 Nothing stGasModel mempty
+    quirkGasFee = v ^? versionQuirks . quirkGasFees . ix requestKey
 
     executionConfigNoHistory = ExecutionConfig
       $ S.singleton FlagDisableHistoryInTransactionalMode
@@ -207,7 +208,7 @@ applyCmd v logger gasLogger pdbenv miner gasModel txCtx spv cmd initialGas mcach
       <> flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)
 
     cenv = TransactionEnv Transactional pdbenv logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice
-      requestKey (fromIntegral gasLimit) executionConfigNoHistory
+      requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee
 
     !requestKey = cmdToRequestKey cmd
     !gasPrice = view cmdGasPrice cmd
@@ -350,6 +351,7 @@ applyGenesisCmd logger dbEnv spv txCtx cmd =
           -- stuff so that we retain this power in genesis and upgrade txs even
           -- after the block height where pact4.4 is on.
           <> S.fromList [ FlagDisableInlineMemCheck, FlagDisablePact44 ]
+        , _txQuirkGasFee = Nothing
         }
     txst = TransactionState
         { _txCache = mempty
@@ -435,7 +437,7 @@ applyCoinbase v logger dbEnv (Miner mid mks@(MinerKeys mk)) reward@(ParsedDecima
       , flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)
       ]
     tenv = TransactionEnv Transactional dbEnv logger Nothing (ctxToPublicData txCtx) noSPVSupport
-           Nothing 0.0 rk 0 ec
+           Nothing 0.0 rk 0 ec Nothing
     txst = TransactionState mc mempty 0 Nothing (_geGasModel freeGasEnv) mempty
     initState = setModuleCache mc $ initCapabilities [magic_COINBASE]
     rk = RequestKey chash
@@ -503,7 +505,7 @@ applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig =
     !gasPrice = view cmdGasPrice cmd
     !gasLimit = view cmdGasLimit cmd
     tenv = TransactionEnv Local dbEnv logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice
-           rk (fromIntegral gasLimit) execConfig
+           rk (fromIntegral gasLimit) execConfig Nothing
     txst = TransactionState mc mempty 0 Nothing gasModel mempty
     gas0 = initialGasOf (_cmdPayload cmdIn)
     cid = V._chainId txCtx
@@ -571,7 +573,7 @@ readInitModules logger dbEnv txCtx
     nid = Nothing
     chash = pactInitialHash
     tenv = TransactionEnv Local dbEnv logger Nothing (ctxToPublicData txCtx) noSPVSupport nid 0.0
-           rk 0 def
+           rk 0 def Nothing
     txst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty
     interp = defaultInterpreter
     die msg = throwM $ PactInternalError $ "readInitModules: " <> msg
@@ -799,16 +801,22 @@ applyExec' initialGas interp (ExecMsg parsedCode execData) senderSigs verifiersW
 
       setEnvGas initialGas eenv
 
-      er <- liftIO $! evalExec interp eenv parsedCode
+      evalResult <- liftIO $! evalExec interp eenv parsedCode
+      -- if we specified this transaction's gas fee manually as a "quirk",
+      -- here we set the result's gas fee to agree with that
+      quirkGasFee <- view txQuirkGasFee
+      let quirkedEvalResult = case quirkGasFee of
+            Nothing -> evalResult
+            Just fee -> evalResult { _erGas = fee }
 
-      for_ (_erExec er) $ \pe -> debug
+      for_ (_erExec quirkedEvalResult) $ \pe -> debug
         $ "applyExec: new pact added: "
         <> sshow (_pePactId pe, _peStep pe, _peYield pe, _peExecuted pe)
 
       -- set log + cache updates + used gas
-      setTxResultState er
+      setTxResultState quirkedEvalResult
 
-      return er
+      return quirkedEvalResult
 
 enablePactEvents' :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag]
 enablePactEvents' v cid bh = [FlagDisablePactEvents | not (enablePactEvents v cid bh)]
@@ -907,11 +915,17 @@ applyContinuation' initialGas interp cm@(ContMsg pid s rb d _) senderSigs hsh ns
 
     setEnvGas initialGas eenv
 
-    er <- liftIO $! evalContinuation interp eenv cm
+    evalResult <- liftIO $! evalContinuation interp eenv cm
+    -- if we specified this transaction's gas fee manually as a "quirk",
+    -- here we set the result's gas fee to agree with that
+    quirkGasFee <- view txQuirkGasFee
+    let quirkedEvalResult = case quirkGasFee of
+          Nothing -> evalResult
+          Just fee -> evalResult { _erGas = fee }
 
-    setTxResultState er
+    setTxResultState quirkedEvalResult
 
-    return er
+    return quirkedEvalResult
   where
     pactStep = Just $ PactStep s rb pid Nothing
 
@@ -946,8 +960,10 @@ buyGas isPactBackCompatV16 cmd (Miner mid mks) = go
             put (initState mc logGas) >> run (pure <$> eval buyGasTerm)
 
       -- no verifiers are allowed in buy gas
-      result <- applyExec' 0 (interp mcache) buyGasCmd
-        (_pSigners $ _cmdPayload cmd) [] bgHash managedNamespacePolicy
+      -- quirked gas is not used either
+      result <- locally txQuirkGasFee (const Nothing) $
+        applyExec' 0 (interp mcache) buyGasCmd
+          (_pSigners $ _cmdPayload cmd) [] bgHash managedNamespacePolicy
 
       case _erExec result of
         Nothing ->
@@ -1030,9 +1046,10 @@ redeemGas cmd = do
 
     fee <- gasSupplyOf <$> use txGasUsed <*> view txGasPrice
 
-    _crEvents <$> applyContinuation 0 (initState mcache) (redeemGasCmd fee gid)
-      (_pSigners $ _cmdPayload cmd) (toUntypedHash $ _cmdHash cmd)
-      managedNamespacePolicy
+    fmap _crEvents $ locally txQuirkGasFee (const Nothing) $
+      applyContinuation 0 (initState mcache) (redeemGasCmd fee gid)
+        (_pSigners $ _cmdPayload cmd) (toUntypedHash $ _cmdHash cmd)
+        managedNamespacePolicy
 
   where
     initState mc = initStateInterpreter

src/Chainweb/Pact/Types.hs

@@ -62,6 +62,7 @@ module Chainweb.Pact.Types
   , txGasPrice
   , txRequestKey
   , txExecutionConfig
+  , txQuirkGasFee
 
     -- * Transaction Execution Monad
   , TransactionM(..)
@@ -335,6 +336,7 @@ data TransactionEnv logger db = TransactionEnv
     , _txRequestKey :: !RequestKey
     , _txGasLimit :: !Gas
     , _txExecutionConfig :: !ExecutionConfig
+    , _txQuirkGasFee :: !(Maybe Gas)
     }
 makeLenses ''TransactionEnv
 

src/Chainweb/Version.hs

@@ -50,6 +50,9 @@ module Chainweb.Version
     , ChainwebVersion(..)
     , Upgrade(..)
     , upgrade
+    , VersionQuirks(..)
+    , noQuirks
+    , quirkGasFees
     , versionForks
     , versionBlockDelay
     , versionCheats
@@ -64,6 +67,7 @@ module Chainweb.Version
     , versionWindow
     , versionGenesis
     , versionVerifierPluginNames
+    , versionQuirks
     , genesisBlockPayload
     , genesisBlockPayloadHash
     , genesisBlockTarget
@@ -144,6 +148,9 @@ import GHC.TypeLits
 
 -- internal modules
 
+import Pact.Types.Command (RequestKey)
+import Pact.Types.Runtime (Gas)
+
 import Chainweb.BlockCreationTime
 import Chainweb.BlockHeight
 import Chainweb.ChainId
@@ -321,6 +328,24 @@ data Upgrade = Upgrade
 upgrade :: [ChainwebTransaction] -> Upgrade
 upgrade txs = Upgrade txs False
 
+-- The type of quirks, i.e. special validation behaviors that are in some
+-- sense one-offs which can't be expressed as upgrade transactions and must be
+-- preserved.
+data VersionQuirks = VersionQuirks
+    { _quirkGasFees :: !(HashMap RequestKey Gas)
+      -- ^ Gas fee to charge at particular 'RequestKey's.
+      --   This should be 'MilliGas' once 'applyCmd' is refactored
+      --   to use 'MilliGas' instead of 'Gas'.
+      --   Note: only works for user txs in blocks right now.
+    }
+    deriving stock (Show, Eq, Ord, Generic)
+    deriving anyclass (NFData)
+
+noQuirks :: VersionQuirks
+noQuirks = VersionQuirks
+    { _quirkGasFees = HM.empty
+    }
+
 -- | Chainweb versions are sets of properties that must remain consistent among
 -- all nodes on the same network. For examples see `Chainweb.Version.Mainnet`,
 -- `Chainweb.Version.Testnet`, `Chainweb.Version.RecapDevelopment`, and
@@ -374,6 +399,8 @@ data ChainwebVersion
         -- ^ Version-specific defaults that can be overridden elsewhere.
     , _versionVerifierPluginNames :: ChainMap (Rule BlockHeight (Set VerifierName))
         -- ^ Verifier plugins that can be run to verify transaction contents.
+    , _versionQuirks :: VersionQuirks
+        -- ^ Modifications to behavior at particular blockheights
     }
     deriving stock (Generic)
     deriving anyclass NFData
@@ -442,6 +469,7 @@ makeLensesWith (lensRules & generateLazyPatterns .~ True) 'ChainwebVersion
 makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionGenesis
 makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionCheats
 makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionDefaults
+makeLensesWith (lensRules & generateLazyPatterns .~ True) 'VersionQuirks
 
 genesisBlockPayloadHash :: ChainwebVersion -> ChainId -> BlockPayloadHash
 genesisBlockPayloadHash v cid = v ^?! versionGenesis . genesisBlockPayload . onChain cid . to _payloadWithOutputsPayloadHash

src/Chainweb/Version/Development.hs

@@ -60,4 +60,5 @@ devnet = ChainwebVersion
         , _disableMempoolSync = False
         }
     , _versionVerifierPluginNames = AllChains $ (End $ Set.fromList $ map VerifierName ["hyperlane_v3_message"])
+    , _versionQuirks = noQuirks
     }

src/Chainweb/Version/Guards.hs

@@ -175,8 +175,8 @@ pactBackCompat_v16 :: ChainwebVersion -> ChainId -> BlockHeight -> Bool
 pactBackCompat_v16 = checkFork before PactBackCompat_v16
 
 -- | Early versions of chainweb used the creation time of the current header
--- for validation of pact tx creation time and TTL. Nowadays the times of
--- the parent header a used.
+-- for validation of pact tx creation time and TTL. Nowadays the time of
+-- the parent header is used.
 --
 -- When this guard is enabled timing validation is skipped.
 --

src/Chainweb/Version/Mainnet.hs

@@ -22,6 +22,7 @@ import Chainweb.Utils.Rule
 import Chainweb.Version
 import P2P.BootstrapNodes
 
+import Pact.Types.Runtime (Gas(..))
 import Pact.Types.Verifier
 
 import qualified Chainweb.BlockHeader.Genesis.Mainnet0Payload as MN0
@@ -211,4 +212,9 @@ mainnet = ChainwebVersion
         }
     , _versionVerifierPluginNames = AllChains $ (4_577_530, Set.fromList $ map VerifierName ["hyperlane_v3_message"]) `Above`
         End mempty
+    , _versionQuirks = VersionQuirks
+        { _quirkGasFees = HM.fromList
+            [ (fromJuste (decodeStrictOrThrow' "\"s9fUspNaCHoV4rNI-Tw-JYU1DxqZAOXS-80oEy7Zfbo\""), Gas 67618)
+            ]
+        }
     }

src/Chainweb/Version/RecapDevelopment.hs

@@ -117,4 +117,5 @@ recapDevnet = ChainwebVersion
         }
     , _versionVerifierPluginNames = AllChains $ (600, Set.fromList $ map VerifierName ["hyperlane_v3_message"]) `Above`
         End mempty
+    , _versionQuirks = noQuirks
     }

src/Chainweb/Version/Registry.hs

@@ -13,8 +13,12 @@
 -- the devnet version, so we maintain a mutable registry mapping codes to
 -- versions in this module.
 --
+-- Be careful in this module. We hope to be able to delete it eventually,
+-- because it works badly with tests.
+--
 module Chainweb.Version.Registry
     ( registerVersion
+    , unregisterVersion
     , lookupVersionByCode
     , lookupVersionByName
     , fabricateVersionWithName
@@ -64,6 +68,13 @@ registerVersion v = do
             Nothing ->
                 (HM.insert (_versionCode v) v m, ())
 
+-- | Unregister a version from the registry. This is ONLY for testing versions.
+unregisterVersion :: HasCallStack => ChainwebVersion -> IO ()
+unregisterVersion v = do
+    if elem (_versionCode v) (_versionCode <$> [mainnet, testnet])
+    then error "You cannot unregister mainnet or testnet versions"
+    else atomicModifyIORef' versionMap $ \m -> (HM.delete (_versionCode v) m, ())
+
 validateVersion :: HasCallStack => ChainwebVersion -> IO ()
 validateVersion v = do
     evaluate (rnf v)
@@ -111,7 +122,7 @@ lookupVersionByCode code
     notRegistered
       | code == _versionCode recapDevnet = "recapDevnet version used but not registered, remember to do so after it's configured"
       | code == _versionCode devnet = "devnet version used but not registered, remember to do so after it's configured"
-      | otherwise = "version not registered with code " <> show code <> ", have you seen Chainweb.Test.TestVersions.legalizeTestVersion?"
+      | otherwise = "version not registered with code " <> show code <> ", have you seen Chainweb.Test.TestVersions.testVersions?"
 
 -- TODO: ideally all uses of this are deprecated. currently in use in
 -- ObjectEncoded block header decoder and CutHashes decoder.
@@ -127,7 +138,7 @@ lookupVersionByName name
             listToMaybe [ v | v <- HM.elems m, _versionName v == name ]
     notRegistered
       | name == _versionName recapDevnet = "recapDevnet version used but not registered, remember to do so after it's configured"
-      | otherwise = "version not registered with name " <> show name <> ", have you seen Chainweb.Test.TestVersions.legalizeTestVersion?"
+      | otherwise = "version not registered with name " <> show name <> ", have you seen Chainweb.Test.TestVersions.testVersions?"
 
 fabricateVersionWithName :: HasCallStack => ChainwebVersionName -> ChainwebVersion
 fabricateVersionWithName name =

src/Chainweb/Version/Testnet.hs

@@ -22,6 +22,7 @@ import Chainweb.Utils.Rule
 import Chainweb.Version
 import P2P.BootstrapNodes
 
+import Pact.Types.Runtime (Gas(..))
 import Pact.Types.Verifier
 
 import qualified Chainweb.Pact.Transactions.CoinV3Transactions as CoinV3
@@ -182,4 +183,10 @@ testnet = ChainwebVersion
         }
     , _versionVerifierPluginNames = AllChains $ (4_100_681, Set.fromList $ map VerifierName ["hyperlane_v3_message"]) `Above`
         End mempty
+    , _versionQuirks = VersionQuirks
+        { _quirkGasFees = HM.fromList
+            [ (fromJuste (decodeStrictOrThrow' "\"myHrgVbYCXlAk8KJbmWHs3TEDSlRKRuzxpFa9yaC7cQ\""), Gas 66239)
+            , (fromJuste (decodeStrictOrThrow' "\"3fpFnFUrRsu67ItHicBGa9PVlWp71AggrcWoikht3jk\""), Gas 65130)
+            ]
+        }
     }

test/Chainweb/Test/Cut/TestBlockDb.hs

@@ -45,6 +45,9 @@ data TestBlockDb = TestBlockDb
   , _bdbCut :: MVar Cut
   }
 
+instance HasChainwebVersion TestBlockDb where
+  _chainwebVersion = _chainwebVersion . _bdbWebBlockHeaderDb
+
 -- | Initialize TestBlockDb.
 withTestBlockDb :: ChainwebVersion -> (TestBlockDb -> IO a) -> IO a
 withTestBlockDb cv a = do

test/Chainweb/Test/Pact/Checkpointer.hs

@@ -664,7 +664,7 @@ runExec cp pactdbenv eData eCode = do
     h' = H.toUntypedHash (H.hash "" :: H.PactHash)
     cmdenv :: TransactionEnv logger (BlockEnv logger SQLiteEnv)
     cmdenv = TransactionEnv Transactional pactdbenv (_cpLogger $ _cpReadCp cp) Nothing def
-             noSPVSupport Nothing 0.0 (RequestKey h') 0 def
+             noSPVSupport Nothing 0.0 (RequestKey h') 0 def Nothing
     cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty
 
 runCont :: Logger logger => Checkpointer logger -> ChainwebPactDbEnv logger -> PactId -> Int -> IO EvalResult
@@ -676,7 +676,7 @@ runCont cp pactdbenv pactId step = do
 
     h' = H.toUntypedHash (H.hash "" :: H.PactHash)
     cmdenv = TransactionEnv Transactional pactdbenv (_cpLogger $ _cpReadCp cp) Nothing def
-             noSPVSupport Nothing 0.0 (RequestKey h') 0 def
+             noSPVSupport Nothing 0.0 (RequestKey h') 0 def Nothing
     cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty
 
 -- -------------------------------------------------------------------------- --