disable init module cache on chainweb 224 (#1861)

Change-Id: I0210312cdf38bef1615a02f3cf0ee57db82894c1

bench/Chainweb/Pact/Backend/ForkingBench.hs

@@ -318,7 +318,7 @@ withResources rdb trunkLength logLevel compact f = C.envWithCleanup create destr
     startPact version l bhdb pdb mempool sqlEnv = do
         reqQ <- newPactQueue pactQueueSize
         a <- async $ runPactService version cid l reqQ mempool bhdb pdb sqlEnv testPactServiceConfig
-            { _pactBlockGasLimit = 180000
+            { _pactBlockGasLimit = 180_000
             }
 
         return (a, reqQ)

src/Chainweb/Pact/PactService.hs

@@ -51,7 +51,6 @@ import Control.Monad.Reader
 import Control.Monad.State.Strict
 import Control.Monad.Primitive (PrimState)
 
-import Data.Default (def)
 import qualified Data.DList as DL
 import Data.Either
 import Data.Foldable (toList)
@@ -249,10 +248,7 @@ initializeCoinContract memPoolAccess v cid pwo = do
         -- cheap. We could also check the height but that would be redundant.
         if _blockHash (_parentHeader currentBlockHeader) /= _blockHash genesisHeader
         then do
-          logger <- view psLogger
-          !mc <- liftIO $ _cpReadFrom (_cpReadCp cp) (Just currentBlockHeader) $ \pdbenv -> do
-            let pd = TxContext currentBlockHeader def
-            readInitModules logger (_cpPactDbEnv pdbenv) pd
+          !mc <- readFrom (Just currentBlockHeader) readInitModules
           updateInitCache mc currentBlockHeader
         else do
           logWarn "initializeCoinContract: Starting from genesis."
@@ -744,7 +740,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
                 -- specified, we run the old behavior. When it is set to true, we also do metadata
                 -- validations.
                 --
-                r <- case preflight of
+                case preflight of
                   Just PreflightSimulation -> do
                     liftPactServiceM (assertLocalMetadata cmd ctx sigVerify) >>= \case
                       Right{} -> do
@@ -773,8 +769,6 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do
                     let cr' = toHashCommandResult cr
                     pure $ LocalResultLegacy cr'
 
-                return r
-
     case timeoutLimit of
       Nothing -> act
       Just limit -> withPactState $ \run -> timeoutYield limit (run act) >>= \case
@@ -1076,7 +1070,7 @@ chainweb213GasModel = modifiedGasModel
 
 getGasModel :: TxContext -> P.GasModel
 getGasModel ctx
-    | chainweb213Pact (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) = chainweb213GasModel
+    | guardCtx chainweb213Pact ctx = chainweb213GasModel
     | otherwise = freeModuleLoadGasModel
 
 pactLabel :: (Logger logger) => Text -> PactServiceM logger tbl x -> PactServiceM logger tbl x

src/Chainweb/Pact/PactService/Checkpointer.hs

@@ -131,8 +131,8 @@ readFrom ph doRead = do
     pactParent <- getPactParent ph
     s <- get
     e <- ask
-    liftIO $ _cpReadFrom (_cpReadCp cp) ph $
-        (\dbenv -> evalPactServiceM s e $ runPactBlockM pactParent dbenv doRead)
+    liftIO $ _cpReadFrom (_cpReadCp cp) ph $ \dbenv ->
+      evalPactServiceM s e $ runPactBlockM pactParent dbenv doRead
 
 -- here we cheat, making the genesis block header's parent the genesis
 -- block header, only for Pact's information, *not* for the checkpointer;

src/Chainweb/Pact/PactService/ExecBlock.hs

@@ -316,10 +316,7 @@ initModuleCacheForBlock isGenesis = do
     Nothing -> if isGenesis
       then return mempty
       else do
-        l <- view (psServiceEnv . psLogger)
-        dbEnv <- view psBlockDbEnv
-        txCtx <- getTxContext def
-        mc <- liftIO (readInitModules l (_cpPactDbEnv dbEnv) txCtx)
+        mc <- readInitModules
         updateInitCacheM mc
         return mc
     Just (_,mc) -> return mc
@@ -374,7 +371,7 @@ applyPactCmds
     -> PactBlockM logger tbl (Vector (Either CommandInvalidError (P.CommandResult [P.TxLogJson])))
 applyPactCmds isGenesis cmds miner mc blockGas txTimeLimit = do
     let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to P._crGas) txs
-    txs <- tracePactBlockM' "applyPactCmds" () txsGas $
+    tracePactBlockM' "applyPactCmds" () txsGas $
       flip evalStateT (T2 mc blockGas) $ do
         let go :: ()
                => [Either CommandInvalidError (P.CommandResult [P.TxLogJson])]
@@ -396,7 +393,6 @@ applyPactCmds isGenesis cmds miner mc blockGas txTimeLimit = do
                   Right a -> do
                     go (Right a : acc) rest
         V.fromList . List.reverse <$> go [] (V.toList cmds)
-    return txs
 
 applyPactCmd
   :: (Logger logger)
@@ -416,8 +412,8 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGa
   v <- view chainwebVersion
   let
     onBuyGasFailure e
-      | Just (BuyGasFailure f) <- fromException e = pure $! (Left (CommandInvalidGasPurchaseFailure f), T2 mcache maybeBlockGasRemaining)
-      | Just t@(TxTimeout {}) <- fromException e = pure $! (Left (CommandInvalidTxTimeout t), T2 mcache maybeBlockGasRemaining)
+      | Just (BuyGasFailure f) <- fromException e = pure (Left (CommandInvalidGasPurchaseFailure f), T2 mcache maybeBlockGasRemaining)
+      | Just t@(TxTimeout {}) <- fromException e = pure (Left (CommandInvalidTxTimeout t), T2 mcache maybeBlockGasRemaining)
       | otherwise = throwM e
     requestedTxGasLimit = view cmdGasLimit (payloadObj <$> cmd)
     -- notice that we add 1 to the remaining block gas here, to distinguish the

src/Chainweb/Pact/TransactionExec.hs

@@ -1,11 +1,9 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -81,6 +79,7 @@ import qualified System.LogLevel as L
 
 -- internal Pact modules
 
+import Chainweb.Pact.Backend.Types (_cpPactDbEnv)
 import Pact.Eval (eval, liftTerm)
 import Pact.Gas (freeGasEnv)
 import Pact.Interpreter
@@ -151,7 +150,7 @@ magic_GENESIS = mkMagicCapSlot "GENESIS"
 
 onChainErrorPrintingFor :: TxContext -> UnexpectedErrorPrinting
 onChainErrorPrintingFor txCtx =
-  if chainweb219Pact (ctxVersion txCtx) (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)
+  if guardCtx chainweb219Pact txCtx
   then CensorsUnexpectedError
   else PrintsUnexpectedError
 
@@ -219,10 +218,10 @@ applyCmd v logger gasLogger pdbenv miner gasModel txCtx spv cmd initialGas mcach
     isModuleNameFix = enableModuleNameFix v cid currHeight
     isModuleNameFix2 = enableModuleNameFix2 v cid currHeight
     isPactBackCompatV16 = pactBackCompat_v16 v cid currHeight
-    chainweb213Pact' = chainweb213Pact v cid currHeight
-    chainweb217Pact' = chainweb217Pact v cid currHeight
-    chainweb219Pact' = chainweb219Pact v cid currHeight
-    chainweb223Pact' = chainweb223Pact v cid currHeight
+    chainweb213Pact' = guardCtx chainweb213Pact txCtx
+    chainweb217Pact' = guardCtx chainweb217Pact txCtx
+    chainweb219Pact' = guardCtx chainweb219Pact txCtx
+    chainweb223Pact' = guardCtx chainweb223Pact txCtx
     allVerifiers = verifiersAt v cid currHeight
     toEmptyPactError (PactError errty _ _ _) = PactError errty def [] mempty
 
@@ -469,11 +468,18 @@ applyCoinbase v logger dbEnv (Miner mid mks@(MinerKeys mk)) reward@(ParsedDecima
           logs <- use txLogs
 
           return $! T2
-            (CommandResult rk (_erTxId er) (PactResult (Right (last $ _erOutput er)))
-              (_erGas er) (Just logs) (_erExec er) Nothing (_erEvents er))
+            CommandResult
+              { _crReqKey = rk
+              , _crTxId = _erTxId er
+              , _crResult = PactResult (Right (last (_erOutput er)))
+              , _crGas = _erGas er
+              , _crLogs = Just logs
+              , _crContinuation = _erExec er
+              , _crMetaData = Nothing
+              , _crEvents = _erEvents er
+              }
             upgradedModuleCache
 
-
 applyLocal
     :: (Logger logger)
     => logger
@@ -543,27 +549,20 @@ applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig =
 
     go = checkTooBigTx gas0 gasLimit (applyVerifiers $ _pPayload $ _cmdPayload cmd) return
 
-
 readInitModules
-    :: forall logger p. (Logger logger)
-    => logger
-      -- ^ Pact logger
-    -> PactDbEnv p
-      -- ^ Pact db environment
-    -> TxContext
-      -- ^ tx metadata and parent header
-    -> IO ModuleCache
-readInitModules logger dbEnv txCtx
-    | chainweb217Pact' = evalTransactionM tenv txst goCw217
-    | otherwise = evalTransactionM tenv txst go
-  where
-    -- guarding chainweb 2.17 here to allow for
-    -- cache purging everything but coin and its
-    -- dependencies.
-    chainweb217Pact' = chainweb217Pact
-      (ctxVersion txCtx)
-      (ctxChainId txCtx)
-      (ctxCurrentBlockHeight txCtx)
+    :: forall logger tbl. (Logger logger)
+    => PactBlockM logger tbl ModuleCache
+readInitModules = do
+  logger <- view (psServiceEnv . psLogger)
+  dbEnv <- _cpPactDbEnv <$> view psBlockDbEnv
+  txCtx <- getTxContext def
+
+  -- guarding chainweb 2.17 here to allow for
+  -- cache purging everything but coin and its
+  -- dependencies.
+  let
+    chainweb217Pact' = guardCtx chainweb217Pact txCtx
+    chainweb224Pact' = guardCtx chainweb224Pact txCtx
 
     parent = _tcParentHeader txCtx
     v = ctxVersion txCtx
@@ -629,6 +628,10 @@ readInitModules logger dbEnv txCtx
       void $ run "load modules" coinDepCmd
       use txCache
 
+  if | chainweb224Pact' -> pure mempty
+     | chainweb217Pact' -> liftIO $ evalTransactionM tenv txst goCw217
+     | otherwise -> liftIO $ evalTransactionM tenv txst go
+
 -- | Apply (forking) upgrade transactions and module cache updates
 -- at a particular blockheight.
 --
@@ -1148,9 +1151,9 @@ setModuleCache mcache es =
 --
 setTxResultState :: EvalResult -> TransactionM logger db ()
 setTxResultState er = do
-    txLogs <>= (_erLogs er)
+    txLogs <>= _erLogs er
     txCache .= moduleCacheFromHashMap (_erLoadedModules er)
-    txGasUsed .= (_erGas er)
+    txGasUsed .= _erGas er
 {-# INLINE setTxResultState #-}
 
 -- | Make an 'EvalEnv' given a tx env + state
@@ -1245,7 +1248,6 @@ debug s = do
     rk <- view txRequestKey
     logDebug_ l $ s <> ": " <> sshow rk
 
-
 -- | Denotes fatal failure points in the tx exec process
 --
 fatal :: (Logger logger) => Text -> TransactionM logger db a

src/Chainweb/Pact/Types.hs

@@ -96,6 +96,7 @@ module Chainweb.Pact.Types
   , ctxCurrentBlockHeight
   , ctxChainId
   , ctxVersion
+  , guardCtx
   , getTxContext
 
     -- * Pact Service State
@@ -586,6 +587,9 @@ ctxChainId = _blockChainId . ctxBlockHeader
 ctxVersion :: TxContext -> ChainwebVersion
 ctxVersion = _chainwebVersion . ctxBlockHeader
 
+guardCtx :: (ChainwebVersion -> ChainId -> BlockHeight -> a) -> TxContext -> a
+guardCtx g txCtx = g (ctxVersion txCtx) (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)
+
 -- | Assemble tx context from transaction metadata and parent header.
 getTxContext :: PublicMeta -> PactBlockM logger tbl TxContext
 getTxContext pm = view psParentHeader >>= \ph -> return (TxContext ph pm)

tools/cwtool/TxSimulator.hs

@@ -44,7 +44,7 @@ import Chainweb.Pact.TransactionExec
 import Chainweb.Pact.Types
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
-import Chainweb.Payload.PayloadStore.InMemory
+import Chainweb.Payload.PayloadStore.RocksDB (newPayloadDb)
 import Chainweb.Payload.RestAPI.Client
 import Chainweb.SPV
 import Chainweb.Transaction
@@ -119,14 +119,37 @@ simulate sc@(SimConfig dbDir txIdx' _ _ cid ver gasLog doTypecheck) = do
           Left _ -> error "bad cmd"
           Right cmdPwt -> do
             let cmd = payloadObj <$> cmdPwt
-                txc = TxContext parent $ publicMetaOf cmd
-            _cpReadFrom (_cpReadCp cp) (Just parent) $ \dbEnv -> do
-              mc <- readInitModules logger (_cpPactDbEnv dbEnv) txc
-              T3 !cr _mc _ <-
-                trace (logFunction cwLogger) "applyCmd" () 1 $
-                  applyCmd ver logger gasLogger (_cpPactDbEnv dbEnv) miner (getGasModel txc)
-                  txc noSPVSupport cmd (initGas cmdPwt) mc ApplySend
-              T.putStrLn (J.encodeText (J.Array <$> cr))
+            let txc = TxContext parent $ publicMetaOf cmd
+            -- This rocksdb isn't actually used, it's just to satisfy
+            -- PactServiceEnv
+            withTempRocksDb "txsim-rocksdb" $ \rdb -> do
+              withBlockHeaderDb rdb ver cid $ \bdb -> do
+                let payloadDb = newPayloadDb rdb
+                let psEnv = PactServiceEnv
+                      { _psMempoolAccess = Nothing
+                      , _psCheckpointer = cp
+                      , _psPdb = payloadDb
+                      , _psBlockHeaderDb = bdb
+                      , _psGasModel = getGasModel
+                      , _psMinerRewards = readRewards
+                      , _psPreInsertCheckTimeout = defaultPreInsertCheckTimeout
+                      , _psReorgLimit = RewindLimit 0
+                      , _psOnFatalError = ferr
+                      , _psVersion = ver
+                      , _psAllowReadsInLocal = False
+                      , _psLogger = logger
+                      , _psGasLogger = gasLogger
+                      , _psBlockGasLimit = testBlockGasLimit
+                      , _psEnableLocalTimeout = False
+                      }
+                evalPactServiceM (PactServiceState mempty) psEnv $ readFrom (Just parent) $ do
+                  mc <- readInitModules
+                  T3 !cr _mc _ <- do
+                    dbEnv <- view psBlockDbEnv
+                    liftIO $ trace (logFunction cwLogger) "applyCmd" () 1 $
+                      applyCmd ver logger gasLogger (_cpPactDbEnv dbEnv) miner (getGasModel txc)
+                        txc noSPVSupport cmd (initGas cmdPwt) mc ApplySend
+                  liftIO $ T.putStrLn (J.encodeText (J.Array <$> cr))
       (_,True) -> do
         _cpReadFrom (_cpReadCp cp) (Just parent) $ \dbEnv -> do
           let refStore = RefStore nativeDefs
@@ -156,14 +179,15 @@ simulate sc@(SimConfig dbDir txIdx' _ _ cid ver gasLog doTypecheck) = do
 
 
       (Nothing,False) -> do -- blocks simulation
-        paydb <- newPayloadDb
-        withRocksDb "txsim-rocksdb" modernDefaultOptions $ \rdb ->
+        -- This rocksdb is unused, it exists to satisfy PactServiceEnv
+        withTempRocksDb "txsim-rocksdb" $ \rdb ->
           withBlockHeaderDb rdb ver cid $ \bdb -> do
+            let payloadDb = newPayloadDb rdb
             let
               pse = PactServiceEnv
                 { _psMempoolAccess = Nothing
                 , _psCheckpointer = cp
-                , _psPdb = paydb
+                , _psPdb = payloadDb
                 , _psBlockHeaderDb = bdb
                 , _psGasModel = getGasModel
                 , _psMinerRewards = readRewards
@@ -200,9 +224,8 @@ simulate sc@(SimConfig dbDir txIdx' _ _ cid ver gasLog doTypecheck) = do
     doBlock _ _ [] = return ()
     doBlock initMC parent ((hdr,pwo):rest) = do
       readFrom (Just parent) $ do
-        dbEnv <- view psBlockDbEnv
         when initMC $ do
-          mc <- liftIO $ readInitModules logger (_cpPactDbEnv dbEnv) (TxContext parent def)
+          mc <- readInitModules
           updateInitCacheM mc
         void $ trace (logFunction cwLogger) "execBlock" () 1 $
             execBlock hdr (payloadWithOutputsToPayloadData pwo)