Address issues from code review

Author: larskuhtz

src/Chainweb/CutDB.hs

@@ -530,7 +530,6 @@ synchronizeProviders logger wbh providers c = do
                 pLog Warn $ "resolveFork for failed"
                     <> "; finfo: " <> encodeToText finfo
                     <> "; failure: " <> sshow e
-                -- pLog Error "It is recommend using --initial-block-height-limit to recover from fork manually."
                 empty
             pLog Info $ "payload provider synced to "
                 <> sshow (view blockHeight hdr)
@@ -707,17 +706,21 @@ processCuts conf logFun headerStore providers cutHashesStore queue cutVar cutPru
                                 -- During this final sync we also enable payload production.
                                 finfo <- forkInfoForHeader hdrStore bh Nothing Nothing True
 
-                                -- Note, that this really should be super quick and
+                                -- Note, that this sync really should be super quick and
                                 -- should never fail.
-                                --
-                                -- FIXME: Can't we go to the merge cut directly?
-                                -- FIXME: we could we trigger this with only a
-                                -- single node in the system?
+                                -- TODO: It would be nicer to go to the merge cut directly.
                                 clog Info "Syncing paylooad provider with merged cut"
                                 resolveForkInfo clog (hdrStore ^?! ixg cid) NullCas provider Nothing finfo `catch`
-                                    -- FIXME calling error is not OK!
-                                    \(e :: SomeException) -> error
-                                        $ "Failed to sync to merge cut (on chain " <> sshow cid <> "): " <> sshow e
+                                    \(e :: SomeException) -> do
+                                        clog Error
+                                            $ "Failed to sync payload provider to the merge cut."
+                                            <> " This should never happen. It may indicated a broken payload provider or a corrupted database."
+                                            <> " Fork info: " <> encodeToText finfo
+                                            <> " Failure: " <> sshow e
+                                        throwM $ InternalInvariantViolation
+                                            $ "Failed to sync payload provider to the merge cut."
+                                            <> " This should never happen. It may indicated a broken payload provider or a corrupted database."
+                                            <> " Failure: " <> sshow e
                             _ -> return ()
                 let cutDiff = cutDiffToTextShort curCut resultCut
                 let currentCutIdMsg = T.unwords

src/Chainweb/Pact/PactService.hs

@@ -540,11 +540,7 @@ syncToFork logger serviceEnv hints forkInfo = do
             Checkpointer.setConsensusState sql forkInfo._forkInfoTargetState
             return (mempty, mempty, forkInfo._forkInfoTargetState)
           else do
-            -- check if some past block had the target as its parent; if so, that
-            -- means we can rewind to it
-            --
-            -- FIXME: why the parent? Why not the block itself?
-            --
+            -- check if the target is in our history
             latestBlockRewindable <-
                 isJust <$> Checkpointer.lookupBlockHash sql (_latestBlockHash forkInfo._forkInfoTargetState)
 
@@ -558,18 +554,11 @@ syncToFork logger serviceEnv hints forkInfo = do
                 Checkpointer.setConsensusState sql forkInfo._forkInfoTargetState
                 return (rewoundTxs, mempty, forkInfo._forkInfoTargetState)
               else do
-                let traceBlockHashesAscending =
+                let traceBlockHashesAscending = _forkInfoTraceBlockHashes forkInfo
 
-                        -- Why do we drop the first entry? That seems fishy.
-                        drop 1 (unwrapParent . _evaluationCtxRankedParentHash <$> forkInfo._forkInfoTrace) <>
-                        [_syncStateRankedBlockHash forkInfo._forkInfoTargetState._consensusStateLatest]
-
-                -- FIXME: we sometimes get stuck in a loop with a fork into trace
-                -- that is too short, i.e. the forkpoint is too far ahead.
-
-                logFunctionText logger Debug $ "playing blocks"
+                logFunctionText logger Debug $ "playing blocks from fork info trace"
                     <> "; from: " <> brief pactConsensusState
-                    <> "; target: " <> brief forkInfo._forkInfoTargetState
+                    <> "; target: " <> brief (_forkInfoTargetState forkInfo)
                     <> "; trace: " <> brief traceBlockHashesAscending
 
                 findForkChainAscending (reverse $ zip forkInfo._forkInfoTrace traceBlockHashesAscending) >>= \case
@@ -595,7 +584,9 @@ syncToFork logger serviceEnv hints forkInfo = do
 
                         let unknownPayloads = NEL.filter (isNothing . snd) knownPayloads
                         unless (null unknownPayloads)
-                            $ logFunctionText logger Debug $ "unknown blocks in context: " <> sshow (length unknownPayloads)
+                            $ logFunctionText logger Debug $ "unknown blocks in context"
+                                <> "; count: " <> sshow (length unknownPayloads)
+                                <> "; hashes: " <> brief (snd . fst <$> unknownPayloads)
 
                         runnableBlocks <- forM knownPayloads $ \((evalCtx, rankedBHash), maybePayload) -> do
                             logFunctionText logger Debug $ "running block: " <> brief rankedBHash

