diff --git a/chainweb.cabal b/chainweb.cabal index ae5ed55841..0a54183e6e 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -314,6 +314,7 @@ library , Chainweb.Pact.Transactions.Mainnet9Transactions , Chainweb.Pact.Transactions.MainnetKADTransactions , Chainweb.Pact.Transactions.OtherTransactions + , Chainweb.Pact.Conversions , Chainweb.Pact.Types , Chainweb.Pact.Utils , Chainweb.Pact.Validations diff --git a/src/Chainweb/Pact/Conversions.hs b/src/Chainweb/Pact/Conversions.hs new file mode 100644 index 0000000000..03743f12f6 --- /dev/null +++ b/src/Chainweb/Pact/Conversions.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE RecordWildCards #-} + +module Chainweb.Pact.Conversions where + +import Data.Coerce (coerce) + +import Pact.Interpreter (PactDbEnv) +import qualified Pact.JSON.Encode as J +import qualified Pact.JSON.Legacy.HashMap as LHM +import Pact.Parse (ParsedDecimal) +import Pact.Types.ChainId (NetworkId) +import Pact.Types.ChainMeta +import Pact.Types.Command +import Pact.Types.Gas +import Pact.Types.Names +import Pact.Types.Persistence (ExecutionMode, TxLogJson) +import Pact.Types.Pretty (viaShow) +import Pact.Types.Runtime (ExecutionConfig(..), ModuleData(..), PactWarning, PactError(..), PactErrorType(..)) +import Pact.Types.SPV +import Pact.Types.Term +import qualified Pact.Types.Logger as P + +import qualified Pact.Core.Evaluate as PCore +import qualified Pact.Core.Compile as PCore +import qualified Pact.Core.Capabilities as PCore +import qualified Pact.Core.Info as PCore +import qualified Pact.Core.Names as PCore +import qualified Pact.Core.Namespace as PCore +import qualified Pact.Core.Persistence as PCore +import qualified Pact.Core.Pretty as PCore +import qualified Pact.Core.Gas as PCore +import qualified Pact.Core.Hash as PCore +import qualified Pact.Core.Errors as PCore +import qualified Pact.Core.Debug as PCore +import qualified Pact.Core.Serialise.LegacyPact as PCore +import qualified Pact.Core.PactValue as PCore +import qualified Pact.Core.Environment as PCore +import qualified Pact.Core.IR.Term as PCore +import qualified Pact.Core.Builtin as PCore +import qualified Pact.Core.Syntax.ParseTree as PCore +import qualified Pact.Core.DefPacts.Types as PCore +import qualified Pact.Core.Scheme as PCore + +convertModuleName :: ModuleName -> PCore.ModuleName +convertModuleName ModuleName{..} = + PCore.ModuleName + { PCore._mnName = _mnName + , PCore._mnNamespace = fmap coerce _mnNamespace + } + diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 79c5326d03..8d2a3d60de 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -428,17 +428,17 @@ attemptBuyGas -> Vector (Either InsertError ChainwebTransaction) -> PactServiceM logger tbl (Vector (Either InsertError ChainwebTransaction)) attemptBuyGas miner (PactDbEnv' (dbEnv,coreDb)) txs = localLabel ("transaction", "attemptBuyGas") $ do - mc <- getInitCache + (mc, cmc) <- getInitCache l <- view psLogger - V.fromList . toList . sfst <$> V.foldM (f l) (T2 mempty mc) txs + V.fromList . toList . sfst <$> V.foldM (f l) (T2 mempty (mc, cmc)) txs where f :: logger - -> T2 (DL.DList (Either InsertError ChainwebTransaction)) ModuleCache + -> T2 (DL.DList (Either InsertError ChainwebTransaction)) (ModuleCache, CoreModuleCache) -> Either InsertError ChainwebTransaction - -> PactServiceM logger tbl (T2 (DL.DList (Either InsertError ChainwebTransaction)) ModuleCache) - f l (T2 dl mcache) cmd = do - T2 mcache' !res <- runBuyGas l dbEnv coreDb mcache cmd - pure $! T2 (DL.snoc dl res) mcache' + -> PactServiceM logger tbl (T2 (DL.DList (Either InsertError ChainwebTransaction)) (ModuleCache, CoreModuleCache)) + f l (T2 dl (mcache, cmcache)) cmd = do + T3 mcache' cmcache' !res <- runBuyGas l dbEnv coreDb (mcache, cmcache) cmd + pure $! T2 (DL.snoc dl res) (mcache', cmcache') createGasEnv :: logger @@ -464,16 +464,17 @@ attemptBuyGas miner (PactDbEnv' (dbEnv,coreDb)) txs = localLabel ("transaction", :: logger -> P.PactDbEnv a -> CoreDb - -> ModuleCache + -> (ModuleCache, CoreModuleCache) -> Either InsertError ChainwebTransaction - -> PactServiceM logger tbl (T2 ModuleCache (Either InsertError ChainwebTransaction)) - runBuyGas _l _db cdb mcache l@Left {} = return (T2 mcache l) - runBuyGas l db cdb mcache (Right tx) = do + -> PactServiceM logger tbl (T3 ModuleCache CoreModuleCache (Either InsertError ChainwebTransaction)) + runBuyGas _l _db cdb (mcache, cmcache) l@Left {} = return (T3 mcache cmcache l) + runBuyGas l db cdb (mcache, cmcache) (Right tx) = do let cmd = payloadObj <$> tx gasPrice = view cmdGasPrice cmd gasLimit = fromIntegral $ view cmdGasLimit cmd txst = TransactionState { _txCache = mcache + , _txCoreCache = cmcache , _txLogs = mempty , _txGasUsed = 0 , _txGasId = Nothing @@ -489,8 +490,8 @@ attemptBuyGas miner (PactDbEnv' (dbEnv,coreDb)) txs = localLabel ("transaction", $! buyGas False cmd miner case cr of - Left err -> return (T2 mcache (Left (InsertErrorBuyGas (T.pack $ show err)))) - Right t -> return (T2 (_txCache t) (Right tx)) + Left err -> return (T3 mcache cmcache (Left (InsertErrorBuyGas (T.pack $ show err)))) + Right t -> return (T3 (_txCache t) (_txCoreCache t) (Right tx)) -- | Note: The BlockHeader param here is the PARENT HEADER of the new -- block-to-be @@ -743,7 +744,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ withDiscarde assertLocalMetadata cmd ctx sigVerify >>= \case Right{} -> do let initialGas = initialGasOf $ P._cmdPayload cwtx - T3 cr _mc warns <- liftIO $ applyCmd + T4 cr _mc _cmc warns <- liftIO $ applyCmd _psVersion _psLogger _psGasLogger pdbenv noMiner gasModel ctx spv cmd initialGas mc ApplyLocal diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/ExecBlock.hs index 8d82da7ac3..3723478b30 100644 --- a/src/Chainweb/Pact/PactService/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/ExecBlock.hs @@ -161,7 +161,8 @@ execBlock currHeader plData pdbenv = do fromIntegral <$> maxBlockGasLimit v (_blockHeight currHeader) logInitCache = do - mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache + initCache <- use psInitCache + let mc = fmap (\(mc, _) -> fmap instr $ _getModuleCache mc) initCache logDebug $ "execBlock: initCache: " <> sshow mc instr (md,_) = preview (P._MDModule . P.mHash) $ P._mdModule md @@ -305,17 +306,17 @@ execTransactions -> Maybe Micros -> PactServiceM logger tbl (Transactions (Either GasPurchaseFailure (P.CommandResult [P.TxLogJson]))) execTransactions isGenesis miner ctxs enfCBFail usePrecomp (PactDbEnv' pactdbenv) gasLimit timeLimit = do - mc <- getCache + (mc, cmc) <- getCache - coinOut <- runCoinbase isGenesis pactdbenv miner enfCBFail usePrecomp mc - txOuts <- applyPactCmds isGenesis pactdbenv ctxs miner mc gasLimit timeLimit + coinOut <- runCoinbase isGenesis pactdbenv miner enfCBFail usePrecomp (mc, cmc) + txOuts <- applyPactCmds isGenesis pactdbenv ctxs miner (mc, cmc) gasLimit timeLimit return $! Transactions (V.zip ctxs txOuts) coinOut where getCache = get >>= \PactServiceState{..} -> do let pbh = _blockHeight . _parentHeader case Map.lookupLE (pbh _psParentHeader) _psInitCache of Nothing -> if isGenesis - then return mempty + then return (mempty, mempty) else do l <- asks _psLogger txCtx <- getTxContext def @@ -344,10 +345,10 @@ runCoinbase -> Miner -> EnforceCoinbaseFailure -> CoinbaseUsePrecompiled - -> ModuleCache + -> (ModuleCache, CoreModuleCache) -> PactServiceM logger tbl (P.CommandResult [P.TxLogJson]) runCoinbase True _ _ _ _ _ = return noCoinbase -runCoinbase False dbEnv miner enfCBFail usePrecomp mc = do +runCoinbase False dbEnv miner enfCBFail usePrecomp (mc, cmc) = do logger <- view psLogger rs <- view psMinerRewards v <- view chainwebVersion @@ -357,7 +358,7 @@ runCoinbase False dbEnv miner enfCBFail usePrecomp mc = do reward <- liftIO $! minerReward v rs bh - (T2 cr upgradedCacheM) <- liftIO $ applyCoinbase v logger dbEnv miner reward txCtx enfCBFail usePrecomp mc + (T2 cr upgradedCacheM) <- liftIO $ applyCoinbase v logger dbEnv miner reward txCtx enfCBFail usePrecomp (mc, cmc) mapM_ upgradeInitCache upgradedCacheM debugResult "runCoinbase" (P.crLogs %~ fmap J.Array $ cr) return $! cr @@ -378,14 +379,14 @@ applyPactCmds -> (P.PactDbEnv p, CoreDb) -> Vector ChainwebTransaction -> Miner - -> ModuleCache + -> (ModuleCache, CoreModuleCache) -> Maybe P.Gas -> Maybe Micros -> PactServiceM logger tbl (Vector (Either GasPurchaseFailure (P.CommandResult [P.TxLogJson]))) -applyPactCmds isGenesis env cmds miner mc blockGas txTimeLimit = do +applyPactCmds isGenesis env cmds miner (mc, cmc) blockGas txTimeLimit = do let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to P._crGas) txs txs <- tracePactServiceM' "applyPactCmds" () txsGas $ - evalStateT (V.mapM (applyPactCmd isGenesis env miner txTimeLimit) cmds) (T2 mc blockGas) + evalStateT (V.mapM (applyPactCmd isGenesis env miner txTimeLimit) cmds) (T3 mc cmc blockGas) return txs applyPactCmd @@ -396,16 +397,16 @@ applyPactCmd -> Maybe Micros -> ChainwebTransaction -> StateT - (T2 ModuleCache (Maybe P.Gas)) + (T3 ModuleCache CoreModuleCache (Maybe P.Gas)) (PactServiceM logger tbl) (Either GasPurchaseFailure (P.CommandResult [P.TxLogJson])) -applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do +applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache maybeBlockGasRemaining) -> do logger <- view psLogger gasLogger <- view psGasLogger gasModel <- view psGasModel v <- view psVersion let - onBuyGasFailure (BuyGasFailure f) = pure $! (Left f, T2 mcache maybeBlockGasRemaining) + onBuyGasFailure (BuyGasFailure f) = pure $! (Left f, T3 mcache cmcache maybeBlockGasRemaining) onBuyGasFailure e = throwM e requestedTxGasLimit = view cmdGasLimit (payloadObj <$> cmd) -- notice that we add 1 to the remaining block gas here, to distinguish the @@ -421,7 +422,7 @@ applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlo set cmdGasLimit newTxGasLimit (payloadObj <$> cmd) initialGas = initialGasOf (P._cmdPayload cmd) handle onBuyGasFailure $ do - T2 result mcache' <- do + T2 result (mcache', cmcache') <- do txCtx <- getTxContext (publicMetaOf gasLimitedCmd) if isGenesis then liftIO $! applyGenesisCmd logger env P.noSPVSupport txCtx gasLimitedCmd @@ -433,14 +434,14 @@ applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlo Nothing -> id Just limit -> maybe (throwM timeoutError) return <=< timeout (fromIntegral limit) - let txGas (T3 r _ _) = fromIntegral $ P._crGas r - T3 r c _warns <- + let txGas (T4 r _ _ _) = fromIntegral $ P._crGas r + T4 r c cc _warns <- tracePactServiceM' "applyCmd" (J.toJsonViaEncode (P._cmdHash cmd)) txGas $ - liftIO $ txTimeout $ applyCmd v logger gasLogger env miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas mcache ApplySend - pure $ T2 r c + liftIO $ txTimeout $ applyCmd v logger gasLogger env miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas (mcache, cmcache) ApplySend + pure $ T2 r (c, cc) if isGenesis - then updateInitCache mcache' + then updateInitCache (mcache', cmcache') else debugResult "applyPactCmd" (P.crLogs %~ fmap J.Array $ result) cp <- getCheckpointer @@ -457,7 +458,7 @@ applyPactCmd isGenesis env miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlo throwM $ BlockGasLimitExceeded (blockGasRemaining - fromIntegral requestedTxGasLimit) Nothing -> return () let maybeBlockGasRemaining' = (\g -> g - P._crGas result) <$> maybeBlockGasRemaining - pure (Right result, T2 mcache' maybeBlockGasRemaining') + pure (Right result, T3 mcache' cmcache' maybeBlockGasRemaining') toHashCommandResult :: P.CommandResult [P.TxLogJson] -> P.CommandResult P.Hash toHashCommandResult = over (P.crLogs . _Just) $ P.pactHash . P.encodeTxLogJsonArray diff --git a/src/Chainweb/Pact/TransactionExec.hs b/src/Chainweb/Pact/TransactionExec.hs index 724d7a2ea6..4db89bb50f 100644 --- a/src/Chainweb/Pact/TransactionExec.hs +++ b/src/Chainweb/Pact/TransactionExec.hs @@ -135,12 +135,13 @@ import Chainweb.Logger import qualified Chainweb.ChainId as Chainweb import Chainweb.Mempool.Mempool (requestKeyToTransactionHash) import Chainweb.Miner.Pact +import Chainweb.Pact.Conversions import Chainweb.Pact.Service.Types import Chainweb.Pact.Templates import Chainweb.Pact.Types hiding (logError) import Chainweb.Pact.Backend.Types import Chainweb.Transaction -import Chainweb.Utils (encodeToByteString, sshow, tryAllSynchronous, T2(..), T3(..)) +import Chainweb.Utils (encodeToByteString, sshow, tryAllSynchronous, T2(..), T3(..), T4(..)) import Chainweb.Version as V import Chainweb.Version.Guards as V import Pact.JSON.Encode (toJsonViaEncode) @@ -197,23 +198,24 @@ applyCmd -- ^ command with payload to execute -> Gas -- ^ initial gas used - -> ModuleCache + -> (ModuleCache, CoreModuleCache) -- ^ cached module state -> ApplyCmdExecutionContext -- ^ is this a local or send execution context? - -> IO (T3 (CommandResult [TxLogJson]) ModuleCache (S.Set PactWarning)) -applyCmd v logger gasLogger (pdbenv, coreDb) miner gasModel txCtx spv cmd initialGas mcache0 callCtx = do + -> IO (T4 (CommandResult [TxLogJson]) ModuleCache CoreModuleCache (S.Set PactWarning)) +applyCmd v logger gasLogger (pdbenv, coreDb) miner gasModel txCtx spv cmd initialGas (mcache0, mccache0) callCtx = do T2 cr st <- runTransactionM cenv txst applyBuyGas let cache = _txCache st + coreCache = _txCoreCache st warns = _txWarnings st - pure $ T3 cr cache warns + pure $ T4 cr cache coreCache warns where stGasModel | chainweb217Pact' = gasModel | otherwise = _geGasModel freeGasEnv - txst = TransactionState mcache0 mempty 0 Nothing stGasModel mempty + txst = TransactionState mcache0 mccache0 mempty 0 Nothing stGasModel mempty executionConfigNoHistory = ExecutionConfig $ S.singleton FlagDisableHistoryInTransactionalMode @@ -322,9 +324,9 @@ applyGenesisCmd -- ^ tx metadata -> Command (Payload PublicMeta ParsedCode) -- ^ command with payload to execute - -> IO (T2 (CommandResult [TxLogJson]) ModuleCache) + -> IO (T2 (CommandResult [TxLogJson]) (ModuleCache, CoreModuleCache)) applyGenesisCmd logger (dbEnv, coreDb) spv txCtx cmd = - second _txCache <$!> runTransactionM tenv txst go + second (\s -> (_txCache s, _txCoreCache s)) <$!> runTransactionM tenv txst go where nid = networkIdOf cmd rk = cmdToRequestKey cmd @@ -351,6 +353,7 @@ applyGenesisCmd logger (dbEnv, coreDb) spv txCtx cmd = } txst = TransactionState { _txCache = mempty + , _txCoreCache = mempty , _txLogs = mempty , _txGasUsed = 0 , _txGasId = Nothing @@ -406,10 +409,10 @@ applyCoinbase -- ^ enforce coinbase failure or not -> CoinbaseUsePrecompiled -- ^ always enable precompilation - -> ModuleCache - -> IO (T2 (CommandResult [TxLogJson]) (Maybe ModuleCache)) + -> (ModuleCache, CoreModuleCache) + -> IO (T2 (CommandResult [TxLogJson]) (Maybe (ModuleCache, CoreModuleCache))) applyCoinbase v logger (dbEnv, coreDb) (Miner mid mks@(MinerKeys mk)) reward@(ParsedDecimal d) txCtx - (EnforceCoinbaseFailure enfCBFailure) (CoinbaseUsePrecompiled enablePC) mc + (EnforceCoinbaseFailure enfCBFailure) (CoinbaseUsePrecompiled enablePC) (mc, cmc) | fork1_3InEffect || enablePC = do when chainweb213Pact' $ enforceKeyFormats (\k -> throwM $ CoinbaseFailure $ "Invalid miner key: " <> sshow k) @@ -436,7 +439,7 @@ applyCoinbase v logger (dbEnv, coreDb) (Miner mid mks@(MinerKeys mk)) reward@(Pa ] tenv = TransactionEnv Transactional dbEnv coreDb logger Nothing (ctxToPublicData txCtx) noSPVSupport Nothing 0.0 rk 0 ec - txst = TransactionState mc mempty 0 Nothing (_geGasModel freeGasEnv) mempty + txst = TransactionState mc cmc mempty 0 Nothing (_geGasModel freeGasEnv) mempty initState = setModuleCache mc $ initCapabilities [magic_COINBASE] rk = RequestKey chash parent = _tcParentHeader txCtx @@ -490,10 +493,10 @@ applyLocal -- ^ SPV support (validates cont proofs) -> Command PayloadWithText -- ^ command with payload to execute - -> ModuleCache + -> (ModuleCache, CoreModuleCache) -> ExecutionConfig -> IO (CommandResult [TxLogJson]) -applyLocal logger gasLogger usePactCore (dbEnv, coreDb) gasModel txCtx spv cmdIn mc execConfig = +applyLocal logger gasLogger usePactCore (dbEnv, coreDb) gasModel txCtx spv cmdIn (mc, cmc) execConfig = evalTransactionM tenv txst go where cmd = payloadObj <$> cmdIn @@ -505,7 +508,7 @@ applyLocal logger gasLogger usePactCore (dbEnv, coreDb) gasModel txCtx spv cmdIn gasLimit = view cmdGasLimit cmd tenv = TransactionEnv Local dbEnv coreDb logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice rk (fromIntegral gasLimit) execConfig - txst = TransactionState mc mempty 0 Nothing gasModel mempty + txst = TransactionState mc cmc mempty 0 Nothing gasModel mempty gas0 = initialGasOf (_cmdPayload cmdIn) applyPayload m = do @@ -532,7 +535,7 @@ readInitModules -- ^ Pact db environment -> TxContext -- ^ tx metadata and parent header - -> IO ModuleCache + -> IO (ModuleCache, CoreModuleCache) readInitModules logger (dbEnv, coreDb) txCtx | chainweb217Pact' = evalTransactionM tenv txst goCw217 | otherwise = evalTransactionM tenv txst go @@ -554,7 +557,7 @@ readInitModules logger (dbEnv, coreDb) txCtx chash = pactInitialHash tenv = TransactionEnv Local dbEnv coreDb logger Nothing (ctxToPublicData txCtx) noSPVSupport nid 0.0 rk 0 def - txst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty + txst = TransactionState mempty mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty interp = defaultInterpreter evalState = def die msg = throwM $ PactInternalError $ "readInitModules: " <> msg @@ -569,7 +572,7 @@ readInitModules logger (dbEnv, coreDb) txCtx (o:_) -> return o - go :: TransactionM logger p ModuleCache + go :: TransactionM logger p (ModuleCache, CoreModuleCache) go = do -- see if fungible-v2 is there @@ -597,18 +600,22 @@ readInitModules logger (dbEnv, coreDb) txCtx void $ run "load modules" refModsCmd -- return loaded cache - use txCache + c <- use txCache + cc <- use txCoreCache + pure (c, cc) -- Only load coin and its dependencies for chainweb >=2.17 -- Note: no need to check if things are there, because this -- requires a block height that witnesses the invariant. -- -- if this changes, we must change the filter in 'updateInitCache' - goCw217 :: TransactionM logger p ModuleCache + goCw217 :: TransactionM logger p (ModuleCache, CoreModuleCache) goCw217 = do coinDepCmd <- liftIO $ mkCmd "coin.MINIMUM_PRECISION" void $ run "load modules" coinDepCmd - use txCache + c <- use txCache + cc <- use txCoreCache + pure (c, cc) -- | Apply (forking) upgrade transactions and module cache updates -- at a particular blockheight. @@ -624,18 +631,24 @@ applyUpgrades => ChainwebVersion -> Chainweb.ChainId -> BlockHeight - -> TransactionM logger p (Maybe ModuleCache) + -> TransactionM logger p (Maybe (ModuleCache, CoreModuleCache)) applyUpgrades v cid height | Just upg <- v ^? versionUpgrades . onChain cid . at height . _Just = applyUpgrade upg | cleanModuleCache v cid height = filterModuleCache | otherwise = return Nothing where - installCoinModuleAdmin = set (evalCapabilities . capModuleAdmin) $ S.singleton (ModuleName "coin" Nothing) + coinModuleName = ModuleName "coin" Nothing + coinCoreModuleName = PCore.ModuleName "coin" Nothing + installCoinModuleAdmin = set (evalCapabilities . capModuleAdmin) $ S.singleton coinModuleName filterModuleCache = do mc <- use txCache - pure $ Just $ filterModuleCacheByKey (== "coin") mc + cmc <- use txCoreCache + pure $ Just $ + ( filterModuleCacheByKey (== coinModuleName) mc + , filterCoreModuleCacheByKey (== coinCoreModuleName) cmc + ) applyUpgrade upg = do infoLog "Applying upgrade!" @@ -652,7 +665,7 @@ applyUpgrades v cid height caches <- local (txExecutionConfig .~ ExecutionConfig flags) (mapM applyTx payloads) - return $ Just $ mconcat $ reverse caches + return $ Just $ bimap mconcat mconcat $ unzip $ reverse caches interp = initStateInterpreter $ installCoinModuleAdmin @@ -663,7 +676,10 @@ applyUpgrades v cid height infoLog $ "Running upgrade tx " <> sshow (_cmdHash tx) tryAllSynchronous (runGenesis tx permissiveNamespacePolicy interp evalState) >>= \case - Right _ -> use txCache + Right _ -> do + c <- use txCache + cc <- use txCoreCache + pure (c, cc) Left e -> do logError $ "Upgrade transaction failed! " <> sshow e throwM e @@ -1110,6 +1126,17 @@ setModuleCache mcache es = c = moduleCacheToHashMap mcache {-# INLINE setModuleCache #-} +setCoreModuleCache + :: CoreModuleCache + -> PCore.EvalState PCore.RawBuiltin () + -> PCore.EvalState PCore.RawBuiltin () +setCoreModuleCache mcache es = + let allDeps = foldMap PCore.allModuleExports $ _getCoreModuleCache mcache + in set (PCore.esLoaded . PCore.loAllLoaded) allDeps $ set (PCore.esLoaded . PCore.loModules) c es + where + c = _getCoreModuleCache mcache +{-# INLINE setCoreModuleCache #-} + -- | Set tx result state -- setTxResultState :: EvalResult -> TransactionM logger db () @@ -1148,11 +1175,7 @@ mkCoreEvalEnv nsp MsgData{..} = do convertAesonValue av = A.parseMaybe A.parseJSON av convertQualName QualifiedName{..} = PCore.QualifiedName { PCore._qnName = _qnName - , PCore._qnModName = _qnQual & \ModuleName{..} -> - PCore.ModuleName - { PCore._mnName = _mnName - , PCore._mnNamespace = fmap coerce _mnNamespace - } + , PCore._qnModName = _qnQual & convertModuleName } let diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index b250abb314..e12b7572b9 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -43,6 +43,7 @@ module Chainweb.Pact.Types , txGasId , txLogs , txCache + , txCoreCache , txWarnings -- * Transaction Env @@ -114,6 +115,9 @@ module Chainweb.Pact.Types , getInitCache , updateInitCache + , CoreModuleCache(..) + , filterCoreModuleCacheByKey + -- * Pact Service Monad , PactServiceM(..) , runPactServiceM @@ -207,6 +211,7 @@ import Chainweb.Miner.Pact import Chainweb.Logger import Chainweb.Pact.Backend.DbCache import Chainweb.Pact.Backend.Types +import Chainweb.Pact.Conversions import Chainweb.Pact.Service.Types import Chainweb.Payload.PayloadStore import Chainweb.Time @@ -215,15 +220,26 @@ import Chainweb.Utils import Chainweb.Version import Utils.Logging.Trace -import qualified Pact.Core.Builtin as PCore +import qualified Pact.Core.Evaluate as PCore import qualified Pact.Core.Compile as PCore -import qualified Pact.Core.Environment as PCore -import qualified Pact.Core.Errors as PCore +import qualified Pact.Core.Capabilities as PCore import qualified Pact.Core.Info as PCore -import qualified Pact.Core.IR.Eval.RawBuiltin as PCore -import qualified Pact.Core.IR.Eval.Runtime as PCore -import qualified Pact.Core.IR.Term as PCore +import qualified Pact.Core.Names as PCore +import qualified Pact.Core.Namespace as PCore import qualified Pact.Core.Persistence as PCore +import qualified Pact.Core.Pretty as PCore +import qualified Pact.Core.Gas as PCore +import qualified Pact.Core.Hash as PCore +import qualified Pact.Core.Errors as PCore +import qualified Pact.Core.Debug as PCore +import qualified Pact.Core.Serialise.LegacyPact as PCore +import qualified Pact.Core.PactValue as PCore +import qualified Pact.Core.Environment as PCore +import qualified Pact.Core.IR.Term as PCore +import qualified Pact.Core.Builtin as PCore +import qualified Pact.Core.Syntax.ParseTree as PCore +import qualified Pact.Core.DefPacts.Types as PCore +import qualified Pact.Core.Scheme as PCore data Transactions r = Transactions { _transactionPairs :: !(Vector (ChainwebTransaction, r)) @@ -262,6 +278,9 @@ newtype CoinbaseUsePrecompiled = CoinbaseUsePrecompiled Bool newtype ModuleCache = ModuleCache { _getModuleCache :: LHM.HashMap ModuleName (ModuleData Ref, Bool) } deriving newtype (Semigroup, Monoid, NFData) +newtype CoreModuleCache = CoreModuleCache { _getCoreModuleCache :: M.Map PCore.ModuleName (PCore.ModuleData PCore.RawBuiltin ()) } + deriving newtype (Semigroup, Monoid, NFData) + filterModuleCacheByKey :: (ModuleName -> Bool) -> ModuleCache @@ -270,6 +289,14 @@ filterModuleCacheByKey f (ModuleCache c) = ModuleCache $ LHM.fromList $ filter (f . fst) $ LHM.toList c {-# INLINE filterModuleCacheByKey #-} +filterCoreModuleCacheByKey + :: (PCore.ModuleName -> Bool) + -> CoreModuleCache + -> CoreModuleCache +filterCoreModuleCacheByKey f (CoreModuleCache c) = CoreModuleCache $ + M.fromList $ filter (f . fst) $ M.toList c +{-# INLINE filterCoreModuleCacheByKey #-} + moduleCacheToHashMap :: ModuleCache -> HM.HashMap ModuleName (ModuleData Ref, Bool) @@ -307,6 +334,7 @@ data ApplyCmdExecutionContext = ApplyLocal | ApplySend -- data TransactionState = TransactionState { _txCache :: !ModuleCache + , _txCoreCache :: !CoreModuleCache , _txLogs :: ![TxLogJson] , _txGasUsed :: !Gas , _txGasId :: !(Maybe GasId) @@ -518,7 +546,7 @@ defaultOnFatalError lf pex t = do where errMsg = pack (show pex) <> "\n" <> t -type ModuleInitCache = M.Map BlockHeight ModuleCache +type ModuleInitCache = M.Map BlockHeight (ModuleCache, CoreModuleCache) data PactServiceState = PactServiceState { _psStateValidated :: !(Maybe BlockHeader) @@ -540,7 +568,7 @@ tracePactServiceM' label param calcWeight a = do return r -- | Look up an init cache that is stored at or before the height of the current parent header. -getInitCache :: PactServiceM logger tbl ModuleCache +getInitCache :: PactServiceM logger tbl (ModuleCache, CoreModuleCache) getInitCache = get >>= \PactServiceState{..} -> case M.lookupLE (pbh _psParentHeader) _psInitCache of Just (_,mc) -> return mc @@ -551,8 +579,8 @@ getInitCache = get >>= \PactServiceState{..} -> -- | Update init cache at adjusted parent block height (APBH). -- Contents are merged with cache found at or before APBH. -- APBH is 0 for genesis and (parent block height + 1) thereafter. -updateInitCache :: ModuleCache -> PactServiceM logger tbl () -updateInitCache mc = get >>= \PactServiceState{..} -> do +updateInitCache :: (ModuleCache, CoreModuleCache) -> PactServiceM logger tbl () +updateInitCache (mc, cmc) = get >>= \PactServiceState{..} -> do let bf 0 = 0 bf h = succ h pbh = bf . _blockHeight . _parentHeader $ _psParentHeader @@ -560,11 +588,11 @@ updateInitCache mc = get >>= \PactServiceState{..} -> do v <- view psVersion psInitCache .= case M.lookupLE pbh _psInitCache of - Nothing -> M.singleton pbh mc - Just (_,before) + Nothing -> M.singleton pbh (mc, cmc) + Just (_,(before, corebefore)) | cleanModuleCache v (_chainId $ _psParentHeader) pbh -> - M.insert pbh mc _psInitCache - | otherwise -> M.insert pbh (before <> mc) _psInitCache + M.insert pbh (mc, cmc) _psInitCache + | otherwise -> M.insert pbh (before <> mc, corebefore <> cmc) _psInitCache -- | Convert context to datatype for Pact environment. -- diff --git a/src/Chainweb/Utils.hs b/src/Chainweb/Utils.hs index a20988ed2e..d08c25595b 100644 --- a/src/Chainweb/Utils.hs +++ b/src/Chainweb/Utils.hs @@ -184,6 +184,7 @@ module Chainweb.Utils -- * Strict Tuples , T2(..) , T3(..) +, T4(..) , sfst , ssnd , scurry @@ -1251,6 +1252,9 @@ instance Bifunctor (T3 a) where bimap f g (T3 a b c) = T3 a (f b) (g c) {-# INLINE bimap #-} +data T4 a b c d = T4 !a !b !c !d + deriving (Show, Eq, Ord, Generic, NFData, Functor) + sfst :: T2 a b -> a sfst (T2 a _) = a {-# INLINE sfst #-} diff --git a/test/Chainweb/Test/Pact/Checkpointer.hs b/test/Chainweb/Test/Pact/Checkpointer.hs index 090f389115..a64a9dbabb 100644 --- a/test/Chainweb/Test/Pact/Checkpointer.hs +++ b/test/Chainweb/Test/Pact/Checkpointer.hs @@ -628,7 +628,7 @@ runExec cp (PactDbEnv' (pactdbenv, coreDb)) eData eCode = do h' = H.toUntypedHash (H.hash "" :: H.PactHash) cmdenv = TransactionEnv Transactional pactdbenv coreDb (_cpLogger cp) Nothing def noSPVSupport Nothing 0.0 (RequestKey h') 0 def - cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty + cmdst = TransactionState mempty mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty runCont :: Checkpointer logger -> PactDbEnv' logger -> PactId -> Int -> IO EvalResult runCont cp (PactDbEnv' (pactdbenv,coreDb)) pactId step = do @@ -640,7 +640,7 @@ runCont cp (PactDbEnv' (pactdbenv,coreDb)) pactId step = do h' = H.toUntypedHash (H.hash "" :: H.PactHash) cmdenv = TransactionEnv Transactional pactdbenv coreDb (_cpLogger cp) Nothing def noSPVSupport Nothing 0.0 (RequestKey h') 0 def - cmdst = TransactionState mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty + cmdst = TransactionState mempty mempty mempty 0 Nothing (_geGasModel freeGasEnv) mempty -- -------------------------------------------------------------------------- -- -- Pact Utils diff --git a/test/Chainweb/Test/Pact/TransactionTests.hs b/test/Chainweb/Test/Pact/TransactionTests.hs index b2763f9dbf..e491635c17 100644 --- a/test/Chainweb/Test/Pact/TransactionTests.hs +++ b/test/Chainweb/Test/Pact/TransactionTests.hs @@ -153,7 +153,7 @@ ccReplTests ccFile = do loadCC :: FilePath -> IO ((PactDbEnv LibState, CoreDb), ModuleCache) loadCC = loadScript -loadScript :: FilePath -> IO ((PactDbEnv LibState, CoreDb), ModuleCache) +loadScript :: FilePath -> IO ((PactDbEnv LibState, CoreDb), (ModuleCache,CoreModuleCache)) loadScript fp = do (r, rst) <- execScript' Quiet fp either fail (const $ return ()) r @@ -358,7 +358,7 @@ testUpgradeScript :: FilePath -> V.ChainId -> BlockHeight - -> (T2 (CommandResult [TxLogJson]) (Maybe ModuleCache) -> IO ()) + -> (T2 (CommandResult [TxLogJson]) (Maybe (ModuleCache, CoreModuleCache)) -> IO ()) -> IO () testUpgradeScript script cid bh test = do (pdb, mc) <- loadScript script