Extract pool stats

Author: kderme

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/EpochUpdate.hs

@@ -10,6 +10,7 @@ import Cardano.DbSync.Era.Shelley.Generic.ProtoParams
 import Cardano.DbSync.Types
 import Cardano.DbSync.Util
 import qualified Cardano.Ledger.BaseTypes as Ledger
+import Cardano.Ledger.Coin (Coin)
 import Cardano.Ledger.Conway.Governance
 import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley
 import Cardano.Prelude hiding (Maybe (..), fromMaybe)
@@ -31,6 +32,7 @@ data NewEpoch = NewEpoch
   , neEpochUpdate :: !EpochUpdate
   , neDRepState :: !(Maybe (DRepPulsingState StandardConway))
   , neEnacted :: !(Maybe (ConwayGovState StandardConway))
+  , nePoolDistr :: !(Maybe (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural))
   }
 
 data EpochUpdate = EpochUpdate

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs

@@ -14,6 +14,7 @@ module Cardano.DbSync.Era.Shelley.Generic.StakeDist (
   StakeSlice (..),
   getSecurityParameter,
   getStakeSlice,
+  getPoolDistr,
 ) where
 
 import Cardano.DbSync.Types
@@ -24,11 +25,13 @@ import qualified Cardano.Ledger.EpochBoundary as Ledger
 import Cardano.Ledger.Era (EraCrypto)
 import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
+import Cardano.Ledger.Val ((<+>))
 import Cardano.Prelude
 import qualified Data.Map.Strict as Map
 import Data.VMap (VB, VMap (..), VP)
 import qualified Data.VMap as VMap
 import qualified Data.Vector.Generic as VG
+import Lens.Micro
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto)
 import Ouroboros.Consensus.Config
@@ -172,3 +175,46 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration
           VMap.toMap $
             VMap.mapMaybe id $
               VMap.mapWithKey (\a p -> (,p) <$> lookupStake a) delegationsSliced
+
+getPoolDistr ::
+  ExtLedgerState CardanoBlock ->
+  Maybe (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural)
+getPoolDistr els =
+  case ledgerState els of
+    LedgerStateByron _ -> Nothing
+    LedgerStateShelley sls -> Just $ genericPoolDistr sls
+    LedgerStateAllegra als -> Just $ genericPoolDistr als
+    LedgerStateMary mls -> Just $ genericPoolDistr mls
+    LedgerStateAlonzo als -> Just $ genericPoolDistr als
+    LedgerStateBabbage bls -> Just $ genericPoolDistr bls
+    LedgerStateConway cls -> Just $ genericPoolDistr cls
+
+genericPoolDistr ::
+  forall era p.
+  (EraCrypto era ~ StandardCrypto) =>
+  LedgerState (ShelleyBlock p era) ->
+  (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural)
+genericPoolDistr lstate =
+  (stakePerPool, blocksPerPool)
+  where
+    nes :: Shelley.NewEpochState era
+    nes = Consensus.shelleyLedgerState lstate
+
+    stakeMark :: Ledger.SnapShot StandardCrypto
+    stakeMark = Ledger.ssStakeMark $ Shelley.esSnapshots $ Shelley.nesEs nes
+
+    stakePerPool = countStakePerPool (Ledger.ssDelegations stakeMark) (Ledger.ssStake stakeMark)
+    blocksPerPool = nes ^. Shelley.nesBprevL
+
+countStakePerPool ::
+  VMap VB VB StakeCred PoolKeyHash ->
+  Ledger.Stake StandardCrypto ->
+  Map PoolKeyHash (Coin, Word64)
+countStakePerPool delegs (Ledger.Stake stake) = VMap.foldlWithKey accum Map.empty stake
+  where
+    accum !acc cred compactCoin =
+      case VMap.lookup cred delegs of
+        Nothing -> acc
+        Just kh -> Map.insertWith addDel kh (Ledger.fromCompact compactCoin, 1) acc
+
+    addDel (c, n) (c', _) = (c <+> c', n + 1)

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Types.hs

