execNewBlock: remove the parent header as paramater and sync from the…

… db instead

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
 

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

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

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

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

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

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

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 ()

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

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