payloadprovider fork detection

src/Chainweb/Sync/WebBlockHeaderStore.hs

@@ -54,6 +54,7 @@ import Chainweb.MinerReward (blockMinerReward)
 import Chainweb.Payload
 import Chainweb.Payload.PayloadStore
 import Chainweb.PayloadProvider
+import Chainweb.Ranked
 import Chainweb.Storage.Table
 import Chainweb.Time
 import Chainweb.TreeDB
@@ -68,6 +69,7 @@ import Control.Monad
 import Control.Monad.Catch
 import Data.Foldable
 import Data.Hashable
+import Data.HashSet qualified as HS
 import Data.LogMessage
 import Data.PQueue
 import Data.TaskMap
@@ -81,6 +83,7 @@ import Servant.Client
 import System.LogLevel
 import Utils.Logging.Trace
 import Chainweb.Parent
+import Streaming.Prelude qualified as S
 
 -- -------------------------------------------------------------------------- --
 -- Response Timeout Constants
@@ -557,12 +560,34 @@ getBlockHeaderInternal
         case providers ^?! atChain cid of
             ConfiguredPayloadProvider provider -> do
                 r <- syncToBlock provider hints finfo `catch` \(e :: SomeException) -> do
-                    logg Warn $ taskMsg k $ "getBlockHeaderInternal payload validation for " <> sshow h <> " failed with :" <> sshow e
+                    logg Warn $ taskMsg k $ "getBlockHeaderInternal payload validation for " <> sshow h <> " failed with : " <> sshow e
                     throwM e
-                unless (r == _forkInfoTargetState finfo) $ do
-                    throwM $ GetBlockHeaderFailure $ "unexpected result state"
-                        <> "; expected: " <> sshow (_forkInfoTargetState finfo)
-                        <> "; actual: " <> sshow r
+                if r /= _forkInfoTargetState finfo
+                then do
+                    let ppBlock = _syncStateRankedBlockHash $ _consensusStateLatest r
+                    let targetBlock = _syncStateRankedBlockHash $ _consensusStateLatest $ _forkInfoTargetState finfo
+                    bhdb <- getWebBlockHeaderDb wdb cid
+                    let forkBlocksDescendingStream = getBranch bhdb
+                            (HS.singleton $ LowerBound (_ranked ppBlock))
+                            (HS.singleton $ UpperBound (_ranked targetBlock))
+                    forkBlocksAscending <- fmap reverse $ S.toList_ forkBlocksDescendingStream
+                    let newTrace =
+                            zipWith
+                                (\prent child ->
+                                    ConsensusPayload (view blockPayloadHash child) Nothing <$
+                                        blockHeaderToEvaluationCtx (Parent prent))
+                                forkBlocksAscending
+                                (tail forkBlocksAscending)
+                    let newForkInfo = finfo { _forkInfoTrace = newTrace }
+                    r' <- syncToBlock provider hints newForkInfo `catch` \(e :: SomeException) -> do
+                        logg Warn $ taskMsg k $ "getBlockHeaderInternal payload validation retry for " <> sshow h <> " failed with: " <> sshow e
+                        throwM e
+                    unless (r' == _forkInfoTargetState finfo) $ do
+                        throwM $ GetBlockHeaderFailure $ "unexpected result state"
+                            <> "; expected: " <> sshow (_forkInfoTargetState finfo)
+                            <> "; actual: " <> sshow r
+                else
+                    return ()
             DisabledPayloadProvider -> do
                 logg Debug $ taskMsg k $ "getBlockHeaderInternal payload provider disabled"
 

src/Chainweb/TreeDB.hs

@@ -523,15 +523,17 @@ getBranch
     -> HS.HashSet (UpperBound (DbKey db))
     -> S.Stream (Of (DbEntry db)) IO ()
 getBranch db lowerBounds upperBounds = do
-    lowers <- getEntriesHs $ HS.map _getLowerBound lowerBounds
-    uppers <- getEntriesHs $ HS.map _getUpperBound upperBounds
+    lowers <- liftIO $ getEntriesHs _getLowerBound lowerBounds
+    uppers <- liftIO $ getEntriesHs _getUpperBound upperBounds
 
-    let mar = L.maximum $ HS.map rank (lowers <> uppers)
+    let mar = getMax $ fromJuste $
+            foldMap' (foldMap' (Just . Max . rank)) [lowers, uppers]
 
     go mar (active mar lowers mempty) (active mar uppers mempty)
   where
-    getEntriesHs = lift . streamToHashSet_ . lookupStream db . S.each
-    getParentsHs = lift . streamToHashSet_ . lookupParentStreamM GenesisParentNone db . S.each
+    getEntriesHs :: (a -> Key (DbEntry db)) -> HS.HashSet a -> IO (HS.HashSet (DbEntry db))
+    getEntriesHs f = streamToHashSet_ . lookupStream db . S.map f . S.each
+    getParentsHs = streamToHashSet_ . lookupParentStreamM GenesisParentNone db . S.each
 
     -- prop> all ((==) r . rank) $ snd (active r s c)
     --
@@ -557,8 +559,8 @@ getBranch db lowerBounds upperBounds = do
         | otherwise = do
             let us1' = us1 `HS.difference` ls1
             mapM_ S.yield us1'
-            us1p <- getParentsHs us1'
-            ls1p <- getParentsHs ls1
+            us1p <- liftIO $ getParentsHs us1'
+            ls1p <- liftIO $ getParentsHs ls1
             let r' = pred r
             go r' (active r' ls0 ls1p) (active r' us0 us1p)