From bd765825be3d490aae2ffb399df10368c8411d57 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Mon, 10 Jun 2024 13:01:26 +0400 Subject: [PATCH] wip: separation pact4 and pact5 --- chainweb.cabal | 6 +- src/Chainweb/Pact/PactService.hs | 69 +- src/Chainweb/Pact/PactService/ExecBlock.hs | 84 +- .../Pact/{Templates.hs => Templates/Pact4.hs} | 84 +- src/Chainweb/Pact/Templates/Pact5.hs | 146 ++ src/Chainweb/Pact/TransactionExec/Pact4.hs | 1396 +++++++++++++++++ .../Pact5.hs} | 825 ++-------- src/Chainweb/Pact/Types.hs | 30 +- 8 files changed, 1784 insertions(+), 856 deletions(-) rename src/Chainweb/Pact/{Templates.hs => Templates/Pact4.hs} (66%) create mode 100644 src/Chainweb/Pact/Templates/Pact5.hs create mode 100644 src/Chainweb/Pact/TransactionExec/Pact4.hs rename src/Chainweb/Pact/{TransactionExec.hs => TransactionExec/Pact5.hs} (62%) diff --git a/chainweb.cabal b/chainweb.cabal index 60540a963..ce8058a13 100644 --- a/chainweb.cabal +++ b/chainweb.cabal @@ -328,8 +328,10 @@ library , Chainweb.Pact.Service.PactInProcApi , Chainweb.Pact.Service.PactQueue , Chainweb.Pact.Service.Types - , Chainweb.Pact.Templates - , Chainweb.Pact.TransactionExec + , Chainweb.Pact.Templates.Pact4 + , Chainweb.Pact.Templates.Pact5 + , Chainweb.Pact.TransactionExec.Pact4 + , Chainweb.Pact.TransactionExec.Pact5 , Chainweb.Pact.Transactions.FungibleV2Transactions , Chainweb.Pact.Transactions.CoinV3Transactions , Chainweb.Pact.Transactions.CoinV4Transactions diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 9dc6b4807..9537930af 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -96,6 +96,8 @@ import qualified Pact.Core.Persistence as PCore import qualified Pact.Core.Gas as PCore import qualified Pact.Core.Gas.TableGasModel as PCore +import qualified Chainweb.Pact.TransactionExec.Pact4 as Pact4 + import Chainweb.BlockHash import Chainweb.BlockHeader import Chainweb.BlockHeaderDB @@ -111,7 +113,6 @@ import Chainweb.Pact.PactService.Checkpointer import Chainweb.Pact.Service.PactQueue (PactQueue, getNextRequest) import Chainweb.Pact.Service.Types import Chainweb.Pact.SPV -import Chainweb.Pact.TransactionExec import Chainweb.Pact.Types import Chainweb.Pact.Validations import Chainweb.Payload @@ -258,7 +259,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 - !mc <- readFrom (Just currentBlockHeader) readInitModules + !mc <- readFrom (Just currentBlockHeader) Pact4.readInitModules updateInitCache mc currentBlockHeader else do logWarn "initializeCoinContract: Starting from genesis." @@ -481,7 +482,7 @@ execNewBlock mpAccess miner = do -- Get and update the module cache initCache <- initModuleCacheForBlock False -- Run the coinbase transaction - cb <- runCoinbase False miner (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) initCache + cb <- runPact4Coinbase False miner (EnforceCoinbaseFailure True) (CoinbaseUsePrecompiled True) initCache successes <- liftIO $ Vec.new @_ @_ @(Pact4Transaction, P.CommandResult [P.TxLogJson]) failures <- liftIO $ Vec.new @_ @_ @TransactionHash @@ -528,11 +529,11 @@ execNewBlock mpAccess miner = do liftIO $! mpaGetBlock mpAccess bfState validate (pHeight + 1) pHash (_parentHeader latestHeader) - refill :: Word64 -> Micros -> GrowableVec (Pact4Transaction, P.CommandResult [P.TxLogJson]) -> GrowableVec TransactionHash -> (ModuleCache, CoreModuleCache) -> BlockFill -> PactBlockM logger tbl BlockFill + refill :: Word64 -> Micros -> GrowableVec (Pact4Transaction, P.CommandResult [P.TxLogJson]) -> GrowableVec TransactionHash -> ModuleCache -> BlockFill -> PactBlockM logger tbl BlockFill refill fetchLimit txTimeLimit successes failures = go where - go :: (ModuleCache, CoreModuleCache) -> BlockFill -> PactBlockM logger tbl BlockFill - go (mc, cmc) unchanged@bfState = do + go :: ModuleCache -> BlockFill -> PactBlockM logger tbl BlockFill + go mc unchanged@bfState = do pdbenv <- view psBlockDbEnv case unchanged of @@ -555,7 +556,7 @@ execNewBlock mpAccess miner = do newTrans <- liftPactServiceM $ getBlockTxs pdbenv bfState if V.null newTrans then pure unchanged else do - T3 pairs mc' cmc' <- execTransactionsOnly miner newTrans (mc, cmc) + T2 pairs mc' <- execTransactionsOnly miner newTrans mc (Just txTimeLimit) `catch` handleTimeout oldSuccessesLength <- liftIO $ Vec.length successes @@ -580,7 +581,7 @@ execNewBlock mpAccess miner = do $ "Invariant failure, gas did not decrease: " <> sshow (bfState,newState,V.length newTrans,addedSuccessCount) else - go (mc', cmc') (incCount newState) + go mc' (incCount newState) incCount :: BlockFill -> BlockFill incCount b = over bfCount succ b @@ -753,7 +754,7 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do PactServiceEnv{..} <- ask let !cmd = payloadObj <$> cwtx - !pm = publicMetaOf cmd + !pm = Pact4.publicMetaOf cmd bhdb <- view psBlockHeaderDb @@ -785,11 +786,11 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do Just PreflightSimulation -> do liftPactServiceM (assertLocalMetadata cmd ctx sigVerify) >>= \case Right{} -> do - let initialGas = initialGasOf $ P._cmdPayload cwtx + let initialGas = Pact4.initialGasOf $ P._cmdPayload cwtx -- TRACE.traceShowM ("execLocal.CACHE: ", LHM.keys $ _getModuleCache mcache, M.keys $ _getCoreModuleCache cmcache) - T4 cr _mc _ warns <- liftIO $ applyCmd - _psVersion _psLogger _psGasLogger (_cpPactDbEnv dbEnv, _cpPactCoreDbEnv dbEnv) - noMiner (gasModel, gasModelCore) ctx spv cmd + T3 cr _mc warns <- liftIO $ Pact4.applyCmd + _psVersion _psLogger _psGasLogger (_cpPactDbEnv dbEnv) + noMiner gasModel ctx spv cmd initialGas mc ApplyLocal let cr' = toHashCommandResult cr @@ -799,13 +800,13 @@ execLocal cwtx preflight sigVerify rdepth = pactLabel "execLocal" $ do _ -> liftIO $ do let execConfig = P.mkExecutionConfig $ [ P.FlagAllowReadInLocal | _psAllowReadsInLocal ] ++ - enablePactEvents' (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) ++ - enforceKeysetFormats' (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) ++ - disableReturnRTC (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) + Pact4.enablePactEvents' (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) ++ + Pact4.enforceKeysetFormats' (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) ++ + Pact4.disableReturnRTC (_chainwebVersion ctx) (_chainId ctx) (ctxCurrentBlockHeight ctx) - cr <- applyLocal - _psLogger _psGasLogger (_cpPactDbEnv dbEnv, _cpPactCoreDbEnv dbEnv) - (gasModel, gasModelCore) ctx spv + cr <- Pact4.applyLocal + _psLogger _psGasLogger (_cpPactDbEnv dbEnv) + gasModel ctx spv cwtx mc execConfig let cr' = toHashCommandResult cr @@ -1023,51 +1024,49 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do -> Vector (Either InsertError Pact4Transaction) -> PactBlockM logger tbl (Vector (Either InsertError Pact4Transaction)) attemptBuyGas miner txsOrErrs = localLabelBlock ("transaction", "attemptBuyGas") $ do - (mc, cmc) <- getInitCache + mc <- getInitCache l <- view (psServiceEnv . psLogger) - V.fromList . toList . sfst <$> V.foldM (buyGasFor l) (T2 mempty (mc, cmc)) txsOrErrs + V.fromList . toList . sfst <$> V.foldM (buyGasFor l) (T2 mempty mc) txsOrErrs where buyGasFor :: logger - -> T2 (DL.DList (Either InsertError Pact4Transaction)) (ModuleCache, CoreModuleCache) + -> T2 (DL.DList (Either InsertError Pact4Transaction)) ModuleCache -> Either InsertError Pact4Transaction - -> PactBlockM logger tbl (T2 (DL.DList (Either InsertError Pact4Transaction)) (ModuleCache, CoreModuleCache)) - buyGasFor _l (T2 dl (mcache,cmcache)) err@Left {} = return (T2 (DL.snoc dl err) (mcache,cmcache)) - buyGasFor l (T2 dl (mcache,cmcache)) (Right tx) = do + -> PactBlockM logger tbl (T2 (DL.DList (Either InsertError Pact4Transaction)) ModuleCache) + buyGasFor _l (T2 dl mcache) err@Left {} = return (T2 (DL.snoc dl err) mcache) + buyGasFor l (T2 dl mcache) (Right tx) = do T2 mcache' !res <- 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 - , _txGasModel = P._geGasModel P.freeGasEnv - , _txGasModelCore = PCore.freeGasModel + , _txGasModel = Left (P._geGasModel P.freeGasEnv) , _txWarnings = mempty } - let !nid = networkIdOf cmd + let !nid = Pact4.networkIdOf cmd let !rk = P.cmdToRequestKey cmd - pd <- getTxContext (publicMetaOf cmd) + pd <- getTxContext (Pact4.publicMetaOf cmd) bhdb <- view (psServiceEnv . psBlockHeaderDb) dbEnv <- view psBlockDbEnv spv <- pactSPV bhdb . _parentHeader <$> view psParentHeader let ec = P.mkExecutionConfig $ [ P.FlagDisableModuleInstall , P.FlagDisableHistoryInTransactionalMode ] ++ - disableReturnRTC (ctxVersion pd) (ctxChainId pd) (ctxCurrentBlockHeight pd) + Pact4.disableReturnRTC (ctxVersion pd) (ctxChainId pd) (ctxCurrentBlockHeight pd) let usePact5 = False - let buyGasEnv = TransactionEnv P.Transactional (_cpPactDbEnv dbEnv) (_cpPactCoreDbEnv dbEnv) l Nothing (ctxToPublicData pd) spv nid gasPrice rk gasLimit ec Nothing usePact5 + let buyGasEnv = TransactionEnv P.Transactional (Left $ _cpPactDbEnv dbEnv) l Nothing (ctxToPublicData pd) spv nid gasPrice rk gasLimit ec Nothing cr <- liftIO $! catchesPactError l CensorsUnexpectedError $! execTransactionM buyGasEnv txst - $! buyGas pd cmd miner + $! Pact4.buyGas pd cmd miner case cr of - Left err -> return (T2 (mcache, cmcache) (Left (InsertErrorBuyGas (T.pack $ show err)))) - Right t -> return (T2 (_txCache t, _txCoreCache t) (Right tx)) + Left err -> return (T2 mcache (Left (InsertErrorBuyGas (T.pack $ show err)))) + Right t -> return (T2 (_txCache t) (Right tx)) pure $! T2 (DL.snoc dl res) mcache' execLookupPactTxs diff --git a/src/Chainweb/Pact/PactService/ExecBlock.hs b/src/Chainweb/Pact/PactService/ExecBlock.hs index f94d1a6b3..b23a90b8f 100644 --- a/src/Chainweb/Pact/PactService/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/ExecBlock.hs @@ -29,7 +29,7 @@ module Chainweb.Pact.PactService.ExecBlock , validateHashes , throwCommandInvalidError , initModuleCacheForBlock - , runCoinbase + , runPact4Coinbase , CommandInvalidError(..) ) where @@ -89,7 +89,8 @@ import Chainweb.Pact.Backend.Types import Chainweb.Pact.NoCoinbase import Chainweb.Pact.Service.Types import Chainweb.Pact.SPV -import Chainweb.Pact.TransactionExec +import Chainweb.Pact.TransactionExec.Pact4 +import qualified Chainweb.Pact.TransactionExec.Pact5 as Pact5 import Chainweb.Pact.Types import Chainweb.Pact.Validations import Chainweb.Payload @@ -116,6 +117,9 @@ execBlock currHeader payload = do let plData = checkablePayloadToPayloadData payload dbEnv <- view psBlockDbEnv miner <- decodeStrictOrThrow' (_minerData $ _payloadDataMiner plData) + + -- if + trans <- liftIO $ pact4TransactionsFromPayload (pactParserVersion v (_blockChainId currHeader) (_blockHeight currHeader)) plData @@ -153,7 +157,7 @@ execBlock currHeader payload = do fromIntegral <$> maxBlockGasLimit v (_blockHeight currHeader) logInitCache = liftPactServiceM $ do - mc <- fmap (fmap instr . _getModuleCache . fst) <$> use psInitCache + mc <- fmap (fmap instr . _getModuleCache) <$> use psInitCache logDebug $ "execBlock: initCache: " <> sshow mc instr (md,_) = preview (P._MDModule . P.mHash) $ P._mdModule md @@ -303,28 +307,28 @@ execTransactions -> CoinbaseUsePrecompiled -> Maybe P.Gas -> Maybe Micros - -> PactBlockM logger tbl (Transactions (Either CommandInvalidError (Either (P.CommandResult [P.TxLogJson]) PCore.CommandResult))) + -> PactBlockM logger tbl (Transactions (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) execTransactions isGenesis miner ctxs enfCBFail usePrecomp gasLimit timeLimit = do mc <- initModuleCacheForBlock isGenesis -- for legacy reasons (ask Emily) we don't use the module cache resulting -- from coinbase to run the pact cmds - coinOut <- runCoinbase isGenesis miner enfCBFail usePrecomp mc - T3 txOuts _mcOut _cmcOut <- applyPactCmds isGenesis ctxs miner mc gasLimit timeLimit + coinOut <- runPact4Coinbase isGenesis miner enfCBFail usePrecomp mc + T2 txOuts _mcOut <- applyPactCmds isGenesis ctxs miner mc gasLimit timeLimit return $! Transactions (V.zip ctxs txOuts) coinOut execTransactionsOnly :: (Logger logger) => Miner -> Vector Pact4Transaction - -> (ModuleCache, CoreModuleCache) + -> ModuleCache -> Maybe Micros -> PactBlockM logger tbl - (T3 (Vector (Pact4Transaction, Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache CoreModuleCache) -execTransactionsOnly miner ctxs (mc, cmc) txTimeLimit = do - T3 txOuts mcOut cmcOut <- applyPactCmds False ctxs miner (mc, cmc) Nothing txTimeLimit - return $! T3 (V.force (V.zip ctxs txOuts)) mcOut cmcOut + (T2 (Vector (Pact4Transaction, Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache) +execTransactionsOnly miner ctxs mc txTimeLimit = do + T2 txOuts mcOut <- applyPactCmds False ctxs miner mc Nothing txTimeLimit + return $! T2 (V.force (V.zip ctxs txOuts)) mcOut -initModuleCacheForBlock :: (Logger logger) => Bool -> PactBlockM logger tbl (ModuleCache, CoreModuleCache) +initModuleCacheForBlock :: (Logger logger) => Bool -> PactBlockM logger tbl ModuleCache initModuleCacheForBlock isGenesis = do PactServiceState{..} <- get pbh <- views psParentHeader (_blockHeight . _parentHeader) @@ -333,23 +337,23 @@ initModuleCacheForBlock isGenesis = do txCtx <- getTxContext def case Map.lookupLE pbh _psInitCache of Nothing -> if isGenesis - then return (mempty, mempty) + then return mempty else do mc <- readInitModules updateInitCacheM mc return mc - Just (_,(mc, cmc)) -> pure (mc, cmc) + Just (_,mc) -> pure mc -runCoinbase +runPact4Coinbase :: (Logger logger) => Bool -> Miner -> EnforceCoinbaseFailure -> CoinbaseUsePrecompiled - -> (ModuleCache, CoreModuleCache) - -> PactBlockM logger tbl (Either (P.CommandResult [P.TxLogJson]) PCore.CommandResult) -runCoinbase True _ _ _ _ = return noCoinbase -runCoinbase False miner enfCBFail usePrecomp (mc, cmc) = do + -> ModuleCache + -> PactBlockM logger tbl (P.CommandResult [P.TxLogJson]) +runPact4Coinbase True _ _ _ _ = return noCoinbase +runPact4Coinbase False miner enfCBFail usePrecomp mc = do logger <- view (psServiceEnv . psLogger) rs <- view (psServiceEnv . psMinerRewards) v <- view chainwebVersion @@ -361,9 +365,9 @@ runCoinbase False miner enfCBFail usePrecomp (mc, cmc) = do dbEnv <- view psBlockDbEnv T2 cr upgradedCacheM <- - liftIO $ applyCoinbase v logger (_cpPactDbEnv dbEnv, _cpPactCoreDbEnv dbEnv) miner reward txCtx enfCBFail usePrecomp (mc, cmc) + liftIO $ applyCoinbase v logger (_cpPactDbEnv dbEnv) miner reward txCtx enfCBFail usePrecomp mc mapM_ upgradeInitCache upgradedCacheM - liftPactServiceM $ debugResult "runCoinbase" (P.crLogs %~ fmap J.Array $ cr) + liftPactServiceM $ debugResult "runPact4Coinbase" (P.crLogs %~ fmap J.Array $ cr) return $! cr where @@ -384,22 +388,22 @@ applyPactCmds => Bool -> Vector Pact4Transaction -> Miner - -> (ModuleCache, CoreModuleCache) + -> ModuleCache -> Maybe P.Gas -> Maybe Micros - -> PactBlockM logger tbl (T3 (Vector (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache CoreModuleCache) -applyPactCmds isGenesis cmds miner (mc, cmc) blockGas txTimeLimit = do + -> PactBlockM logger tbl (T2 (Vector (Either CommandInvalidError (P.CommandResult [P.TxLogJson]))) ModuleCache) +applyPactCmds isGenesis cmds miner mc blockGas txTimeLimit = do let txsGas txs = fromIntegral $ sumOf (traversed . _Right . to P._crGas) txs - (txOuts, T3 mcOut cmcOut _) <- tracePactBlockM' "applyPactCmds" () (txsGas . fst) $ - flip runStateT (T3 mc cmc blockGas) $ + (txOuts, T2 mcOut _) <- tracePactBlockM' "applyPactCmds" () (txsGas . fst) $ + flip runStateT (T2 mc blockGas) $ go [] (V.toList cmds) - return $! T3 (V.fromList . List.reverse $ txOuts) mcOut cmcOut + return $! T2 (V.fromList . List.reverse $ txOuts) mcOut where go :: [Either CommandInvalidError (P.CommandResult [P.TxLogJson])] -> [Pact4Transaction] -> StateT - (T3 ModuleCache CoreModuleCache (Maybe P.Gas)) + (T2 ModuleCache (Maybe P.Gas)) (PactBlockM logger tbl) [Either CommandInvalidError (P.CommandResult [P.TxLogJson])] go !acc = \case @@ -422,10 +426,10 @@ applyPactCmd -> Maybe Micros -> Pact4Transaction -> StateT - (T3 ModuleCache CoreModuleCache (Maybe P.Gas)) + (T2 ModuleCache (Maybe P.Gas)) (PactBlockM logger tbl) (Either CommandInvalidError (P.CommandResult [P.TxLogJson])) -applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache maybeBlockGasRemaining) -> do +applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining) -> do dbEnv <- view psBlockDbEnv prevBlockState <- liftIO $ fmap _benvBlockState $ readMVar $ pdPactDbVar $ _cpPactDbEnv dbEnv @@ -437,7 +441,7 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache mayb let -- for errors so fatal that the tx doesn't make it in the block onFatalError e - | Just (BuyGasFailure f) <- fromException e = pure (Left (CommandInvalidGasPurchaseFailure f), T3 mcache cmcache maybeBlockGasRemaining) + | Just (BuyGasFailure f) <- fromException e = pure (Left (CommandInvalidGasPurchaseFailure f), T2 mcache maybeBlockGasRemaining) | Just t@(TxTimeout {}) <- fromException e = do -- timeouts can occur at any point during the transaction, even after -- gas has been bought (or even while gas is being redeemed, after the @@ -446,7 +450,7 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache mayb liftIO $ P.modifyMVar' (pdPactDbVar $ _cpPactDbEnv dbEnv) (benvBlockState .~ prevBlockState) - pure (Left (CommandInvalidTxTimeout t), T3 mcache cmcache maybeBlockGasRemaining) + 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 @@ -464,10 +468,10 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache mayb let !hsh = P._cmdHash cmd handle onFatalError $ do - T2 result (mcache', cmcache') <- do + T2 result mcache' <- do txCtx <- getTxContext (publicMetaOf gasLimitedCmd) if isGenesis - then liftIO $! applyGenesisCmd logger (_cpPactDbEnv dbEnv, _cpPactCoreDbEnv dbEnv) P.noSPVSupport txCtx gasLimitedCmd + then liftIO $! applyGenesisCmd logger (_cpPactDbEnv dbEnv) P.noSPVSupport txCtx gasLimitedCmd else do bhdb <- view (psServiceEnv . psBlockHeaderDb) parent <- view psParentHeader @@ -478,15 +482,15 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache mayb Nothing -> id Just limit -> maybe (throwM timeoutError) return <=< timeout (fromIntegral limit) - txGas (T4 r _ _ _) = fromIntegral $ P._crGas r - T4 r c cc _warns <- do + txGas (T3 r _ _) = fromIntegral $ P._crGas r + T3 r c _warns <- do -- TRACE.traceShowM ("applyPactCmd.CACHE: ", LHM.keys $ _getModuleCache mcache, M.keys $ _getCoreModuleCache cmcache) tracePactBlockM' "applyCmd" (J.toJsonViaEncode hsh) txGas $ do - liftIO $ txTimeout $ applyCmd v logger gasLogger (_cpPactDbEnv dbEnv, _cpPactCoreDbEnv dbEnv) miner (gasModel txCtx, gasModelCore txCtx) txCtx spv gasLimitedCmd initialGas (mcache, cmcache) ApplySend - pure $ T2 r (c, cc) + liftIO $ txTimeout $ applyCmd v logger gasLogger (_cpPactDbEnv dbEnv) miner (gasModel txCtx) txCtx spv gasLimitedCmd initialGas mcache ApplySend + pure $ T2 r c if isGenesis - then updateInitCacheM (mcache', cmcache') + then updateInitCacheM mcache' else liftPactServiceM $ debugResult "applyPactCmd" (P.crLogs %~ fmap J.Array $ result) -- mark the tx as processed at the checkpointer. @@ -501,7 +505,7 @@ applyPactCmd isGenesis miner txTimeLimit cmd = StateT $ \(T3 mcache cmcache mayb throwM $ BlockGasLimitExceeded (blockGasRemaining - fromIntegral requestedTxGasLimit) Nothing -> return () let maybeBlockGasRemaining' = (\g -> g - P._crGas result) <$> maybeBlockGasRemaining - pure (Right result, T3 mcache' cmcache' maybeBlockGasRemaining') + pure (Right result, T2 mcache' 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/Templates.hs b/src/Chainweb/Pact/Templates/Pact4.hs similarity index 66% rename from src/Chainweb/Pact/Templates.hs rename to src/Chainweb/Pact/Templates/Pact4.hs index 11003c602..f0dd577ef 100644 --- a/src/Chainweb/Pact/Templates.hs +++ b/src/Chainweb/Pact/Templates/Pact4.hs @@ -14,17 +14,12 @@ -- -- Prebuilt Term templates for automated operations (coinbase, gas buy) -- -module Chainweb.Pact.Templates +module Chainweb.Pact.Templates.Pact4 ( mkFundTxTerm , mkBuyGasTerm , mkRedeemGasTerm , mkCoinbaseTerm -, mkFundTxCoreTerm -, mkBuyGasCoreTerm -, mkRedeemGasCoreTerm -, mkCoinbaseCoreTerm - , mkCoinbaseCmd ) where @@ -48,12 +43,6 @@ import Chainweb.Miner.Pact import Chainweb.Pact.Types import Chainweb.Pact.Service.Types -import qualified Pact.Core.Literal as Core -import qualified Pact.Core.Names as Core -import qualified Pact.Core.Info as PCore -import qualified Pact.Core.Syntax.ParseTree as CoreLisp - - inf :: Info inf = Info $ Just (Code "",Parsed (Columns 0 0) 0) {-# NOINLINE inf #-} @@ -100,22 +89,6 @@ buyGasTemplate = , strArgSetter 0 ) -fundTxTemplateCore :: Text -> Text -> CoreLisp.Expr PCore.SpanInfo -fundTxTemplateCore sender mid = - let senderTerm = coreStrLit sender - midTerm = coreStrLit mid - varApp = coreQn "fund-tx" "coin" - rks = coreApp (coreBn "read-keyset") [coreStrLit "miner-keyset"] - rds = coreApp (coreBn "read-decimal") [coreStrLit "total"] - in coreApp varApp [senderTerm, midTerm, rks, rds] - -buyGasTemplateCore :: Text -> CoreLisp.Expr PCore.SpanInfo -buyGasTemplateCore sender = - let senderTerm = coreStrLit sender - varApp = coreQn "buy-gas" "coin" - rds = coreApp (coreBn "read-decimal") [coreStrLit "total"] - in coreApp varApp [senderTerm, rds] - redeemGasTemplate :: (Term Name, ASetter' (Term Name) Text, ASetter' (Term Name) Text) redeemGasTemplate = ( app (qn "coin" "redeem-gas") @@ -128,27 +101,6 @@ redeemGasTemplate = , strArgSetter 0 ) -redeemGasTemplateCore :: Text -> Text -> CoreLisp.Expr PCore.SpanInfo -redeemGasTemplateCore mid sender = - let midTerm = coreStrLit mid - senderTerm = coreStrLit sender - varApp = coreQn "redeem-gas" "coin" - rks = coreApp (coreBn "read-keyset") [coreStrLit "miner-keyset"] - rds = coreApp (coreBn "read-decimal") [coreStrLit "total"] - in coreApp varApp [midTerm, rks, senderTerm, rds] - -coreApp :: CoreLisp.Expr PCore.SpanInfo -> [CoreLisp.Expr PCore.SpanInfo] -> CoreLisp.Expr PCore.SpanInfo -coreApp arg args = CoreLisp.App arg args def - -coreStrLit :: Text -> CoreLisp.Expr PCore.SpanInfo -coreStrLit txt = CoreLisp.Constant (Core.LString txt) def - -coreQn :: Text -> Text -> CoreLisp.Expr PCore.SpanInfo -coreQn name modname = CoreLisp.Var (Core.QN (Core.QualifiedName name (Core.ModuleName modname Nothing))) def - -coreBn :: Text -> CoreLisp.Expr PCore.SpanInfo -coreBn name = CoreLisp.Var (Core.BN (Core.BareName name)) def - dummyParsedCode :: ParsedCode dummyParsedCode = ParsedCode "1" [ELiteral $ LiteralExp (LInteger 1) def] {-# NOINLINE dummyParsedCode #-} @@ -200,26 +152,6 @@ mkRedeemGasTerm (MinerId mid) (MinerKeys ks) sender total fee = (populatedTerm, ] {-# INLINABLE mkRedeemGasTerm #-} -mkFundTxCoreTerm - :: MinerId -- ^ Id of the miner to fund - -> Text -- ^ Address of the sender from the command - -> CoreLisp.Expr PCore.SpanInfo -mkFundTxCoreTerm (MinerId mid) sender = fundTxTemplateCore sender mid -{-# INLINABLE mkFundTxCoreTerm #-} - -mkBuyGasCoreTerm - :: Text -- ^ Address of the sender from the command - -> CoreLisp.Expr PCore.SpanInfo -mkBuyGasCoreTerm sender = buyGasTemplateCore sender -{-# INLINABLE mkBuyGasCoreTerm #-} - -mkRedeemGasCoreTerm - :: MinerId -- ^ Id of the miner to fund - -> Text -- ^ Address of the sender from the command - -> CoreLisp.Expr PCore.SpanInfo -mkRedeemGasCoreTerm (MinerId mid) sender = redeemGasTemplateCore mid sender -{-# INLINABLE mkRedeemGasCoreTerm #-} - coinbaseTemplate :: (Term Name,ASetter' (Term Name) Text) coinbaseTemplate = ( app (qn "coin" "coinbase") @@ -231,14 +163,6 @@ coinbaseTemplate = ) {-# NOINLINE coinbaseTemplate #-} -coinbaseTemplateCore :: Text -> CoreLisp.Expr PCore.SpanInfo -coinbaseTemplateCore mid = - let midTerm = coreStrLit mid - varApp = coreQn "coinbase" "coin" - rks = coreApp (coreBn "read-keyset") [coreStrLit "miner-keyset"] - rds = coreApp (coreBn "read-decimal") [coreStrLit "reward"] - in coreApp varApp [midTerm, rks, rds] - mkCoinbaseTerm :: MinerId -> MinerKeys -> ParsedDecimal -> (Term Name,ExecMsg ParsedCode) mkCoinbaseTerm (MinerId mid) (MinerKeys ks) reward = (populatedTerm, execMsg) where @@ -251,12 +175,6 @@ mkCoinbaseTerm (MinerId mid) (MinerKeys ks) reward = (populatedTerm, execMsg) ] {-# INLINABLE mkCoinbaseTerm #-} -mkCoinbaseCoreTerm - :: MinerId -- ^ Id of the miner to fund - -> CoreLisp.Expr PCore.SpanInfo -mkCoinbaseCoreTerm (MinerId mid) = coinbaseTemplateCore mid -{-# INLINABLE mkCoinbaseCoreTerm #-} - -- | "Old method" to build a coinbase 'ExecMsg' for back-compat. -- mkCoinbaseCmd :: MinerId -> MinerKeys -> ParsedDecimal -> IO (ExecMsg ParsedCode) diff --git a/src/Chainweb/Pact/Templates/Pact5.hs b/src/Chainweb/Pact/Templates/Pact5.hs new file mode 100644 index 000000000..70cbcd6cc --- /dev/null +++ b/src/Chainweb/Pact/Templates/Pact5.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Chainweb.Pact.Templates +-- Copyright : Copyright © 2010 Kadena LLC. +-- License : (see the file LICENSE) +-- Maintainer : Stuart Popejoy +-- Stability : experimental +-- +-- Prebuilt Term templates for automated operations (coinbase, gas buy) +-- +module Chainweb.Pact.Templates.Pact5 +( mkFundTxTerm +, mkBuyGasTerm +, mkRedeemGasTerm +, mkCoinbaseTerm +) where + + +import Control.Lens +import Data.Default (def) +import Data.Decimal +import Data.Text (Text, pack) + +import Text.Trifecta.Delta (Delta(..)) + +-- internal modules + +import qualified Pact.Types.RPC as Pact4 +import qualified Pact.JSON.Encode as J +import qualified Pact.JSON.Legacy.Value as J + +import Chainweb.Miner.Pact +import Chainweb.Pact.Types +import Chainweb.Pact.Service.Types + +import Pact.Core.Evaluate +import Pact.Core.Literal +import Pact.Core.Names +import Pact.Core.Info +import Pact.Core.Syntax.ParseTree + +fundTxTemplate :: Text -> Text -> Expr SpanInfo +fundTxTemplate sender mid = + let senderTerm = strLit sender + midTerm = strLit mid + varApp = qn "fund-tx" "coin" + rks = app (bn "read-keyset") [strLit "miner-keyset"] + rds = app (bn "read-decimal") [strLit "total"] + in app varApp [senderTerm, midTerm, rks, rds] + +buyGasTemplate :: Text -> Expr SpanInfo +buyGasTemplate sender = + let senderTerm = strLit sender + varApp = qn "buy-gas" "coin" + rds = app (bn "read-decimal") [strLit "total"] + in app varApp [senderTerm, rds] + +redeemGasTemplate :: Text -> Text -> Expr SpanInfo +redeemGasTemplate mid sender = + let midTerm = strLit mid + senderTerm = strLit sender + varApp = qn "redeem-gas" "coin" + rks = app (bn "read-keyset") [strLit "miner-keyset"] + rds = app (bn "read-decimal") [strLit "total"] + in app varApp [midTerm, rks, senderTerm, rds] + +app :: Expr SpanInfo -> [Expr SpanInfo] -> Expr SpanInfo +app arg args = App arg args def + +strLit :: Text -> Expr SpanInfo +strLit txt = Constant (LString txt) def + +qn :: Text -> Text -> Expr SpanInfo +qn name modname = Var (QN (QualifiedName name (ModuleName modname Nothing))) def + +bn :: Text -> Expr SpanInfo +bn name = Var (BN (BareName name)) def + +mkFundTxTerm + :: MinerId -- ^ Id of the miner to fund + -> MinerKeys + -> Text -- ^ Address of the sender from the command + -> GasSupply + -> (Expr SpanInfo, Pact4.ExecMsg RawCode) +mkFundTxTerm (MinerId mid) (MinerKeys ks) sender total = + let + term = fundTxTemplate sender mid + buyGasData = J.object + [ "miner-keyset" J..= ks + , "total" J..= total + ] + execMsg = Pact4.ExecMsg (RawCode "") (J.toLegacyJsonViaEncode buyGasData) + in (term, execMsg) +{-# INLINABLE mkFundTxTerm #-} + +mkBuyGasTerm + :: Text -- ^ Address of the sender from the command + -> GasSupply + -> (Expr SpanInfo, Pact4.ExecMsg RawCode) +mkBuyGasTerm sender total = (buyGasTemplate sender, execMsg) + where + execMsg = Pact4.ExecMsg (RawCode "") (J.toLegacyJsonViaEncode buyGasData) + buyGasData = J.object + [ "total" J..= total ] +{-# INLINABLE mkBuyGasTerm #-} + +mkRedeemGasTerm + :: MinerId -- ^ Id of the miner to fund + -> MinerKeys -- ^ Miner keyset + -> Text -- ^ Address of the sender from the command + -> GasSupply -- ^ The gas limit total * price + -> GasSupply -- ^ The gas used * price + -> (Expr SpanInfo, Pact4.ExecMsg RawCode) +mkRedeemGasTerm (MinerId mid) (MinerKeys ks) sender total fee = (redeemGasTemplate mid sender, execMsg) + where + execMsg = Pact4.ExecMsg (RawCode "") (J.toLegacyJsonViaEncode redeemGasData) + redeemGasData = J.object + [ "total" J..= total + , "fee" J..= J.toJsonViaEncode fee + , "miner-keyset" J..= ks + ] +{-# INLINABLE mkRedeemGasTerm #-} + +coinbaseTemplate :: Text -> Expr SpanInfo +coinbaseTemplate mid = + let midTerm = strLit mid + varApp = qn "coinbase" "coin" + rks = app (bn "read-keyset") [strLit "miner-keyset"] + rds = app (bn "read-decimal") [strLit "reward"] + in app varApp [midTerm, rks, rds] + +mkCoinbaseTerm :: MinerId -> MinerKeys -> GasSupply -> (Expr SpanInfo, Pact4.ExecMsg RawCode) +mkCoinbaseTerm (MinerId mid) (MinerKeys ks) reward = (coinbaseTemplate mid, execMsg) + where + execMsg = Pact4.ExecMsg (RawCode "") (J.toLegacyJsonViaEncode coinbaseData) + coinbaseData = J.object + [ "miner-keyset" J..= ks + , "reward" J..= reward + ] +{-# INLINABLE mkCoinbaseTerm #-} \ No newline at end of file diff --git a/src/Chainweb/Pact/TransactionExec/Pact4.hs b/src/Chainweb/Pact/TransactionExec/Pact4.hs new file mode 100644 index 000000000..63db1b3b8 --- /dev/null +++ b/src/Chainweb/Pact/TransactionExec/Pact4.hs @@ -0,0 +1,1396 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Chainweb.Pact.TransactionExec +-- Copyright : Copyright © 2018 Kadena LLC. +-- License : (see the file LICENSE) +-- Maintainer : Mark Nichols , Emily Pillmore +-- Stability : experimental +-- +-- Pact command execution and coin-contract transaction logic for Chainweb +-- +module Chainweb.Pact.TransactionExec.Pact4 +( -- * Transaction Execution + applyCmd +, applyGenesisCmd +, applyLocal +, applyExec +, applyExec' +, applyContinuation +, applyContinuation' +, runPayload +, readInitModules +, enablePactEvents' +, enforceKeysetFormats' +, disableReturnRTC + + -- * Gas Execution +, buyGas + + -- * Coinbase Execution +, applyCoinbase +, EnforceCoinbaseFailure(..) + + -- * Command Helpers +, publicMetaOf +, networkIdOf +, gasSupplyOf + + -- * Utilities +, buildExecParsedCode +, mkMagicCapSlot +, listErrMsg +, initialGasOf + +) where + +import Control.DeepSeq +import Control.Lens +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Trans.Maybe +import Control.Parallel.Strategies(using, rseq) + +import Data.Aeson hiding ((.=)) +import qualified Data.Aeson as A +import Data.Bifunctor +import qualified Data.ByteString as B +import qualified Data.ByteString.Short as SB +import Data.Decimal (Decimal, roundTo) +import Data.Default (def) +import Data.Foldable (fold, for_) +import Data.IORef +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +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 +import qualified Pact.JSON.Encode as J +import Pact.JSON.Legacy.Value +import Pact.Native.Capabilities (evalCap) +import Pact.Native.Internal (appToCap) +import Pact.Parse (ParsedDecimal(..)) +import Pact.Runtime.Capabilities (popCapStack) +import Pact.Runtime.Utils (lookupModule) +import Pact.Types.Capability +import Pact.Types.Command +import Pact.Types.Hash as Pact +import Pact.Types.KeySet +import Pact.Types.PactValue +import Pact.Types.Pretty +import Pact.Types.RPC +import Pact.Types.Runtime hiding (catchesPactError) +import Pact.Types.Server +import Pact.Types.SPV +import Pact.Types.Verifier + +import Pact.Types.Util as PU + +-- internal Chainweb modules + +import Chainweb.BlockHeader +import Chainweb.BlockHeight +import Chainweb.Logger +import qualified Chainweb.ChainId as Chainweb +import Chainweb.Mempool.Mempool (requestKeyToTransactionHash) +import Chainweb.Miner.Pact +import Chainweb.Pact.Service.Types +import Chainweb.Pact.Templates.Pact4 +import Chainweb.Pact.Types hiding (logError) +import Chainweb.Transaction +import Chainweb.Utils (encodeToByteString, sshow, tryAllSynchronous, T2(..), T3(..)) +import Chainweb.VerifierPlugin +import Chainweb.Version as V +import Chainweb.Version.Guards as V +import Chainweb.Version.Utils as V +import Pact.JSON.Encode (toJsonViaEncode) + +-- Note [Throw out verifier proofs eagerly] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We try to discard verifier proofs eagerly so that we don't hang onto them in +-- the liveset. This implies that we also try to discard `Command`s for the same +-- reason, because they contain the verifier proofs and other data we probably +-- don't need. + +-- -------------------------------------------------------------------------- -- + +-- | "Magic" capability 'COINBASE' used in the coin contract to +-- constrain coinbase calls. +-- +magic_COINBASE :: CapSlot SigCapability +magic_COINBASE = mkMagicCapSlot "COINBASE" + +-- | "Magic" capability 'GAS' used in the coin contract to +-- constrain gas buy/redeem calls. +-- +magic_GAS :: CapSlot SigCapability +magic_GAS = mkMagicCapSlot "GAS" + +-- | "Magic" capability 'GENESIS' used in the coin contract to +-- constrain genesis-only allocations +-- +magic_GENESIS :: CapSlot SigCapability +magic_GENESIS = mkMagicCapSlot "GENESIS" + +debitCap :: Text -> SigCapability +debitCap s = mkCoinCap "DEBIT" [PLiteral (LString s)] + +onChainErrorPrintingFor :: TxContext -> UnexpectedErrorPrinting +onChainErrorPrintingFor txCtx = + if guardCtx chainweb219Pact txCtx + then CensorsUnexpectedError + else PrintsUnexpectedError + +-- | The main entry point to executing transactions. From here, +-- 'applyCmd' assembles the command environment for a command and +-- orchestrates gas buys/redemption, and executing payloads. +-- +applyCmd + :: (Logger logger) + => ChainwebVersion + -> logger + -- ^ Pact logger + -> Maybe logger + -- ^ Pact gas logger + -> PactDbEnv p + -- ^ Pact db environment + -> Miner + -- ^ The miner chosen to mine the block + -> GasModel + -- ^ Gas model (pact Service config) + -> TxContext + -- ^ tx metadata and parent header + -> SPVSupport + -- ^ SPV support (validates cont proofs) + -> Command (Payload PublicMeta ParsedCode) + -- ^ command with payload to execute + -> Gas + -- ^ initial gas used + -> ModuleCache + -- ^ 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 miner gasModel txCtx spv cmd initialGas mcache0 callCtx = do + T2 cr st <- runTransactionM cenv txst applyBuyGas + + let cache = _txCache st + warns = _txWarnings st + + pure $ T3 cr cache warns + where + stGasModel + | chainweb217Pact' = gasModel + | otherwise = _geGasModel freeGasEnv + txst = TransactionState mcache0 mempty 0 Nothing (Left stGasModel) mempty + quirkGasFee = v ^? versionQuirks . quirkGasFees . ix requestKey + + executionConfigNoHistory = ExecutionConfig + $ S.singleton FlagDisableHistoryInTransactionalMode + <> S.fromList + ([ FlagOldReadOnlyBehavior | isPactBackCompatV16 ] + ++ [ FlagPreserveModuleNameBug | not isModuleNameFix ] + ++ [ FlagPreserveNsModuleInstallBug | not isModuleNameFix2 ]) + <> flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) + + cenv = TransactionEnv Transactional (Left pdbenv) logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice + requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee + + !requestKey = cmdToRequestKey cmd + !gasPrice = view cmdGasPrice cmd + !gasLimit = view cmdGasLimit cmd + !nid = networkIdOf cmd + currHeight = ctxCurrentBlockHeight txCtx + cid = ctxChainId txCtx + isModuleNameFix = enableModuleNameFix v cid currHeight + isModuleNameFix2 = enableModuleNameFix2 v cid currHeight + isPactBackCompatV16 = pactBackCompat_v16 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 + + toOldListErr pe = pe { peDoc = listErrMsg } + isOldListErr = \case + PactError EvalError _ _ doc -> "Unknown primitive" `T.isInfixOf` renderCompactText' doc + _ -> False + + redeemAllGas r = do + txGasUsed .= fromIntegral gasLimit + applyRedeem r + + applyBuyGas = + catchesPactError logger (onChainErrorPrintingFor txCtx) (buyGas txCtx cmd miner) >>= \case + Left e -> view txRequestKey >>= \rk -> + throwM $ BuyGasFailure $ GasPurchaseFailure (requestKeyToTransactionHash rk) e + Right _ -> checkTooBigTx initialGas gasLimit applyVerifiers redeemAllGas + + displayPactError e = do + r <- failTxWith e "tx failure for request key when running cmd" + redeemAllGas r + + stripPactError e = do + let e' = case callCtx of + ApplyLocal -> e + ApplySend -> toEmptyPactError e + r <- failTxWith e' "tx failure for request key when running cmd" + redeemAllGas r + + applyVerifiers = do + if chainweb223Pact' + then do + gasUsed <- use txGasUsed + let initGasRemaining = fromIntegral gasLimit - gasUsed + verifierResult <- liftIO $ runVerifierPlugins (ctxVersion txCtx, cid, currHeight) logger allVerifiers initGasRemaining cmd + case verifierResult of + Left err -> do + let errMsg = "Tx verifier error: " <> getVerifierError err + cmdResult <- failTxWith + (PactError TxFailure def [] (pretty errMsg)) + errMsg + redeemAllGas cmdResult + Right verifierGasRemaining -> do + txGasUsed += initGasRemaining - verifierGasRemaining + applyPayload + else applyPayload + + applyPayload = do + txGasModel .= (Left gasModel) + if chainweb217Pact' then txGasUsed += initialGas + else txGasUsed .= initialGas + + cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runPayload cmd managedNamespacePolicy + case cr of + Left e + -- 2.19 onwards errors return on chain + | chainweb219Pact' -> displayPactError e + -- 2.17 errors were removed + | chainweb217Pact' -> stripPactError e + | chainweb213Pact' || not (isOldListErr e) -> displayPactError e + | otherwise -> do + r <- failTxWith (toOldListErr e) "tx failure for request key when running cmd" + redeemAllGas r + Right r -> applyRedeem r + + applyRedeem cr = do + txGasModel .= Left (_geGasModel freeGasEnv) + + r <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! redeemGas txCtx cmd miner + case r of + Left e -> + -- redeem gas failure is fatal (block-failing) so miner doesn't lose coins + fatal $ "tx failure for request key while redeeming gas: " <> sshow e + Right es -> do + logs <- use txLogs + + -- /local requires enriched results with metadata, while /send strips them. + -- when ?preflight=true is set, make sure that metadata occurs in result. + + let !cr' = case callCtx of + ApplySend -> set crLogs (Just logs) $ over crEvents (es ++) cr + ApplyLocal -> set crMetaData (Just $ J.toJsonViaEncode $ ctxToPublicData' txCtx) + $ set crLogs (Just logs) + $ over crEvents (es ++) cr + + return cr' + +listErrMsg :: Doc +listErrMsg = + "Unknown primitive \"list\" in determining cost of GUnreduced\nCallStack (from HasCallStack):\n error, called at src/Pact/Gas/Table.hs:209:22 in pact-4.2.0-fe223ad86f1795ba381192792f450820557e59c2926c747bf2aa6e398394bee6:Pact.Gas.Table" + +applyGenesisCmd + :: (Logger logger) + => logger + -- ^ Pact logger + -> PactDbEnv p + -- ^ Pact db environment + -> SPVSupport + -- ^ SPV support (validates cont proofs) + -> TxContext + -- ^ tx metadata + -> Command (Payload PublicMeta ParsedCode) + -- ^ command with payload to execute + -> IO (T2 (CommandResult [TxLogJson]) ModuleCache) +applyGenesisCmd logger dbEnv spv txCtx cmd = + second _txCache <$!> runTransactionM tenv txst go + where + nid = networkIdOf cmd + rk = cmdToRequestKey cmd + tenv = TransactionEnv + { _txMode = Transactional + , _txDbEnv = Left dbEnv + , _txLogger = logger + , _txGasLogger = Nothing + , _txPublicData = def + , _txSpvSupport = spv + , _txNetworkId = nid + , _txGasPrice = 0.0 + , _txRequestKey = rk + , _txGasLimit = 0 + , _txExecutionConfig = ExecutionConfig + $ flagsFor (ctxVersion txCtx) (ctxChainId txCtx) (_blockHeight $ ctxBlockHeader txCtx) + -- TODO this is very ugly. Genesis blocks need to install keysets + -- outside of namespaces so we need to disable Pact 4.4. It would be + -- preferable to have a flag specifically for the namespaced keyset + -- 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 + , _txLogs = mempty + , _txGasUsed = 0 + , _txGasId = Nothing + , _txGasModel = Left $ _geGasModel freeGasEnv + , _txWarnings = mempty + } + + interp = initStateInterpreter + $ initCapabilities [magic_GENESIS, magic_COINBASE] + + go = do + -- TODO: fix with version recordification so that this matches the flags at genesis heights. + cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runGenesis cmd permissiveNamespacePolicy interp + case cr of + Left e -> fatal $ "Genesis command failed: " <> sshow e + Right r -> r <$ debug "successful genesis tx for request key" + +flagsFor :: ChainwebVersion -> V.ChainId -> BlockHeight -> S.Set ExecutionFlag +flagsFor v cid bh = S.fromList $ concat + [ enablePactEvents' v cid bh + , enablePact40 v cid bh + , enablePact42 v cid bh + , enforceKeysetFormats' v cid bh + , enablePactModuleMemcheck v cid bh + , enablePact43 v cid bh + , enablePact431 v cid bh + , enablePact44 v cid bh + , enablePact45 v cid bh + , enableNewTrans v cid bh + , enablePact46 v cid bh + , enablePact47 v cid bh + , enablePact48 v cid bh + , disableReturnRTC v cid bh + , enablePact49 v cid bh + , enablePact410 v cid bh + , enablePact411 v cid bh + , enablePact412 v cid bh + ] + +applyCoinbase + :: (Logger logger) + => ChainwebVersion + -> logger + -- ^ Pact logger + -> PactDbEnv p + -- ^ Pact db environment + -> Miner + -- ^ The miner chosen to mine the block + -> ParsedDecimal + -- ^ Miner reward + -> TxContext + -- ^ tx metadata and parent header + -> EnforceCoinbaseFailure + -- ^ enforce coinbase failure or not + -> CoinbaseUsePrecompiled + -- ^ always enable precompilation + -> ModuleCache + -> IO (T2 (CommandResult [TxLogJson]) (Maybe ModuleCache)) +applyCoinbase v logger dbEnv (Miner mid mks@(MinerKeys mk)) reward@(ParsedDecimal d) txCtx + (EnforceCoinbaseFailure enfCBFailure) (CoinbaseUsePrecompiled enablePC) mc + | fork1_3InEffect || enablePC = do + when chainweb213Pact' $ enforceKeyFormats + (\k -> throwM $ CoinbaseFailure $ "Invalid miner key: " <> sshow k) + (validKeyFormats v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx)) + mk + let (cterm, cexec) = mkCoinbaseTerm mid mks reward + interp = Interpreter $ \_ -> do put initState; fmap pure (eval cterm) + + go interp cexec + | otherwise = do + cexec <- mkCoinbaseCmd mid mks reward + let interp = initStateInterpreter initState + go interp cexec + where + chainweb213Pact' = chainweb213Pact v cid bh + fork1_3InEffect = vuln797Fix v cid bh + throwCritical = fork1_3InEffect || enfCBFailure + ec = ExecutionConfig $ S.delete FlagEnforceKeyFormats $ fold + [ S.singleton FlagDisableModuleInstall + , S.singleton FlagDisableHistoryInTransactionalMode + , flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) + ] + tenv = TransactionEnv Transactional (Left dbEnv) logger Nothing (ctxToPublicData txCtx) noSPVSupport + Nothing 0.0 rk 0 ec Nothing + txst = TransactionState mc mempty 0 Nothing (Left $ _geGasModel freeGasEnv) mempty + initState = setModuleCache mc $ initCapabilities [magic_COINBASE] + rk = RequestKey chash + parent = _tcParentHeader txCtx + + bh = ctxCurrentBlockHeight txCtx + cid = Chainweb._chainId parent + chash = Pact.Hash $ SB.toShort $ encodeToByteString $ _blockHash $ _parentHeader parent + -- NOTE: it holds that @ _pdPrevBlockHash pd == encode _blockHash@ + -- NOTE: chash includes the /quoted/ text of the parent header. + + go interp cexec = evalTransactionM tenv txst $! do + cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $ + applyExec' 0 interp cexec [] [] chash managedNamespacePolicy + + case cr of + Left e + | throwCritical -> throwM $ CoinbaseFailure $ sshow e + | otherwise -> (`T2` Nothing) <$> failTxWith e "coinbase tx failure" + Right er -> do + debug + $! "successful coinbase of " + <> T.take 18 (sshow d) + <> " to " + <> sshow mid + + upgradedModuleCache <- applyUpgrades v cid bh + + logs <- use txLogs + + return $! T2 + 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 + -- ^ Pact logger + -> Maybe logger + -- ^ Pact gas logger + -> PactDbEnv p + -- ^ Pact db environment + -> GasModel + -- ^ Gas model (pact Service config) + -> TxContext + -- ^ tx metadata and parent header + -> SPVSupport + -- ^ SPV support (validates cont proofs) + -> Command PayloadWithText + -- ^ command with payload to execute + -> ModuleCache + -> ExecutionConfig + -> IO (CommandResult [TxLogJson]) +applyLocal logger gasLogger dbEnv gasModel txCtx spv cmdIn mc execConfig = + evalTransactionM tenv txst go + where + !cmd = payloadObj <$> cmdIn `using` traverse rseq + !rk = cmdToRequestKey cmd + !nid = networkIdOf cmd + !chash = toUntypedHash $ _cmdHash cmd + !signers = _pSigners $ _cmdPayload cmd + !verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd + !gasPrice = view cmdGasPrice cmd + !gasLimit = view cmdGasLimit cmd + tenv = TransactionEnv Local (Left dbEnv) logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice + rk (fromIntegral gasLimit) execConfig Nothing + txst = TransactionState mc mempty 0 Nothing (Left gasModel) mempty + gas0 = initialGasOf (_cmdPayload cmdIn) + currHeight = ctxCurrentBlockHeight txCtx + cid = V._chainId txCtx + v = _chainwebVersion txCtx + allVerifiers = verifiersAt v cid currHeight + -- Note [Throw out verifier proofs eagerly] + !verifiersWithNoProof = + (fmap . fmap) (\_ -> ()) verifiers + `using` (traverse . traverse) rseq + + applyVerifiers m = do + let initGasRemaining = fromIntegral gasLimit - gas0 + verifierResult <- liftIO $ runVerifierPlugins (v, cid, currHeight) logger allVerifiers initGasRemaining cmd + case verifierResult of + Left err -> do + let errMsg = "Tx verifier error: " <> getVerifierError err + failTxWith + (PactError TxFailure def [] (pretty errMsg)) + errMsg + Right verifierGasRemaining -> do + let gas1 = (initGasRemaining - verifierGasRemaining) + gas0 + applyPayload gas1 m + + applyPayload gas1 m = do + interp <- gasInterpreter gas1 + cr <- catchesPactError logger PrintsUnexpectedError $! case m of + Exec em -> + applyExec gas1 interp em signers verifiersWithNoProof chash managedNamespacePolicy + Continuation cm -> + applyContinuation gas1 interp cm signers chash managedNamespacePolicy + + case cr of + Left e -> failTxWith e "applyLocal" + Right r -> return $! r { _crMetaData = Just (J.toJsonViaEncode $ ctxToPublicData' txCtx) } + + go = checkTooBigTx gas0 gasLimit (applyVerifiers $ _pPayload $ _cmdPayload cmd) return + +readInitModules + :: 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 + cid = ctxChainId txCtx + h = _blockHeight (_parentHeader parent) + 1 + rk = RequestKey chash + nid = Nothing + chash = pactInitialHash + tenv = TransactionEnv Local (Left dbEnv) logger Nothing (ctxToPublicData txCtx) noSPVSupport nid 0.0 + rk 0 def Nothing + txst = TransactionState mempty mempty 0 Nothing (Left $ _geGasModel freeGasEnv) mempty + interp = defaultInterpreter + die msg = throwM $ PactInternalError $ "readInitModules: " <> msg + mkCmd = buildExecParsedCode (pactParserVersion v cid h) Nothing + run msg cmd = do + er <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! + applyExec' 0 interp cmd [] [] chash permissiveNamespacePolicy + case er of + Left e -> die $ msg <> ": failed: " <> sshow e + Right r -> case _erOutput r of + [] -> die $ msg <> ": empty result" + (o:_) -> return o + + + go :: TransactionM logger p ModuleCache + go = do + + -- see if fungible-v2 is there + checkCmd <- liftIO $ mkCmd "(contains \"fungible-v2\" (list-modules))" + checkFv2 <- run "check fungible-v2" checkCmd + hasFv2 <- case checkFv2 of + (PLiteral (LBool b)) -> return b + t -> die $ "got non-bool result from module read: " <> T.pack (showPretty t) + + -- see if fungible-xchain-v1 is there + checkCmdx <- liftIO $ mkCmd "(contains \"fungible-xchain-v1\" (list-modules))" + checkFx <- run "check fungible-xchain-v1" checkCmdx + hasFx <- case checkFx of + (PLiteral (LBool b)) -> return b + t -> die $ "got non-bool result from module read: " <> T.pack (showPretty t) + + -- load modules by referencing members + refModsCmd <- liftIO $ mkCmd $ T.intercalate " " $ + [ "coin.MINIMUM_PRECISION" + , "ns.GUARD_SUCCESS" + , "(use gas-payer-v1)" + , "fungible-v1.account-details"] ++ + [ "fungible-v2.account-details" | hasFv2 ] ++ + [ "(let ((m:module{fungible-xchain-v1} coin)) 1)" | hasFx ] + void $ run "load modules" refModsCmd + + -- return loaded cache + use txCache + + -- 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 = do + coinDepCmd <- liftIO $ mkCmd "coin.MINIMUM_PRECISION" + 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. +-- +-- This is the place where we consistently /introduce/ new transactions +-- into the blockchain along with module cache updates. The only other +-- places are Pact Service startup and the +-- empty-module-cache-after-initial-rewind case caught in 'execTransactions' +-- which both hit the database. +-- +applyUpgrades + :: (Logger logger) + => ChainwebVersion + -> Chainweb.ChainId + -> BlockHeight + -> TransactionM logger p (Maybe ModuleCache) +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) + + filterModuleCache = do + mc <- use txCache + pure $ Just $ filterModuleCacheByKey (== "coin") mc + + applyUpgrade upg = do + infoLog "Applying upgrade!" + let payloads = map (fmap payloadObj) $ _upgradeTransactions upg + + -- + -- In order to prime the module cache with all new modules for subsequent + -- blocks, the caches from each tx are collected and the union of all + -- those caches is returned. The calling code adds this new cache to the + -- init cache in the pact service state (_psInitCache). + -- + + let flags = flagsFor v cid (if _legacyUpgradeIsPrecocious upg then height + 1 else height) + caches <- local + (txExecutionConfig .~ ExecutionConfig flags) + (mapM applyTx payloads) + return $ Just $ mconcat $ reverse caches + + interp = initStateInterpreter + $ installCoinModuleAdmin + $ initCapabilities [mkMagicCapSlot "REMEDIATE"] + + applyTx tx = do + infoLog $ "Running upgrade tx " <> sshow (_cmdHash tx) + + tryAllSynchronous (runGenesis tx permissiveNamespacePolicy interp) >>= \case + Right _ -> use txCache + Left e -> do + logError $ "Upgrade transaction failed! " <> sshow e + throwM e + +failTxWith + :: (Logger logger) + => PactError + -> Text + -> TransactionM logger p (CommandResult [TxLogJson]) +failTxWith err msg = do + logs <- use txLogs + gas <- view txGasLimit -- error means all gas was charged + rk <- view txRequestKey + l <- view txLogger + + liftIO $ logFunction l L.Info + (Pact4TxFailureLog rk err msg) + + return $! CommandResult rk Nothing (PactResult (Left err)) + gas (Just logs) Nothing Nothing [] + +runPayload + :: (Logger logger) + => Command (Payload PublicMeta ParsedCode) + -> NamespacePolicy + -> TransactionM logger p (CommandResult [TxLogJson]) +runPayload cmd nsp = do + g0 <- use txGasUsed + interp <- gasInterpreter g0 + + -- Note [Throw out verifier proofs eagerly] + let !verifiersWithNoProof = + (fmap . fmap) (\_ -> ()) verifiers + `using` (traverse . traverse) rseq + + case payload of + Exec pm -> + applyExec g0 interp pm signers verifiersWithNoProof chash nsp + Continuation ym -> + applyContinuation g0 interp ym signers chash nsp + + + where + verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd + signers = _pSigners $ _cmdPayload cmd + chash = toUntypedHash $ _cmdHash cmd + payload = _pPayload $ _cmdPayload cmd + +-- | Run genesis transaction payloads with custom interpreter +-- +runGenesis + :: (Logger logger) + => Command (Payload PublicMeta ParsedCode) + -> NamespacePolicy + -> Interpreter p + -> TransactionM logger p (CommandResult [TxLogJson]) +runGenesis cmd nsp interp = case payload of + Exec pm -> + applyExec 0 interp pm signers verifiersWithNoProof chash nsp + Continuation ym -> + applyContinuation 0 interp ym signers chash nsp + where + signers = _pSigners $ _cmdPayload cmd + verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd + -- Note [Throw out verifier proofs eagerly] + !verifiersWithNoProof = + (fmap . fmap) (\_ -> ()) verifiers + `using` (traverse . traverse) rseq + chash = toUntypedHash $ _cmdHash cmd + payload = _pPayload $ _cmdPayload cmd + +-- | Execute an 'ExecMsg' and Return the result with module cache +-- +applyExec + :: (Logger logger) + => Gas + -> Interpreter p + -> ExecMsg ParsedCode + -> [Signer] + -> [Verifier ()] + -> Hash + -> NamespacePolicy + -> TransactionM logger p (CommandResult [TxLogJson]) +applyExec initialGas interp em senderSigs verifiers hsh nsp = do + EvalResult{..} <- applyExec' initialGas interp em senderSigs verifiers hsh nsp + for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl + !logs <- use txLogs + !rk <- view txRequestKey + + -- concat tx warnings with eval warnings + modify' $ txWarnings <>~ _erWarnings + + -- applyExec enforces non-empty expression set so `last` ok + -- forcing it here for lazy errors. TODO NFData the Pacts + let !lastResult = force $ last _erOutput + return $ CommandResult rk _erTxId (PactResult (Right lastResult)) + _erGas (Just logs) _erExec Nothing _erEvents + +-- | Variation on 'applyExec' that returns 'EvalResult' as opposed to +-- wrapping it up in a JSON result. +-- +applyExec' + :: (Logger logger) + => Gas + -> Interpreter p + -> ExecMsg ParsedCode + -> [Signer] + -> [Verifier ()] + -> Hash + -> NamespacePolicy + -> TransactionM logger p EvalResult +applyExec' initialGas interp (ExecMsg parsedCode execData) senderSigs verifiersWithNoProof hsh nsp + | null (_pcExps parsedCode) = throwCmdEx "No expressions found" + | otherwise = do + + eenv <- mkEvalEnv nsp (MsgData execData Nothing hsh senderSigs verifiersWithNoProof) + + setEnvGas initialGas eenv + + 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 quirkedEvalResult) $ \pe -> debug + $ "applyExec: new pact added: " + <> sshow (_pePactId pe, _peStep pe, _peYield pe, _peExecuted pe) + + -- set log + cache updates + used gas + setTxResultState quirkedEvalResult + + return quirkedEvalResult + +enablePactEvents' :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePactEvents' v cid bh = [FlagDisablePactEvents | not (enablePactEvents v cid bh)] + +enforceKeysetFormats' :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enforceKeysetFormats' v cid bh = [FlagEnforceKeyFormats | enforceKeysetFormats v cid bh] + +enablePact40 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact40 v cid bh = [FlagDisablePact40 | not (pact4Coin3 v cid bh)] + +enablePact42 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact42 v cid bh = [FlagDisablePact42 | not (pact42 v cid bh)] + +enablePactModuleMemcheck :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePactModuleMemcheck v cid bh = [FlagDisableInlineMemCheck | not (chainweb213Pact v cid bh)] + +enablePact43 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact43 v cid bh = [FlagDisablePact43 | not (chainweb214Pact v cid bh)] + +enablePact431 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact431 v cid bh = [FlagDisablePact431 | not (chainweb215Pact v cid bh)] + +enablePact44 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact44 v cid bh = [FlagDisablePact44 | not (chainweb216Pact v cid bh)] + +enablePact45 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact45 v cid bh = [FlagDisablePact45 | not (chainweb217Pact v cid bh)] + +enableNewTrans :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enableNewTrans v cid bh = [FlagDisableNewTrans | not (pact44NewTrans v cid bh)] + +enablePact46 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact46 v cid bh = [FlagDisablePact46 | not (chainweb218Pact v cid bh)] + +enablePact47 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact47 v cid bh = [FlagDisablePact47 | not (chainweb219Pact v cid bh)] + +enablePact48 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact48 v cid bh = [FlagDisablePact48 | not (chainweb220Pact v cid bh)] + +enablePact49 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact49 v cid bh = [FlagDisablePact49 | not (chainweb221Pact v cid bh)] + +enablePact410 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact410 v cid bh = [FlagDisablePact410 | not (chainweb222Pact v cid bh)] + +enablePact411 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact411 v cid bh = [FlagDisablePact411 | not (chainweb223Pact v cid bh)] + +enablePact412 :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +enablePact412 v cid bh = [FlagDisablePact412 | not (chainweb224Pact v cid bh)] + +-- | Even though this is not forking, abstracting for future shutoffs +disableReturnRTC :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] +disableReturnRTC _v _cid _bh = [FlagDisableRuntimeReturnTypeChecking] + +-- | Execute a 'ContMsg' and return the command result and module cache +-- +applyContinuation + :: (Logger logger) + => Gas + -> Interpreter p + -> ContMsg + -> [Signer] + -> Hash + -> NamespacePolicy + -> TransactionM logger p (CommandResult [TxLogJson]) +applyContinuation initialGas interp cm senderSigs hsh nsp = do + EvalResult{..} <- applyContinuation' initialGas interp cm senderSigs hsh nsp + for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl + logs <- use txLogs + rk <- view txRequestKey + + -- set tx warnings to eval warnings + txWarnings <>= _erWarnings + + -- last safe here because cont msg is guaranteed one exp + return $! CommandResult rk _erTxId (PactResult (Right (last _erOutput))) + _erGas (Just logs) _erExec Nothing _erEvents + + +setEnvGas :: Gas -> EvalEnv e -> TransactionM logger p () +setEnvGas initialGas = liftIO . views eeGas (`writeIORef` gasToMilliGas initialGas) + +-- | Execute a 'ContMsg' and return just eval result, not wrapped in a +-- 'CommandResult' wrapper +-- +applyContinuation' + :: Gas + -> Interpreter p + -> ContMsg + -> [Signer] + -> Hash + -> NamespacePolicy + -> TransactionM logger p EvalResult +applyContinuation' initialGas interp cm@(ContMsg pid s rb d _) senderSigs hsh nsp = do + + eenv <- mkEvalEnv nsp (MsgData d pactStep hsh senderSigs []) + + setEnvGas initialGas eenv + + 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 quirkedEvalResult + + return quirkedEvalResult + where + pactStep = Just $ PactStep s rb pid Nothing + +-- | Build and execute 'coin.buygas' command from miner info and user command +-- info (see 'TransactionExec.applyCmd') +-- +-- see: 'pact/coin-contract/coin.pact#fund-tx' +-- +buyGas :: (Logger logger) => TxContext -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p () +buyGas txCtx cmd (Miner mid mks) = go + where + isChainweb224Pact = guardCtx chainweb224Pact txCtx + sender = view (cmdPayload . pMeta . pmSender) cmd + + initState mc logGas = + set evalLogGas (guard logGas >> Just [("GBuyGas",0)]) $ setModuleCache mc $ initCapabilities [magic_GAS] + + run input = do + (findPayer txCtx cmd) >>= \r -> case r of + Nothing -> input + Just withPayerCap -> withPayerCap input + + (Hash chash) = toUntypedHash (_cmdHash cmd) + bgHash = Hash (chash <> "-buygas") + + go = do + mcache <- use txCache + supply <- gasSupplyOf <$> view txGasLimit <*> view txGasPrice + logGas <- isJust <$> view txGasLogger + + let (buyGasTerm, buyGasCmd) = + -- post-chainweb 2.24, we call buy-gas directly rather than + -- going through fund-tx which is a defpact. + if isChainweb224Pact + then mkBuyGasTerm sender supply + else mkFundTxTerm mid mks sender supply + -- I don't recall why exactly, but we set up an interpreter + -- that ignores its argument and instead executes a term + -- of our choice. we do the same to redeem gas. + interp mc = Interpreter $ \_input -> + put (initState mc logGas) >> run (pure <$> eval buyGasTerm) + + let + gasCapName = QualifiedName (ModuleName "coin" Nothing) "GAS" def + signedForGas signer = + any (\sc -> _scName sc == gasCapName) (_siCapList signer) + addDebit signer + | signedForGas signer = + signer & siCapList %~ (debitCap sender:) + | otherwise = signer + addDebitToSigners = + fmap addDebit + + -- no verifiers are allowed in buy gas + -- quirked gas is not used either + result <- locally txQuirkGasFee (const Nothing) $ + applyExec' 0 (interp mcache) buyGasCmd + (addDebitToSigners $ _pSigners $ _cmdPayload cmd) [] bgHash managedNamespacePolicy + + case _erExec result of + Nothing + | isChainweb224Pact -> + return () + | otherwise -> + -- should never occur pre-chainweb 2.24: + -- would mean coin.fund-tx is not a pact + fatal "buyGas: Internal error - empty continuation before 2.24 fork" + Just pe + | isChainweb224Pact -> + fatal "buyGas: Internal error - continuation found after 2.24 fork" + | otherwise -> + void $! txGasId .= (Just $! GasId (_pePactId pe)) + +findPayer + :: TxContext + -> Command (Payload PublicMeta ParsedCode) + -> Eval e (Maybe (Eval e [Term Name] -> Eval e [Term Name])) +findPayer txCtx cmd = runMaybeT $ do + (!m,!qn,!as) <- MaybeT findPayerCap + pMod <- MaybeT $ lookupModule qn m + capRef <- MaybeT $ return $ lookupIfaceModRef qn pMod + return $ runCap (getInfo qn) capRef as + where + setEnvMsgBody v e = set eeMsgBody v e + + findPayerCap :: Eval e (Maybe (ModuleName,QualifiedName,[PactValue])) + findPayerCap = preview $ eeMsgSigs . folded . folded . to sigPayerCap . _Just + + sigPayerCap (SigCapability q@(QualifiedName m n _) as) + | n == "GAS_PAYER" = Just (m,q,as) + sigPayerCap _ = Nothing + + gasPayerIface = ModuleName "gas-payer-v1" Nothing + + lookupIfaceModRef (QualifiedName _ n _) (ModuleData (MDModule Module{..}) refs _) + | gasPayerIface `elem` _mInterfaces = HM.lookup n refs + lookupIfaceModRef _ _ = Nothing + + mkApp i r as = App (TVar r i) (map (liftTerm . fromPactValue) as) i + + runCap i capRef as input = do + let msgBody = enrichedMsgBody cmd + enrichMsgBody | guardCtx pactBackCompat_v16 txCtx = id + | otherwise = setEnvMsgBody (toLegacyJson msgBody) + ar <- local enrichMsgBody $ do + (cap, capDef, args) <- appToCap $ mkApp i capRef as + evalCap i CapCallStack False (cap, capDef, args, i) + + case ar of + NewlyAcquired -> do + r <- input + popCapStack (const (return ())) + return r + _ -> evalError' i "Internal error, GAS_PAYER already acquired" + +enrichedMsgBody :: Command (Payload PublicMeta ParsedCode) -> Value +enrichedMsgBody cmd = case (_pPayload $ _cmdPayload cmd) of + Exec (ExecMsg (ParsedCode _ exps) userData) -> + object [ "tx-type" A..= ( "exec" :: Text) + , "exec-code" A..= map renderCompactText exps + , "exec-user-data" A..= pactFriendlyUserData (_getLegacyValue userData) ] + Continuation (ContMsg pid step isRollback userData proof) -> + object [ "tx-type" A..= ("cont" :: Text) + , "cont-pact-id" A..= toJsonViaEncode pid + , "cont-step" A..= toJsonViaEncode (LInteger $ toInteger step) + , "cont-is-rollback" A..= toJsonViaEncode (LBool isRollback) + , "cont-user-data" A..= pactFriendlyUserData (_getLegacyValue userData) + , "cont-has-proof" A..= toJsonViaEncode (isJust proof) + ] + where + pactFriendlyUserData Null = object [] + pactFriendlyUserData v = v + +-- | Build and execute 'coin.redeem-gas' command from miner info and previous +-- command results (see 'TransactionExec.applyCmd') +-- +-- see: 'pact/coin-contract/coin.pact#fund-tx' +-- +redeemGas :: (Logger logger) => TxContext -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p [PactEvent] +redeemGas txCtx cmd (Miner mid mks) = do + mcache <- use txCache + let sender = view (cmdPayload . pMeta . pmSender) cmd + fee <- gasSupplyOf <$> use txGasUsed <*> view txGasPrice + -- if we're past chainweb 2.24, we don't use defpacts for gas + if guardCtx chainweb224Pact txCtx + then do + total <- gasSupplyOf <$> view txGasLimit <*> view txGasPrice + let (redeemGasTerm, redeemGasCmd) = + mkRedeemGasTerm mid mks sender total fee + -- I don't recall why exactly, but we set up an interpreter + -- that ignores its argument and instead executes a term + -- of our choice. we do the same to buy gas. + interp = Interpreter $ \_input -> do + -- we don't log gas when redeeming, because nobody can pay for it + put (initCapabilities [magic_GAS] & setModuleCache mcache) + fmap List.singleton (eval redeemGasTerm) + (Hash chash) = toUntypedHash (_cmdHash cmd) + rgHash = Hash (chash <> "-redeemgas") + + locally txQuirkGasFee (const Nothing) $ _erEvents <$> + applyExec' 0 interp redeemGasCmd + (_pSigners $ _cmdPayload cmd) + [] + rgHash + managedNamespacePolicy + else do + GasId gid <- use txGasId >>= \case + Nothing -> fatal $! "redeemGas: no gas id in scope for gas refunds" + Just g -> return g + let redeemGasCmd = + ContMsg gid 1 False (toLegacyJson $ object [ "fee" A..= toJsonViaEncode fee ]) Nothing + + fmap _crEvents $ locally txQuirkGasFee (const Nothing) $ + applyContinuation 0 (initState mcache) redeemGasCmd + (_pSigners $ _cmdPayload cmd) (toUntypedHash $ _cmdHash cmd) + managedNamespacePolicy + + where + initState mc = initStateInterpreter + $ setModuleCache mc + $ initCapabilities [magic_GAS] + + +-- ---------------------------------------------------------------------------- -- +-- Utilities + +-- | Initialize a fresh eval state with magic capabilities. +-- This is the way we inject the correct guards into the environment +-- during Pact code execution +-- +initCapabilities :: [CapSlot SigCapability] -> EvalState +initCapabilities cs = set (evalCapabilities . capStack) cs def +{-# INLINABLE initCapabilities #-} + +initStateInterpreter :: EvalState -> Interpreter e +initStateInterpreter s = Interpreter (put s >>) + +-- | Check whether the cost of running a tx is more than the allowed +-- gas limit and do some action depending on the outcome +-- +checkTooBigTx + :: (Logger logger) + => Gas + -> GasLimit + -> TransactionM logger p (CommandResult [TxLogJson]) + -> (CommandResult [TxLogJson] -> TransactionM logger p (CommandResult [TxLogJson])) + -> TransactionM logger p (CommandResult [TxLogJson]) +checkTooBigTx initialGas gasLimit next onFail + | initialGas >= fromIntegral gasLimit = do + + let !pe = PactError GasError def [] + $ "Tx too big (" <> pretty initialGas <> "), limit " + <> pretty gasLimit + + r <- failTxWith pe "Tx too big" + onFail r + | otherwise = next + +gasInterpreter :: Gas -> TransactionM logger db (Interpreter p) +gasInterpreter g = do + mc <- use txCache + logGas <- isJust <$> view txGasLogger + return $ initStateInterpreter + $ set evalLogGas (guard logGas >> Just [("GTxSize",g)]) -- enables gas logging + $ setModuleCache mc def + + +-- | Initial gas charged for transaction size +-- ignoring the size of a continuation proof, if present +-- +initialGasOf :: PayloadWithText -> Gas +initialGasOf payload = gasFee + where + feePerByte :: Rational = 0.01 + + contProofSize = + case _pPayload (payloadObj payload) of + Continuation (ContMsg _ _ _ _ (Just (ContProof p))) -> B.length p + _ -> 0 + txSize = SB.length (payloadBytes payload) - contProofSize + + costPerByte = fromIntegral txSize * feePerByte + sizePenalty = txSizeAccelerationFee costPerByte + gasFee = ceiling (costPerByte + sizePenalty) +{-# INLINE initialGasOf #-} + +txSizeAccelerationFee :: Rational -> Rational +txSizeAccelerationFee costPerByte = total + where + total = (costPerByte / bytePenalty) ^ power + bytePenalty = 512 + power :: Integer = 7 +{-# INLINE txSizeAccelerationFee #-} + +-- | Set the module cache of a pact 'EvalState' +-- +setModuleCache + :: ModuleCache + -> EvalState + -> EvalState +setModuleCache mcache es = + let allDeps = foldMap (allModuleExports . fst) $ _getModuleCache mcache + in set (evalRefs . rsQualifiedDeps) allDeps $ set (evalRefs . rsLoadedModules) c es + where + c = moduleCacheToHashMap mcache +{-# INLINE setModuleCache #-} + +-- | Set tx result state +-- +setTxResultState :: EvalResult -> TransactionM logger db () +setTxResultState er = do + txLogs <>= _erLogs er + txCache .= moduleCacheFromHashMap (_erLoadedModules er) + txGasUsed .= _erGas er +{-# INLINE setTxResultState #-} + +-- | Make an 'EvalEnv' given a tx env + state +-- +mkEvalEnv + :: NamespacePolicy + -> MsgData + -> TransactionM logger db (EvalEnv db) +mkEvalEnv nsp msg = do + tenv <- ask + genv <- GasEnv + <$> view (txGasLimit . to (MilliGasLimit . gasToMilliGas)) + <*> view txGasPrice + <*> (either id (error "mkEvalEnv: pact5 impossible") <$> use txGasModel) + fmap (set eeSigCapBypass txCapBypass) + $ liftIO $ setupEnv tenv genv + where + setupEnv tenv genv = either (\db -> setupEvalEnv db Nothing (_txMode tenv) + msg (versionedNativesRefStore (_txExecutionConfig tenv)) genv + nsp (_txSpvSupport tenv) (_txPublicData tenv) (_txExecutionConfig tenv)) (error "mkEvalEnv: pact5 impossible") (_txDbEnv tenv) + txCapBypass = + M.fromList + [ (wizaDebit, (wizaBypass, wizaMH)) + , (skdxDebit, (kdxBypass, skdxMH)) + , (collectGallinasMarket, (collectGallinasBypass, collectGallinasMH)) + , (marmaladeGuardPolicyMint, (marmaladeBypass, marmaladeGuardPolicyMH)) + ] + where + -- wiza code + wizaDebit = QualifiedName "free.wiza" "DEBIT" def + wizaMH = unsafeModuleHashFromB64Text "8b4USA1ZNVoLYRT1LBear4YKt3GB2_bl0AghZU8QxjI" + wizEquipmentOwner = QualifiedName "free.wiz-equipment" "OWNER" def + wizEquipmentAcctGuard = QualifiedName "free.wiz-equipment" "ACCOUNT_GUARD" def + wizArenaAcctGuard = QualifiedName "free.wiz-arena" "ACCOUNT_GUARD" def + wizArenaOwner = QualifiedName "free.wiz-arena" "OWNER" def + wizaTransfer = QualifiedName "free.wiza" "TRANSFER" def + + wizaBypass granted sigCaps = + let debits = filter ((== wizaDebit) . _scName) $ S.toList granted + in all (\c -> any (match c) sigCaps) debits + where + match prov sigCap = fromMaybe False $ do + guard $ _scName sigCap `elem` wizaBypassList + sender <- preview _head (_scArgs prov) + (== sender) <$> preview _head (_scArgs sigCap) + wizaBypassList = + [ wizArenaOwner + , wizEquipmentOwner + , wizaTransfer + , wizEquipmentAcctGuard + , wizArenaAcctGuard] + -- kaddex code + skdxDebit = QualifiedName "kaddex.skdx" "DEBIT" def + skdxMH = unsafeModuleHashFromB64Text "g90VWmbKj87GkMkGs8uW947kh_Wg8JdQowa8rO_vZ1M" + kdxUnstake = QualifiedName "kaddex.staking" "UNSTAKE" def + + kdxBypass granted sigCaps = + let debits = filter ((== skdxDebit) . _scName) $ S.toList granted + in all (\c -> S.member (SigCapability kdxUnstake (_scArgs c)) sigCaps) debits + -- Collect-gallinas code + collectGallinasMH = unsafeModuleHashFromB64Text "x3BLGdidqSjUQy5q3MorGco9mBDpoVTh_Yoagzu0hls" + collectGallinasMarket = QualifiedName "free.collect-gallinas" "MARKET" def + collectGallinasAcctGuard = QualifiedName "free.collect-gallinas" "ACCOUNT_GUARD" def + + collectGallinasBypass granted sigCaps = fromMaybe False $ do + let mkt = filter ((== collectGallinasMarket) . _scName) $ S.toList granted + let matchingGuard provided toMatch = _scName toMatch == collectGallinasAcctGuard && (_scArgs provided == _scArgs toMatch) + pure $ all (\c -> any (matchingGuard c) sigCaps) mkt + -- marmalade code + marmaladeGuardPolicyMH = unsafeModuleHashFromB64Text "LB5sRKx8jN3FP9ZK-rxDK7Bqh0gyznprzS8L4jYlT5o" + marmaladeGuardPolicyMint = QualifiedName "marmalade-v2.guard-policy-v1" "MINT" def + marmaladeLedgerMint = QualifiedName "marmalade-v2.ledger" "MINT-CALL" def + + marmaladeBypass granted sigCaps = fromMaybe False $ do + let mkt = filter ((== marmaladeGuardPolicyMint) . _scName) $ S.toList granted + let matchingGuard provided toMatch = _scName toMatch == marmaladeLedgerMint && (_scArgs provided == _scArgs toMatch) + pure $ all (\c -> any (matchingGuard c) sigCaps) mkt + +unsafeModuleHashFromB64Text :: Text -> ModuleHash +unsafeModuleHashFromB64Text = + either error ModuleHash . PU.fromText' + +-- | Managed namespace policy CAF +-- +managedNamespacePolicy :: NamespacePolicy +managedNamespacePolicy = SmartNamespacePolicy False + (QualifiedName (ModuleName "ns" Nothing) "validate" def) +{-# NOINLINE managedNamespacePolicy #-} + +-- | Builder for "magic" capabilities given a magic cap name +-- +mkMagicCapSlot :: Text -> CapSlot SigCapability +mkMagicCapSlot c = CapSlot CapCallStack (mkCoinCap c []) [] +{-# INLINE mkMagicCapSlot #-} + +mkCoinCap :: Text -> [PactValue] -> SigCapability +mkCoinCap c as = SigCapability fqn as + where + mn = ModuleName "coin" Nothing + fqn = QualifiedName mn c def +{-# INLINE mkCoinCap #-} + +-- | Build the 'ExecMsg' for some pact code fed to the function. The 'value' +-- parameter is for any possible environmental data that needs to go into +-- the 'ExecMsg'. +-- +buildExecParsedCode + :: PactParserVersion + -> Maybe Value + -> Text + -> IO (ExecMsg ParsedCode) +buildExecParsedCode ppv value code = maybe (go Null) go value + where + go val = case parsePact ppv code of + Right !t -> pure $! ExecMsg t (toLegacyJson val) + -- if we can't construct coin contract calls, this should + -- fail fast + Left err -> internalError $ "buildExecParsedCode: parse failed: " <> T.pack err + +-- | Retrieve public metadata from a command +-- +publicMetaOf :: Command (Payload PublicMeta ParsedCode) -> PublicMeta +publicMetaOf = _pMeta . _cmdPayload +{-# INLINE publicMetaOf #-} + +-- | Retrieve the optional Network identifier from a command +-- +networkIdOf :: Command (Payload PublicMeta ParsedCode) -> Maybe NetworkId +networkIdOf = _pNetworkId . _cmdPayload +{-# INLINE networkIdOf #-} + +-- | Calculate the gas fee (pact-generate gas cost * user-specified gas price), +-- rounding to the nearest stu. +-- +gasSupplyOf :: Gas -> GasPrice -> GasSupply +gasSupplyOf gas (GasPrice (ParsedDecimal gp)) = GasSupply (ParsedDecimal gs) + where + gs = toCoinUnit ((fromIntegral gas) * gp) +{-# INLINE gasSupplyOf #-} + +-- | Round to the nearest Stu +-- +toCoinUnit :: Decimal -> Decimal +toCoinUnit = roundTo 12 +{-# INLINE toCoinUnit #-} + +gasLog :: (Logger logger) => Text -> TransactionM logger db () +gasLog m = do + l <- view txGasLogger + rk <- view txRequestKey + for_ l $ \logger -> + logInfo_ logger $ m <> ": " <> sshow rk + +-- | Log request keys at DEBUG when successful +-- +debug :: (Logger logger) => Text -> TransactionM logger db () +debug s = do + l <- view txLogger + 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 +fatal e = do + l <- view txLogger + rk <- view txRequestKey + + logError_ l + $ "critical transaction failure: " + <> sshow rk <> ": " <> e + + throwM $ PactTransactionExecError (fromUntypedHash $ unRequestKey rk) e + +logError :: (Logger logger) => Text -> TransactionM logger db () +logError msg = view txLogger >>= \l -> logError_ l msg + +infoLog :: (Logger logger) => Text -> TransactionM logger db () +infoLog msg = view txLogger >>= \l -> logInfo_ l msg \ No newline at end of file diff --git a/src/Chainweb/Pact/TransactionExec.hs b/src/Chainweb/Pact/TransactionExec/Pact5.hs similarity index 62% rename from src/Chainweb/Pact/TransactionExec.hs rename to src/Chainweb/Pact/TransactionExec/Pact5.hs index 5d71af6ff..36c72b670 100644 --- a/src/Chainweb/Pact/TransactionExec.hs +++ b/src/Chainweb/Pact/TransactionExec/Pact5.hs @@ -18,21 +18,15 @@ -- -- Pact command execution and coin-contract transaction logic for Chainweb -- -module Chainweb.Pact.TransactionExec +module Chainweb.Pact.TransactionExec.Pact5 ( -- * Transaction Execution applyCmd -, applyGenesisCmd , applyLocal , applyExec , applyExec' -, applyExecTng -, applyExecTng' , applyContinuation , applyContinuation' -, applyContinuationTng -, applyContinuationTng' , runPayload -, readInitModules , enablePactEvents' , enforceKeysetFormats' , disableReturnRTC @@ -117,9 +111,7 @@ import Pact.Types.Util as PU import Pact.Core.Serialise.LegacyPact () import qualified Pact.Core.Compile as PCore import qualified Pact.Core.Evaluate as PCore -import qualified Pact.Core.Command as PCore import qualified Pact.Core.Capabilities as PCore -import qualified Pact.Core.Errors as PCore import qualified Pact.Core.Names as PCore import qualified Pact.Core.Namespace as PCore import qualified Pact.Core.Persistence as PCore @@ -147,7 +139,8 @@ import qualified Chainweb.ChainId as Chainweb import Chainweb.Mempool.Mempool (requestKeyToTransactionHash) import Chainweb.Miner.Pact import Chainweb.Pact.Service.Types -import Chainweb.Pact.Templates +import qualified Chainweb.Pact.Templates.Pact5 as Pact5 +import Chainweb.Pact.Templates.Pact4 import Chainweb.Pact.Utils import qualified Chainweb.Pact.Conversion as PactConversion import Chainweb.Pact.Types hiding (logError) @@ -236,15 +229,14 @@ applyCmd -- ^ cached module state -> ApplyCmdExecutionContext -- ^ is this a local or send execution context? - -> IO (T4 (Either (CommandResult [TxLogJson]) PCore.CommandResult) ModuleCache CoreModuleCache (S.Set PactWarning)) + -> IO (T4 (CommandResult [TxLogJson]) ModuleCache CoreModuleCache (S.Set PactWarning)) applyCmd v logger gasLogger (pdbenv, coreDb) miner (gasModel, gasModelCore) 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 $ T4 cr cache coreCache warns + pure $ T4 cr cache undefined warns where stGasModel | chainweb217Pact' = gasModel @@ -253,7 +245,7 @@ applyCmd v logger gasLogger (pdbenv, coreDb) miner (gasModel, gasModelCore) txCt stGasModelCore | chainweb217Pact' = gasModelCore | otherwise = PCore.freeGasModel - txst = TransactionState mcache0 mccache0 mempty 0 Nothing stGasModel stGasModelCore mempty + txst = TransactionState mcache0 mempty 0 Nothing (Right stGasModelCore) mempty quirkGasFee = v ^? versionQuirks . quirkGasFees . ix requestKey executionConfigNoHistory = ExecutionConfig @@ -264,8 +256,8 @@ applyCmd v logger gasLogger (pdbenv, coreDb) miner (gasModel, gasModelCore) txCt ++ [ FlagPreserveNsModuleInstallBug | not isModuleNameFix2 ]) <> flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) - cenv = TransactionEnv Transactional pdbenv coreDb logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice - requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee usePact5 + cenv = TransactionEnv Transactional (Right coreDb) logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice + requestKey (fromIntegral gasLimit) executionConfigNoHistory quirkGasFee !requestKey = cmdToRequestKey cmd !gasPrice = view cmdGasPrice cmd @@ -281,7 +273,7 @@ applyCmd v logger gasLogger (pdbenv, coreDb) miner (gasModel, gasModelCore) txCt chainweb219Pact' = guardCtx chainweb219Pact txCtx chainweb223Pact' = guardCtx chainweb223Pact txCtx allVerifiers = verifiersAt v cid currHeight - usePact5 = pact5 v cid currHeight + usePactTng = chainweb223Pact v cid currHeight toEmptyPactError (PactError errty _ _ _) = PactError errty def [] mempty toOldListErr pe = pe { peDoc = listErrMsg } @@ -320,42 +312,35 @@ applyCmd v logger gasLogger (pdbenv, coreDb) miner (gasModel, gasModelCore) txCt case verifierResult of Left err -> do let errMsg = "Tx verifier error: " <> getVerifierError err - Left <$> do - cmdResult <- failTxWith - (PactError TxFailure def [] (pretty errMsg)) - errMsg - redeemAllGas cmdResult + cmdResult <- failTxWith + (PactError TxFailure def [] (pretty errMsg)) + errMsg + redeemAllGas cmdResult Right verifierGasRemaining -> do txGasUsed += initGasRemaining - verifierGasRemaining applyPayload else applyPayload applyPayload = do - txGasModel .= gasModel - txGasModelCore .= gasModelCore + txGasModel .= (Right gasModelCore) if chainweb217Pact' then txGasUsed += initialGas else txGasUsed .= initialGas - if usePactTng then do - cr <- runPayloadTng cmd managedNamespacePolicy - return $ Right $ cr - else Left <$> do - cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runPayload cmd managedNamespacePolicy - case cr of - Left e - -- 2.19 onwards errors return on chain - | chainweb219Pact' -> displayPactError e - -- 2.17 errors were removed - | chainweb217Pact' -> stripPactError e - | chainweb213Pact' || not (isOldListErr e) -> displayPactError e - | otherwise -> do - r <- failTxWith (toOldListErr e) "tx failure for request key when running cmd" - redeemAllGas r - Right r -> applyRedeem r + cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runPayload cmd managedNamespacePolicy + case cr of + Left e + -- 2.19 onwards errors return on chain + | chainweb219Pact' -> displayPactError e + -- 2.17 errors were removed + | chainweb217Pact' -> stripPactError e + | chainweb213Pact' || not (isOldListErr e) -> displayPactError e + | otherwise -> do + r <- failTxWith (toOldListErr e) "tx failure for request key when running cmd" + redeemAllGas r + Right r -> applyRedeem r applyRedeem cr = do - txGasModel .= _geGasModel freeGasEnv - txGasModelCore .= PCore.freeGasModel + txGasModel .= (Right gasModelCore) r <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! redeemGas txCtx cmd miner case r of @@ -374,74 +359,12 @@ applyCmd v logger gasLogger (pdbenv, coreDb) miner (gasModel, gasModelCore) txCt $ set crLogs (Just logs) $ over crEvents (es ++) cr - return $ cr' + return cr' listErrMsg :: Doc listErrMsg = "Unknown primitive \"list\" in determining cost of GUnreduced\nCallStack (from HasCallStack):\n error, called at src/Pact/Gas/Table.hs:209:22 in pact-4.2.0-fe223ad86f1795ba381192792f450820557e59c2926c747bf2aa6e398394bee6:Pact.Gas.Table" -applyGenesisCmd - :: (Logger logger) - => logger - -- ^ Pact logger - -> (PactDbEnv p, CoreDb) - -- ^ Pact db environment - -> SPVSupport - -- ^ SPV support (validates cont proofs) - -> TxContext - -- ^ tx metadata - -> Command (Payload PublicMeta ParsedCode) - -- ^ command with payload to execute - -> IO (T2 (CommandResult [TxLogJson]) (ModuleCache, CoreModuleCache)) -applyGenesisCmd logger (dbEnv, coreDb) spv txCtx cmd = - second (\s -> (_txCache s, _txCoreCache s)) <$!> runTransactionM tenv txst go - where - nid = networkIdOf cmd - rk = cmdToRequestKey cmd - tenv = TransactionEnv - { _txMode = Transactional - , _txDbEnv = dbEnv - , _txCoreDb = coreDb - , _txLogger = logger - , _txGasLogger = Nothing - , _txPublicData = def - , _txSpvSupport = spv - , _txNetworkId = nid - , _txGasPrice = 0.0 - , _txRequestKey = rk - , _txGasLimit = 0 - , _txExecutionConfig = ExecutionConfig - $ flagsFor (ctxVersion txCtx) (ctxChainId txCtx) (_blockHeight $ ctxBlockHeader txCtx) - -- TODO this is very ugly. Genesis blocks need to install keysets - -- outside of namespaces so we need to disable Pact 4.4. It would be - -- preferable to have a flag specifically for the namespaced keyset - -- 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 - , _txusePact5 = False - } - txst = TransactionState - { _txCache = mempty - , _txCoreCache = mempty - , _txLogs = mempty - , _txGasUsed = 0 - , _txGasId = Nothing - , _txGasModel = _geGasModel freeGasEnv - , _txGasModelCore = PCore.freeGasModel - , _txWarnings = mempty - } - - interp = initStateInterpreter - $ initCapabilities [magic_GENESIS, magic_COINBASE] - - go = do - -- TODO: fix with version recordification so that this matches the flags at genesis heights. - cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! runGenesis cmd permissiveNamespacePolicy interp - case cr of - Left e -> fatal $ "Genesis command failed: " <> sshow e - Right r -> r <$ debug "successful genesis tx for request key" - flagsFor :: ChainwebVersion -> V.ChainId -> BlockHeight -> S.Set ExecutionFlag flagsFor v cid bh = S.fromList $ concat [ enablePactEvents' v cid bh @@ -482,7 +405,7 @@ applyCoinbase -> CoinbaseUsePrecompiled -- ^ always enable precompilation -> (ModuleCache, CoreModuleCache) - -> IO (T2 (Either (CommandResult [TxLogJson]) PCore.CommandResult) (Maybe (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, cmc) | fork1_3InEffect || enablePC = do @@ -493,7 +416,7 @@ applyCoinbase v logger (dbEnv, coreDb) (Miner mid mks@(MinerKeys mk)) reward@(Pa let (cterm, cexec) = mkCoinbaseTerm mid mks reward interp = Interpreter $ \_ -> do put initState; fmap pure (eval cterm) coreState = setCoreModuleCache cmc $ initCoreCapabilities [core_magic_COINBASE] - coinbaseTerm = mkCoinbaseCoreTerm mid + (coinbaseTerm, _) = Pact5.mkCoinbaseTerm mid mks (GasSupply reward) go interp coreState cexec (Just coinbaseTerm) | otherwise = do cexec <- mkCoinbaseCmd mid mks reward @@ -509,10 +432,10 @@ applyCoinbase v logger (dbEnv, coreDb) (Miner mid mks@(MinerKeys mk)) reward@(Pa , S.singleton FlagDisableHistoryInTransactionalMode , flagsFor v (ctxChainId txCtx) (ctxCurrentBlockHeight txCtx) ] - usePact5 = pact5 v (ctxChainId txCtx) bh - tenv = TransactionEnv Transactional dbEnv coreDb logger Nothing (ctxToPublicData txCtx) noSPVSupport - Nothing 0.0 rk 0 ec Nothing usePact5 - txst = TransactionState mc cmc mempty 0 Nothing (_geGasModel freeGasEnv) (PCore.freeGasModel) mempty + usePactTng = chainweb223Pact v (ctxChainId txCtx) bh + tenv = TransactionEnv Transactional (Right coreDb) logger Nothing (ctxToPublicData txCtx) noSPVSupport + Nothing 0.0 rk 0 ec Nothing + txst = TransactionState mc mempty 0 Nothing (Right $ PCore.freeGasModel) mempty initState = setModuleCache mc $ initCapabilities [magic_COINBASE] rk = RequestKey chash parent = _tcParentHeader txCtx @@ -525,7 +448,7 @@ applyCoinbase v logger (dbEnv, coreDb) (Miner mid mks@(MinerKeys mk)) reward@(Pa go interp evState cexec@(ExecMsg _ execData) mCoinbaseTerm = evalTransactionM tenv txst $! do case mCoinbaseTerm of - Just coinbaseTerm | usePact5 -> do + Just coinbaseTerm -> do evalEnv <- mkCoreEvalEnv managedNamespacePolicy (MsgData execData Nothing chash mempty []) cr <- liftIO $ PCore.evalTermExec evalEnv evState coinbaseTerm @@ -539,47 +462,19 @@ applyCoinbase v logger (dbEnv, coreDb) (Miner mid mks@(MinerKeys mk)) reward@(Pa upgradedModuleCache <- applyUpgrades v cid bh - txCoreCache .= (CoreModuleCache (PCore._erLoadedModules er)) + coreCr <- mkCommandResultFromCoreResult er return $! T2 - (Right $ PCore.CommandResult $ PCore.PactResult $ Right $ PCore.PERExpr er) + coreCr upgradedModuleCache Left e | throwCritical -> throwM $ CoinbaseFailure $ sshow e - | otherwise -> (`T2` Nothing) <$> (Left <$> failTxWith (PactError EvalError (Info Nothing) [] mempty) "coinbase tx failure") + | otherwise -> (`T2` Nothing) <$> failTxWith (PactError EvalError (Info Nothing) [] mempty) "coinbase tx failure" _ -> do - cr <- catchesPactError logger (onChainErrorPrintingFor txCtx) $ - applyExec' 0 interp cexec [] [] chash managedNamespacePolicy + -- TODO: what to do if no coinbase term? + pure undefined - -- liftIO $ print cr - case cr of - Left e - | throwCritical -> throwM $ CoinbaseFailure $ sshow e - | otherwise -> (`T2` Nothing) <$> (Left <$> failTxWith e "coinbase tx failure") - Right er -> do - debug - $! "successful coinbase of " - <> T.take 18 (sshow d) - <> " to " - <> sshow mid - - upgradedModuleCache <- applyUpgrades v cid bh - - logs <- use txLogs - - return $! T2 - (Left $ 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) @@ -599,7 +494,7 @@ applyLocal -- ^ command with payload to execute -> (ModuleCache, CoreModuleCache) -> ExecutionConfig - -> IO (Either (CommandResult [TxLogJson]) PCore.CommandResult) + -> IO (CommandResult [TxLogJson]) applyLocal logger gasLogger (dbEnv, coreDb) (gasModel, gasModelCore) txCtx spv cmdIn (mc, cmc) execConfig = evalTransactionM tenv txst go where @@ -611,15 +506,15 @@ applyLocal logger gasLogger (dbEnv, coreDb) (gasModel, gasModelCore) txCtx spv c !verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd !gasPrice = view cmdGasPrice cmd !gasLimit = view cmdGasLimit cmd - tenv = TransactionEnv Local dbEnv coreDb logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice - rk (fromIntegral gasLimit) execConfig Nothing usePact5 - txst = TransactionState mc cmc mempty 0 Nothing gasModel gasModelCore mempty + tenv = TransactionEnv Local (Right coreDb) logger gasLogger (ctxToPublicData txCtx) spv nid gasPrice + rk (fromIntegral gasLimit) execConfig Nothing + txst = TransactionState mc mempty 0 Nothing (Right gasModelCore) mempty gas0 = initialGasOf (_cmdPayload cmdIn) currHeight = ctxCurrentBlockHeight txCtx cid = V._chainId txCtx v = _chainwebVersion txCtx allVerifiers = verifiersAt v cid currHeight - usePact5 = pact5 (ctxVersion txCtx) (ctxChainId txCtx) currHeight + usePactTng = chainweb223Pact (ctxVersion txCtx) (ctxChainId txCtx) currHeight -- Note [Throw out verifier proofs eagerly] !verifiersWithNoProof = (fmap . fmap) (\_ -> ()) verifiers @@ -631,7 +526,7 @@ applyLocal logger gasLogger (dbEnv, coreDb) (gasModel, gasModelCore) txCtx spv c case verifierResult of Left err -> do let errMsg = "Tx verifier error: " <> getVerifierError err - Left <$> failTxWith + failTxWith (PactError TxFailure def [] (pretty errMsg)) errMsg Right verifierGasRemaining -> do @@ -640,124 +535,17 @@ applyLocal logger gasLogger (dbEnv, coreDb) (gasModel, gasModelCore) txCtx spv c applyPayload gas1 m = do interp <- gasInterpreter gas1 - coreState <- do - cmc' <- use txCoreCache - pure $ setCoreModuleCache cmc' def + let coreState = def cr <- catchesPactError logger PrintsUnexpectedError $! case m of - Exec em -> do - if usePact5 then applyExecTng gas1 coreState em signers chash managedNamespacePolicy - else applyExec gas1 interp em signers verifiersWithNoProof chash managedNamespacePolicy - Continuation cm -> - if usePact5 then applyContinuationTng gas1 coreState cm signers chash managedNamespacePolicy - else applyContinuation gas1 interp cm signers chash managedNamespacePolicy - - if usePactTng then do - cr <- case m of - Exec em -> applyExecTng gas1 coreState em signers chash managedNamespacePolicy - Continuation cm -> applyContinuationTng gas1 coreState cm signers chash managedNamespacePolicy - - Right <$> case PCore._pactResult $ PCore._crResult cr of - Left e -> do - failTx5With e "applyLocal" - pure cr - Right _ -> pure cr - else do - cr <- catchesPactError logger PrintsUnexpectedError $! case m of - Exec em -> applyExec gas1 interp em signers verifiersWithNoProof chash managedNamespacePolicy - Continuation cm -> applyContinuation gas1 interp cm signers chash managedNamespacePolicy - - Left <$> case cr of - Left e -> failTxWith e "applyLocal" - Right r -> return $! r { _crMetaData = Just (J.toJsonViaEncode $ ctxToPublicData' txCtx) } + Exec em -> applyExec gas1 coreState em signers chash managedNamespacePolicy + Continuation cm -> applyContinuation gas1 coreState cm signers chash managedNamespacePolicy - go = checkTooBigTx gas0 gasLimit (applyVerifiers $ _pPayload $ _cmdPayload cmd) return - -readInitModules - :: forall logger tbl. (Logger logger) - => PactBlockM logger tbl (ModuleCache, CoreModuleCache) -readInitModules = do - logger <- view (psServiceEnv . psLogger) - dbEnv <- _cpPactDbEnv <$> view psBlockDbEnv - coreDb <- _cpPactCoreDbEnv <$> 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 - cid = ctxChainId txCtx - h = _blockHeight (_parentHeader parent) + 1 - rk = RequestKey chash - nid = Nothing - chash = pactInitialHash - usePact5 = True - tenv = TransactionEnv Local dbEnv coreDb logger Nothing (ctxToPublicData txCtx) noSPVSupport nid 0.0 - rk 0 def Nothing usePact5 - txst = TransactionState mempty mempty mempty 0 Nothing (_geGasModel freeGasEnv) PCore.freeGasModel mempty - interp = defaultInterpreter - die msg = throwM $ PactInternalError $ "readInitModules: " <> msg - mkCmd = buildExecParsedCode (pactParserVersion v cid h) Nothing - run msg cmd = do - er <- catchesPactError logger (onChainErrorPrintingFor txCtx) $! do - applyExec' 0 interp cmd [] [] chash permissiveNamespacePolicy - case er of - Left e -> die $ msg <> ": failed: " <> sshow e - Right r -> case _erOutput r of - [] -> die $ msg <> ": empty result" - (o:_) -> return o + case cr of + Left e -> failTxWith e "applyLocal" + Right r -> return $! r { _crMetaData = Just (J.toJsonViaEncode $ ctxToPublicData' txCtx) } - go :: TransactionM logger p (ModuleCache, CoreModuleCache) - go = do - -- see if fungible-v2 is there - checkCmd <- liftIO $ mkCmd "(contains \"fungible-v2\" (list-modules))" - checkFv2 <- run "check fungible-v2" checkCmd - hasFv2 <- case checkFv2 of - (PLiteral (LBool b)) -> return b - t -> die $ "got non-bool result from module read: " <> T.pack (showPretty t) - - -- see if fungible-xchain-v1 is there - checkCmdx <- liftIO $ mkCmd "(contains \"fungible-xchain-v1\" (list-modules))" - checkFx <- run "check fungible-xchain-v1" checkCmdx - hasFx <- case checkFx of - (PLiteral (LBool b)) -> return b - t -> die $ "got non-bool result from module read: " <> T.pack (showPretty t) - - -- load modules by referencing members - refModsCmd <- liftIO $ mkCmd $ T.intercalate " " $ - [ "coin.MINIMUM_PRECISION" - , "ns.GUARD_SUCCESS" - , "(use gas-payer-v1)" - , "fungible-v1.account-details"] ++ - [ "fungible-v2.account-details" | hasFv2 ] ++ - [ "(let ((m:module{fungible-xchain-v1} coin)) 1)" | hasFx ] - void $ run "load modules" refModsCmd - - -- return loaded cache - 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, CoreModuleCache) - goCw217 = do - coinDepCmd <- liftIO $ mkCmd "coin.MINIMUM_PRECISION" - void $ run "load modules" coinDepCmd - c <- use txCache - cc <- use txCoreCache - pure (c, cc) - - if | chainweb224Pact' -> pure mempty - | chainweb217Pact' -> liftIO $ evalTransactionM tenv txst goCw217 - | otherwise -> liftIO $ evalTransactionM tenv txst go + go = checkTooBigTx gas0 gasLimit (applyVerifiers $ _pPayload $ _cmdPayload cmd) return -- | Apply (forking) upgrade transactions and module cache updates -- at a particular blockheight. @@ -783,14 +571,13 @@ applyUpgrades v cid height coinModuleName = ModuleName "coin" Nothing coinCoreModuleName = PCore.ModuleName "coin" Nothing installCoinModuleAdmin = set (evalCapabilities . capModuleAdmin) $ S.singleton coinModuleName - -- installCoreCoinModuleAdmin = set (PCore.esCaps . PCore.csModuleAdmin) $ S.singleton coinCoreModuleName + installCoreCoinModuleAdmin = set (PCore.esCaps . PCore.csModuleAdmin) $ S.singleton coinCoreModuleName filterModuleCache = do mc <- use txCache - cmc <- use txCoreCache pure $ Just $ ( filterModuleCacheByKey (== coinModuleName) mc - , filterCoreModuleCacheByKey (== coinCoreModuleName) cmc + , mempty ) applyUpgrade upg = do @@ -810,18 +597,14 @@ applyUpgrades v cid height (mapM applyTx payloads) return $ Just $ bimap mconcat mconcat $ unzip $ reverse caches - interp = initStateInterpreter - $ installCoinModuleAdmin - $ initCapabilities [mkMagicCapSlot "REMEDIATE"] - -- coreInitState = installCoreCoinModuleAdmin $ initCoreCapabilities [mkMagicCoreCapSlot "REMEDIATE"] + coreInitState = installCoreCoinModuleAdmin $ initCoreCapabilities [mkMagicCoreCapSlot "REMEDIATE"] applyTx tx = do infoLog $ "Running upgrade tx " <> sshow (_cmdHash tx) - tryAllSynchronous (runGenesis tx permissiveNamespacePolicy interp) >>= \case + tryAllSynchronous (runGenesisCore tx permissiveNamespacePolicy coreInitState) >>= \case Right _ -> do c <- use txCache - cc <- use txCoreCache - pure (c, cc) + pure (c, undefined) Left e -> do logError $ "Upgrade transaction failed! " <> sshow e throwM e @@ -843,20 +626,6 @@ failTxWith err msg = do return $! CommandResult rk Nothing (PactResult (Left err)) gas (Just logs) Nothing Nothing [] -failTx5With - :: (Logger logger) - => PCore.PactError PCore.SpanInfo - -> Text - -> TransactionM logger p () -failTx5With err msg = do - logs <- use txLogs - gas <- view txGasLimit -- error means all gas was charged - rk <- view txRequestKey - l <- view txLogger - - liftIO $ logFunction l L.Info - (Pact5TxFailureLog rk err msg) - runPayload :: (Logger logger) => Command (Payload PublicMeta ParsedCode) @@ -865,37 +634,7 @@ runPayload runPayload cmd nsp = do g0 <- use txGasUsed interp <- gasInterpreter g0 - coreState <- do - cmc <- use txCoreCache - pure $ setCoreModuleCache cmc def - - -- Note [Throw out verifier proofs eagerly] - let !verifiersWithNoProof = - (fmap . fmap) (\_ -> ()) verifiers - `using` (traverse . traverse) rseq - - usePact5 <- view txusePact5 - case payload of - Exec pm -> applyExec g0 interp pm signers verifiersWithNoProof chash nsp - Continuation ym -> applyContinuation g0 interp ym signers chash nsp - - where - verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd - signers = _pSigners $ _cmdPayload cmd - chash = toUntypedHash $ _cmdHash cmd - payload = _pPayload $ _cmdPayload cmd - -runPayloadTng - :: (Logger logger) - => Command (Payload PublicMeta ParsedCode) - -> NamespacePolicy - -> TransactionM logger p PCore.CommandResult -runPayloadTng cmd nsp = do - g0 <- use txGasUsed - interp <- gasInterpreter g0 - coreState <- do - cmc <- use txCoreCache - pure $ setCoreModuleCache cmc def + let coreState = def -- Note [Throw out verifier proofs eagerly] let !verifiersWithNoProof = @@ -903,8 +642,8 @@ runPayloadTng cmd nsp = do `using` (traverse . traverse) rseq case payload of - Exec pm -> applyExecTng g0 coreState pm signers chash nsp - Continuation ym -> applyContinuationTng g0 coreState ym signers chash nsp + Exec pm -> applyExec g0 coreState pm signers chash nsp + Continuation ym -> applyContinuation g0 coreState ym signers chash nsp where verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd @@ -912,29 +651,6 @@ runPayloadTng cmd nsp = do chash = toUntypedHash $ _cmdHash cmd payload = _pPayload $ _cmdPayload cmd --- | Run genesis transaction payloads with custom interpreter --- -runGenesis - :: (Logger logger) - => Command (Payload PublicMeta ParsedCode) - -> NamespacePolicy - -> Interpreter p - -> TransactionM logger p (CommandResult [TxLogJson]) -runGenesis cmd nsp interp = case payload of - Exec pm -> -- TODO: make it work for the core - applyExec 0 interp pm signers verifiersWithNoProof chash nsp - Continuation ym -> - applyContinuation 0 interp ym signers chash nsp - where - signers = _pSigners $ _cmdPayload cmd - verifiers = fromMaybe [] $ _pVerifiers $ _cmdPayload cmd - -- Note [Throw out verifier proofs eagerly] - !verifiersWithNoProof = - (fmap . fmap) (\_ -> ()) verifiers - `using` (traverse . traverse) rseq - chash = toUntypedHash $ _cmdHash cmd - payload = _pPayload $ _cmdPayload cmd - runGenesisCore :: (Logger logger) => Command (Payload PublicMeta ParsedCode) @@ -942,40 +658,13 @@ runGenesisCore -> PCore.EvalState PCore.CoreBuiltin PCore.SpanInfo -> TransactionM logger p () runGenesisCore cmd nsp coreState = case payload of - Exec pm -> void $ applyExecTng' 0 coreState pm signers chash nsp + Exec pm -> void $ applyExec' 0 coreState pm signers chash nsp Continuation _ -> error "runGenesisCore Continuation not supported" where signers = _pSigners $ _cmdPayload cmd chash = toUntypedHash $ _cmdHash cmd payload = _pPayload $ _cmdPayload cmd --- | Execute an 'ExecMsg' and Return the result with module cache --- -applyExec - :: (Logger logger) - => Gas - -> Interpreter p - -> ExecMsg ParsedCode - -> [Signer] - -> [Verifier ()] - -> Hash - -> NamespacePolicy - -> TransactionM logger p (CommandResult [TxLogJson]) -applyExec initialGas interp em senderSigs verifiers hsh nsp = do - EvalResult{..} <- applyExec' initialGas interp em senderSigs verifiers hsh nsp - for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl - !logs <- use txLogs - !rk <- view txRequestKey - - -- concat tx warnings with eval warnings - modify' $ txWarnings <>~ _erWarnings - - -- applyExec enforces non-empty expression set so `last` ok - -- forcing it here for lazy errors. TODO NFData the Pacts - let !lastResult = force $ last _erOutput - return $ CommandResult rk _erTxId (PactResult (Right lastResult)) - _erGas (Just logs) _erExec Nothing _erEvents - mkCommandResultFromCoreResult :: (Logger logger) => PCore.EvalResult a @@ -1050,7 +739,7 @@ mkCommandResultFromCoreResult PCore.EvalResult{..} = do (case _erGas of { PCore.Gas g -> Gas $ fromIntegral g }) (Just logs) (toPactExec <$> _erExec) Nothing (map toPactEvent _erEvents) -applyExecTng +applyExec :: (Logger logger) => Gas -> PCore.EvalState PCore.CoreBuiltin PCore.SpanInfo @@ -1058,53 +747,13 @@ applyExecTng -> [Signer] -> Hash -> NamespacePolicy - -> TransactionM logger p PCore.CommandResult -- (Either (PCore.PactError PCore.SpanInfo) (PCore.EvalResult [PCore.TopLevel PCore.SpanInfo])) -applyExecTng initialGas coreState em senderSigs hsh nsp = do - er <- applyExecTng' initialGas coreState em senderSigs hsh nsp + -> TransactionM logger p (CommandResult [TxLogJson]) +applyExec initialGas coreState em senderSigs hsh nsp = do + er <- applyExec' initialGas coreState em senderSigs hsh nsp - -- return er - pure $ PCore.CommandResult $ PCore.PactResult $ PCore.PERTopLevel <$> er - -- either id mkCommandResultFromCoreResult er + mkCommandResultFromCoreResult er --- | Variation on 'applyExec' that returns 'EvalResult' as opposed to --- wrapping it up in a JSON result. --- applyExec' - :: (Logger logger) - => Gas - -> Interpreter p - -> ExecMsg ParsedCode - -> [Signer] - -> [Verifier ()] - -> Hash - -> NamespacePolicy - -> TransactionM logger p EvalResult -applyExec' initialGas interp (ExecMsg parsedCode execData) senderSigs verifiersWithNoProof hsh nsp - | null (_pcExps parsedCode) = throwCmdEx "No expressions found" - | otherwise = do - - eenv <- mkEvalEnv nsp (MsgData execData Nothing hsh senderSigs verifiersWithNoProof) - - setEnvGas initialGas eenv - - 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 quirkedEvalResult) $ \pe -> debug - $ "applyExec: new pact added: " - <> sshow (_pePactId pe, _peStep pe, _peYield pe, _peExecuted pe) - - -- set log + cache updates + used gas - setTxResultState quirkedEvalResult - - return quirkedEvalResult - -applyExecTng' :: (Logger logger) => Gas -> PCore.EvalState PCore.CoreBuiltin PCore.SpanInfo @@ -1112,8 +761,8 @@ applyExecTng' -> [Signer] -> Hash -> NamespacePolicy - -> TransactionM logger p (Either (PCore.PactError PCore.SpanInfo) (PCore.EvalResult [PCore.TopLevel PCore.SpanInfo])) -applyExecTng' (Gas initialGas) coreState (ExecMsg parsedCode execData) senderSigs hsh nsp + -> TransactionM logger p (PCore.EvalResult [PCore.TopLevel PCore.SpanInfo]) +applyExec' (Gas initialGas) coreState (ExecMsg parsedCode execData) senderSigs hsh nsp | null (_pcExps parsedCode) = throwCmdEx "No expressions found" | otherwise = do @@ -1121,9 +770,6 @@ applyExecTng' (Gas initialGas) coreState (ExecMsg parsedCode execData) senderSig setEnvGasCore (PCore.Gas $ fromIntegral initialGas) evalEnv - ccache <- use txCoreCache - - er <- liftIO $! PCore.evalExec evalEnv coreState (PCore.RawCode $ _pcCode parsedCode) case er of Right er' -> do @@ -1136,15 +782,12 @@ applyExecTng' (Gas initialGas) coreState (ExecMsg parsedCode execData) senderSig Nothing -> er' Just (Gas fee) -> er' { PCore._erGas = PCore.Gas $ fromIntegral fee } - txCoreCache .= (CoreModuleCache $ PCore._erLoadedModules er') - return $ Right quirkedEvalResult + return quirkedEvalResult Left err -> do -- TRACE.traceShowM ("CORE.applyExec' modulecache" :: String, show $ _getCoreModuleCache ccache) TRACE.traceShowM ("CORE.applyExec'!!!!" :: String, show err, show $ PCore.RawCode $ _pcCode parsedCode) - -- TODO: return either an error instead of throwing an exception here fatal $ "Pact Tng execution failed: " <> (T.pack $ show $ PCore.pretty err) - return $ Left err enablePactEvents' :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] enablePactEvents' v cid bh = [FlagDisablePactEvents | not (enablePactEvents v cid bh)] @@ -1201,31 +844,7 @@ enablePact412 v cid bh = [FlagDisablePact412 | not (chainweb224Pact v cid bh)] disableReturnRTC :: ChainwebVersion -> V.ChainId -> BlockHeight -> [ExecutionFlag] disableReturnRTC _v _cid _bh = [FlagDisableRuntimeReturnTypeChecking] --- | Execute a 'ContMsg' and return the command result and module cache --- applyContinuation - :: (Logger logger) - => Gas - -> Interpreter p - -> ContMsg - -> [Signer] - -> Hash - -> NamespacePolicy - -> TransactionM logger p (CommandResult [TxLogJson]) -applyContinuation initialGas interp cm senderSigs hsh nsp = do - EvalResult{..} <- applyContinuation' initialGas interp cm senderSigs hsh nsp - for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl - logs <- use txLogs - rk <- view txRequestKey - - -- set tx warnings to eval warnings - txWarnings <>= _erWarnings - - -- last safe here because cont msg is guaranteed one exp - return $! CommandResult rk _erTxId (PactResult (Right (last _erOutput))) - _erGas (Just logs) _erExec Nothing _erEvents - -applyContinuationTng :: (Logger logger) => Gas -> PCore.EvalState PCore.CoreBuiltin PCore.SpanInfo @@ -1233,56 +852,24 @@ applyContinuationTng -> [Signer] -> Hash -> NamespacePolicy - -> TransactionM logger p PCore.CommandResult -- (Either (PCore.PactError PCore.SpanInfo) (PCore.EvalResult [PCore.TopLevel PCore.SpanInfo])) -applyContinuationTng initialGas coreState cm senderSigs hsh nsp = do - er <- applyContinuationTng' initialGas coreState cm senderSigs hsh nsp - -- return er - -- either id mkCommandResultFromCoreResult - pure $ PCore.CommandResult $ PCore.PactResult $ PCore.PERTopLevel <$> er - + -> TransactionM logger p (CommandResult [TxLogJson]) +applyContinuation initialGas coreState cm senderSigs hsh nsp = do + er <- applyContinuation' initialGas coreState cm senderSigs hsh nsp + cr <- mkCommandResultFromCoreResult er -- for_ _erLogGas $ \gl -> gasLog $ "gas logs: " <> sshow gl -- TODO: set tx warnings to eval warnings -- txWarnings <>= _erWarnings + return cr + setEnvGas :: Gas -> EvalEnv e -> TransactionM logger p () setEnvGas initialGas = liftIO . views eeGas (`writeIORef` gasToMilliGas initialGas) setEnvGasCore :: PCore.Gas -> PCore.EvalEnv PCore.CoreBuiltin PCore.SpanInfo -> TransactionM logger p () setEnvGasCore initialGas = liftIO . views PCore.eeGasRef (`writeIORef` PCore.gasToMilliGas initialGas) --- | Execute a 'ContMsg' and return just eval result, not wrapped in a --- 'CommandResult' wrapper --- applyContinuation' - :: Gas - -> Interpreter p - -> ContMsg - -> [Signer] - -> Hash - -> NamespacePolicy - -> TransactionM logger p EvalResult -applyContinuation' initialGas interp cm@(ContMsg pid s rb d _) senderSigs hsh nsp = do - - eenv <- mkEvalEnv nsp (MsgData d pactStep hsh senderSigs []) - - setEnvGas initialGas eenv - - 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 quirkedEvalResult - - return quirkedEvalResult - where - pactStep = Just $ PactStep s rb pid Nothing - -applyContinuationTng' :: (Logger logger) => Gas -> PCore.EvalState PCore.CoreBuiltin PCore.SpanInfo @@ -1290,8 +877,8 @@ applyContinuationTng' -> [Signer] -> Hash -> NamespacePolicy - -> TransactionM logger p (Either (PCore.PactError PCore.SpanInfo) (PCore.EvalResult [PCore.TopLevel PCore.SpanInfo])) -applyContinuationTng' initialGas coreState (ContMsg pid s rb d proof) senderSigs hsh nsp = do + -> TransactionM logger p (PCore.EvalResult [PCore.TopLevel PCore.SpanInfo]) +applyContinuation' initialGas coreState (ContMsg pid s rb d proof) senderSigs hsh nsp = do evalEnv <- mkCoreEvalEnv nsp (MsgData d pactStep hsh senderSigs []) @@ -1299,13 +886,13 @@ applyContinuationTng' initialGas coreState (ContMsg pid s rb d proof) senderSigs let convertPactValue pv = PactConversion.fromLegacyPactValue $ - aeson (error "applyContinuationTng': failed to parseJSON pact value") id $ A.fromJSON $ _getLegacyValue pv + aeson (error "applyContinuation': failed to parseJSON pact value") id $ A.fromJSON $ _getLegacyValue pv coreCm = PCore.ContMsg { PCore._cmPactId = coerce pid , PCore._cmStep = s , PCore._cmRollback = rb - , PCore._cmData = either (error "applyContinuationTng': failed to convert pact value") id $ convertPactValue d + , PCore._cmData = either (error "applyContinuation': failed to convert pact value") id $ convertPactValue d , PCore._cmProof = coerce proof } @@ -1319,9 +906,9 @@ applyContinuationTng' initialGas coreState (ContMsg pid s rb d proof) senderSigs Nothing -> er' Just (Gas fee) -> er' { PCore._erGas = PCore.Gas $ fromIntegral fee } - txCoreCache .= (CoreModuleCache $ PCore._erLoadedModules er') - return $ Right $ quirkedEvalResult - err -> pure err + return quirkedEvalResult + Left err -> do + fatal $ "Pact Tng execution failed: " <> (T.pack $ show $ PCore.pretty err) where pactStep = Just $ PactStep s rb pid Nothing @@ -1350,7 +937,6 @@ buyGas txCtx cmd (Miner mid mks) = go go = do mcache <- use txCache - cmcache <- use txCoreCache supply <- gasSupplyOf <$> view txGasLimit <*> view txGasPrice logGas <- isJust <$> view txGasLogger @@ -1365,7 +951,7 @@ buyGas txCtx cmd (Miner mid mks) = go -- of our choice. we do the same to redeem gas. interp mc = Interpreter $ \_input -> put (initState mc logGas) >> run (pure <$> eval buyGasTerm) - coreState = setCoreModuleCache cmcache $ initCoreCapabilities [core_magic_GAS] + coreState = initCoreCapabilities [core_magic_GAS] let gasCapName = QualifiedName (ModuleName "coin" Nothing) "GAS" def @@ -1379,60 +965,35 @@ buyGas txCtx cmd (Miner mid mks) = go fmap addDebit signersWithDebit = addDebitToSigners $ _pSigners $ _cmdPayload cmd - -- no verifiers are allowed in buy gas - -- quirked gas is not used either - result <- locally txQuirkGasFee (const Nothing) $ - applyExec' 0 (interp mcache) buyGasCmd signersWithDebit [] bgHash managedNamespacePolicy - usePact5 <- view txusePact5 - if usePact5 then do - evalEnv <- mkCoreEvalEnv managedNamespacePolicy (MsgData execData Nothing bgHash signersWithDebit []) + evalEnv <- mkCoreEvalEnv managedNamespacePolicy (MsgData execData Nothing bgHash signersWithDebit []) - let - t = if isChainweb224Pact - then mkBuyGasCoreTerm sender - else mkFundTxCoreTerm mid sender + let + (t, _) = if isChainweb224Pact + then Pact5.mkBuyGasTerm sender supply + else Pact5.mkFundTxTerm mid mks sender supply - er <- liftIO $ PCore.evalTermExec evalEnv coreState t - case er of - Right er' -> do - case PCore._erExec er' of - Nothing - | isChainweb224Pact -> - return () - | otherwise -> - -- should never occur pre-chainweb 2.24: - -- would mean coin.fund-tx is not a pact - fatal "buyGas: Internal error - empty continuation before 2.24 fork" - Just pe - | isChainweb224Pact -> - fatal "buyGas: Internal error - continuation found after 2.24 fork" - | otherwise -> do - void $! txGasId .= (Just $! GasId (coerce $ PCore._peDefPactId pe)) - txCoreCache .= (CoreModuleCache $ PCore._erLoadedModules er') - Left err -> do - TRACE.traceM $ "CORE.buyGas failed!!" <> sshow err <> "\n" <> sshow t - fatal $ "buyGas: Internal error - " <> sshow err - else do - -- no verifiers are allowed in buy gas - -- 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 - | isChainweb224Pact -> - return () - | otherwise -> - -- should never occur pre-chainweb 2.24: - -- would mean coin.fund-tx is not a pact - fatal "buyGas: Internal error - empty continuation before 2.24 fork" - Just pe - | isChainweb224Pact -> - fatal "buyGas: Internal error - continuation found after 2.24 fork" - | otherwise -> - void $! txGasId .= (Just $! GasId (_pePactId pe)) + -- no verifiers are allowed in buy gas + -- quirked gas is not used either + er <- locally txQuirkGasFee (const Nothing) $ liftIO $ PCore.evalTermExec evalEnv coreState t + case er of + Right er' -> do + case PCore._erExec er' of + Nothing + | isChainweb224Pact -> + return () + | otherwise -> + -- should never occur pre-chainweb 2.24: + -- would mean coin.fund-tx is not a pact + fatal "buyGas: Internal error - empty continuation before 2.24 fork" + Just pe + | isChainweb224Pact -> + fatal "buyGas: Internal error - continuation found after 2.24 fork" + | otherwise -> do + void $! txGasId .= (Just $! GasId (coerce $ PCore._peDefPactId pe)) + Left err -> do + TRACE.traceM $ "CORE.buyGas failed!!" <> sshow err <> "\n" <> sshow t + fatal $ "buyGas: Internal error - " <> sshow err findPayer :: TxContext @@ -1502,14 +1063,12 @@ enrichedMsgBody cmd = case (_pPayload $ _cmdPayload cmd) of redeemGas :: (Logger logger) => TxContext -> Command (Payload PublicMeta ParsedCode) -> Miner -> TransactionM logger p [PactEvent] redeemGas txCtx cmd (Miner mid mks) = do mcache <- use txCache - cmcache <- use txCoreCache let sender = view (cmdPayload . pMeta . pmSender) cmd fee <- gasSupplyOf <$> use txGasUsed <*> view txGasPrice -- if we're past chainweb 2.24, we don't use defpacts for gas - usePact5 <- view txusePact5 let - coreState = setCoreModuleCache cmcache $ initCoreCapabilities [core_magic_GAS] + coreState = initCoreCapabilities [core_magic_GAS] if guardCtx chainweb224Pact txCtx then do @@ -1525,39 +1084,32 @@ redeemGas txCtx cmd (Miner mid mks) = do fmap List.singleton (eval redeemGasTerm) (Hash chash) = toUntypedHash (_cmdHash cmd) rgHash = Hash (chash <> "-redeemgas") - locally txQuirkGasFee (const Nothing) $ - if usePact5 then do - evalEnv <- mkCoreEvalEnv managedNamespacePolicy (MsgData execData Nothing rgHash (_pSigners $ _cmdPayload cmd) []) - - er <- liftIO $ PCore.evalTermExec evalEnv coreState $ mkRedeemGasCoreTerm mid sender - case er of - Right er' -> do - let - convertPactValue pv = J.decodeStrict $ PCore.encodeStable pv - toModuleName m = - ModuleName - { _mnName = PCore._mnName m - , _mnNamespace = coerce <$> PCore._mnNamespace m - } - toPactEvent e = - PactEvent - { _eventName = PCore._peName e - , _eventParams = catMaybes $ convertPactValue <$> PCore._peArgs e - , _eventModule = toModuleName $ PCore._peModule e - , _eventModuleHash = coerce $ PCore._peModuleHash e - } - txCoreCache .= (CoreModuleCache $ PCore._erLoadedModules er') - return $ map toPactEvent $ PCore._erEvents er' - - Left err -> do - TRACE.traceM $ "CORE.redeemGas failed!!" <> sshow err - fatal $ "redeemGas: Internal error - " <> sshow err - else _erEvents <$> - applyExec' 0 interp redeemGasCmd - (_pSigners $ _cmdPayload cmd) - [] - rgHash - managedNamespacePolicy + (redeemGasTermCore, _) = Pact5.mkRedeemGasTerm mid mks sender total fee + locally txQuirkGasFee (const Nothing) $ do + evalEnv <- mkCoreEvalEnv managedNamespacePolicy (MsgData execData Nothing rgHash (_pSigners $ _cmdPayload cmd) []) + + er <- liftIO $ PCore.evalTermExec evalEnv coreState redeemGasTermCore + case er of + Right er' -> do + let + convertPactValue pv = J.decodeStrict $ PCore.encodeStable pv + toModuleName m = + ModuleName + { _mnName = PCore._mnName m + , _mnNamespace = coerce <$> PCore._mnNamespace m + } + toPactEvent e = + PactEvent + { _eventName = PCore._peName e + , _eventParams = catMaybes $ convertPactValue <$> PCore._peArgs e + , _eventModule = toModuleName $ PCore._peModule e + , _eventModuleHash = coerce $ PCore._peModuleHash e + } + return $ map toPactEvent $ PCore._erEvents er' + + Left err -> do + TRACE.traceM $ "CORE.redeemGas failed!!" <> sshow err + fatal $ "redeemGas: Internal error - " <> sshow err else do GasId gid <- use txGasId >>= \case Nothing -> fatal $! "redeemGas: no gas id in scope for gas refunds" @@ -1565,15 +1117,10 @@ redeemGas txCtx cmd (Miner mid mks) = do let redeemGasCmd = ContMsg gid 1 False (toLegacyJson $ object [ "fee" A..= toJsonViaEncode fee ]) Nothing - locally txQuirkGasFee (const Nothing) $ - if usePact5 then do - r <- applyContinuationTng 0 coreState redeemGasCmd - (_pSigners $ _cmdPayload cmd) (toUntypedHash $ _cmdHash cmd) - managedNamespacePolicy - return [] - else fmap _crEvents $ applyContinuation 0 (initState mcache) redeemGasCmd - (_pSigners $ _cmdPayload cmd) (toUntypedHash $ _cmdHash cmd) - managedNamespacePolicy + fmap _crEvents $ locally txQuirkGasFee (const Nothing) $ + applyContinuation 0 coreState redeemGasCmd + (_pSigners $ _cmdPayload cmd) (toUntypedHash $ _cmdHash cmd) + managedNamespacePolicy where initState mc = initStateInterpreter @@ -1606,9 +1153,9 @@ checkTooBigTx :: (Logger logger) => Gas -> GasLimit - -> TransactionM logger p (Either (CommandResult [TxLogJson]) PCore.CommandResult) - -> ((CommandResult [TxLogJson]) -> TransactionM logger p ((CommandResult [TxLogJson]))) - -> TransactionM logger p (Either (CommandResult [TxLogJson]) PCore.CommandResult) + -> TransactionM logger p (CommandResult [TxLogJson]) + -> (CommandResult [TxLogJson] -> TransactionM logger p (CommandResult [TxLogJson])) + -> TransactionM logger p (CommandResult [TxLogJson]) checkTooBigTx initialGas gasLimit next onFail | initialGas >= fromIntegral gasLimit = do @@ -1616,9 +1163,8 @@ checkTooBigTx initialGas gasLimit next onFail $ "Tx too big (" <> pretty initialGas <> "), limit " <> pretty gasLimit - Left <$> do - r <- failTxWith pe "Tx too big" - onFail r + r <- failTxWith pe "Tx too big" + onFail r | otherwise = next gasInterpreter :: Gas -> TransactionM logger db (Interpreter p) @@ -1690,81 +1236,6 @@ setTxResultState er = do txGasUsed .= _erGas er {-# INLINE setTxResultState #-} --- | Make an 'EvalEnv' given a tx env + state --- -mkEvalEnv - :: NamespacePolicy - -> MsgData - -> TransactionM logger db (EvalEnv db) -mkEvalEnv nsp msg = do - tenv <- ask - genv <- GasEnv - <$> view (txGasLimit . to (MilliGasLimit . gasToMilliGas)) - <*> view txGasPrice - <*> use txGasModel - fmap (set eeSigCapBypass txCapBypass) - $ liftIO $ setupEvalEnv (_txDbEnv tenv) Nothing (_txMode tenv) - msg (versionedNativesRefStore (_txExecutionConfig tenv)) genv - nsp (_txSpvSupport tenv) (_txPublicData tenv) (_txExecutionConfig tenv) - where - txCapBypass = - M.fromList - [ (wizaDebit, (wizaBypass, wizaMH)) - , (skdxDebit, (kdxBypass, skdxMH)) - , (collectGallinasMarket, (collectGallinasBypass, collectGallinasMH)) - , (marmaladeGuardPolicyMint, (marmaladeBypass, marmaladeGuardPolicyMH)) - ] - where - -- wiza code - wizaDebit = QualifiedName "free.wiza" "DEBIT" def - wizaMH = unsafeModuleHashFromB64Text "8b4USA1ZNVoLYRT1LBear4YKt3GB2_bl0AghZU8QxjI" - wizEquipmentOwner = QualifiedName "free.wiz-equipment" "OWNER" def - wizEquipmentAcctGuard = QualifiedName "free.wiz-equipment" "ACCOUNT_GUARD" def - wizArenaAcctGuard = QualifiedName "free.wiz-arena" "ACCOUNT_GUARD" def - wizArenaOwner = QualifiedName "free.wiz-arena" "OWNER" def - wizaTransfer = QualifiedName "free.wiza" "TRANSFER" def - - wizaBypass granted sigCaps = - let debits = filter ((== wizaDebit) . _scName) $ S.toList granted - in all (\c -> any (match c) sigCaps) debits - where - match prov sigCap = fromMaybe False $ do - guard $ _scName sigCap `elem` wizaBypassList - sender <- preview _head (_scArgs prov) - (== sender) <$> preview _head (_scArgs sigCap) - wizaBypassList = - [ wizArenaOwner - , wizEquipmentOwner - , wizaTransfer - , wizEquipmentAcctGuard - , wizArenaAcctGuard] - -- kaddex code - skdxDebit = QualifiedName "kaddex.skdx" "DEBIT" def - skdxMH = unsafeModuleHashFromB64Text "g90VWmbKj87GkMkGs8uW947kh_Wg8JdQowa8rO_vZ1M" - kdxUnstake = QualifiedName "kaddex.staking" "UNSTAKE" def - - kdxBypass granted sigCaps = - let debits = filter ((== skdxDebit) . _scName) $ S.toList granted - in all (\c -> S.member (SigCapability kdxUnstake (_scArgs c)) sigCaps) debits - -- Collect-gallinas code - collectGallinasMH = unsafeModuleHashFromB64Text "x3BLGdidqSjUQy5q3MorGco9mBDpoVTh_Yoagzu0hls" - collectGallinasMarket = QualifiedName "free.collect-gallinas" "MARKET" def - collectGallinasAcctGuard = QualifiedName "free.collect-gallinas" "ACCOUNT_GUARD" def - - collectGallinasBypass granted sigCaps = fromMaybe False $ do - let mkt = filter ((== collectGallinasMarket) . _scName) $ S.toList granted - let matchingGuard provided toMatch = _scName toMatch == collectGallinasAcctGuard && (_scArgs provided == _scArgs toMatch) - pure $ all (\c -> any (matchingGuard c) sigCaps) mkt - -- marmalade code - marmaladeGuardPolicyMH = unsafeModuleHashFromB64Text "LB5sRKx8jN3FP9ZK-rxDK7Bqh0gyznprzS8L4jYlT5o" - marmaladeGuardPolicyMint = QualifiedName "marmalade-v2.guard-policy-v1" "MINT" def - marmaladeLedgerMint = QualifiedName "marmalade-v2.ledger" "MINT-CALL" def - - marmaladeBypass granted sigCaps = fromMaybe False $ do - let mkt = filter ((== marmaladeGuardPolicyMint) . _scName) $ S.toList granted - let matchingGuard provided toMatch = _scName toMatch == marmaladeLedgerMint && (_scArgs provided == _scArgs toMatch) - pure $ all (\c -> any (matchingGuard c) sigCaps) mkt - unsafeModuleHashFromB64Text :: Text -> ModuleHash unsafeModuleHashFromB64Text = either error ModuleHash . PU.fromText' @@ -1857,7 +1328,7 @@ mkCoreEvalEnv nsp MsgData{..} = do , PCore._pdPrevBlockHash = _pdPrevBlockHash pd } - gasModel <- use txGasModelCore + gasModel <- use txGasModel let toCoreExFlag = \case FlagDisableModuleInstall -> Just PCore.FlagDisableModuleInstall @@ -1867,7 +1338,7 @@ mkCoreEvalEnv nsp MsgData{..} = do FlagEnforceKeyFormats -> Just PCore.FlagEnforceKeyFormats _ -> Nothing executionFlags = mapMaybe toCoreExFlag $ S.toList $ _ecFlags $ _txExecutionConfig tenv - liftIO $ PCore.setupEvalEnv (_txCoreDb tenv) txMode' coreMsg gasModel coreNsp PCore.noSPVSupport cpd (S.fromList executionFlags) + liftIO $ PCore.setupEvalEnv (either (error "impossible") id $ _txDbEnv tenv) txMode' coreMsg (either (error "impossible") id gasModel) coreNsp PCore.noSPVSupport cpd (S.fromList executionFlags) -- | Managed namespace policy CAF -- diff --git a/src/Chainweb/Pact/Types.hs b/src/Chainweb/Pact/Types.hs index 50d2355ef..124f9180b 100644 --- a/src/Chainweb/Pact/Types.hs +++ b/src/Chainweb/Pact/Types.hs @@ -39,20 +39,17 @@ module Chainweb.Pact.Types -- * Transaction State , TransactionState(..) , txGasModel - , txGasModelCore , txGasLimit , txGasUsed , txGasId , txLogs , txCache - , txCoreCache , txWarnings -- * Transaction Env , TransactionEnv(..) , txMode , txDbEnv - , txCoreDb , txLogger , txGasLogger , txPublicData @@ -62,7 +59,6 @@ module Chainweb.Pact.Types , txRequestKey , txExecutionConfig , txQuirkGasFee - , txusePact5 -- * Transaction Execution Monad , TransactionM(..) @@ -331,12 +327,10 @@ data ApplyCmdExecutionContext = ApplyLocal | ApplySend -- data TransactionState = TransactionState { _txCache :: !ModuleCache - , _txCoreCache :: !CoreModuleCache , _txLogs :: ![TxLogJson] , _txGasUsed :: !Gas , _txGasId :: !(Maybe GasId) - , _txGasModel :: !GasModel - , _txGasModelCore :: !(PCore.GasModel PCore.CoreBuiltin) + , _txGasModel :: !(Either GasModel (PCore.GasModel PCore.CoreBuiltin)) , _txWarnings :: !(Set PactWarning) } makeLenses ''TransactionState @@ -345,8 +339,7 @@ makeLenses ''TransactionState -- data TransactionEnv logger db = TransactionEnv { _txMode :: !ExecutionMode - , _txDbEnv :: !(PactDbEnv db) - , _txCoreDb :: !CoreDb + , _txDbEnv :: !(Either (PactDbEnv db) CoreDb) , _txLogger :: !logger , _txGasLogger :: !(Maybe logger) , _txPublicData :: !PublicData @@ -357,7 +350,6 @@ data TransactionEnv logger db = TransactionEnv , _txGasLimit :: !Gas , _txExecutionConfig :: !ExecutionConfig , _txQuirkGasFee :: !(Maybe Gas) - , _txusePact5 :: !Bool } makeLenses ''TransactionEnv @@ -546,7 +538,7 @@ defaultOnFatalError lf pex t = do where errMsg = pack (show pex) <> "\n" <> t -type ModuleInitCache = M.Map BlockHeight (ModuleCache, CoreModuleCache) +type ModuleInitCache = M.Map BlockHeight ModuleCache data PactBlockEnv logger tbl = PactBlockEnv { _psServiceEnv :: !(PactServiceEnv logger tbl) @@ -679,7 +671,7 @@ liftPactServiceM :: PactServiceM logger tbl a -> PactBlockM logger tbl a liftPactServiceM (PactServiceM a) = PactBlockM (magnify psServiceEnv a) -- | Look up an init cache that is stored at or before the height of the current parent header. -getInitCache :: PactBlockM logger tbl (ModuleCache, CoreModuleCache) +getInitCache :: PactBlockM logger tbl ModuleCache getInitCache = do ph <- views psParentHeader (_blockHeight . _parentHeader) get >>= \PactServiceState{..} -> @@ -690,8 +682,8 @@ getInitCache = do -- | 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, CoreModuleCache) -> ParentHeader -> PactServiceM logger tbl () -updateInitCache (mc, cmc) ph = get >>= \PactServiceState{..} -> do +updateInitCache :: ModuleCache -> ParentHeader -> PactServiceM logger tbl () +updateInitCache mc ph = get >>= \PactServiceState{..} -> do let bf 0 = 0 bf h = succ h let pbh = bf (_blockHeight $ _parentHeader ph) @@ -700,14 +692,14 @@ updateInitCache (mc, cmc) ph = get >>= \PactServiceState{..} -> do cid <- view chainId psInitCache .= case M.lookupLE pbh _psInitCache of - Nothing -> M.singleton pbh (mc, cmc) - Just (_,(before,corebefore)) + Nothing -> M.singleton pbh mc + Just (_,before) | cleanModuleCache v cid pbh -> - M.insert pbh (mc, cmc) _psInitCache - | otherwise -> M.insert pbh (before <> mc, corebefore <> cmc) _psInitCache + M.insert pbh mc _psInitCache + | otherwise -> M.insert pbh (before <> mc) _psInitCache -- | A wrapper for 'updateInitCache' that uses the current block. -updateInitCacheM :: (ModuleCache, CoreModuleCache) -> PactBlockM logger tbl () +updateInitCacheM :: ModuleCache -> PactBlockM logger tbl () updateInitCacheM mc = do pc <- view psParentHeader liftPactServiceM $