feat: When ro-replay upper bound is unset use latest checkpointer block

Change-Id: I808d5799db1639b45945fe36ffbd1762f070b734

changes/2024-05-30T145604-0400.txt

@@ -0,0 +1 @@
+Fixed a crash when using read-only replay with no upper bound

src/Chainweb/Chainweb.hs

@@ -331,7 +331,7 @@ validatingMempoolConfig cid v gl gp mv = Mempool.InMemConfig
 
 data StartedChainweb logger where
   StartedChainweb :: (CanReadablePayloadCas cas, Logger logger) => !(Chainweb logger cas) -> StartedChainweb logger
-  Replayed :: !Cut -> !Cut -> StartedChainweb logger
+  Replayed :: !Cut -> !(Maybe Cut) -> StartedChainweb logger
 
 data ChainwebStatus
     = ProcessStarted
@@ -506,25 +506,27 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re
                     unsafeMkCut v <$> readHighestCutHeaders v (logFunctionText logger) webchain (cutHashesTable rocksDb)
                 lowerBoundCut <-
                     tryLimitCut webchain (fromMaybe 0 $ _cutInitialBlockHeightLimit $ _configCuts conf) highestCut
-                upperBoundCut <-
-                    tryLimitCut webchain (fromMaybe maxBound $ _cutFastForwardBlockHeightLimit $ _configCuts conf) highestCut
+                upperBoundCut <- forM (_cutFastForwardBlockHeightLimit $ _configCuts conf) $ \upperBound ->
+                    tryLimitCut webchain upperBound highestCut
                 let
-                    replayOneChain :: (ChainResources logger, (BlockHeader, BlockHeader)) -> IO ()
+                    replayOneChain :: (ChainResources logger, (BlockHeader, Maybe BlockHeader)) -> IO ()
                     replayOneChain (cr, (l, u)) = do
                         let chainPact = _chainResPact cr
                         let logCr = logFunctionText
                                 $ addLabel ("component", "pact")
                                 $ addLabel ("sub-component", "init")
                                 $ _chainResLogger cr
-                        logCr Info $ "pact db replaying between blocks "
-                            <> T.pack (show (_blockHeight l, _blockHash l)) <> " and "
-                            <> T.pack (show (_blockHeight u, _blockHash u))
                         void $ _pactReadOnlyReplay chainPact l u
                         logCr Info "pact db synchronized"
-                mapConcurrently_ replayOneChain $
-                    HM.intersectionWith (,)
-                        pactSyncChains
-                        (HM.intersectionWith (,) (_cutMap lowerBoundCut) (_cutMap upperBoundCut))
+                let bounds =
+                        HM.intersectionWith (,)
+                            pactSyncChains
+                            (HM.mapWithKey
+                                (\cid bh ->
+                                    (bh, (HM.! cid) . _cutMap <$> upperBoundCut))
+                                (_cutMap lowerBoundCut)
+                            )
+                mapConcurrently_ replayOneChain bounds
                 logg Info "finished fast forward replay"
                 logFunctionJson logger Info PactReplaySuccessful
                 inner $ Replayed lowerBoundCut upperBoundCut
@@ -542,7 +544,7 @@ withChainwebInternal conf logger peer serviceSock rocksDb pactDbDir backupDir re
                 synchronizePactDb pactSyncChains newCut
                 logg Info "finished replaying Pact DBs to fast forward cut"
                 logFunctionJson logger Info PactReplaySuccessful
-                inner $ Replayed initialCut newCut
+                inner $ Replayed initialCut (Just newCut)
             else do
                 initialCut <- _cut mCutDb
                 logg Info "start synchronizing Pact DBs to initial cut"

src/Chainweb/Pact/PactService.hs

@@ -109,7 +109,6 @@ import Chainweb.Pact.Types
 import Chainweb.Pact.Validations
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
-import Chainweb.Storage.Table
 import Chainweb.Time
 import Chainweb.Transaction
 import Chainweb.TreeDB
@@ -640,22 +639,34 @@ execReadOnlyReplay
     :: forall logger tbl
     . (Logger logger, CanReadablePayloadCas tbl)
     => BlockHeader
-    -> BlockHeader
+    -> Maybe BlockHeader
     -> PactServiceM logger tbl ()
-execReadOnlyReplay lowerBound upperBound = pactLabel "execReadOnlyReplay" $ do
+execReadOnlyReplay lowerBound maybeUpperBound = pactLabel "execReadOnlyReplay" $ do
     ParentHeader cur <- findLatestValidBlockHeader
     logger <- view psLogger
     bhdb <- view psBlockHeaderDb
     pdb <- view psPdb
     v <- view chainwebVersion
     cid <- view chainId
     -- lower bound must be an ancestor of upper.
-    liftIO (ancestorOf bhdb (_blockHash lowerBound) (_blockHash upperBound)) >>=
-      flip unless (throwM $ PactInternalError "lower bound is not an ancestor of upper bound")
+    upperBound <- case maybeUpperBound of
+        Just upperBound -> do
+            liftIO (ancestorOf bhdb (_blockHash lowerBound) (_blockHash upperBound)) >>=
+                flip unless (throwM $ PactInternalError "lower bound is not an ancestor of upper bound")
+
+            -- upper bound must be an ancestor of latest header.
+            liftIO (ancestorOf bhdb (_blockHash upperBound) (_blockHash cur)) >>=
+                flip unless (throwM $ PactInternalError "upper bound is not an ancestor of latest header")
+
+            return upperBound
+        Nothing -> do
+            liftIO (ancestorOf bhdb (_blockHash lowerBound) (_blockHash cur)) >>=
+                flip unless (throwM $ PactInternalError "lower bound is not an ancestor of latest header")
 
