Try #1168:

lib/core/src/Cardano/Pool/Metrics.hs

@@ -89,10 +89,12 @@ import Control.Monad.Trans.Except
     ( ExceptT (..), mapExceptT, runExceptT, throwE, withExceptT )
 import Control.Tracer
     ( contramap )
+import Data.Function
+    ( on )
 import Data.Generics.Internal.VL.Lens
     ( view, (^.) )
 import Data.List
-    ( foldl', nub, nubBy, sortOn )
+    ( foldl', maximumBy, nub, nubBy, sortOn )
 import Data.List.NonEmpty
     ( NonEmpty )
 import Data.Map.Merge.Strict
@@ -274,20 +276,24 @@ newStakePoolLayer db@DBLayer{..} nl tr = StakePoolLayer
 
         (distr, prod) <- liftIO . atomically $ (,)
             <$> (Map.fromList <$> readStakeDistribution nodeEpoch)
-            <*> (count <$> readPoolProduction nodeEpoch)
+            <*> readPoolProduction nodeEpoch
+
+        let prodTip = maximumBy (compare `on` view #slotId)
+                $ mconcat (Map.elems prod)
 
         when (Map.null distr || Map.null prod) $ do
-            computeProgress nodeTip >>= throwE . ErrMetricsIsUnsynced
+            liftIO $ logTrace tr $ MsgComputedProgress prodTip nodeTip
+            throwE $ ErrMetricsIsUnsynced $ computeProgress prodTip nodeTip
 
         if nodeEpoch == genesisEpoch
         then do
             seed <- liftIO $ atomically readSystemSeed
-            combineWith (sortArbitrarily seed) distr prod mempty
+            combineWith (sortArbitrarily seed) distr (count prod) mempty
 
         else do
-            let tip = nodeTip ^. #slotId
-            perfs <- liftIO $ readPoolsPerformances db epochLength tip
-            combineWith (pure . sortByPerformance) distr prod perfs
+            let sl = prodTip ^. #slotId
+            perfs <- liftIO $ readPoolsPerformances db epochLength sl
+            combineWith (pure . sortByPerformance) distr (count prod) perfs
 
     -- For each pool, look up its metadata. If metadata could not be found for a
     -- pool, the result will be 'Nothing'.
@@ -327,11 +333,6 @@ newStakePoolLayer db@DBLayer{..} nl tr = StakePoolLayer
             Left e ->
                 throwE $ ErrListStakePoolsMetricsInconsistency e
 
-    poolProductionTip :: IO (Maybe BlockHeader)
-    poolProductionTip = atomically $ readPoolProductionCursor 1 >>= \case
-        [x] -> return $ Just x
-        _ -> return Nothing
-
     sortByPerformance :: [StakePool] -> [StakePool]
     sortByPerformance = sortOn (Down . apparentPerformance)
 
@@ -349,20 +350,16 @@ newStakePoolLayer db@DBLayer{..} nl tr = StakePoolLayer
         StakePool{poolId,stake,production,apparentPerformance}
 
     computeProgress
-        :: BlockHeader -- ^ The node tip, which respresents 100%.
-        -> ExceptT e IO (Quantity "percent" Percentage)
-    computeProgress nodeTip = liftIO $ do
-        mDbTip <- poolProductionTip
-        logTrace tr $ MsgComputedProgress mDbTip nodeTip
-        pure $ Quantity $ maybe minBound (`progress` nodeTip) mDbTip
-
-    progress :: BlockHeader -> BlockHeader -> Percentage
-    progress tip target =
-        let
-            s0 = getQuantity $ tip ^. #blockHeight
-            s1 = getQuantity $ target ^. #blockHeight
-        in toEnum $ round $ 100 * (toD s0) / (toD s1)
+        :: BlockHeader -- ^ ... / denominator
+        -> BlockHeader -- ^ numerator /...
+        -> Quantity "percent" Percentage
+    computeProgress prodTip nodeTip =
+        Quantity $ if s1 == 0
+            then minBound
+            else toEnum $ round $ 100 * (toD s0) / (toD s1)
       where
+        s0 = getQuantity $ prodTip ^. #blockHeight
+        s1 = getQuantity $ nodeTip ^. #blockHeight
         toD :: Integral i => i -> Double
         toD = fromIntegral
 
@@ -583,7 +580,7 @@ data StakePoolLayerMsg
     | MsgMetadataUsing PoolId PoolOwner StakePoolMetadata
     | MsgMetadataMissing PoolId
     | MsgMetadataMultiple PoolId [(PoolOwner, StakePoolMetadata)]
-    | MsgComputedProgress (Maybe BlockHeader) BlockHeader
+    | MsgComputedProgress BlockHeader BlockHeader
     deriving (Show, Eq)
 
 instance DefinePrivacyAnnotation StakePoolLayerMsg
@@ -602,14 +599,13 @@ instance ToText StakePoolLayerMsg where
         MsgRegistry msg -> toText msg
         MsgListStakePoolsBegin -> "Listing stake pools"
         MsgMetadataUnavailable -> "Stake pool metadata is unavailable"
-        MsgComputedProgress (Just dbTip) nodeTip -> mconcat
+        MsgComputedProgress prodTip nodeTip -> mconcat
             [ "The node tip is:\n"
             , pretty nodeTip
             , ",\nbut the last pool production stored in the db"
             , " is from:\n"
-            , pretty dbTip
+            , pretty prodTip
             ]
-        MsgComputedProgress Nothing _nodeTip -> ""
         MsgMetadataUsing pid owner _ ->
             "Using stake pool metadata from " <>
             toText owner <> " for " <> toText pid