Add rewards thread

Author: kderme

cardano-db-sync/cardano-db-sync.cabal

@@ -135,6 +135,7 @@ library
                         Cardano.DbSync.Threads.Database
                         Cardano.DbSync.Threads.EpochStake
                         Cardano.DbSync.Threads.Ledger
+                        Cardano.DbSync.Threads.Rewards
                         Cardano.DbSync.Threads.Stake
                         Cardano.DbSync.Threads.TxInResolve
                         Cardano.DbSync.Tracing.ToObjectOrphans

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

@@ -136,7 +136,6 @@ applyAndInsertBlock ::
   ExceptT SyncNodeError (ReaderT SqlBackend (LoggingT IO)) ()
 applyAndInsertBlock syncEnv ((blockId, firstAfterRollback), cblock) = do
   applyRessultVar <- liftIO (asyncApplyResult syncEnv cblock)
-  -- insertNewEpochLedgerEvents syncEnv (sdEpochNo (apSlotDetails applyResult)) (apEvents applyResult)
   whenGeneric $ \blk ->
     prepareInsertBlock syncEnv (blockId, blk) applyRessultVar firstAfterRollback
   where

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

@@ -15,7 +15,6 @@ module Cardano.DbSync.Config (
   SyncProtocol (..),
   SyncNodeConfig (..),
   SyncNodeParams (..),
-  cardanoLedgerConfig,
   genesisProtocolMagicId,
   readCardanoGenesisConfig,
   readSyncNodeConfig,

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

@@ -7,7 +7,6 @@
 
 module Cardano.DbSync.Config.Cardano (
   GenesisConfig (..),
-  cardanoLedgerConfig,
   genesisProtocolMagicId,
   mkTopLevelConfig,
   mkProtocolInfoCardano,
@@ -35,7 +34,6 @@ import Ouroboros.Consensus.Cardano (Nonce (..), ProtVer (ProtVer))
 import qualified Ouroboros.Consensus.Cardano as Consensus
 import Ouroboros.Consensus.Cardano.Node
 import Ouroboros.Consensus.Config (TopLevelConfig (..), emptyCheckpointsMap)
-import Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
 import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo)
 import qualified Ouroboros.Consensus.Node.ProtocolInfo as Consensus
 import Ouroboros.Consensus.Shelley.Eras (StandardCrypto)
@@ -73,9 +71,6 @@ readCardanoGenesisConfig enc =
 
 -- -------------------------------------------------------------------------------------------------
 
-cardanoLedgerConfig :: GenesisConfig -> LedgerConfig CardanoBlock
-cardanoLedgerConfig = topLevelConfigLedger . mkTopLevelConfig
-
 mkTopLevelConfig :: GenesisConfig -> TopLevelConfig CardanoBlock
 mkTopLevelConfig cfg = Consensus.pInfoConfig $ fst $ mkProtocolInfoCardano cfg []
 

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

@@ -2,12 +2,25 @@
 
 module Cardano.DbSync.Ledger.Async where
 
+import Cardano.DbSync.Era.Shelley.Generic.Rewards as Generic
+import Cardano.DbSync.Ledger.Event
 import Cardano.DbSync.Ledger.Types
-import Cardano.Ledger.BaseTypes (EpochNo)
+import Cardano.DbSync.Types
+import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Crypto (StandardCrypto)
 import qualified Cardano.Ledger.EpochBoundary as Ledger
+import qualified Cardano.Ledger.Rewards as Ledger
+import Cardano.Ledger.Shelley.RewardUpdate as Ledger
 import Control.Concurrent.Class.MonadSTM.Strict
 import qualified Control.Concurrent.STM.TBQueue as TBQ
+import Control.Monad.Extra (whenJust)
+import Data.Map (Map)
+import Data.Set (Set)
+import Data.Word (Word64)
+
+--------------------------------------------------------------------------------
+-- EpochStake
+--------------------------------------------------------------------------------
 
 newEpochStakeChannels :: IO EpochStakeChannels
 newEpochStakeChannels =
@@ -18,9 +31,9 @@ newEpochStakeChannels =
     <*> newTVarIO Nothing
 
 -- To be used by the main thread
-ensureEpochDone :: EpochStakeChannels -> EpochNo -> Ledger.SnapShot StandardCrypto -> IO ()
-ensureEpochDone sQueue epoch snapshot = atomically $ do
-  mLastEpochDone <- waitFinished sQueue
+ensureStakeDone :: EpochStakeChannels -> EpochNo -> Ledger.SnapShot StandardCrypto -> IO ()
+ensureStakeDone sQueue epoch snapshot = atomically $ do
+  mLastEpochDone <- waitStakeFinished sQueue
   case mLastEpochDone of
     Just lastEpochDone | lastEpochDone == epoch -> pure ()
     _ -> do
@@ -29,8 +42,8 @@ ensureEpochDone sQueue epoch snapshot = atomically $ do
       retry
 
 -- To be used by the main thread
-waitFinished :: EpochStakeChannels -> STM IO (Maybe EpochNo)
-waitFinished sQueue = do
+waitStakeFinished :: EpochStakeChannels -> STM IO (Maybe EpochNo)
+waitStakeFinished sQueue = do
   stakeThreadState <- readTVar (epochResult sQueue)
   case stakeThreadState of
     Just (lastEpoch, Done) -> pure $ Just lastEpoch -- Normal case
@@ -42,3 +55,74 @@ writeEpochStakeAction :: EpochStakeChannels -> EpochNo -> Ledger.SnapShot Standa
 writeEpochStakeAction sQueue epoch snapShot checkFirst = do
   TBQ.writeTBQueue (estakeQueue sQueue) $ EpochStakeDBAction epoch snapShot checkFirst
   writeTVar (epochResult sQueue) $ Just (epoch, Running)
+
+--------------------------------------------------------------------------------
+-- Rewards
+--------------------------------------------------------------------------------
+
+newRewardsChannels :: IO RewardsChannels
+newRewardsChannels =
+  RewardsChannels
+    <$> TBQ.newTBQueueIO 5
+    <*> newTVarIO Nothing
+
+-- TODO: add a boolean flag that shows the start of the epoch, so that 'isNewEpoch' is more reliable
+asyncWriteRewards :: HasLedgerEnv -> CardanoLedgerState -> EpochNo -> Bool -> [LedgerEvent] -> IO ()
+asyncWriteRewards env newState currentEpochNo isNewEpoch rewardEventsEB = do
+  rewState <- atomically $ readTVar $ rewardsResult rc
+  if isNewEpoch
+    then do
+      case rewState of
+        Just (e', RewRunning) | e' == currentEpochNo -> do
+          waitRewardUntil rc (e', RewDone)
+        _ -> do
+          ensureRewardsDone rc currentEpochNo (findTotal rewardEventsEB)
+      waitEBRewardsAction rc currentEpochNo rewardEventsEB
+    else do
+      case rewState of {}
+      whenJust (Generic.getRewardsUpdate (getTopLevelconfigHasLedger env) (clsState newState)) $ \ru -> do
+        atomically $ writeRewardsAction rc currentEpochNo currentEpochNo False (Ledger.rs ru) -- (e-1) (e+1)
+  where
+    rc = leRewardsChans env
+
+    _subFromCurrentEpoch :: Word64 -> EpochNo
+    _subFromCurrentEpoch m =
+      if unEpochNo currentEpochNo >= m
+        then EpochNo $ unEpochNo currentEpochNo - m
+        else EpochNo 0
+
+    findTotal :: [LedgerEvent] -> Maybe (Map StakeCred (Set (Ledger.Reward StandardCrypto)))
+    findTotal [] = Nothing
+    findTotal (LedgerTotalRewards _ mp : _) = Just mp
+    findTotal (_ : rest) = findTotal rest
+
+-- To be used by the main thread
+ensureRewardsDone :: RewardsChannels -> EpochNo -> Maybe (Map StakeCred (Set (Ledger.Reward StandardCrypto))) -> IO ()
+ensureRewardsDone rc epoch mmp = do
+  whenJust mmp $ \mp -> do
+    atomically $ writeRewardsAction rc epoch epoch True mp -- e-2 e-1
+    waitRewardUntil rc (epoch, RewDone)
+
+waitEBRewardsAction :: RewardsChannels -> EpochNo -> [LedgerEvent] -> IO ()
+waitEBRewardsAction rc epoch les = do
+  atomically $ do
+    TBQ.writeTBQueue (rQueue rc) $ RewardsEpochBoundary epoch les
+    writeTVar (rewardsResult rc) $ Just (epoch, RewEBRunning)
+  waitRewardUntil rc (epoch, RewEBDone)
+
+-- To be used by the main thread
+writeRewardsAction :: RewardsChannels -> EpochNo -> EpochNo -> Bool -> Map StakeCred (Set (Ledger.Reward StandardCrypto)) -> STM IO ()
+writeRewardsAction rc epoch epoch' checkFirst mp = do
+  TBQ.writeTBQueue (rQueue rc) $ RewardsDBAction epoch epoch' mp checkFirst
+  writeTVar (rewardsResult rc) $ Just (epoch, RewRunning)
+
+waitRewardUntil :: RewardsChannels -> (EpochNo, EpochRewardState) -> IO ()
+waitRewardUntil rc st = waitRewardUntilPred rc (== st)
+
+-- blocks until the reward result satisfies a specific predicate.
+waitRewardUntilPred :: RewardsChannels -> ((EpochNo, EpochRewardState) -> Bool) -> IO ()
+waitRewardUntilPred rc prd = atomically $ do
+  rewardsThreadState <- readTVar (rewardsResult rc)
+  case rewardsThreadState of
+    Just st | prd st -> pure ()
+    _ -> retry

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

@@ -19,6 +19,7 @@ module Cardano.DbSync.Ledger.Event (
   convertPoolRewards,
   ledgerEventName,
   splitDeposits,
+  splitRewardsEpochBoundary,
 ) where
 
 import Cardano.Db hiding (AdaPots, EpochNo, SyncState, TreasuryWithdrawals, epochNo)
@@ -465,3 +466,14 @@ splitDeposits les =
       case le of
         LedgerDeposits hsh coin -> Left (txHashFromSafe hsh, coin)
         _ -> Right le
+
+splitRewardsEpochBoundary :: [LedgerEvent] -> ([LedgerEvent], [LedgerEvent])
+splitRewardsEpochBoundary les =
+  partitionEithers $ eitherRewEB <$> les
+  where
+    eitherRewEB :: LedgerEvent -> Either LedgerEvent LedgerEvent
+    eitherRewEB le = case le of
+      LedgerDeltaRewards {} -> Left le
+      LedgerRestrainedRewards {} -> Left le
+      LedgerTotalRewards {} -> Left le
+      _ -> Right le

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

@@ -32,7 +32,6 @@ module Cardano.DbSync.Ledger.State (
   hashToAnnotation,
   getHeaderHash,
   runLedgerStateWriteThread,
-  getSliceMeta,
   findProposedCommittee,
 ) where
 
@@ -176,6 +175,7 @@ mkHasLedgerEnv trce protoInfo dir nw systemStart syncOptions = do
   intervar <- newTVarIO Strict.Nothing
   swQueue <- newTBQueueIO 5 -- Should be relatively shallow.
   stakeChans <- newEpochStakeChannels
+  rewardsChans <- newRewardsChannels
   applyQueue <- newTBQueueIO 10
   pure
     HasLedgerEnv
@@ -194,6 +194,7 @@ mkHasLedgerEnv trce protoInfo dir nw systemStart syncOptions = do
       , leStateWriteQueue = swQueue
       , leApplyQueue = applyQueue
       , leEpochStakeChans = stakeChans
+      , leRewardsChans = rewardsChans
       }
 
 initCardanoLedgerState :: Consensus.ProtocolInfo CardanoBlock -> CardanoLedgerState
@@ -203,9 +204,6 @@ initCardanoLedgerState pInfo =
     , clsEpochBlockNo = GenesisEpochBlockNo
     }
 
-getTopLevelconfigHasLedger :: HasLedgerEnv -> TopLevelConfig CardanoBlock
-getTopLevelconfigHasLedger = Consensus.pInfoConfig . leProtocolInfo
-
 readCurrentStateUnsafe :: HasLedgerEnv -> IO (ExtLedgerState CardanoBlock)
 readCurrentStateUnsafe hle = atomically (clsState . ledgerDbCurrent <$> readStateUnsafe hle)
 
@@ -234,13 +232,15 @@ applyBlock env blk = do
   let oldState = ledgerDbCurrent ledgerDB
   !result <- throwLeftIO $ tickThenReapplyCheckHash (ExtLedgerCfg (getTopLevelconfigHasLedger env)) blk (clsState oldState)
   let ledgerEventsFull = mapMaybe (convertAuxLedgerEvent (leHasRewards env)) (lrEvents result)
-  let (ledgerEvents, deposits) = splitDeposits ledgerEventsFull
+  let (ledgerEvents', deposits) = splitDeposits ledgerEventsFull
+  let (rewardsEpochBoundary, ledgerEvents) = splitRewardsEpochBoundary ledgerEvents'
   let !newLedgerState = finaliseDrepDistr (lrResult result)
   !details <- atomically $ getSlotDetails env (ledgerState newLedgerState) time (cardanoBlockSlotNo blk)
   !newEpoch <- throwLeftIO $ mkOnNewEpoch (clsState oldState) newLedgerState (findAdaPots ledgerEvents)
   let !newEpochBlockNo = applyToEpochBlockNo (isJust $ blockIsEBB blk) (isJust newEpoch) (clsEpochBlockNo oldState)
   let !newState = CardanoLedgerState newLedgerState newEpochBlockNo
   asyncWriteStakeSnapShot env oldState newState
+  asyncWriteRewards env newState (sdEpochNo details) (isJust newEpoch) rewardsEpochBoundary
   let !ledgerDB' = pushLedgerDB ledgerDB newState
   atomically $ writeTVar (leStateVar env) (Strict.Just ledgerDB')
   let !appResult =
@@ -321,13 +321,9 @@ asyncWriteStakeSnapShot env oldState newState =
     EpochBlockNo n
       | n == 0
       , Just (snapshot, epoch) <- Generic.getSnapShot (clsState oldState) -> do
-          ensureEpochDone (leEpochStakeChans env) epoch snapshot
+          ensureStakeDone (leEpochStakeChans env) epoch snapshot
     _ -> pure ()
 
-getSliceMeta :: Generic.StakeSliceRes -> Maybe (Bool, EpochNo)
-getSliceMeta (Generic.Slice (Generic.StakeSlice epochNo _) isFinal) = Just (isFinal, epochNo)
-getSliceMeta _ = Nothing
-
 storeSnapshotAndCleanupMaybe ::
   HasLedgerEnv ->
   CardanoLedgerState ->

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

@@ -21,6 +21,7 @@ import Cardano.DbSync.Types (
   CardanoPoint,
   PoolKeyHash,
   SlotDetails,
+  StakeCred,
  )
 import Cardano.Ledger.Alonzo.Scripts (Prices)
 import qualified Cardano.Ledger.BaseTypes as Ledger
@@ -29,6 +30,7 @@ import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Credential (Credential (..))
 import qualified Cardano.Ledger.EpochBoundary as Ledger
 import Cardano.Ledger.Keys (KeyRole (..))
+import qualified Cardano.Ledger.Rewards as Ledger
 import Cardano.Ledger.Shelley.LedgerState (NewEpochState ())
 import Cardano.Prelude hiding (atomically)
 import Cardano.Slotting.Slot (
@@ -48,6 +50,7 @@ import qualified Data.Strict.Maybe as Strict
 import Lens.Micro (Traversal')
 import Ouroboros.Consensus.BlockchainTime.WallClock.Types (SystemStart (..))
 import Ouroboros.Consensus.Cardano.Block hiding (CardanoBlock, CardanoLedgerState)
+import Ouroboros.Consensus.Config (TopLevelConfig (..))
 import Ouroboros.Consensus.HardFork.Combinator.Basics (LedgerState (..))
 import Ouroboros.Consensus.Ledger.Abstract (getTipSlot)
 import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
@@ -76,6 +79,7 @@ data HasLedgerEnv = HasLedgerEnv
   , leStateWriteQueue :: !(TBQueue (FilePath, CardanoLedgerState))
   , leApplyQueue :: TBQueue LedgerAction
   , leEpochStakeChans :: EpochStakeChannels
+  , leRewardsChans :: RewardsChannels
   }
 
 data CardanoLedgerState = CardanoLedgerState
@@ -188,6 +192,9 @@ updatedCommittee membersToRemove membersToAdd newQuorum committee =
             newCommitteeMembers
             newQuorum
 
+getTopLevelconfigHasLedger :: HasLedgerEnv -> TopLevelConfig CardanoBlock
+getTopLevelconfigHasLedger = Consensus.pInfoConfig . leProtocolInfo
+
 newtype LedgerDB = LedgerDB
   { ledgerDbCheckpoints :: AnchoredSeq (WithOrigin SlotNo) CardanoLedgerState CardanoLedgerState
   }
@@ -213,6 +220,18 @@ data EpochStakeChannels = EpochStakeChannels
   , epochResult :: StrictTVar IO (Maybe (EpochNo, EpochState))
   }
 
+data EpochRewardState = RewRunning | RewDone | RewEBRunning | RewEBDone
+  deriving (Eq, Ord, Show)
+
+data RewardsDBAction
+  = RewardsDBAction EpochNo EpochNo (Map StakeCred (Set (Ledger.Reward StandardCrypto))) Bool
+  | RewardsEpochBoundary EpochNo [LedgerEvent]
+
+data RewardsChannels = RewardsChannels
+  { rQueue :: TBQueue RewardsDBAction
+  , rewardsResult :: StrictTVar IO (Maybe (EpochNo, EpochRewardState))
+  }
+
 -- | Per-era pure getters and setters on @NewEpochState@. Note this is a bit of an abuse
 -- of the cardano-ledger/ouroboros-consensus public APIs, because ledger state is not
 -- designed to be updated this way. We are only replaying the chain, so this should be

cardano-db-sync/src/Cardano/DbSync/Threads/Rewards.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Cardano.DbSync.Threads.Rewards where
+
+import Cardano.BM.Trace (logInfo)
+import qualified Cardano.Db as DB
+import Cardano.DbSync.Api
+import Cardano.DbSync.Api.Types
+import Cardano.DbSync.Era.Shelley.Generic.Rewards
+import Cardano.DbSync.Era.Universal.Epoch
+import Cardano.DbSync.Era.Universal.Insert.LedgerEvent
+import Cardano.DbSync.Error
+import Cardano.DbSync.Ledger.Event
+import Cardano.DbSync.Ledger.Types
+import Cardano.DbSync.Util
+import Control.Concurrent.Class.MonadSTM.Strict
+import qualified Control.Concurrent.STM.TBQueue as TBQ
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except.Extra (runExceptT)
+import qualified Data.Map as Map
+import Database.Persist.Postgresql (IsolationLevel (..), runSqlConnWithIsolation, withPostgresqlConn)
+
+runRewardsThread ::
+  SyncEnv ->
+  IO ()
+runRewardsThread syncEnv =
+  case envLedgerEnv syncEnv of
+    NoLedger _ -> pure ()
+    HasLedger le -> do
+      logInfo trce "Running Rewards thread"
+      logException trce "runRewardsThread: " (runRewLoop syncEnv le)
+      logInfo trce "Shutting Rewards thread"
+  where
+    trce = getTrace syncEnv
+
+runRewLoop :: SyncEnv -> HasLedgerEnv -> IO ()
+runRewLoop syncEnv lenv =
+  DB.runIohkLogging trce $
+    withPostgresqlConn (envConnectionString syncEnv) loop
+  where
+    loop backend = do
+      runOrThrowIO $ runSqlConnWithIsolation (runExceptT loopAction) backend Serializable
+      loop backend
+
+    loopAction = do
+      rAction <- liftIO $ atomically $ TBQ.readTBQueue (rQueue rc)
+      case rAction of
+        RewardsDBAction epoch epoch' mp _shouldCheck -> do
+          insertRewards syncEnv epoch epoch' (Map.toList $ unRewards $ convertPoolRewards mp)
+          liftIO $ atomically $ writeTVar (rewardsResult rc) $ Just (epoch', RewDone)
+        RewardsEpochBoundary epoch events -> do
+          insertNewEpochLedgerEvents syncEnv epoch events
+          liftIO $ atomically $ writeTVar (rewardsResult rc) $ Just (epoch, RewEBDone)
+
+    rc = leRewardsChans lenv
+    trce = getTrace syncEnv