-    -- upper bound must be an ancestor of latest header.
-    liftIO (ancestorOf bhdb (_blockHash upperBound) (_blockHash cur)) >>=
-      flip unless (throwM $ PactInternalError "upper bound is not an ancestor of latest header")
+            return cur
+    liftIO $ logFunctionText logger Info $ "pact db replaying between blocks "
+        <> sshow (_blockHeight lowerBound, _blockHash lowerBound) <> " and "
+        <> sshow (_blockHeight upperBound, _blockHash upperBound)
 
     let genHeight = genesisHeight v cid
     -- we don't want to replay the genesis header in here.
@@ -689,10 +700,9 @@ execReadOnlyReplay lowerBound upperBound = pactLabel "execReadOnlyReplay" $ do
                 printError e = throwM e
             handle printError $ runPact $ readFrom (Just $ ParentHeader bhParent) $ do
                 liftIO $ writeIORef heightRef (_blockHeight bh)
-                plData <- liftIO $ fromJuste <$> tableLookup
-                    (_transactionDb pdb)
-                    (_blockPayloadHash bh)
-                void $ execBlock bh (CheckablePayload plData)
+                payload <- liftIO $ fromJuste <$>
+                  lookupPayloadDataWithHeight pdb (Just $ _blockHeight bh) (_blockPayloadHash bh)
+                void $ execBlock bh (CheckablePayload payload)
             )
         validationFailed <- readIORef validationFailedRef
         when validationFailed $

src/Chainweb/Pact/Service/BlockValidation.hs

@@ -91,7 +91,7 @@ lookupPactTxs confDepth txs reqQ = do
 
 pactReadOnlyReplay
     :: BlockHeader
-    -> BlockHeader
+    -> Maybe BlockHeader
     -> PactQueue
     -> IO ()
 pactReadOnlyReplay l u reqQ = do

src/Chainweb/Pact/Service/Types.hs

@@ -442,7 +442,7 @@ instance Show HistoricalLookupReq where
 
 data ReadOnlyReplayReq = ReadOnlyReplayReq
     { _readOnlyReplayLowerBound :: !BlockHeader
-    , _readOnlyReplayUpperBound :: !BlockHeader
+    , _readOnlyReplayUpperBound :: !(Maybe BlockHeader)
     }
 instance Show ReadOnlyReplayReq where
   show (ReadOnlyReplayReq l u) =

src/Chainweb/WebPactExecutionService.hs

@@ -78,7 +78,7 @@ data PactExecutionService = PactExecutionService
         )
     , _pactReadOnlyReplay :: !(
         BlockHeader ->
-        BlockHeader ->
+        Maybe BlockHeader ->
         IO ()
       )
       -- ^ Lookup pact hashes as of a block header to detect duplicates

test/Chainweb/Test/MultiNode.hs

@@ -579,7 +579,7 @@ replayTest loglevel v n rdb pactDbDir step = do
                 & set (configCuts . cutInitialBlockHeightLimit) (Just replayInitialHeight)
                 & set configOnlySyncPact True)
             n (Seconds 20) rdb pactDbDir $ \nid cw -> case cw of
-                Replayed l u -> do
+                Replayed l (Just u) -> do
                     writeIORef firstReplayCompleteRef True
                     _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh ->
                         assertEqual ("lower chain " <> sshow cid) replayInitialHeight (_blockHeight bh)
@@ -589,6 +589,7 @@ replayTest loglevel v n rdb pactDbDir step = do
                     _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh ->
                         assertGe ("upper chain " <> sshow cid) (Actual $ _blockHeight bh) (Expected replayInitialHeight)
                     return ()
+                Replayed _ Nothing -> error "replayTest: no replay upper bound"
                 _ -> error "replayTest: not a replay"
         assertEqual "first replay completion" True =<< readIORef firstReplayCompleteRef
         let fastForwardHeight = 10
@@ -600,13 +601,15 @@ replayTest loglevel v n rdb pactDbDir step = do
                 & set (configCuts . cutFastForwardBlockHeightLimit) (Just fastForwardHeight)
                 & set configOnlySyncPact True)
             n (Seconds 20) rdb pactDbDir $ \_ cw -> case cw of
-                Replayed l u -> do
+                Replayed l (Just u) -> do
                     writeIORef secondReplayCompleteRef True
                     _ <- flip HM.traverseWithKey (_cutMap l) $ \cid bh ->
                         assertEqual ("lower chain " <> sshow cid) replayInitialHeight (_blockHeight bh)
                     _ <- flip HM.traverseWithKey (_cutMap u) $ \cid bh ->
                         assertEqual ("upper chain " <> sshow cid) fastForwardHeight (_blockHeight bh)
                     return ()
+                Replayed _ Nothing -> do
+                    error "replayTest: no replay upper bound"
                 _ -> error "replayTest: not a replay"
         assertEqual "second replay completion" True =<< readIORef secondReplayCompleteRef
         tastylog "done."