src/Chainweb/PayloadProvider/EVM.hs

@@ -24,6 +24,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wprepositive-qualified-module #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 
 -- |
 -- Module: Chainweb.PayloadProvider.EVM
@@ -112,6 +113,7 @@ import Network.URI.Static
 import P2P.Session (ClientEnv)
 import P2P.TaskQueue
 import System.LogLevel
+import Servant.Client (ClientM)
 
 -- -------------------------------------------------------------------------- --
 -- Payload Database
@@ -525,16 +527,7 @@ withEvmPayloadProvider logger c rdb mgr conf
         SomeChainIdT @c _ <- return $ someChainIdVal c
 
         let pldCli = Rest.payloadClient @v @c @p
-
-        -- FIXME move the following two definitions elsewhere
-        let payloadRankedPayloadHash pld = RankedBlockPayloadHash
-                { _rankedBlockPayloadHashHeight = int $ EVM._hdrNumber $ _payloadHeader pld
-                , _rankedBlockPayloadHashHash = EVM._hdrPayloadHash $ _payloadHeader pld
-                }
-        let pldCliBatch rhs = do
-                rs <- _payloadList <$> Rest.payloadBatchClient @v @c @p rhs
-                let rs' = HM.fromList $ (\pld -> (payloadRankedPayloadHash pld, pld)) <$> rs
-                return $ (`HM.lookup` rs') <$> rhs
+        let pldCliBatch = mkPayloadBatchClient @v @c
 
         genPld <- liftIO $ checkExecutionClient logger c engineCtx (EVM.ChainId (fromSNat ecid))
         liftIO $ logFunctionText logger Info $ "genesis payload block hash: " <> sshow (EVM._hdrPayloadHash genPld)
@@ -571,6 +564,17 @@ withEvmPayloadProvider logger c rdb mgr conf
   where
     pldStoreLogger = addLabel ("sub-component", "payloadStore") logger
 
+mkPayloadBatchClient
+    :: forall (v :: ChainwebVersionT) (c :: ChainIdT)
+    . KnownChainwebVersionSymbol v
+    => KnownChainIdSymbol c
+    => [RankedBlockPayloadHash]
+    -> ClientM [Maybe Payload]
+mkPayloadBatchClient rhs = do
+    rs <- _payloadList <$> Rest.payloadBatchClient @v @c @(EvmProvider _) rhs
+    let rs' = HM.fromList $ (\pld -> (_pldRankedBlockPayloadHash pld, pld)) <$> rs
+    return $ (`HM.lookup` rs') <$> rhs
+
 -- | Checks the availability of the Execution Client
 --
 -- - asserts API availability

src/Chainweb/PayloadProvider/P2P.hs

@@ -117,6 +117,14 @@ data PayloadStore tbl a = PayloadStore
         -- could make it easier to limit concurrency across chains. If this is
         -- needed the ChainId parameter would have to be re-added.
     , _payloadStoreGetPayloadBatchClient :: !([RankedBlockPayloadHash] -> ClientM [Maybe a])
+        -- ^ HTTP client for querying payloads in batches (provided by the
+        -- PayloadProvider)
+        --
+        -- There is a default Payload REST API in
+        -- "Chainweb.PayloadProvider.P2P.RestAPI" that can be used in common
+        -- cases.
+        --
+        -- The same considerations apply as for '_payloadStoreGetPayloadClient'.
     }
 
 -- FIXME: not sure whether the following instances are a good idea...

src/Chainweb/Sync/ForkInfo.hs

@@ -209,6 +209,17 @@ resolveForkInfoForProviderState logg bhdb candidateHdrs provider hints finfo ppS
                 -- error.
 
                 (forkBlocksDescendingStream S.:> forkPoint) <- S.toList
+
+                    -- Note that this assumes that the parent of hdr is in the
+                    -- block header DB. With the current cut pipeline that is
+                    -- always the case, because we never validate a header for
+                    -- which the parent hasn't already been validated. In case
+                    -- that this changes in the future we need to adjust the
+                    -- branch diff to start from parent of the lowest processed
+                    -- block. That block would certainly be on the canonical
+                    -- chain, since we wouldn't validate block that aren't
+                    -- extending the current head.
+                    --
                     $ branchDiff_ bhdb ppBlock hdr
 
                 let forkBlocksAscending = reverse

src/P2P/TaskQueue.hs

@@ -204,8 +204,10 @@ session_ limit q logFun env = E.mask $ \restore -> do
                 return False
             | otherwise -> do
                 logg task' Warn
-                    $ "task finally failed with: " <> sshow e <> " after " <> sshow attempts <> " attempts, limit: "
-                    <> sshow limit
+                    $ "task finally failed"
+                    <> "; attempts: " <> sshow attempts
+                    <> "; limit: " <> sshow limit
+                    <> "; failure: " <> sshow e
                 putResult (_taskResult task') $! Left $! _taskFailures task'
 
     logg task l m = logFun @T.Text l $ sshow (_taskId task) <> ": " <> m