wip

cardano-db-sync/src/Cardano/DbSync/Plugin/Default.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 module Cardano.DbSync.Plugin.Default
   ( defDbSyncNodePlugin
   , insertDefaultBlock
@@ -28,10 +29,11 @@ import           Cardano.Sync.Types
 import           Cardano.Sync.Util
 
 import           Control.Concurrent.STM.TMVar (putTMVar)
-import           Control.Concurrent.STM.TVar (readTVarIO)
+import           Control.Concurrent.STM.TVar (readTVarIO, writeTVar)
 import           Control.Monad.Logger (LoggingT)
 
 import qualified Data.List as List
+import qualified Data.Map.Strict as Map
 
 import           Database.Persist.Sql (SqlBackend)
 
@@ -75,6 +77,7 @@ insertDefaultBlock backend tracer env blockDetails = do
       -- update ledgerStateVar.
       let network = leNetwork (envLedger env)
       lStateSnap <- liftIO $ applyBlock (envLedger env) cblk
+      prepareEpochUpdate (envLedger env)
       res <- case cblk of
                 BlockByron blk ->
                   insertByronBlock tracer blk details
@@ -113,3 +116,27 @@ chunkByEpoch ws =
           ([], _) -> panic "Cardano.DbSync.Plugin.Default.chunkByEpoch: Impossible"
           (ys, []) -> [ys]
           (ys, zs) -> ys : chunkByEpoch zs
+
+prepareEpochUpdate :: MonadIO m => LedgerEnv -> ReaderT SqlBackend m ()
+prepareEpochUpdate env = do
+    currState <- liftIO $ readTVarIO (leStateVar env)
+    upState <- liftIO $ readTVarIO (ruState $ leEpochUpdate env)
+    when (upState /= WaitingForData) $ do
+      let mRewards = Generic.epochRewards (leNetwork env) (clsState currState)
+      case Generic.epochUpdate (leNetwork env) (ledgerEpochNo env currState) (clsState currState) mRewards of
+        Nothing -> pure ()
+        Just origRu -> do
+          ru <- queryPopulateEpochUpdateCaches env origRu
+          liftIO . atomically $ do
+            putTMVar (ruInsertDone $ leEpochUpdate env) ru
+            writeTVar (ruState $ leEpochUpdate env) Processing
+
+queryPopulateEpochUpdateCaches :: MonadIO m => SyncEnv -> Generic.EpochUpdate -> ReaderT SqlBackend m Generic.EpochUpdate
+queryPopulateEpochUpdateCaches env origRu = do
+    addrs <- mapM ((\ a -> (a,) <$> queryStakeAddress) . Generic.stakingCredHash env) stakeAddresses
+    pure $ origRu
+            { Generic.enStakeAddressCache = Map.fromList addrs
+            }
+  where
+    stakeAddresses :: [Generic.StakeCred]
+    stakeAddresses = List.nub . List.sort $ Map.keys (Generic.enStakeAddressCache origRu)

cardano-sync/cardano-sync.cabal

@@ -73,6 +73,7 @@ library
                       , cardano-crypto
                       , cardano-crypto-class
                       , cardano-crypto-wrapper
+                      , cardano-db
                       , cardano-ledger-byron
                       -- Only for some orphan tracing instances.
                       , cardano-node

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

@@ -11,6 +11,8 @@ module Cardano.Sync.Era.Shelley.Generic.EpochUpdate
 
 import           Cardano.Prelude
 
+import qualified Cardano.Db as Db
+
 import           Cardano.Slotting.Slot (EpochNo (..))
 
 import           Cardano.Sync.Era.Shelley.Generic.ProtoParams
@@ -39,6 +41,9 @@ data EpochUpdate = EpochUpdate
   { euEpoch :: !EpochNo
   , euRewards :: !(Maybe Rewards)
   , euStakeDistribution :: !StakeDist
+  -- The following Maps are initialized as empty and populated later.
+  , enStakeAddressCache :: !(Map StakeCred Db.StakeAddressId)
+  , enPoolIdCache :: !(Map StakeCred Db.PoolHashId)
   }
 
 -- There is a similar type in ledger-spec, but it is not exported yet.
@@ -68,6 +73,8 @@ allegraEpochUpdate nw epochNo als mRewards =
     { euEpoch = epochNo
     , euRewards = mRewards
     , euStakeDistribution = allegraStakeDist nw als
+    , enStakeAddressCache = mempty
+    , enPoolIdCache = mempty
     }
 
 maryEpochUpdate :: Shelley.Network -> EpochNo -> LedgerState (ShelleyBlock StandardMary) -> Maybe Rewards -> EpochUpdate
@@ -76,6 +83,8 @@ maryEpochUpdate nw epochNo mls mRewards =
     { euEpoch = epochNo
     , euRewards = mRewards
     , euStakeDistribution = maryStakeDist nw mls
+    , enStakeAddressCache = mempty
+    , enPoolIdCache = mempty
     }
 
 shelleyEpochUpdate :: Shelley.Network -> EpochNo -> LedgerState (ShelleyBlock StandardShelley) -> Maybe Rewards -> EpochUpdate
@@ -84,4 +93,6 @@ shelleyEpochUpdate nw epochNo sls mRewards =
     { euEpoch = epochNo
     , euRewards = mRewards
     , euStakeDistribution = shelleyStakeDist nw sls
+    , enStakeAddressCache = mempty
+    , enPoolIdCache = mempty
     }

cardano-sync/src/Cardano/Sync/LedgerState.hs

@@ -14,6 +14,7 @@ module Cardano.Sync.LedgerState
   , EpochUpdateControl (..)
   , EpochUpdateState (..)
   , applyBlock
+  , ledgerEpochNo
   , loadLedgerStateAtPoint
   , saveLedgerStateMaybe
   , listLedgerStateFilesOrdered
@@ -41,7 +42,7 @@ import           Cardano.Slotting.Block (BlockNo (..))
 import           Cardano.Slotting.EpochInfo (EpochInfo, epochInfoEpoch)
 import           Cardano.Slotting.Slot (EpochNo (..), SlotNo (..), WithOrigin (..), fromWithOrigin)
 
-import           Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVarIO, putTMVar)
+import           Control.Concurrent.STM.TMVar (TMVar, newEmptyTMVarIO)
 import           Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, readTVarIO, writeTVar)
 
 import qualified Control.Exception as Exception
