From 668a579ceaf00aeec17c1c2e435ea18e0ed33ea9 Mon Sep 17 00:00:00 2001 From: Edmund Noble Date: Fri, 17 May 2024 14:44:31 -0400 Subject: [PATCH] fix: Make NewBlock take a parent header as a parameter Change-Id: Ia9a721c1bbc09ca5612676c6fd16c88750f6de78 --- bench/Chainweb/Pact/Backend/ForkingBench.hs | 21 ++++--- src/Chainweb/Chainweb/MinerResources.hs | 36 ++++------- src/Chainweb/Pact/PactService.hs | 10 +-- src/Chainweb/Pact/PactService/Checkpointer.hs | 1 + src/Chainweb/Pact/Service/BlockValidation.hs | 5 +- src/Chainweb/Pact/Service/Types.hs | 4 +- src/Chainweb/WebPactExecutionService.hs | 14 +++-- test/Chainweb/Test/CutDB.hs | 9 +-- .../Test/Pact/ModuleCacheOnRestart.hs | 5 +- test/Chainweb/Test/Pact/PactReplay.hs | 28 +++++---- .../Chainweb/Test/Pact/PactSingleChainTest.hs | 30 +++++---- test/Chainweb/Test/Pact/TTL.hs | 61 ++++++++++--------- test/Chainweb/Test/Pact/Utils.hs | 8 +-- 13 files changed, 124 insertions(+), 108 deletions(-) diff --git a/bench/Chainweb/Pact/Backend/ForkingBench.hs b/bench/Chainweb/Pact/Backend/ForkingBench.hs index 120d00edb8..6a3073e425 100644 --- a/bench/Chainweb/Pact/Backend/ForkingBench.hs +++ b/bench/Chainweb/Pact/Backend/ForkingBench.hs @@ -173,10 +173,11 @@ bench rdb = C.bgroup "PactService" $ oneBlock :: BenchConfig -> Int -> C.Benchmark oneBlock cfg txCount = withResources rdb cfg.numPriorBlocks Error cfg.compact cfg.persistIntraBlockWrites go where - go _mainLineBlocks _pdb _bhdb _nonceCounter pactQueue txsPerBlock = do + go mainLineBlocks _pdb _bhdb _nonceCounter pactQueue txsPerBlock = do C.bench name $ C.whnfIO $ do writeIORef txsPerBlock txCount - createBlock cfg.validate (Nonce 1234) pactQueue + let (T3 _ join1 _) = last mainLineBlocks + createBlock cfg.validate (ParentHeader join1) (Nonce 1234) pactQueue name = "block-new [" ++ List.intercalate "," [ "txCount=" ++ show txCount @@ -209,20 +210,22 @@ playLine pdb bhdb trunkLength startingBlock pactQueue counter = do startHeight = fromIntegral $ _blockHeight start go = do r <- ask + pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter - ret@(T3 _ newblock _) <- liftIO $ mineBlock n pdb bhdb r + ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n pdb bhdb r liftIO $ modifyIORef' ncounter succ put newblock return ret mineBlock - :: Nonce + :: ParentHeader + -> Nonce -> PayloadDb HashMapTable -> BlockHeaderDb -> PactQueue -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) -mineBlock nonce pdb bhdb pact = do - r@(T3 parent newHeader payload) <- createBlock DoValidate nonce pact +mineBlock parent nonce pdb bhdb pact = do + r@(T3 _ newHeader payload) <- createBlock DoValidate parent nonce pact addNewPayload pdb (succ (_blockHeight (_parentHeader parent))) payload -- NOTE: this doesn't validate the block header, which is fine in this test case unsafeInsertBlockHeaderDb bhdb newHeader @@ -230,15 +233,15 @@ mineBlock nonce pdb bhdb pact = do createBlock :: Validate + -> ParentHeader -> Nonce -> PactQueue -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) -createBlock validate nonce pact = do +createBlock validate parent nonce pact = do -- assemble block without nonce and timestamp - bip <- newBlock noMiner True pact - let parent = _blockInProgressParentHeader bip + !bip <- fromJuste <$> newBlock noMiner True parent pact let payload = blockInProgressToPayloadWithOutputs bip let creationTime = add second $ _blockCreationTime $ _parentHeader parent diff --git a/src/Chainweb/Chainweb/MinerResources.hs b/src/Chainweb/Chainweb/MinerResources.hs index ce5696d7be..b149828fda 100644 --- a/src/Chainweb/Chainweb/MinerResources.hs +++ b/src/Chainweb/Chainweb/MinerResources.hs @@ -34,6 +34,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar +import Control.Exception (evaluate) import Control.Lens import Control.Monad @@ -62,7 +63,6 @@ import Chainweb.Miner.Coordinator import Chainweb.Miner.Miners import Chainweb.Miner.Pact (Miner(..), minerId) import Chainweb.Pact.Service.Types(BlockInProgress(..), Transactions(..)) -import Chainweb.Pact.Utils import Chainweb.Payload import Chainweb.Payload.PayloadStore import Chainweb.Sync.WebBlockHeaderStore @@ -75,8 +75,6 @@ import Data.LogMessage (JsonLog(..), LogFunction) import Numeric.AffineSpace -import Utils.Logging.Trace (trace) - -- -------------------------------------------------------------------------- -- -- Miner @@ -98,7 +96,8 @@ withMiningCoordination logger conf cdb inner in fmap ((mid,) . HM.fromList) $ forM cids $ \cid -> do let bh = fromMaybe (genesisBlockHeader v cid) (HM.lookup cid (_cutMap cut)) - newBlock <- getPayload cid miner (ParentHeader bh) + maybeNewBlock <- _pactNewBlock pact cid miner True (ParentHeader bh) + newBlock <- evaluate $ fromJuste maybeNewBlock return (cid, Just newBlock) m <- newTVarIO initialPw @@ -189,25 +188,16 @@ withMiningCoordination logger conf cdb inner atomically $ modifyTVar' tpw (ourMiner .~ Nothing) -- Get a payload for the new block - newBlock <- getPayload cid miner newParent - - atomically $ modifyTVar' tpw (ourMiner .~ Just newBlock) - - - getPayload :: ChainId -> Miner -> ParentHeader -> IO NewBlock - getPayload cid m ph = - if v ^. versionCheats . disablePact - -- if pact is disabled, we must keep track of the latest header - -- ourselves. otherwise we use the header we get from newBlock as the - -- real parent. newBlock may return a header in the past due to a race - -- with rocksdb though that shouldn't cause a problem, just wasted work, - -- see docs for - -- Chainweb.Pact.PactService.Checkpointer.findLatestValidBlockHeader' - then return $ - NewBlockPayload ph emptyPayload - else trace (logFunction (chainLogger cid logger)) - "Chainweb.Chainweb.MinerResources.withMiningCoordination.newBlock" - () 1 (_pactNewBlock pact cid m True) + maybeNewBlock <- _pactNewBlock pact cid miner True newParent + + case maybeNewBlock of + Nothing -> do + logFunctionText (chainLogger cid logger) Warn + "current block is not in the checkpointer; halting primed work loop temporarily" + approximateThreadDelay 1_000_000 + atomically $ modifyTVar' tpw (ourMiner .~ Just outdatedPayload) + Just newBlock -> + atomically $ modifyTVar' tpw (ourMiner .~ Just newBlock) pact :: PactExecutionService pact = _webPactExecutionService $ view cutDbPactService cdb diff --git a/src/Chainweb/Pact/PactService.hs b/src/Chainweb/Pact/PactService.hs index 13195d2136..879c24af1c 100644 --- a/src/Chainweb/Pact/PactService.hs +++ b/src/Chainweb/Pact/PactService.hs @@ -314,7 +314,7 @@ serviceRequests memPoolAccess reqQ = go trace logFn "Chainweb.Pact.PactService.execNewBlock" () 1 $ tryOne "execNewBlock" statusRef $ - execNewBlock memPoolAccess _newBlockMiner _newBlockFill + execNewBlock memPoolAccess _newBlockMiner _newBlockFill _newBlockParent go ContinueBlockMsg (ContinueBlockReq bip) -> do trace logFn "Chainweb.Pact.PactService.execContinueBlock" @@ -448,10 +448,10 @@ execNewBlock => MemPoolAccess -> Miner -> Bool - -> PactServiceM logger tbl BlockInProgress -execNewBlock mpAccess miner fill = pactLabel "execNewBlock" $ do - readFromLatest $ do - newBlockParent <- view psParentHeader + -> ParentHeader + -> PactServiceM logger tbl (Maybe BlockInProgress) +execNewBlock mpAccess miner fill newBlockParent = pactLabel "execNewBlock" $ do + readFrom (Just newBlockParent) $ do blockDbEnv <- view psBlockDbEnv let pHeight = _blockHeight $ _parentHeader newBlockParent let pHash = _blockHash $ _parentHeader newBlockParent diff --git a/src/Chainweb/Pact/PactService/Checkpointer.hs b/src/Chainweb/Pact/PactService/Checkpointer.hs index 8641180302..028c648f22 100644 --- a/src/Chainweb/Pact/PactService/Checkpointer.hs +++ b/src/Chainweb/Pact/PactService/Checkpointer.hs @@ -134,6 +134,7 @@ readFromNthParent n doRead = do Just r -> return r -- read-only rewind to a target block. +-- if that target block is missing, return Nothing. readFrom :: Logger logger => Maybe ParentHeader -> PactBlockM logger tbl a -> PactServiceM logger tbl (Maybe a) diff --git a/src/Chainweb/Pact/Service/BlockValidation.hs b/src/Chainweb/Pact/Service/BlockValidation.hs index fcfaa550bc..d7c0ef3533 100644 --- a/src/Chainweb/Pact/Service/BlockValidation.hs +++ b/src/Chainweb/Pact/Service/BlockValidation.hs @@ -45,11 +45,12 @@ import Chainweb.Transaction import Chainweb.Utils -newBlock :: Miner -> Bool -> PactQueue -> IO BlockInProgress -newBlock mi fill reqQ = do +newBlock :: Miner -> Bool -> ParentHeader -> PactQueue -> IO (Maybe BlockInProgress) +newBlock mi fill parent reqQ = do let !msg = NewBlockMsg NewBlockReq { _newBlockMiner = mi , _newBlockFill = fill + , _newBlockParent = parent } submitRequestAndWait reqQ msg diff --git a/src/Chainweb/Pact/Service/Types.hs b/src/Chainweb/Pact/Service/Types.hs index 250ed9ad11..4ed31a4a79 100644 --- a/src/Chainweb/Pact/Service/Types.hs +++ b/src/Chainweb/Pact/Service/Types.hs @@ -381,7 +381,7 @@ instance Show SubmittedRequestMsg where show (SubmittedRequestMsg msg _) = show msg data RequestMsg r where - NewBlockMsg :: !NewBlockReq -> RequestMsg BlockInProgress + NewBlockMsg :: !NewBlockReq -> RequestMsg (Maybe BlockInProgress) ContinueBlockMsg :: !ContinueBlockReq -> RequestMsg (Maybe BlockInProgress) ValidateBlockMsg :: !ValidateBlockReq -> RequestMsg PayloadWithOutputs LocalMsg :: !LocalReq -> RequestMsg LocalResult @@ -412,6 +412,8 @@ data NewBlockReq , _newBlockFill :: !Bool -- ^ whether to fill this block with transactions; if false, the block -- will be empty. + , _newBlockParent :: !ParentHeader + -- ^ the parent to use for the new block } deriving stock Show newtype ContinueBlockReq diff --git a/src/Chainweb/WebPactExecutionService.hs b/src/Chainweb/WebPactExecutionService.hs index bb80957bcb..e09ac848a6 100644 --- a/src/Chainweb/WebPactExecutionService.hs +++ b/src/Chainweb/WebPactExecutionService.hs @@ -75,7 +75,8 @@ data PactExecutionService = PactExecutionService ChainId -> Miner -> Bool -> - IO NewBlock + ParentHeader -> + IO (Maybe NewBlock) ) , _pactContinueBlock :: !( ChainId -> @@ -142,7 +143,8 @@ _webPactNewBlock -> ChainId -> Miner -> Bool - -> IO NewBlock + -> ParentHeader + -> IO (Maybe NewBlock) _webPactNewBlock = _pactNewBlock . _webPactExecutionService {-# INLINE _webPactNewBlock #-} @@ -175,7 +177,7 @@ mkWebPactExecutionService -> WebPactExecutionService mkWebPactExecutionService hm = WebPactExecutionService $ PactExecutionService { _pactValidateBlock = \h pd -> withChainService (_chainId h) $ \p -> _pactValidateBlock p h pd - , _pactNewBlock = \cid m fill -> withChainService cid $ \p -> _pactNewBlock p cid m fill + , _pactNewBlock = \cid m fill parent -> withChainService cid $ \p -> _pactNewBlock p cid m fill parent , _pactContinueBlock = \cid bip -> withChainService cid $ \p -> _pactContinueBlock p cid bip , _pactLocal = \_pf _sv _rd _ct -> throwM $ userError "Chainweb.WebPactExecutionService.mkPactExecutionService: No web-level local execution supported" , _pactLookup = \cid cd txs -> withChainService cid $ \p -> _pactLookup p cid cd txs @@ -197,8 +199,8 @@ mkPactExecutionService mkPactExecutionService q = PactExecutionService { _pactValidateBlock = \h pd -> do validateBlock h pd q - , _pactNewBlock = \_ m fill -> do - NewBlockInProgress <$> newBlock m fill q + , _pactNewBlock = \_ m fill parent -> do + fmap NewBlockInProgress <$> newBlock m fill parent q , _pactContinueBlock = \_ bip -> do continueBlock bip q , _pactLocal = \pf sv rd ct -> @@ -221,7 +223,7 @@ mkPactExecutionService q = PactExecutionService emptyPactExecutionService :: HasCallStack => PactExecutionService emptyPactExecutionService = PactExecutionService { _pactValidateBlock = \_ _ -> pure emptyPayload - , _pactNewBlock = \_ _ _ -> throwM (userError "emptyPactExecutionService: attempted `newBlock` call") + , _pactNewBlock = \_ _ _ _ -> throwM (userError "emptyPactExecutionService: attempted `newBlock` call") , _pactContinueBlock = \_ _ -> throwM (userError "emptyPactExecutionService: attempted `continueBlock` call") , _pactLocal = \_ _ _ _ -> throwM (userError "emptyPactExecutionService: attempted `local` call") , _pactLookup = \_ _ _ -> return $! HM.empty diff --git a/test/Chainweb/Test/CutDB.hs b/test/Chainweb/Test/CutDB.hs index a5c992db4b..a0afaf1d25 100644 --- a/test/Chainweb/Test/CutDB.hs +++ b/test/Chainweb/Test/CutDB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} @@ -403,7 +404,7 @@ tryMineForChain -> ChainId -> IO (Either MineFailure (Cut, ChainId, PayloadWithOutputs)) tryMineForChain miner webPact cutDb c cid = do - newBlock <- _webPactNewBlock webPact cid miner True + !newBlock <- fromJuste <$> _webPactNewBlock webPact cid miner True parent let outputs = newBlockToPayloadWithOutputs newBlock let payloadHash = _payloadWithOutputsPayloadHash outputs t <- getCurrentTimeIntegral @@ -417,6 +418,7 @@ 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 @@ -488,10 +490,9 @@ fakePact = WebPactExecutionService $ PactExecutionService return $ payloadWithOutputs d coinbase $ getFakeOutput <$> _payloadDataTransactions d - , _pactNewBlock = \_ _ _ -> do + , _pactNewBlock = \_ _ _ ph -> do payloadDat <- generate $ V.fromList . getNonEmpty <$> arbitrary - ph <- ParentHeader <$> generate arbitrary - return + return $ Just $ NewBlockPayload ph $ newPayloadWithOutputs fakeMiner coinbase $ (\x -> (x, getFakeOutput x)) <$> payloadDat diff --git a/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs b/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs index d6564a80ea..3c3ae13179 100644 --- a/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs +++ b/test/Chainweb/Test/Pact/ModuleCacheOnRestart.hs @@ -127,7 +127,8 @@ testCoinbase iobdb = (initPayloadState >> doCoinbase,snapshotCache) genHeight = genesisHeight testVer testChainId doCoinbase = do bdb <- liftIO iobdb - bip <- execNewBlock mempty noMiner True + !bip <- fromJuste <$> execNewBlock mempty noMiner True + (ParentHeader (genesisBlockHeader testVer testChainId)) let pwo = blockInProgressToPayloadWithOutputs bip void $ liftIO $ addTestBlockDb bdb (succ genHeight) (Nonce 0) (offsetBlockTime second) testChainId pwo nextH <- liftIO $ getParentTestBlockDb bdb testChainId @@ -250,7 +251,7 @@ doNextCoinbase iobdb = do pwo' <- liftIO $ getPWOByHeader prevH bdb _ <- execValidateBlock mempty prevH (CheckablePayloadWithOutputs pwo') - bip <- execNewBlock mempty noMiner True + !bip <- fromJuste <$> execNewBlock mempty noMiner True (ParentHeader prevH) let prevH' = _blockInProgressParentHeader bip let pwo = blockInProgressToPayloadWithOutputs bip liftIO $ ParentHeader prevH @?= prevH' diff --git a/test/Chainweb/Test/Pact/PactReplay.hs b/test/Chainweb/Test/Pact/PactReplay.hs index 2411feda81..fa54e2d6d0 100644 --- a/test/Chainweb/Test/Pact/PactReplay.hs +++ b/test/Chainweb/Test/Pact/PactReplay.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} @@ -73,7 +74,7 @@ tests rdb = , withPactTestBlockDb testVer cid rdb mp (forkLimit $ RewindLimit 100_000) (testCaseSteps "on-restart" . onRestart mpio) , withPactTestBlockDb testVer cid rdb mp (forkLimit $ RewindLimit 100_000) - (testCase "reject-dupes" . testDupes mpio) + (testCase "reject-dupes" . testDupes mpio genblock) , let deepForkLimit = RewindLimit 4 in withPactTestBlockDb testVer cid rdb mp (forkLimit deepForkLimit) (testCaseSteps "deep-fork-limit" . testDeepForkLimit mpio deepForkLimit) @@ -98,7 +99,7 @@ onRestart mpio iop step = do step $ "max block has height " <> sshow (_blockHeight block) let nonce = Nonce $ fromIntegral $ _blockHeight block step "mine block on top of max block" - T3 _ b _ <- mineBlock nonce iop + T3 _ b _ <- mineBlock (ParentHeader block) nonce iop assertEqual "Invalid BlockHeight" 1 (_blockHeight b) testMemPoolAccess :: MemPoolAccess @@ -183,8 +184,9 @@ serviceInitializationAfterFork mpio genesisBlock iop = do where startHeight = fromIntegral $ _blockHeight start go = do + pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter - ret@(T3 _ newblock _) <- liftIO $ mineBlock n iop + ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop liftIO $ modifyIORef' ncounter succ put newblock return ret @@ -231,21 +233,23 @@ firstPlayThrough mpio genesisBlock iop = do where startHeight = fromIntegral $ _blockHeight start go = do + pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter - ret@(T3 _ newblock _) <- liftIO $ mineBlock n iop + ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop liftIO $ modifyIORef' ncounter succ put newblock return ret testDupes :: IO (IORef MemPoolAccess) + -> BlockHeader -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> Assertion -testDupes mpio iop = do +testDupes mpio genesisBlock iop = do setMempool mpio =<< dupegenMemPoolAccess - (T3 _ newblock payload) <- liftIO $ mineBlock (Nonce 1) iop + (T3 _ newblock payload) <- liftIO $ mineBlock (ParentHeader genesisBlock) (Nonce 1) iop expectException newblock payload $ liftIO $ - mineBlock (Nonce 3) iop + mineBlock (ParentHeader newblock) (Nonce 3) iop where expectException newblock payload act = do m <- wrap `catchAllSynchronous` h @@ -306,17 +310,18 @@ testDeepForkLimit mpio (RewindLimit deepForkLimit) iop step = do pblock <- gets ParentHeader n <- liftIO $ Nonce <$> readIORef ncounter liftIO $ step $ "mine block on top of height " <> sshow (_blockHeight $ _parentHeader pblock) - ret@(T3 _ newblock _) <- liftIO $ mineBlock n iop + ret@(T3 _ newblock _) <- liftIO $ mineBlock pblock n iop liftIO $ modifyIORef' ncounter succ put newblock return ret mineBlock - :: Nonce + :: ParentHeader + -> Nonce -> IO (SQLiteEnv, PactQueue, TestBlockDb) -> IO (T3 ParentHeader BlockHeader PayloadWithOutputs) -mineBlock nonce iop = timeout 5000000 go >>= \case +mineBlock ph nonce iop = timeout 5000000 go >>= \case Nothing -> error "PactReplay.mineBlock: Test timeout. Most likely a test case caused a pact service failure that wasn't caught, and the test was blocked while waiting for the result" Just x -> return x where @@ -324,8 +329,7 @@ mineBlock nonce iop = timeout 5000000 go >>= \case -- assemble block without nonce and timestamp (_, q, bdb) <- iop - bip <- newBlock noMiner True q - let ph = _blockInProgressParentHeader bip + !bip <- fromJuste <$> newBlock noMiner True ph q let payload = blockInProgressToPayloadWithOutputs bip let diff --git a/test/Chainweb/Test/Pact/PactSingleChainTest.hs b/test/Chainweb/Test/Pact/PactSingleChainTest.hs index a0fb064ba0..679a716552 100644 --- a/test/Chainweb/Test/Pact/PactSingleChainTest.hs +++ b/test/Chainweb/Test/Pact/PactSingleChainTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} @@ -103,6 +104,10 @@ 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 @@ -178,8 +183,8 @@ forSuccess msg act = (`catchAllSynchronous` handler) $ do runBlockE :: (HasCallStack) => PactQueue -> TestBlockDb -> TimeSpan Micros -> IO (Either PactException PayloadWithOutputs) runBlockE q bdb timeOffset = do - bip <- newBlock noMiner True q - let ParentHeader ph = _blockInProgressParentHeader bip + ph <- getParentTestBlockDb bdb cid + !bip <- fromJuste <$> newBlock noMiner True (ParentHeader ph) q let nb = blockInProgressToPayloadWithOutputs bip let blockTime = add timeOffset $ _bct $ _blockCreationTime ph forM_ (chainIds testVersion) $ \c -> do @@ -226,7 +231,7 @@ newBlockAndContinue refIO reqIO = testCase "newBlockAndContinue" $ do , V.fromList [ c3 ] ] - bipStart <- newBlock noMiner True q + !bipStart <- fromJuste <$> newBlock noMiner True (ParentHeader genesisHeader) q let ParentHeader ph = _blockInProgressParentHeader bipStart Just bipContinued <- continueBlock bipStart q Just bipFinal <- continueBlock bipContinued q @@ -256,7 +261,7 @@ newBlockAndContinue refIO reqIO = testCase "newBlockAndContinue" $ do [ V.fromList [ c1, c2, c3 ] ] - bipAllAtOnce <- newBlock noMiner True q + !bipAllAtOnce <- fromJuste <$> newBlock noMiner True (ParentHeader genesisHeader) q let nbAllAtOnce = blockInProgressToPayloadWithOutputs bipAllAtOnce assertEqual "a continued block, and one that's all done at once, should be exactly equal" nbContinued nbAllAtOnce @@ -275,12 +280,14 @@ newBlockNoFill refIO reqIO = testCase "newBlockNoFill" $ do set cbRPC (mkExec "1" (object [])) $ defaultCmd setMempool refIO =<< mempoolOf [V.fromList [c1]] - noFillPwo <- blockInProgressToPayloadWithOutputs <$> newBlock noMiner False q + !noFillPwo <- blockInProgressToPayloadWithOutputs . fromJuste <$> + newBlock noMiner False (ParentHeader genesisHeader) q assertEqual "an unfilled newblock must have no transactions, even with a full mempool" mempty (_payloadWithOutputsTransactions noFillPwo) - fillPwo <- blockInProgressToPayloadWithOutputs <$> newBlock noMiner True q + !fillPwo <- blockInProgressToPayloadWithOutputs . fromJuste <$> + newBlock noMiner True (ParentHeader genesisHeader) q assertEqual "an filled newblock has transactions with a full mempool" 1 @@ -291,14 +298,13 @@ newBlockAndValidationFailure refIO reqIO = testCase "newBlockAndValidationFailur (_, q, bdb) <- reqIO setOneShotMempool refIO =<< goldenMemPool - bip <- newBlock noMiner True q - let (ParentHeader ph) = _blockInProgressParentHeader bip + !bip <- fromJuste <$> newBlock noMiner True (ParentHeader genesisHeader) q let nb = blockInProgressToPayloadWithOutputs bip - let blockTime = add second $ _bct $ _blockCreationTime ph + let blockTime = add second $ _bct $ _blockCreationTime genesisHeader forM_ (chainIds testVersion) $ \c -> do let o | c == cid = nb | otherwise = emptyPayload - addTestBlockDb bdb (succ $ _blockHeight ph) (Nonce 0) (\_ _ -> blockTime) c o + addTestBlockDb bdb (succ $ _blockHeight genesisHeader) (Nonce 0) (\_ _ -> blockTime) c o nextH <- getParentTestBlockDb bdb cid @@ -976,7 +982,7 @@ badlistNewBlockTest mpRefIO reqIO = testCase "badlistNewBlockTest" $ do $ set cbRPC (mkExec' "(+ 1 2)") $ defaultCmd setOneShotMempool mpRefIO (badlistMPA badTx badHashRef) - bip <- newBlock noMiner True reqQ + !bip <- fromJuste <$> newBlock noMiner True (ParentHeader genesisHeader) reqQ let resp = blockInProgressToPayloadWithOutputs bip assertEqual "bad tx filtered from block" mempty (_payloadWithOutputsTransactions resp) badHash <- readIORef badHashRef @@ -992,7 +998,7 @@ goldenNewBlock name mpIO mpRefIO reqIO = golden name $ do mp <- mpIO (_, reqQ, _) <- reqIO setOneShotMempool mpRefIO mp - blockInProgress <- newBlock noMiner True reqQ + !blockInProgress <- fromJuste <$> newBlock noMiner True (ParentHeader genesisHeader) reqQ let resp = blockInProgressToPayloadWithOutputs blockInProgress -- ensure all golden txs succeed forM_ (_payloadWithOutputsTransactions resp) $ \(txIn,TransactionOutput out) -> do diff --git a/test/Chainweb/Test/Pact/TTL.hs b/test/Chainweb/Test/Pact/TTL.hs index eb716360b0..cedcc099ae 100644 --- a/test/Chainweb/Test/Pact/TTL.hs +++ b/test/Chainweb/Test/Pact/TTL.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} @@ -56,6 +57,9 @@ testVer = instantCpmTestVersion peterson defTtl :: Seconds defTtl = 60 * 60 * 2 -- 2 hours +genblock :: BlockHeader +genblock = genesisBlockHeader testVer (someChainId testVer) + -- -------------------------------------------------------------------------- -- -- Tests @@ -91,63 +95,63 @@ tests rdb = testGroup "Chainweb.Test.Pact.TTL" testTxTime :: IO Ctx -> TestTree testTxTime ctxIO = testCase "tx time of parent time and default ttl pass validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 0) 1 - _ <- mineBlock ctxIO (offset 0) (Nonce 1) 1 - void $ mineBlock ctxIO (offset (-1)) (Nonce 2) 1 + T2 hdr1 _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 0) 1 + T2 hdr2 _ <- mineBlock ctxIO (offset 0) (ParentHeader hdr1) (Nonce 1) 1 + void $ mineBlock ctxIO (offset (-1)) (ParentHeader hdr2) (Nonce 2) 1 testTxTimeLenient :: IO Ctx -> TestTree testTxTimeLenient ctxIO = testCase "testTxTimeLenient: tx time of parent time + slop and default ttl succeeds during new block validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 1 - void $ doNewBlock ctxIO (offset defaultLenientTimeSlop) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 + void $ doNewBlock ctxIO (offset defaultLenientTimeSlop) (ParentHeader hdr) (Nonce 2) 1 testTxTimeFail1 :: IO Ctx -> TestTree testTxTimeFail1 ctxIO = testCase "testTxTimeFail1: tx time of parent time + slop + 1 and default ttl fails during new block validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 1 - assertDoPreBlockFailure $ doNewBlock ctxIO (offset (succ defaultLenientTimeSlop)) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 + assertDoPreBlockFailure $ doNewBlock ctxIO (offset (succ defaultLenientTimeSlop)) (ParentHeader hdr) (Nonce 2) 1 testTxTimeFail2 :: IO Ctx -> TestTree testTxTimeFail2 ctxIO = testCase "tx time of parent time + 1000 and default ttl fails during new block validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 1 - assertDoPreBlockFailure $ doNewBlock ctxIO (offset 1000) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 + assertDoPreBlockFailure $ doNewBlock ctxIO (offset 1000) (ParentHeader hdr) (Nonce 2) 1 testTtlTooLarge :: IO Ctx -> TestTree testTtlTooLarge ctxIO = testCase "too large TTL fails validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 1 - assertDoPreBlockFailure $ doNewBlock ctxIO (ttl (100 * 24 * 3600)) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 + assertDoPreBlockFailure $ doNewBlock ctxIO (ttl (100 * 24 * 3600)) (ParentHeader hdr) (Nonce 2) 1 testTtlSmall :: IO Ctx -> TestTree testTtlSmall ctxIO = testCase "testTtlSmall: small TTL passes validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 1 - void $ doNewBlock ctxIO (ttl 5) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 1 + void $ doNewBlock ctxIO (ttl 5) (ParentHeader hdr) (Nonce 2) 1 testExpired :: IO Ctx -> TestTree testExpired ctxIO = testCase "expired transaction fails validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 500 - assertDoPreBlockFailure $ doNewBlock ctxIO (offsetTtl (-400) 300) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 500 + assertDoPreBlockFailure $ doNewBlock ctxIO (offsetTtl (-400) 300) (ParentHeader hdr) (Nonce 2) 1 testExpiredTight :: IO Ctx -> TestTree testExpiredTight ctxIO = testCase "tightly expired transaction fails validation" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 500 - assertDoPreBlockFailure $ doNewBlock ctxIO (offsetTtl (-300) 300) (Nonce 2) 1 + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 500 + assertDoPreBlockFailure $ doNewBlock ctxIO (offsetTtl (-300) 300) (ParentHeader hdr) (Nonce 2) 1 testJustMadeItSmall :: IO Ctx -> TestTree testJustMadeItSmall ctxIO = - testCase "testJustMadeIdSmall" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 100 - void $ doNewBlock ctxIO (offsetTtl (-99) 100) (Nonce 2) 1 + testCase "testJustMadeItSmall" $ do + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 100 + void $ doNewBlock ctxIO (offsetTtl (-99) 100) (ParentHeader hdr) (Nonce 2) 1 testJustMadeItLarge :: IO Ctx -> TestTree testJustMadeItLarge ctxIO = - testCase "testJustMadeItLage" $ do - _ <- mineBlock ctxIO mempty (Nonce 1) 500 - void $ doNewBlock ctxIO (offsetTtl (-399) 400) (Nonce 2) 1 + testCase "testJustMadeItLarge" $ do + T2 hdr _ <- mineBlock ctxIO mempty (ParentHeader genblock) (Nonce 1) 500 + void $ doNewBlock ctxIO (offsetTtl (-399) 400) (ParentHeader hdr) (Nonce 2) 1 -- -------------------------------------------------------------------------- -- -- Mempool Access @@ -193,12 +197,13 @@ modAtTtl f (Seconds t) = mempty mineBlock :: IO Ctx -> MemPoolAccess + -> ParentHeader -> Nonce -> Seconds -- ^ Block time -> IO (T2 BlockHeader PayloadWithOutputs) -mineBlock ctxIO mempool nonce s = do - T2 hdr payload <- doNewBlock ctxIO mempool nonce s +mineBlock ctxIO mempool parent nonce s = do + T2 hdr payload <- doNewBlock ctxIO mempool parent nonce s doValidateBlock ctxIO hdr payload return $ T2 hdr payload @@ -207,17 +212,17 @@ mineBlock ctxIO mempool nonce s = do doNewBlock :: IO Ctx -> MemPoolAccess + -> ParentHeader -> Nonce -> Seconds -- ^ Block time -> IO (T2 BlockHeader PayloadWithOutputs) -doNewBlock ctxIO mempool nonce t = do +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" - bip <- newBlock noMiner True $ _ctxQueue ctx - let parent = _blockInProgressParentHeader bip + !bip <- fmap fromJuste $ newBlock noMiner True parent $ _ctxQueue ctx let payload = blockInProgressToPayloadWithOutputs bip let creationTime = BlockCreationTime diff --git a/test/Chainweb/Test/Pact/Utils.hs b/test/Chainweb/Test/Pact/Utils.hs index d83c8bd448..9cf04ad51b 100644 --- a/test/Chainweb/Test/Pact/Utils.hs +++ b/test/Chainweb/Test/Pact/Utils.hs @@ -739,8 +739,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 $ PactExecutionService - { _pactNewBlock = \_ m fill -> - evalPactServiceM_ ctx $ NewBlockInProgress <$> execNewBlock mempoolAccess m fill + { _pactNewBlock = \_ m fill ph -> + evalPactServiceM_ ctx $ fmap NewBlockInProgress <$> execNewBlock mempoolAccess m fill ph , _pactContinueBlock = \_ bip -> evalPactServiceM_ ctx $ execContinueBlock mempoolAccess bip , _pactValidateBlock = \h d -> @@ -779,8 +779,8 @@ runCut -> IO () runCut v bdb pact genTime noncer miner = forM_ (chainIds v) $ \cid -> do - newBlock <- _webPactNewBlock pact cid miner True - let ph = newBlockParentHeader newBlock + ph <- ParentHeader <$> getParentTestBlockDb bdb cid + !newBlock <- fromJuste <$> _webPactNewBlock pact cid miner True ph let pout = newBlockToPayloadWithOutputs newBlock n <- noncer cid