Pact 5 review phase 2

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

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"
 

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."
       ]

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 (?,?);"

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.
@@ -1098,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
@@ -1117,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 ->

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
@@ -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 ()
@@ -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)
@@ -213,15 +221,17 @@ 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.
+-- 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.
@@ -236,18 +246,17 @@ 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
       checkTxHash logger v cid bh 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)
@@ -311,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
@@ -368,7 +377,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 +395,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
@@ -532,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
@@ -826,7 +834,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

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
@@ -126,8 +126,8 @@ runPact5Coinbase 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
 
@@ -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
@@ -588,7 +599,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)
 

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
@@ -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