Stub StakePoolLayer with listStakePools

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

@@ -18,6 +18,11 @@ module Cardano.Pool.Metrics
     , combineMetrics
     , ErrMetricsInconsistency (..)
 
+    -- * StakePoolLayer
+    , StakePoolLayer (..)
+    , newStakePoolLayer
+    , ErrListStakePools (..)
+
     -- * Helper
     , withinSameTip
     , ErrWithinSameTip (..)
@@ -29,20 +34,30 @@ module Cardano.Pool.Metrics
 
 import Prelude
 
+import Cardano.Pool.DB
+    ( DBLayer (..) )
+import Cardano.Wallet.DB
+    ()
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..), EpochNo (..), PoolId (..), SlotId (..) )
+import Control.Exception
+    ( Exception, throwIO )
 import Control.Monad.IO.Class
-    ( MonadIO )
+    ( MonadIO, liftIO )
+import Control.Monad.Trans.Except
+    ( ExceptT )
 import Control.Retry
     ( RetryPolicyM, retrying )
 import Data.Either
     ( isLeft )
+import Data.Generics.Internal.VL.Lens
+    ( (^.) )
 import Data.Map.Merge.Strict
     ( WhenMatched, WhenMissing, mergeA, traverseMissing, zipWithMatched )
 import Data.Map.Strict
     ( Map )
 import Data.Quantity
-    ( Quantity (..) )
+    ( Percentage, Quantity (..) )
 import Data.Word
     ( Word64 )
 import Fmt
@@ -64,12 +79,49 @@ activityForEpoch epoch s =
   where
     slotInCurrentEpoch = ((epoch ==) . epochNumber)
 
+--------------------------------------------------------------------------------
+-- StakePoolLayer
+--------------------------------------------------------------------------------
+
+newtype ErrListStakePools
+     = ErrListStakePoolsMetricsIsUnsynced (Quantity "percent" Percentage)
+
+-- | @StakePoolLayer@ is a thin layer ontop of the DB. It is /one/ value that
+-- can easily be passed to the API-server, where it can be used in a simple way.
+newtype StakePoolLayer m = StakePoolLayer
+      { listStakePools
+          :: ExceptT ErrListStakePools m
+             [(PoolId, (Quantity "lovelace" Word64, Quantity "block" Natural))]
+      }
+
+newStakePoolLayer
+     :: DBLayer IO
+     -> IO (StakePoolLayer IO)
+newStakePoolLayer db = do
+     return $ StakePoolLayer
+        { listStakePools = do
+            cursor <- liftIO $ readCursor db 1
+            case cursor of
+                [dbTip] -> do
+                    let epochNo = dbTip ^. #slotId ^. #epochNumber
+                    distr <- liftIO $ Map.fromList <$> readStakeDistribution db epochNo
+                    prod <- liftIO $ convert <$> readPoolProduction db epochNo
+                    case combineMetrics distr prod of
+                        Right x -> return $ Map.toList x
+                        Left e -> liftIO $ throwIO e
+                _ -> return []
+        }
+  where
+    convert = Map.map (Quantity . fromIntegral . length)
+
 data ErrMetricsInconsistency
     = ErrMetricsInconsistencyBlockProducerNotInStakeDistr
         PoolId
         (Quantity "block" Natural)
     deriving (Show, Eq)
 
+instance Exception ErrMetricsInconsistency
+
 -- | Combines two different sources of data into one:
 --
 -- 1. A stake-distribution map