@@ -17,6 +17,7 @@ module Cardano.DbSync.Era.Shelley.Generic.Tx.Types (
   TxScript (..),
   PlutusData (..),
   TxOutDatum (..),
+  PoolStats (..),
   DBScriptPurpose (..),
   DBPlutusScript (..),
   toTxCert,
@@ -143,6 +144,13 @@ data PlutusData = PlutusData
 
 data TxOutDatum = InlineDatum PlutusData | DatumHash DataHash | NoDatum
 
+data PoolStats = PoolStats
+  { nBlocks :: Maybe Natural
+  , nDelegators :: Maybe Word64
+  , stake :: Maybe Coin
+  , votingPower :: Maybe Coin
+  }
+
 toTxCert :: Word16 -> Cert -> TxCertificate
 toTxCert idx dcert =
   TxCertificate

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -34,15 +35,17 @@ import Cardano.DbSync.Era.Universal.Insert.Other (toDouble)
 import Cardano.DbSync.Error
 import Cardano.DbSync.Ledger.Event
 import Cardano.DbSync.Types
-import Cardano.DbSync.Util (whenStrictJust)
+import Cardano.DbSync.Util (whenDefault, whenStrictJust, whenStrictJustDefault)
 import Cardano.DbSync.Util.Constraint (constraintNameEpochStake, constraintNameReward)
 import Cardano.Ledger.Address (RewardAccount (..))
 import Cardano.Ledger.BaseTypes (Network, unEpochInterval)
 import qualified Cardano.Ledger.BaseTypes as Ledger
 import Cardano.Ledger.Binary.Version (getVersion)
 import qualified Cardano.Ledger.Coin as Shelley
+import Cardano.Ledger.Compactible
 import Cardano.Ledger.Conway.Core (PoolVotingThresholds (..))
 import Cardano.Ledger.Conway.Governance (finishDRepPulser)
+import qualified Cardano.Ledger.Conway.Governance.DRepPulser as Ledger
 import Cardano.Ledger.Conway.PParams (DRepVotingThresholds (..))
 import Cardano.Ledger.Conway.Rules (RatifyState (..))
 import Cardano.Prelude
@@ -73,18 +76,37 @@ insertOnNewEpoch tracer cache iopts blkId slotNo epochNo newEpoch = do
     lift $ insertEpochParam tracer blkId epochNo params (Generic.euNonce epochUpdate)
   whenStrictJust (Generic.neAdaPots newEpoch) $ \pots ->
     insertPots blkId slotNo epochNo pots
-  whenStrictJust (Generic.neDRepState newEpoch) $ \dreps -> when (ioGov iopts) $ do
+  spoVoting <- whenStrictJustDefault Map.empty (Generic.neDRepState newEpoch) $ \dreps -> whenDefault Map.empty (ioGov iopts) $ do
     let (drepSnapshot, ratifyState) = finishDRepPulser dreps
     lift $ insertDrepDistr epochNo drepSnapshot
     updateRatified cache epochNo (toList $ rsEnacted ratifyState)
     updateExpired cache epochNo (toList $ rsExpired ratifyState)
+    pure (Ledger.psPoolDistr drepSnapshot)
   whenStrictJust (Generic.neEnacted newEpoch) $ \enactedSt -> do
     when (ioGov iopts) $ do
       insertUpdateEnacted tracer cache blkId epochNo enactedSt
+  whenStrictJust (Generic.nePoolDistr newEpoch) $ \(poolDistrDeleg, poolDistrNBlocks) -> do
+    let nothingMap = Map.fromList $ (,Nothing) <$> (Map.keys poolDistrNBlocks <> Map.keys spoVoting)
+    let mapWithAllKeys = Map.union (Map.map Just poolDistrDeleg) nothingMap
+    let _ = Map.mapWithKey (mkPoolStats poolDistrNBlocks spoVoting) mapWithAllKeys
+    pure ()
   where
     epochUpdate :: Generic.EpochUpdate
     epochUpdate = Generic.neEpochUpdate newEpoch
 
+    mkPoolStats :: Map PoolKeyHash Natural -> Map PoolKeyHash (Shelley.CompactForm Shelley.Coin) -> PoolKeyHash -> Maybe (Shelley.Coin, Word64) -> Generic.PoolStats
+    mkPoolStats blocks voting pkh deleg =
+      let
+        mnBlock = Map.lookup pkh blocks
+        mVoting = Map.lookup pkh voting
+       in
+        Generic.PoolStats
+          { Generic.nBlocks = mnBlock
+          , Generic.nDelegators = snd <$> deleg
+          , Generic.stake = fst <$> deleg
+          , Generic.votingPower = fromCompact <$> mVoting
+          }
+
 insertEpochParam ::
   (MonadBaseControl IO m, MonadIO m) =>
   Trace IO Text ->
@@ -372,3 +394,10 @@ sumRewardTotal =
     sumCoin :: Integer -> Set Generic.Reward -> Integer
     sumCoin !acc sr =
       acc + sum (map (Shelley.unCoin . Generic.rewardAmount) $ Set.toList sr)
+
+_inseertPoolStats ::
+  Monad m =>
+  SyncEnv ->
+  Map PoolKeyHash Generic.PoolStats ->
+  ExceptT SyncNodeError (ReaderT SqlBackend m) ()
+_inseertPoolStats _syncEnv _mp = pure () -- TODO

cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs

@@ -278,6 +278,7 @@ applyBlock env blk = do
             , Generic.neEpochUpdate = Generic.epochUpdate newState
             , Generic.neDRepState = maybeToStrict $ getDrepState newState
             , Generic.neEnacted = maybeToStrict $ getGovState newState
+            , Generic.nePoolDistr = maybeToStrict $ Generic.getPoolDistr newState
             }
 
     applyToEpochBlockNo :: Bool -> Bool -> EpochBlockNo -> EpochBlockNo

cardano-db-sync/src/Cardano/DbSync/Util.hs

@@ -28,6 +28,8 @@ module Cardano.DbSync.Util (
   splitLast,
   traverseMEither,
   whenStrictJust,
+  whenStrictJustDefault,
+  whenDefault,
   whenMaybe,
   mlookup,
   whenRight,
@@ -181,6 +183,15 @@ whenStrictJust ma f =
     Strict.Nothing -> pure ()
     Strict.Just a -> f a
 
+whenStrictJustDefault :: Applicative m => b -> Strict.Maybe a -> (a -> m b) -> m b
+whenStrictJustDefault b ma f =
+  case ma of
+    Strict.Nothing -> pure b
+    Strict.Just a -> f a
+
+whenDefault :: Applicative m => a -> Bool -> m a -> m a
+whenDefault a bl ma = if bl then ma else pure a
+
 whenMaybe :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b)
 whenMaybe (Just a) f = Just <$> f a
 whenMaybe Nothing _f = pure Nothing