diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index dcb4876db3..7bfaae6a7c 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/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) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 3ff7f5ab0d..797d119b54 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/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 diff --git a/src/Chainweb/Pact/PactService/Checkpointer.hs b/src/Chainweb/Pact/PactService/Checkpointer.hs index f5896c6a7b..66a9e00f70 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer.hs +++ b/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; diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/ExecBlock.hs index ecacaf399a..c6230f624d 100644 --- a/src/Chainweb/Pact/PactService/ExecBlock.hs +++ b/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 diff --git a/src/Chainweb/Pact/TransactionExec.hs b/src/Chainweb/Pact/TransactionExec.hs index ee755ea082..914bbf48d5 100644 --- a/src/Chainweb/Pact/TransactionExec.hs +++ b/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 diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index ddf33df011..f3f802a5e0 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/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) diff --git a/tools/cwtool/TxSimulator.hs b/tools/cwtool/TxSimulator.hs index f86a37a48d..551aba78ed 100644 --- a/tools/cwtool/TxSimulator.hs +++ b/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)