From d647b910780805d8aa89f8ff1997a0b78ac71610 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 01/14] Delete hs-hashes and patience source-repo-packages, and Cabal bounds --- cabal.project | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/cabal.project b/cabal.project index 95fa0bf7c..a5a7ab87b 100644 --- a/cabal.project +++ b/cabal.project @@ -128,12 +128,6 @@ source-repository-package tag: 3837c4c81f1beaffc1d52375e61576366d49170a --sha256: 1knhscph2g3saz0pjd1d5a32mr281msapccfrillgd2qk4pj7xjc -source-repository-package - type: git - location: https://github.com/edmundnoble/hs-hashes.git - tag: 9665a5d82c9bf890ded0346f58e6bde9843a9320 - --sha256: sha256-6zK5nPiGGy7EIDj8l9nBQxcBkZlzUiz3/LYKhGemhdg= - source-repository-package type: git location: https://github.com/kadena-io/wai-middleware-validation.git @@ -156,12 +150,6 @@ source-repository-package tag: 90247042ab3b8662809210af2a78e6dee0f9b4ac --sha256: 0dqsrjxm0cm35xcihm49dhwdvmz79vsv4sd5qs2izc4sbnd0d8n6 -source-repository-package - type: git - location: https://github.com/chessai/patience - tag: 2f67d546ea6608fc6ebe5f2f6976503cbf340442 - --sha256: 0x137akvbh4kr3qagksw74xdj2xz5vjnx1fbr41bb54a0lkcb8mm - source-repository-package type: git location: https://gitlab.com/edmundnoble/predicate-transformers @@ -237,8 +225,3 @@ allow-newer: lrucaching:base-compat -- -------------------------------------------------------------------------- -- -- Upper Bounds - --- This is needed on GHC <9.10.1 due to a bug (either in GHC or cabal) it --- that Cabal and Cabal-syntax are compatible. -constraints: Cabal <=3.12.1.0 -constraints: Cabal-syntax <=3.12.1.0 From 15f07a4db00fa6e65430f022a8bd7a25b66eb26a Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 02/14] Delete spacing --- src/Chainweb/Miner/RestAPI/Server.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Chainweb/Miner/RestAPI/Server.hs b/src/Chainweb/Miner/RestAPI/Server.hs index 6715f0ff8..26d11ac25 100644 --- a/src/Chainweb/Miner/RestAPI/Server.hs +++ b/src/Chainweb/Miner/RestAPI/Server.hs @@ -254,7 +254,6 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d -- no apparent change | otherwise -> retry - (WorkReady (NewBlockPayload lastPh lastPwo), WorkReady (NewBlockPayload currentPh currentPwo)) | lastPh /= currentPh -> -- we've got a new block on a new parent, we must've missed @@ -270,7 +269,6 @@ updatesHandler mr (ChainBytes cbytes) = Tagged $ \req resp -> withLimit resp $ d -- no apparent change | otherwise -> retry - (WorkReady _, WorkReady _) -> error "awaitNewPrimedWork: impossible: NewBlockInProgress replaced by a NewBlockPayload" From 8ed8b1fedb5b0f72207c6db41c9488f873b38a09 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 03/14] Fix bad find/replace --- src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs b/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs index d56b2f69a..dd6d81e23 100644 --- a/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs +++ b/src/Chainweb/Pact/Backend/PactState/GrandHash/Import.hs @@ -212,7 +212,7 @@ pactImportMain = do -- -- pact-import doesn't use this environment variable; it's for -- debugging and/or consumption by other tools. - setEnv "SNAPSHOTview blockHeight" (show snapshotBlockHeight) + setEnv "SNAPSHOT_BLOCKHEIGHT" (show snapshotBlockHeight) forM_ cfg.targetPactDir $ \targetDir -> do pactDropPostVerified logger cfg.chainwebVersion cfg.sourcePactDir targetDir snapshotBlockHeight snapshotChainHashes @@ -226,7 +226,7 @@ pactImportMain = do , "If the hash matches, and a target directory is specificied, the" , "database will be copied to the target directory, and any state" , "later than what is cryptographically verifiable will be dropped." - , "This tool sets the environment variable `SNAPSHOTview blockHeight` which" + , "This tool sets the environment variable `SNAPSHOT_BLOCKHEIGHT` which" , "can be useful for debugging, or if you want to use the blockheight" , "for your own queries." ] From 2a1d9323ac068d6f3f0c948ca91c580d97b72956 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 04/14] Remove unnecessary shadowed parameter --- src/Chainweb/Pact/Backend/Utils.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Chainweb/Pact/Backend/Utils.hs b/src/Chainweb/Pact/Backend/Utils.hs index ccbdf7715..30a078e90 100644 --- a/src/Chainweb/Pact/Backend/Utils.hs +++ b/src/Chainweb/Pact/Backend/Utils.hs @@ -373,13 +373,13 @@ commitBlockStateToDatabase db hsh bh blockHandle = do writeTable (tableName, writes) = do execMulti db q (map prepRow writes) - markTableMutation tableName bh db + markTableMutation tableName bh where q = "INSERT OR REPLACE INTO " <> tbl tableName <> "(rowkey,txid,rowdata) VALUES(?,?,?)" -- Mark the table as being mutated during this block, so that we know -- to delete from it if we rewind past this block. - markTableMutation tablename blockheight db = do + markTableMutation tablename blockheight = do Pact4.exec' db mutq [Pact4.SText tablename, Pact4.SInt (fromIntegral blockheight)] where mutq = "INSERT OR IGNORE INTO VersionedTableMutation VALUES (?,?);" From 79847c091538ae4fb805daf993b26364da64796c Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 05/14] s/runPact[45]Coinbase/runCoinbase --- src/Chainweb/Pact/PactService.hs | 5 ++--- src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs | 8 ++++---- src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs | 8 ++++---- 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 4e6c50393..1e2170ba6 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -125,7 +125,6 @@ import qualified Pact.Core.Command.Types as Pact5 import qualified Pact.Core.Hash as Pact5 import qualified Data.ByteString.Short as SB import Data.Coerce (coerce) -import Chainweb.Pact.PactService.Pact5.ExecBlock (runPact5Coinbase) import Data.Void import qualified Chainweb.Pact5.Types as Pact5 import qualified Chainweb.Pact.PactService.Pact5.ExecBlock as Pact5 @@ -499,7 +498,7 @@ execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do (do blockDbEnv <- view psBlockDbEnv initCache <- initModuleCacheForBlock - coinbaseOutput <- runPact4Coinbase + coinbaseOutput <- Pact4.runCoinbase miner (Pact4.EnforceCoinbaseFailure True) (Pact4.CoinbaseUsePrecompiled True) initCache @@ -531,7 +530,7 @@ execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do ) (do - coinbaseOutput <- runPact5Coinbase miner >>= \case + coinbaseOutput <- Pact5.runCoinbase miner >>= \case Left coinbaseError -> internalError $ "Error during coinbase: " <> sshow coinbaseError Right coinbaseOutput -> -- pretend that coinbase can throw an error, when we know it can't. diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index b1fec3517..96f77125f 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -33,7 +33,7 @@ module Chainweb.Pact.PactService.Pact4.ExecBlock , validateHashes , throwCommandInvalidError , initModuleCacheForBlock - , runPact4Coinbase + , runCoinbase , CommandInvalidError(..) , checkParse ) where @@ -368,7 +368,7 @@ execTransactions miner ctxs enfCBFail usePrecomp gasLimit timeLimit = do mc <- initModuleCacheForBlock -- for legacy reasons (ask Emily) we don't use the module cache resulting -- from coinbase to run the pact cmds - coinOut <- runPact4Coinbase miner enfCBFail usePrecomp mc + coinOut <- runCoinbase miner enfCBFail usePrecomp mc T2 txOuts _mcOut <- applyPactCmds ctxs miner mc gasLimit timeLimit return $! Transactions (V.zip ctxs txOuts) coinOut @@ -386,14 +386,14 @@ initModuleCacheForBlock = do return mc Just (_,mc) -> pure mc -runPact4Coinbase +runCoinbase :: (Logger logger) => Miner -> EnforceCoinbaseFailure -> CoinbaseUsePrecompiled -> ModuleCache -> PactBlockM logger tbl (Pact4.CommandResult [Pact4.TxLogJson]) -runPact4Coinbase miner enfCBFail usePrecomp mc = do +runCoinbase miner enfCBFail usePrecomp mc = do isGenesis <- view psIsGenesis if isGenesis then return noCoinbase diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 5a1cb92d0..795e57e7b 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeApplications #-} module Chainweb.Pact.PactService.Pact5.ExecBlock - ( runPact5Coinbase + ( runCoinbase , continueBlock , execExistingBlock , validateRawChainwebTx @@ -109,11 +109,11 @@ minerReward v (MinerRewards rs) bh = err = internalError "block heights have been exhausted" {-# INLINE minerReward #-} -runPact5Coinbase +runCoinbase :: (Logger logger) => Miner -> PactBlockM logger tbl (Either Pact5CoinbaseError (Pact5.CommandResult [Pact5.TxLog ByteString] Void)) -runPact5Coinbase miner = do +runCoinbase miner = do isGenesis <- view psIsGenesis if isGenesis then return $ Right noCoinbase @@ -588,7 +588,7 @@ execExistingBlock currHeader payload = do Nothing -> return () Just errorsNel -> throwM $ Pact5TransactionValidationException errorsNel - coinbaseResult <- runPact5Coinbase miner >>= \case + coinbaseResult <- runCoinbase miner >>= \case Left err -> throwM $ CoinbaseFailure (Pact5CoinbaseFailure err) Right r -> return (absurd <$> r) From 8e14aed557df7994fdf3387eac6fa721a9d5b753 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 06/14] Comment tx validation functions --- src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs | 11 +++++++++++ src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs | 13 ++++++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index 96f77125f..c0281f163 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -202,6 +202,14 @@ throwCommandInvalidError = (transactionPairs . traverse . _2) throwGasFailure Right r -> pure r +-- | The validation logic for Pact Transactions that have not had their +-- code parsed yet. This is used by the mempool to estimate tx validity +-- before inclusion into blocks, but it's also used by ExecBlock to check +-- if all of the txs in a block are valid. +-- +-- Skips validation for genesis transactions, since gas accounts, etc. don't +-- exist yet. +-- validateRawChainwebTx :: forall logger . (Logger logger) @@ -222,6 +230,9 @@ validateRawChainwebTx logger v cid dbEnv txValidationTime bh doBuyGas tx = do return parsed -- | The principal validation logic for groups of Pact Transactions. +-- This is used by the mempool to estimate tx validity +-- before inclusion into blocks, but it's also used by ExecBlock to check +-- if all of the txs in a block are valid. -- -- Skips validation for genesis transactions, since gas accounts, etc. don't -- exist yet. diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 795e57e7b..5b27abd2c 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -466,10 +466,13 @@ applyPactCmd env miner tx = StateT $ \(blockHandle, blockGasRemaining) -> do ] -- | The principal validation logic for groups of Pact Transactions. +-- This is used by the mempool to estimate tx validity +-- before inclusion into blocks, but it's also used by ExecBlock to check +-- if all of the txs in a block are valid. -- -- Skips validation for genesis transactions, since gas accounts, etc. don't -- exist yet. - +-- validateParsedChainwebTx :: (Logger logger) => logger @@ -533,6 +536,14 @@ validateParsedChainwebTx _logger v cid db _blockHandle txValidationTime bh isGen sigs = Pact5._cmdSigs t signers = Pact5._pSigners $ view Pact5.payloadObj $ Pact5._cmdPayload t +-- | The validation logic for Pact Transactions that have not had their +-- code parsed yet. This is used by the mempool to estimate tx validity +-- before inclusion into blocks, but it's also used by ExecBlock to check +-- if all of the txs in a block are valid. +-- +-- Skips validation for genesis transactions, since gas accounts, etc. don't +-- exist yet. +-- validateRawChainwebTx :: (Logger logger) => logger From 8023834912fc16ac13efee289d70df03f26c8811 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 07/14] Remove doBuyGas parameter from Pact 4 tx validation functions Just have the caller do it, like with Pact 5 --- src/Chainweb/Pact/PactService.hs | 14 +++++++------- src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs | 14 ++++++-------- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 1e2170ba6..f32b117b5 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -1097,11 +1097,12 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do cid = _chainId pc liftIO $ forM txs $ \tx -> do let isGenesis = False - fmap (either Just (\_ -> Nothing)) $ runExceptT $ - Pact4.validateRawChainwebTx - logger v cid pdb parentTime currHeight - (ExceptT . evalPactServiceM psState psEnv . Pact4.runPactBlockM pc isGenesis pdb . attemptBuyGasPact4 noMiner) - tx + fmap (either Just (\_ -> Nothing)) $ runExceptT $ do + parsedTx <- Pact4.validateRawChainwebTx + logger v cid pdb parentTime currHeight tx + ExceptT $ evalPactServiceM psState psEnv . Pact4.runPactBlockM pc isGenesis pdb + $ attemptBuyGasPact4 noMiner parsedTx + return parsedTx ) (do db <- view psBlockDbEnv @@ -1116,8 +1117,7 @@ execPreInsertCheckReq txs = pactLabel "execPreInsertCheckReq" $ do liftIO $ forM txs $ \tx -> fmap (either Just (\_ -> Nothing)) $ runExceptT $ do pact5Tx <- Pact5.validateRawChainwebTx - logger v cid db blockHandle parentTime currHeight isGenesis - tx + logger v cid db blockHandle parentTime currHeight isGenesis tx attemptBuyGasPact5 logger ph db blockHandle noMiner pact5Tx ) withPactState $ \run -> diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index c0281f163..9d7dd26d2 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -148,7 +148,7 @@ execBlock currHeader payload = do fmap (Pact4._cmdHash tx,) $ runExceptT $ validateParsedChainwebTx logger v cid dbEnv txValidationTime - (view blockHeight currHeader) (\_ -> pure ()) tx + (view blockHeight currHeader) tx case NE.nonEmpty [ (hsh, sshow err) | (hsh, Left err) <- errorsIfPresent ] of Nothing -> return () @@ -221,12 +221,11 @@ validateRawChainwebTx -- ^ reference time for tx validation. -> BlockHeight -- ^ Current block height - -> (Pact4.Transaction -> ExceptT InsertError IO ()) -> Pact4.UnparsedTransaction -> ExceptT InsertError IO Pact4.Transaction -validateRawChainwebTx logger v cid dbEnv txValidationTime bh doBuyGas tx = do +validateRawChainwebTx logger v cid dbEnv txValidationTime bh tx = do parsed <- checkParse logger v cid bh tx - validateParsedChainwebTx logger v cid dbEnv txValidationTime bh doBuyGas parsed + validateParsedChainwebTx logger v cid dbEnv txValidationTime bh parsed return parsed -- | The principal validation logic for groups of Pact Transactions. @@ -247,10 +246,9 @@ validateParsedChainwebTx -- ^ reference time for tx validation. -> BlockHeight -- ^ Current block height - -> (Pact4.Transaction -> ExceptT InsertError IO ()) -> Pact4.Transaction -> ExceptT InsertError IO () -validateParsedChainwebTx logger v cid dbEnv txValidationTime bh doBuyGas tx +validateParsedChainwebTx logger v cid dbEnv txValidationTime bh tx | bh == genesisHeight v cid = pure () | otherwise = do checkUnique logger dbEnv tx @@ -258,7 +256,7 @@ validateParsedChainwebTx logger v cid dbEnv txValidationTime bh doBuyGas tx checkTxSigs logger v cid bh tx checkTimes logger v cid bh txValidationTime tx _ <- checkCompile logger v cid bh tx - doBuyGas tx + return () checkUnique :: (Logger logger) @@ -837,7 +835,7 @@ continueBlock mpAccess blockInProgress = do let pHeight = view blockHeight parent let pHash = view blockHash parent let validate bhi _bha txs = forM txs $ \tx -> runExceptT $ do - validateRawChainwebTx logger v cid dbEnv (ParentCreationTime parentTime) bhi (\_ -> pure ()) tx + validateRawChainwebTx logger v cid dbEnv (ParentCreationTime parentTime) bhi tx liftIO $! mpaGetBlock mpAccess bfState validate (pHeight + 1) pHash parentTime From 57d30c5674b5359e487a7231bb6ea41ff854c802 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 08/14] Add space --- src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index 9d7dd26d2..271822ae1 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -320,7 +320,7 @@ checkTxSigs -> f () checkTxSigs logger v cid bh t = do liftIO $ logFunctionText logger Debug $ "Pact4.checkTxSigs: " <> sshow (Pact4._cmdHash t) - if | isRight(Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs) -> pure () + if | isRight (Pact4.assertValidateSigs validSchemes webAuthnPrefixLegal hsh signers sigs) -> pure () | otherwise -> throwError InsertErrorInvalidSigs where hsh = Pact4._cmdHash t From c71835eabca11492a5cbeb7126891a60b286f525 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 09/14] Delete comment --- src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs index 271822ae1..38806cc8b 100644 --- a/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact4/ExecBlock.hs @@ -541,7 +541,6 @@ applyPactCmd miner txTimeLimit cmd = StateT $ \(T2 mcache maybeBlockGasRemaining maybe (throwM timeoutError) return =<< newTimeout (fromIntegral limit) io txGas (T3 r _ _) = fromIntegral $ Pact4._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 $ Pact4.applyCmd v logger gasLogger txFailuresCounter pactDb miner gasModel txCtx spv gasLimitedCmd initialGas mcache ApplySend From 5145c11978af6ee56d39d33d53baa138e5e07063 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 10/14] Remove wrong FIXME --- src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs index 5b27abd2c..93fe5a722 100644 --- a/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs +++ b/src/Chainweb/Pact/PactService/Pact5/ExecBlock.hs @@ -126,8 +126,8 @@ runCoinbase miner = do let !bh = ctxCurrentBlockHeight txCtx reward <- liftIO $ minerReward v rs bh - -- FIXME Pact5: add the coinbase request key here, which is the hash of the parent block. - -- see the Pact 4 version for more info. + -- the coinbase request key is not passed here because TransactionIndex + -- does not contain coinbase transactions pactTransaction Nothing $ \db -> applyCoinbase logger db reward txCtx From e8a7a1a932e509466bc268c8ee941a3406ef68da Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 11/14] Change Gen's in Pact 5 CheckpointerTest --- test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs b/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs index ea1ccd360..246161bfc 100644 --- a/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs +++ b/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs @@ -102,12 +102,12 @@ genDbAction = do type DbBlock f = [DbAction f] genDbBlock :: Gen (DbBlock (Const ())) -genDbBlock = Gen.list (Range.linear 1 20) genDbAction +genDbBlock = Gen.list (Range.constant 1 20) genDbAction genBlockHistory :: Gen [DbBlock (Const ())] genBlockHistory = do let create tn = DbCreateTable tn (Const ()) - blocks <- Gen.list (Range.constant 1 20) genDbBlock + blocks <- Gen.list (Range.linear 1 20) genDbBlock -- we always start by making tables A and B to ensure the tests do something, -- but we leave table C uncreated to leave some room for divergent table sets return $ [create "A", create "B"] : blocks From e23e740d7deb3f8d0d2555e9e8298751dd378bc1 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 12/14] Add comments --- test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs b/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs index 246161bfc..44986b516 100644 --- a/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs +++ b/test/unit/Chainweb/Test/Pact5/CheckpointerTest.hs @@ -125,6 +125,7 @@ tryShow = handleAny (fmap Left . \case e -> return $ sshow e ) . fmap Right +-- Run an empty DbAction, annotating it with its result runDbAction :: PactDb CoreBuiltin Info -> DbAction (Const ()) -> IO (DbAction Identity) runDbAction pactDB act = fmap (hoistDbAction (\(Pair (Const ()) fa) -> fa)) @@ -133,6 +134,7 @@ runDbAction pactDB act = extractInt :: RowData -> IO Integer extractInt (RowData m) = evaluate (m ^?! ix (Field "k") . _PLiteral . _LInteger) +-- Annotate a DbAction with its result, including any other contents it has runDbAction' :: PactDb CoreBuiltin Info -> DbAction f -> IO (DbAction (Product f Identity)) runDbAction' pactDB = \case DbRead tn k v -> do @@ -179,6 +181,7 @@ blockHeaderFromTxLogs ph txLogs = do -- TODO things to test later: -- that a tree of blocks can be explored, such that reaching any particular block gives identical results to running to that block from genesis +-- more specific regressions, like in the Pact 4 checkpointer test runBlocks :: Checkpointer GenericLogger @@ -198,6 +201,8 @@ runBlocks cp ph blks = do ] return finishedBlks +-- Check that a block's result at the time it was added to the checkpointer +-- is consistent with us executing that block with `readFrom` assertBlock :: HasCallStack => Checkpointer GenericLogger -> ParentHeader -> (BlockHeader, DbBlock Identity) -> IO () assertBlock cp ph (expectedBh, blk) = do hist <- Checkpointer.readFrom cp (Just ph) Pact5T $ \db startHandle -> do @@ -233,7 +238,7 @@ tests = testGroup "Pact5 Checkpointer tests" Pact.Core.runPactDbRegression txdb return () , withResourceT (liftIO . initCheckpointer testVer cid =<< withTempSQLiteResource) $ \cpIO -> - testProperty "linear block history validity" $ withTests 1000 $ property $ do + testProperty "readFrom with linear block history is valid" $ withTests 1000 $ property $ do blocks <- forAll genBlockHistory liftIO $ do cp <- cpIO From 4767905eee03bdd678f7e4cafc9ecaf04af67817 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 13/14] Slight changes to PactServiceTest Change some assertions subtly and use reversed-application assertions --- .../Chainweb/Test/Pact5/PactServiceTest.hs | 26 +++++++++---------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs b/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs index 595113f47..e939cb439 100644 --- a/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs +++ b/test/unit/Chainweb/Test/Pact5/PactServiceTest.hs @@ -167,9 +167,9 @@ simpleEndToEnd baseRdb = runResourceT $ do results <- advanceAllChainsWithTxs fixture $ onChain cid [cmd1, cmd2] -- we only care that they succeed; specifics regarding their outputs are in TransactionExecTest - predful ? onChain cid ? - predful ? Vector.replicate 2 successfulTx $ - results + results & + predful ? onChain cid ? + predful ? Vector.replicate 2 successfulTx newBlockEmpty :: RocksDb -> IO () newBlockEmpty baseRdb = runResourceT $ do @@ -190,9 +190,9 @@ newBlockEmpty baseRdb = runResourceT $ do newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue return $ finalizeBlock nonEmptyBip - predful ? onChain cid ? - predful ? Vector.replicate 1 successfulTx $ - results + results & + predful ? onChain cid ? + predful ? Vector.replicate 1 successfulTx continueBlockSpec :: RocksDb -> IO () continueBlockSpec baseRdb = runResourceT $ do @@ -213,9 +213,9 @@ continueBlockSpec baseRdb = runResourceT $ do newBlock noMiner NewBlockFill (ParentHeader ph) pactQueue return $ finalizeBlock bipAllAtOnce -- assert that 3 successful txs are in the block - predful ? onChain cid ? - predful ? Vector.replicate 3 successfulTx $ - allAtOnceResults + allAtOnceResults & + predful ? onChain cid ? + predful ? Vector.replicate 3 successfulTx -- reset back to the empty block for the next phase -- next, produce the same block by repeatedly extending a block @@ -224,7 +224,7 @@ continueBlockSpec baseRdb = runResourceT $ do -- mempool, so we need to clear it after, or else the block will -- contain all of the transactions before we extend it. revert fixture startCut - results <- advanceAllChains fixture $ onChain cid $ \ph pactQueue mempool -> do + continuedResults <- advanceAllChains fixture $ onChain cid $ \ph pactQueue mempool -> do mempoolClear mempool insertMempool mempool CheckedInsert [cmd3] bipStart <- throwIfNotPact5 =<< throwIfNoHistory =<< @@ -250,10 +250,8 @@ continueBlockSpec baseRdb = runResourceT $ do return $ finalizeBlock bipFinal - -- assert that 3 successful txs are in the block - predful ? onChain cid ? - predful ? Vector.replicate 3 successfulTx $ - results + -- assert that the continued results are equal to doing it all at once + continuedResults & equals allAtOnceResults -- * test that the NewBlock timeout works properly and doesn't leave any extra state from a timed-out transaction newBlockTimeoutSpec :: RocksDb -> IO () From e77046df8c589f8642a5b74cecd67abfb72fb178 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 13 Dec 2024 15:20:10 -0500 Subject: [PATCH 14/14] Unused import --- test/unit/Chainweb/Test/Pact5/RemotePactTest.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs index de5b963a2..d40549b63 100644 --- a/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs +++ b/test/unit/Chainweb/Test/Pact5/RemotePactTest.hs @@ -30,7 +30,6 @@ import Chainweb.Test.RestAPI.Utils (getCurrentBlockHeight) import Data.Text qualified as Text import Pact.Core.Errors import "pact" Pact.Types.API qualified as Pact4 -import "pact" Pact.Types.Command qualified as Pact4 import "pact" Pact.Types.Hash qualified as Pact4 import Chainweb.ChainId import Chainweb.Graph (singletonChainGraph)