fix: Make NewBlock take a parent header as a parameter

Change-Id: Ia9a721c1bbc09ca5612676c6fd16c88750f6de78

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,36 +210,38 @@ 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
     return r
 
 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

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

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

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)

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
 

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

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

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

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'

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,26 +310,26 @@ 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
     go = do
 
       -- 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