Fix incorrect apparent_performance calculation

For the parameter
>  S - total number of slots in the epoch
we used to sum the total block productions in our `Map PoolId nOfBlocks` map.

This is wrong as empty slots are not represented in the map of block
productions. Summing the map gives us the number of /blocks/ in the
epoch, not number of /slots/.

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

@@ -51,7 +51,13 @@ import Cardano.Wallet.Network
     , staticBlockchainParameters
     )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader (..), EpochNo (..), PoolId (..), SlotId (..) )
+    ( BlockHeader (..)
+    , EpochLength (..)
+    , EpochNo (..)
+    , PoolId (..)
+    , SlotId (..)
+    , SlotNo (unSlotNo)
+    )
 import Control.Monad
     ( forM, forM_, when )
 import Control.Monad.IO.Class
@@ -214,7 +220,7 @@ newStakePoolLayer db@DBLayer{..} nl tr = StakePoolLayer
             computeProgress nodeTip >>= throwE . ErrMetricsIsUnsynced
 
         perfs <- liftIO $
-            readPoolsPerformances db nodeEpoch
+            readPoolsPerformances db epochLength (nodeTip ^. #slotId)
 
         case combineMetrics distr prod perfs of
             Right x -> return
@@ -229,6 +235,10 @@ newStakePoolLayer db@DBLayer{..} nl tr = StakePoolLayer
         [x] -> return $ Just x
         _ -> return Nothing
 
+
+    (_, bp) = staticBlockchainParameters nl
+    epochLength = bp ^. #getEpochLength
+
     mkStakePool
         :: PoolId
         -> ( Quantity "lovelace" Word64
@@ -268,14 +278,24 @@ newStakePoolLayer db@DBLayer{..} nl tr = StakePoolLayer
 
 readPoolsPerformances
     :: DBLayer m
-    -> EpochNo
+    -> EpochLength
+    -> SlotId
     -> m (Map PoolId Double)
-readPoolsPerformances DBLayer{..} (EpochNo epochNo) = do
-    let range = [max 0 (fromIntegral epochNo - 14) .. fromIntegral epochNo]
+readPoolsPerformances DBLayer{..} (EpochLength el) tip = do
+    let range = [max 0 (currentEpoch - 14) .. currentEpoch]
     atomically $ fmap avg $ forM range $ \ep -> calculatePerformance
+        (slotsInEpoch ep)
         <$> (Map.fromList <$> readStakeDistribution ep)
         <*> (count <$> readPoolProduction ep)
   where
+    currentEpoch = tip ^. #epochNumber
+
+    slotsInEpoch :: EpochNo -> Int
+    slotsInEpoch e =
+        if e == currentEpoch
+        then fromIntegral $ unSlotNo $ tip ^. #slotNumber
+        else fromIntegral el
+
     -- | Performances are computed over many epochs to cope with the fact that
     -- our data is sparse (regarding stake distribution at least).
     --
@@ -305,23 +325,24 @@ readPoolsPerformances DBLayer{..} (EpochNo epochNo) = do
 -- practice, be greater than 1 if a stake pool produces more than it is
 -- expected.
 calculatePerformance
-    :: Map PoolId (Quantity "lovelace" Word64)
+    :: Int
+    -> Map PoolId (Quantity "lovelace" Word64)
     -> Map PoolId (Quantity "block" Word64)
     -> Map PoolId Double
-calculatePerformance mStake mProd =
+calculatePerformance nTotal mStake mProd =
     let
         stakeButNotProd = traverseMissing $ \_ _ -> 0
         prodButNoStake  = dropMissing
-        stakeAndProd sTotal nTotal = zipWithMatched $ \_ s n ->
+        stakeAndProd sTotal = zipWithMatched $ \_ s n ->
             if (nTotal == 0 || s == Quantity 0) then
                 0
             else
-                min 1 ((double n / nTotal) * (sTotal / double s))
+                min 1 ((double n / fromIntegral nTotal) * (sTotal / double s))
     in
         Map.merge
             stakeButNotProd
             prodButNoStake
-            (stakeAndProd (sumQ mStake) (sumQ mProd))
+            (stakeAndProd (sumQ mStake))
             mStake
             mProd
   where

lib/core/test/unit/Cardano/Pool/MetricsSpec.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -14,6 +16,7 @@ import Cardano.Pool.Metrics
     ( Block (..), calculatePerformance, combineMetrics )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
+    , Coin (..)
     , EpochLength (..)
     , Hash (..)
     , PoolId (..)
@@ -33,12 +36,16 @@ import Test.Hspec
     ( Spec, describe, it, shouldBe )
 import Test.QuickCheck
     ( Arbitrary (..)
+    , NonNegative (..)
     , Property
+    , Small (..)
     , checkCoverage
+    , choose
     , classify
     , counterexample
     , cover
     , elements
+    , frequency
     , property
     , vectorOf
     , (===)
@@ -63,13 +70,13 @@ spec = do
         it "performances are always between 0 and 1"
             $ property prop_performancesBounded01
         it "50% stake, producing 4/8 blocks => performance=1" $ do
-           let p = calculatePerformance stake (productions 4)
+           let p = calculatePerformance 8 stake (productions 4)
            Map.lookup pool p `shouldBe` (Just 1)
         it "50% stake, producing 2/8 blocks => performance=0.5" $ do
-           let p = calculatePerformance stake (productions 2)
+           let p = calculatePerformance 8 stake (productions 2)
            Map.lookup pool p `shouldBe` (Just 0.5)
         it "50% stake, producing 0/8 blocks => performance=0" $ do
-           let p = calculatePerformance stake (productions 0)
+           let p = calculatePerformance 8 stake (productions 0)
            Map.lookup pool p `shouldBe` (Just 0)
   where
     pool = PoolId "athena"
@@ -123,14 +130,19 @@ prop_combineIsLeftBiased mStake mProd mPerf =
 prop_performancesBounded01
     :: Map PoolId (Quantity "lovelace" Word64)
     -> Map PoolId (Quantity "block" Word64)
+    -> (NonNegative Int)
     -> Property
-prop_performancesBounded01 mStake mProd =
+prop_performancesBounded01 mStake mProd (NonNegative emptySlots) =
     all (between 0 1) performances
     & counterexample (show performances)
     & classify (all (== 0) performances) "all null"
   where
     performances :: [Double]
-    performances = Map.elems $ calculatePerformance mStake mProd
+    performances = Map.elems $ calculatePerformance slots mStake mProd
+
+    slots :: Int
+    slots = emptySlots +
+        fromIntegral (Map.foldl (\y (Quantity x) -> (y + x)) 0 mProd)
 
     between :: Ord a => a -> a -> a -> Bool
     between inf sup x = x >= inf && x <= sup
@@ -164,11 +176,24 @@ instance Arbitrary Block where
      arbitrary = genericArbitrary
      shrink = genericShrink
 
-instance Arbitrary (Quantity "block" Word32) where
-     arbitrary = Quantity . fromIntegral <$> (arbitrary @Word32)
-
-instance Arbitrary (Quantity any Word64) where
-     arbitrary = Quantity . fromIntegral <$> (arbitrary @Word64)
+deriving via Word32 instance (Arbitrary (Quantity "block" Word32))
+deriving via (Small (Word64)) instance (Arbitrary (Quantity "block" Word64))
+deriving via Lovelace instance (Arbitrary (Quantity "lovelace" Word64))
+
+-- TODO: Move to a shared location for Arbitrary newtypes
+newtype Lovelace = Lovelace Word64
+instance Arbitrary Lovelace where
+    shrink (Lovelace x) = map Lovelace $ shrink x
+    arbitrary = do
+        n <- choose (0, 100)
+        Lovelace <$> frequency
+            [ (50, return n)
+            , (25, return $ minLovelace - n)
+            , (25, choose (minLovelace, maxLovelace))
+            ]
+      where
+        minLovelace = fromIntegral . getCoin $ minBound @Coin
+        maxLovelace = fromIntegral . getCoin $ maxBound @Coin
 
 instance Arbitrary PoolId where
     shrink _  = []