From 1a4ee003e2df8444bb81d24bd659539353d6b6f1 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Tue, 26 Sep 2023 16:48:24 +0400 Subject: [PATCH] execNewBlock: remove the parent header as paramater and sync from the db instead --- bench/Chainweb/Pact/Backend/ForkingBench.hs | 24 +++++++++-- src/Chainweb/Chainweb/MinerResources.hs | 10 ++--- src/Chainweb/Pact/PactService.hs | 17 ++++++-- src/Chainweb/Pact/Service/BlockValidation.hs | 7 ++-- src/Chainweb/Pact/Service/Types.hs | 5 +-- src/Chainweb/WebPactExecutionService.hs | 10 ++--- test/Chainweb/Test/CutDB.hs | 3 +- .../Test/Pact/ModuleCacheOnRestart.hs | 13 +++--- test/Chainweb/Test/Pact/PactMultiChainTest.hs | 16 +++++++- test/Chainweb/Test/Pact/PactReplay.hs | 24 +++++++++-- .../Chainweb/Test/Pact/PactSingleChainTest.hs | 41 ++----------------- test/Chainweb/Test/Pact/TTL.hs | 2 +- test/Chainweb/Test/Pact/Utils.hs | 13 +++--- 13 files changed, 105 insertions(+), 80 deletions(-) diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index df780f3292..f07c8f2faa 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/bench/Chainweb/Pact/Backend/ForkingBench.hs @@ -155,16 +155,28 @@ bench rdb = C.bgroup "PactService" $ forkingBench = withResources rdb 10 Quiet DontCompact $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ -> C.bench "forkingBench" $ C.whnfIO $ do - let (T3 _ join1 _) = mainLineBlocks !! 5 + let (T3 _ join1 pwo1) = mainLineBlocks !! 5 + + -- we have to execValidateBlock on `join1` block height to update the parent header + void $ validateBlock join1 (payloadWithOutputsToPayloadData pwo1) pactQueue + void $ playLine pdb bhdb 5 join1 pactQueue nonceCounter doubleForkingBench = withResources rdb 10 Quiet DontCompact $ \mainLineBlocks pdb bhdb nonceCounter pactQueue _ -> C.bench "doubleForkingBench" $ C.whnfIO $ do - let (T3 _ join1 _) = mainLineBlocks !! 5 + let (T3 _ join1 pwo1) = mainLineBlocks !! 5 forkLength1 = 5 forkLength2 = 5 + + -- we have to execValidateBlock on `join1` block height to update the parent header + void $ validateBlock join1 (payloadWithOutputsToPayloadData pwo1) pactQueue + void $ playLine pdb bhdb forkLength1 join1 pactQueue nonceCounter + + -- we have to execValidateBlock on `join1` block height to update the parent header + void $ validateBlock join1 (payloadWithOutputsToPayloadData pwo1) pactQueue + void $ playLine pdb bhdb forkLength2 join1 pactQueue nonceCounter oneBlock :: BenchConfig -> Int -> C.Benchmark @@ -173,7 +185,11 @@ bench rdb = C.bgroup "PactService" $ go mainLineBlocks _pdb _bhdb _nonceCounter pactQueue txsPerBlock = do C.bench name $ C.whnfIO $ do writeIORef txsPerBlock txCount - let (T3 _ join1 _) = last mainLineBlocks + let (T3 _ join1 pwo1) = last mainLineBlocks + + -- we have to execValidateBlock on `join1` block height to update the parent header + void $ validateBlock join1 (payloadWithOutputsToPayloadData pwo1) pactQueue + createBlock cfg.validate (ParentHeader join1) (Nonce 1234) pactQueue name = "block-new [" ++ List.intercalate "," @@ -236,7 +252,7 @@ createBlock validate parent nonce pact = do -- assemble block without nonce and timestamp - mv <- newBlock noMiner parent pact + mv <- newBlock noMiner pact payload <- assertNotLeft =<< takeMVar mv diff --git a/src/Chainweb/Chainweb/MinerResources.hs b/src/Chainweb/Chainweb/MinerResources.hs index 523c09d37c..0243f0a200 100644 --- a/src/Chainweb/Chainweb/MinerResources.hs +++ b/src/Chainweb/Chainweb/MinerResources.hs @@ -134,7 +134,7 @@ withMiningCoordination logger conf cdb inner -- Generate new payloads, one for each Miner we're managing -- let !newParent = ParentHeader . fromJuste . HM.lookup cid $ _cutMap new !newParentHash = _blockHash $ _parentHeader newParent - payloads <- traverse (\m -> T2 m <$> getPayload newParent m) miners + payloads <- traverse (\m -> T2 m <$> getPayload cid m) miners -- Update the cache in a single step -- atomically $ modifyTVar' tpw $ \pw -> foldl' (updateCache cid newParentHash) pw payloads @@ -174,13 +174,13 @@ withMiningCoordination logger conf cdb inner -> IO (HM.HashMap ChainId (Maybe (PayloadData, BlockHash))) fromCut m cut = HM.fromList <$> traverse - (\(T2 cid bh) -> (cid,) . Just . (, _blockHash (_parentHeader bh)) <$> getPayload bh m) + (\(T2 cid bh) -> (cid,) . Just . (, _blockHash (_parentHeader bh)) <$> getPayload cid m) cut - getPayload :: ParentHeader -> Miner -> IO PayloadData - getPayload parent m = trace (logFunction logger) + getPayload :: ChainId -> Miner -> IO PayloadData + getPayload cid m = trace (logFunction logger) "Chainweb.Chainweb.MinerResources.withMiningCoordination.newBlock" - () 1 (payloadWithOutputsToPayloadData <$> _pactNewBlock pact m parent) + () 1 (payloadWithOutputsToPayloadData <$> _pactNewBlock pact cid m) pact :: PactExecutionService pact = _webPactExecutionService $ view cutDbPactService cdb diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 15d9c45578..abe8399062 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -314,9 +314,9 @@ serviceRequests memPoolAccess reqQ = do go NewBlockMsg NewBlockReq {..} -> do trace logFn "Chainweb.Pact.PactService.execNewBlock" - (_parentHeader _newBlockHeader) 1 $ + () 1 $ tryOne "execNewBlock" _newResultVar $ - execNewBlock memPoolAccess _newBlockHeader _newMiner + execNewBlock memPoolAccess _newMiner go ValidateBlockMsg ValidateBlockReq {..} -> do tryOne "execValidateBlock" _valResultVar $ @@ -489,16 +489,25 @@ attemptBuyGas miner (PactDbEnv' dbEnv) txs = localLabel ("transaction", "attempt Left err -> return (T2 mcache (Left (InsertErrorBuyGas (T.pack $ show err)))) Right t -> return (T2 (_txCache t) (Right tx)) +execNewBlock + :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl) + => MemPoolAccess + -> Miner + -> PactServiceM logger tbl PayloadWithOutputs +execNewBlock mpAccess miner = do + parent <- syncParentHeader "execNewBlock" + execNewBlock' mpAccess parent miner + -- | Note: The BlockHeader param here is the PARENT HEADER of the new -- block-to-be -- -execNewBlock +execNewBlock' :: forall logger tbl. (Logger logger, CanReadablePayloadCas tbl) => MemPoolAccess -> ParentHeader -> Miner -> PactServiceM logger tbl PayloadWithOutputs -execNewBlock mpAccess parent miner = pactLabel "execNewBlock" $ do +execNewBlock' mpAccess parent miner = pactLabel "execNewBlock" $ do updateMempool withDiscardedBatch $ do withCheckpointerRewind newblockRewindLimit (Just parent) "execNewBlock" doNewBlock diff --git a/src/Chainweb/Pact/Service/BlockValidation.hs b/src/Chainweb/Pact/Service/BlockValidation.hs index ccac66e3ec..0b71f3d3bf 100644 --- a/src/Chainweb/Pact/Service/BlockValidation.hs +++ b/src/Chainweb/Pact/Service/BlockValidation.hs @@ -45,13 +45,12 @@ import Chainweb.Transaction import Chainweb.Utils (T2) -newBlock :: Miner -> ParentHeader -> PactQueue -> +newBlock :: Miner -> PactQueue -> IO (MVar (Either PactException PayloadWithOutputs)) -newBlock mi bHeader reqQ = do +newBlock mi reqQ = do !resultVar <- newEmptyMVar :: IO (MVar (Either PactException PayloadWithOutputs)) let !msg = NewBlockMsg NewBlockReq - { _newBlockHeader = bHeader - , _newMiner = mi + { _newMiner = mi , _newResultVar = resultVar } addRequest reqQ msg return resultVar diff --git a/src/Chainweb/Pact/Service/Types.hs b/src/Chainweb/Pact/Service/Types.hs index 55df2d595d..b55f9cb81d 100644 --- a/src/Chainweb/Pact/Service/Types.hs +++ b/src/Chainweb/Pact/Service/Types.hs @@ -303,11 +303,10 @@ data RequestMsg = NewBlockMsg !NewBlockReq type PactExMVar t = MVar (Either PactException t) data NewBlockReq = NewBlockReq - { _newBlockHeader :: !ParentHeader - , _newMiner :: !Miner + { _newMiner :: !Miner , _newResultVar :: !(PactExMVar PayloadWithOutputs) } -instance Show NewBlockReq where show NewBlockReq{..} = show (_newBlockHeader, _newMiner) +instance Show NewBlockReq where show NewBlockReq{..} = show _newMiner data ValidateBlockReq = ValidateBlockReq { _valBlockHeader :: !BlockHeader diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs index 5d0604de2a..1608023c50 100644 --- a/src/Chainweb/WebPactExecutionService.hs +++ b/src/Chainweb/WebPactExecutionService.hs @@ -55,8 +55,8 @@ data PactExecutionService = PactExecutionService ) -- ^ Validate block payload data by running through pact service. , _pactNewBlock :: !( + ChainId -> Miner -> - ParentHeader -> IO PayloadWithOutputs ) -- ^ Request a new block to be formed using mempool @@ -111,8 +111,8 @@ newtype WebPactExecutionService = WebPactExecutionService _webPactNewBlock :: WebPactExecutionService + -> ChainId -> Miner - -> ParentHeader -> IO PayloadWithOutputs _webPactNewBlock = _pactNewBlock . _webPactExecutionService {-# INLINE _webPactNewBlock #-} @@ -131,7 +131,7 @@ mkWebPactExecutionService -> WebPactExecutionService mkWebPactExecutionService hm = WebPactExecutionService $ PactExecutionService { _pactValidateBlock = \h pd -> withChainService (_chainId h) $ \p -> _pactValidateBlock p h pd - , _pactNewBlock = \m h -> withChainService (_chainId h) $ \p -> _pactNewBlock p m h + , _pactNewBlock = \cid m -> withChainService cid $ \p -> _pactNewBlock p cid m , _pactLocal = \_pf _sv _rd _ct -> throwM $ userError "Chainweb.WebPactExecutionService.mkPactExecutionService: No web-level local execution supported" , _pactLookup = \h cd txs -> withChainService (_chainId h) $ \p -> _pactLookup p h cd txs , _pactPreInsertCheck = \cid txs -> withChainService cid $ \p -> _pactPreInsertCheck p cid txs @@ -155,8 +155,8 @@ mkPactExecutionService q = PactExecutionService case r of Right (!pdo) -> return pdo Left e -> throwM e - , _pactNewBlock = \m h -> do - mv <- newBlock m h q + , _pactNewBlock = \_ m -> do + mv <- newBlock m q r <- takeMVar mv either throwM evaluate r , _pactLocal = \pf sv rd ct -> diff --git a/test/Chainweb/Test/CutDB.hs b/test/Chainweb/Test/CutDB.hs index 491a0bbf0d..f24b36744c 100644 --- a/test/Chainweb/Test/CutDB.hs +++ b/test/Chainweb/Test/CutDB.hs @@ -403,7 +403,7 @@ tryMineForChain -> ChainId -> IO (Either MineFailure (Cut, ChainId, PayloadWithOutputs)) tryMineForChain miner webPact cutDb c cid = do - outputs <- _webPactNewBlock webPact miner parent + outputs <- _webPactNewBlock webPact cid miner let payloadHash = _payloadWithOutputsPayloadHash outputs t <- getCurrentTimeIntegral x <- testMineWithPayloadHash wdb (Nonce 0) t payloadHash cid c @@ -416,7 +416,6 @@ tryMineForChain miner webPact cutDb c cid = do return $ Right (c', cid, outputs) Left e -> return $ Left e where - parent = ParentHeader $ c ^?! ixg cid -- parent to mine on wdb = view cutDbWebBlockHeaderDb cutDb -- | picks a random block header from a web chain. The result header is diff --git a/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs b/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs index fb215ab78f..8d5608bf1d 100644 --- a/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs +++ b/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs @@ -49,6 +49,7 @@ import Chainweb.Time import Chainweb.Test.Cut import Chainweb.Test.Cut.TestBlockDb import Chainweb.Test.Utils +import Chainweb.Test.Pact.Utils (getPWOByHeader) import Chainweb.Test.TestVersions(fastForkingCpmTestVersion) import Chainweb.Utils (T2(..)) import Chainweb.Version @@ -125,7 +126,7 @@ testCoinbase iobdb = (initPayloadState >> doCoinbase,snapshotCache) where doCoinbase = do bdb <- liftIO iobdb - pwo <- execNewBlock mempty (ParentHeader genblock) noMiner + pwo <- execNewBlock mempty noMiner void $ liftIO $ addTestBlockDb bdb (Nonce 0) (offsetBlockTime second) testChainId pwo nextH <- liftIO $ getParentTestBlockDb bdb testChainId void $ execValidateBlock mempty nextH (payloadWithOutputsToPayloadData pwo) @@ -242,8 +243,13 @@ rewindToBlock (rewindHeader, pwo) = void $ execValidateBlock mempty rewindHeader doNextCoinbase :: (Logger logger, CanReadablePayloadCas tbl) => IO TestBlockDb -> PactServiceM logger tbl (BlockHeader, PayloadWithOutputs) doNextCoinbase iobdb = do bdb <- liftIO iobdb + + -- we have to execValidateBlock on `prevH` block height to update the parent header prevH <- liftIO $ getParentTestBlockDb bdb testChainId - pwo <- execNewBlock mempty (ParentHeader prevH) noMiner + pwo' <- liftIO $ getPWOByHeader prevH bdb + _ <- execValidateBlock mempty prevH (payloadWithOutputsToPayloadData pwo') + + pwo <- execNewBlock mempty noMiner void $ liftIO $ addTestBlockDb bdb (Nonce 0) (offsetBlockTime second) testChainId pwo nextH <- liftIO $ getParentTestBlockDb bdb testChainId (valPWO, _g) <- execValidateBlock mempty nextH (payloadWithOutputsToPayloadData pwo) @@ -265,9 +271,6 @@ justModuleHashes' :: ModuleCache -> HM.HashMap ModuleName (Maybe ModuleHash) justModuleHashes' = fmap (preview (_1 . mdModule . _MDModule . mHash)) . moduleCacheToHashMap -genblock :: BlockHeader -genblock = genesisBlockHeader testVer testChainId - initPayloadState :: (CanReadablePayloadCas tbl, Logger logger, logger ~ GenericLogger) => PactServiceM logger tbl () diff --git a/test/Chainweb/Test/Pact/PactMultiChainTest.hs b/test/Chainweb/Test/Pact/PactMultiChainTest.hs index df18fff525..3f506e03a6 100644 --- a/test/Chainweb/Test/Pact/PactMultiChainTest.hs +++ b/test/Chainweb/Test/Pact/PactMultiChainTest.hs @@ -1267,7 +1267,21 @@ currentCut :: PactTestM Cut currentCut = view menvBdb >>= liftIO . readMVar . _bdbCut rewindTo :: Cut -> PactTestM () -rewindTo c = view menvBdb >>= \bdb -> void $ liftIO $ swapMVar (_bdbCut bdb) c +rewindTo c = do + pact <- view menvPact + bdb <- view menvBdb + + forM_ (chainIds testVersion) $ \cid' -> do + let + ph = case HM.lookup cid' (_cutMap c) of + Just h -> h + Nothing -> error $ "rewindTo: can't find block header for " ++ show cid' + + -- reset the parent header using validateBlock + pout <- liftIO $ getPWOByHeader ph bdb + void $ liftIO $ _webPactValidateBlock pact ph (payloadWithOutputsToPayloadData pout) + + void $ liftIO $ swapMVar (_bdbCut bdb) c assertTxEvents :: (HasCallStack, MonadIO m) => String -> [PactEvent] -> CommandResult Hash -> m () assertTxEvents msg evs = liftIO . assertEqual msg evs . _crEvents diff --git a/test/Chainweb/Test/Pact/PactReplay.hs b/test/Chainweb/Test/Pact/PactReplay.hs index c62c97d606..ed35b5beaa 100644 --- a/test/Chainweb/Test/Pact/PactReplay.hs +++ b/test/Chainweb/Test/Pact/PactReplay.hs @@ -171,7 +171,13 @@ serviceInitializationAfterFork mpio genesisBlock iop = do -- cycle. pruneDbs restartPact - let T3 _ line1 _ = mainlineblocks !! 6 + let T3 _ line1 pwo1 = mainlineblocks !! 6 + + (_, q, _) <- iop + + -- reset the pact service state to line1 + void $ validateBlock line1 (payloadWithOutputsToPayloadData pwo1) q + void $ mineLine line1 nonceCounter 4 where mineLine start ncounter len = @@ -208,9 +214,19 @@ firstPlayThrough mpio genesisBlock iop = do setOneShotMempool mpio testMemPoolAccess nonceCounter <- newIORef (1 :: Word64) mainlineblocks <- mineLine genesisBlock nonceCounter 7 - let T3 _ startline1 _ = head mainlineblocks - let T3 _ startline2 _ = mainlineblocks !! 1 + let T3 _ startline1 pwo1 = head mainlineblocks + let T3 _ startline2 pwo2 = mainlineblocks !! 1 + + (_, q, _) <- iop + + -- reset the pact service state to startline1 + void $ validateBlock startline1 (payloadWithOutputsToPayloadData pwo1) q + void $ mineLine startline1 nonceCounter 4 + + -- reset the pact service state to startline2 + void $ validateBlock startline2 (payloadWithOutputsToPayloadData pwo2) q + void $ mineLine startline2 nonceCounter 4 where mineLine start ncounter len = @@ -312,7 +328,7 @@ mineBlock ph nonce iop = timeout 5000000 go >>= \case -- assemble block without nonce and timestamp let r = (\(_, q, _) -> q) <$> iop - mv <- r >>= newBlock noMiner ph + mv <- r >>= newBlock noMiner payload <- assertNotLeft =<< takeMVar mv let bh = newBlockHeader diff --git a/test/Chainweb/Test/Pact/PactSingleChainTest.hs b/test/Chainweb/Test/Pact/PactSingleChainTest.hs index f8942d0edb..e9192387bf 100644 --- a/test/Chainweb/Test/Pact/PactSingleChainTest.hs +++ b/test/Chainweb/Test/Pact/PactSingleChainTest.hs @@ -100,16 +100,12 @@ testVersion = slowForkingCpmTestVersion petersonChainGraph cid :: ChainId cid = someChainId testVersion -genesisHeader :: BlockHeader -genesisHeader = genesisBlockHeader testVersion cid - tests :: RocksDb -> TestTree tests rdb = testGroup testName [ test $ goldenNewBlock "new-block-0" goldenMemPool , test $ goldenNewBlock "empty-block-tests" mempty , test newBlockAndValidate , test newBlockAndValidationFailure - , test newBlockRewindValidate , test getHistory , test testHistLookup1 , test testHistLookup2 @@ -174,7 +170,7 @@ runBlock q bdb timeOffset = do ph <- getParentTestBlockDb bdb cid let blockTime = add timeOffset $ _bct $ _blockCreationTime ph nb <- forSuccess "newBlock" $ - newBlock noMiner (ParentHeader ph) q + newBlock noMiner q forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb | otherwise = emptyPayload @@ -197,7 +193,7 @@ newBlockAndValidationFailure refIO reqIO = testCase "newBlockAndValidationFailur ph <- getParentTestBlockDb bdb cid let blockTime = add second $ _bct $ _blockCreationTime ph nb <- forSuccess ("newBlockAndValidate" <> ": newblock") $ - newBlock noMiner (ParentHeader ph) q + newBlock noMiner q forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb | otherwise = emptyPayload @@ -632,35 +628,6 @@ assertSender00Bal bal msg hist = ]))) hist -newBlockRewindValidate :: IO (IORef MemPoolAccess) -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> TestTree -newBlockRewindValidate mpRefIO reqIO = testCase "newBlockRewindValidate" $ do - (_, q, bdb) <- reqIO - setOneShotMempool mpRefIO chainDataMemPool - cut0 <- readMVar $ _bdbCut bdb -- genesis cut - - -- cut 1a - void $ runBlock q bdb second - cut1a <- readMVar $ _bdbCut bdb - - -- rewind, cut 1b - void $ swapMVar (_bdbCut bdb) cut0 - void $ runBlock q bdb second - - -- rewind to cut 1a to trigger replay with chain data bug - void $ swapMVar (_bdbCut bdb) cut1a - void $ runBlock q bdb (secondsToTimeSpan 2) - - where - - chainDataMemPool = mempty { - mpaGetBlock = \_ _ _ _ bh -> do - fmap V.singleton $ buildCwCmd - $ signSender00 - $ setFromHeader bh - $ mkCmd (sshow bh) - $ mkExec' "(chain-data)" - } - signSender00 :: CmdBuilder -> CmdBuilder signSender00 = set cbSigners [mkSigner' sender00 []] @@ -905,7 +872,7 @@ badlistNewBlockTest mpRefIO reqIO = testCase "badlistNewBlockTest" $ do $ mkCmd "badListMPA" $ mkExec' "(+ 1 2)" setOneShotMempool mpRefIO (badlistMPA badTx badHashRef) - resp <- forSuccess "badlistNewBlockTest" $ newBlock noMiner (ParentHeader genesisHeader) reqQ + resp <- forSuccess "badlistNewBlockTest" $ newBlock noMiner reqQ assertEqual "bad tx filtered from block" mempty (_payloadWithOutputsTransactions resp) badHash <- readIORef badHashRef assertEqual "Badlist should have badtx hash" (hashToTxHashList $ _cmdHash badTx) badHash @@ -921,7 +888,7 @@ goldenNewBlock name mp mpRefIO reqIO = golden name $ do (_, reqQ, _) <- reqIO setOneShotMempool mpRefIO mp resp <- forSuccess ("goldenNewBlock:" ++ name) $ - newBlock noMiner (ParentHeader genesisHeader) reqQ + newBlock noMiner reqQ -- ensure all golden txs succeed forM_ (_payloadWithOutputsTransactions resp) $ \(txIn,TransactionOutput out) -> do cr :: CommandResult Hash <- decodeStrictOrThrow out diff --git a/test/Chainweb/Test/Pact/TTL.hs b/test/Chainweb/Test/Pact/TTL.hs index 7a3cd167a7..e4f5a462c9 100644 --- a/test/Chainweb/Test/Pact/TTL.hs +++ b/test/Chainweb/Test/Pact/TTL.hs @@ -220,7 +220,7 @@ doNewBlock ctxIO mempool parent nonce t = do ctx <- ctxIO unlessM (tryPutMVar (_ctxMempool ctx) mempool) $ error "Test failure: mempool access is not empty. Some previous test step failed unexpectedly" - mv <- newBlock noMiner parent $ _ctxQueue ctx + mv <- newBlock noMiner $ _ctxQueue ctx payload <- assertNotLeft =<< takeMVar mv let bh = newBlockHeader diff --git a/test/Chainweb/Test/Pact/Utils.hs b/test/Chainweb/Test/Pact/Utils.hs index 0681b89717..6206f6e364 100644 --- a/test/Chainweb/Test/Pact/Utils.hs +++ b/test/Chainweb/Test/Pact/Utils.hs @@ -117,7 +117,7 @@ module Chainweb.Test.Pact.Utils , someTestVersionHeader , someBlockHeader , testPactFilesDir - +, getPWOByHeader ) where import Control.Arrow ((&&&)) @@ -217,6 +217,7 @@ import Chainweb.Version.Utils (someChainId) import Chainweb.WebBlockHeaderDB import Chainweb.WebPactExecutionService +import Chainweb.Storage.Table (casLookupM) import Chainweb.Storage.Table.RocksDB -- ----------------------------------------------------------------------- -- @@ -681,8 +682,8 @@ withWebPactExecutionService logger v pactConfig bdb mempoolAccess gasmodel act = bhdb <- getBlockHeaderDb c bdb (ctx,_) <- testPactCtxSQLite logger v c bhdb (_bdbPayloadDb bdb) sqlenv pactConfig gasmodel return $ (c,) $ PactExecutionService - { _pactNewBlock = \m p -> - evalPactServiceM_ ctx $ execNewBlock mempoolAccess p m + { _pactNewBlock = \_ m -> + evalPactServiceM_ ctx $ execNewBlock mempoolAccess m , _pactValidateBlock = \h d -> evalPactServiceM_ ctx $ fst <$> execValidateBlock mempoolAccess h d , _pactLocal = \pf sv rd cmd -> @@ -717,8 +718,7 @@ runCut -> IO () runCut v bdb pact genTime noncer miner = forM_ (chainIds v) $ \cid -> do - ph <- ParentHeader <$> getParentTestBlockDb bdb cid - pout <- _webPactNewBlock pact miner ph + pout <- _webPactNewBlock pact cid miner n <- noncer cid -- skip this chain if mining fails and retry with the next chain. @@ -985,3 +985,6 @@ compact :: () compact logLevel cFlags (SQLiteEnv db _) bh = do C.withDefaultLogger logLevel $ \logger -> do void $ C.compact bh logger db cFlags + +getPWOByHeader :: BlockHeader -> TestBlockDb -> IO PayloadWithOutputs +getPWOByHeader h (TestBlockDb _ pdb _) = casLookupM pdb (_blockPayloadHash h)