@@ -170,16 +171,14 @@ applyBlock env blk = do
     -- 'LedgerStateVar' is just being used as a mutable variable. There should not ever
     -- be any contention on this variable, so putting everything inside 'atomically'
     -- is fine.
-    res <- atomically $ do
-            oldState <- readTVar (leStateVar env)
-            let !newState = oldState { clsState = applyBlk (ExtLedgerCfg (topLevelConfig env)) blk (clsState oldState) }
-            writeTVar (leStateVar env) newState
-            pure $ LedgerStateSnapshot
-                    { lssState = newState
-                    , lssNewEpoch = mkNewEpoch oldState newState
-                    }
-    rewardWibble env
-    pure res
+    atomically $ do
+      oldState <- readTVar (leStateVar env)
+      let !newState = oldState { clsState = applyBlk (ExtLedgerCfg (topLevelConfig env)) blk (clsState oldState) }
+      writeTVar (leStateVar env) newState
+      pure $ LedgerStateSnapshot
+              { lssState = newState
+              , lssNewEpoch = mkNewEpoch oldState newState
+              }
   where
     applyBlk
         :: ExtLedgerCfg CardanoBlock -> CardanoBlock
@@ -530,17 +529,3 @@ totalAdaPots lState =
 
     utxo :: Coin
     utxo = Val.coin $ Shelley.balance (Shelley._utxo uState)
-
-
-rewardWibble :: LedgerEnv -> IO ()
-rewardWibble env = do
-    currState <- readTVarIO (leStateVar env)
-    upState <- readTVarIO (ruState $ leEpochUpdate env)
-    when (upState == WaitingForData) $ do
-      let mRewards = Generic.epochRewards (leNetwork env) (clsState currState)
-      case Generic.epochUpdate (leNetwork env) (ledgerEpochNo env currState) (clsState currState) mRewards of
-        Nothing -> pure ()
-        Just ru ->
-          atomically $ do
-            putTMVar (ruInsertDone $ leEpochUpdate env) ru
-            writeTVar (ruState $ leEpochUpdate env) Processing