db-sync: Add accounting for pool deposit refunds

Closes: #826

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

@@ -11,6 +11,7 @@
 module Cardano.DbSync.Era.Shelley.Insert.Epoch
   ( finalizeEpochBulkOps
   , insertEpochInterleaved
+  , insertPoolDepositRefunds
   , postEpochRewards
   , postEpochStake
   ) where
@@ -178,6 +179,7 @@ insertRewards epoch icache rewardsChunk = do
                   , DB.rewardPoolId = lookupPoolIdPairMaybe (Generic.rewardPool rwd) icache
                   }
 
+    -- The earnedEpoch and spendableEpoch functions have been tweaked to match the login of the ledger.
     earnedEpoch :: DB.RewardSource -> Word64
     earnedEpoch src =
       unEpochNo epoch +
@@ -186,6 +188,7 @@ insertRewards epoch icache rewardsChunk = do
           DB.RwdLeader -> 0
           DB.RwdReserves -> 1
           DB.RwdTreasury -> 1
+          DB.RwdDepositRefund -> 0
 
     spendableEpoch :: DB.RewardSource -> Word64
     spendableEpoch src =
@@ -195,6 +198,15 @@ insertRewards epoch icache rewardsChunk = do
           DB.RwdLeader -> 2
           DB.RwdReserves -> 2
           DB.RwdTreasury -> 2
+          DB.RwdDepositRefund -> 0
+
+insertPoolDepositRefunds
+    :: (MonadBaseControl IO m, MonadIO m)
+    => LedgerEnv -> Generic.Rewards
+    -> ExceptT SyncNodeError (ReaderT SqlBackend m) ()
+insertPoolDepositRefunds lenv refunds = do
+  icache <- lift $ updateIndexCache lenv (Generic.rewardsStakeCreds refunds) (Generic.rewardsPoolHashKeys refunds)
+  insertRewards (Generic.rwdEpoch refunds) icache (Map.toList $ Generic.rwdRewards refunds)
 
 -- -------------------------------------------------------------------------------------------------
 

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

@@ -30,8 +30,8 @@ import qualified Data.List.Extra as List
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as Text
 
-import           Database.Esqueleto.Legacy (InnerJoin (..), Value (..), countRows, desc, from, on,
-                   orderBy, select, sum_, val, where_, (==.), (^.))
+import           Database.Esqueleto.Legacy (InnerJoin (..), Value (..), countRows, desc, from, not_,
+                   on, orderBy, select, sum_, val, where_, (==.), (^.))
 
 import           Database.Persist.Sql (SqlBackend)
 
@@ -67,6 +67,9 @@ queryEpochRewardTotal
 queryEpochRewardTotal (EpochNo epochNo) = do
   res <- select . from $ \ rwd -> do
             where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo)
+            -- For ... reasons ... pool deposit refunds are put into the rewards account
+            -- but are not considered part of the total rewards for an epoh.
+            where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdDepositRefund)
             pure (sum_ $ rwd ^. Db.RewardAmount)
   pure $ Db.unValueSumAda (listToMaybe res)
 
@@ -75,7 +78,6 @@ queryEpochRewardTotal (EpochNo epochNo) = do
 convertRewardMap :: Network -> Map (Ledger.StakeCredential c) Coin -> Map Generic.StakeCred Coin
 convertRewardMap nw = Map.mapKeys (Generic.toStakeCred nw)
 
-
 logFullRewardMap
     :: (MonadBaseControl IO m, MonadIO m)
     => EpochNo -> Map Generic.StakeCred Coin -> ReaderT SqlBackend m ()

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -25,13 +26,16 @@ import           Cardano.DbSync.Era.Shelley.Insert.Epoch
 import           Cardano.DbSync.Era.Shelley.Validate
 import           Cardano.DbSync.Rollback (rollbackToPoint)
 
+import           Cardano.Ledger.BaseTypes (Network)
 import           Cardano.Ledger.Coin (Coin (..))
 import           Cardano.Ledger.Credential (StakeCredential)
 import           Cardano.Ledger.Crypto (StandardCrypto)
+import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 
 import           Cardano.Slotting.Slot (EpochNo (..))
 
 import           Cardano.Sync.Api
+import qualified Cardano.Sync.Era.Shelley.Generic as Generic
 import           Cardano.Sync.Error
 import           Cardano.Sync.LedgerState
 import           Cardano.Sync.Plugin
@@ -44,6 +48,7 @@ import           Control.Monad.Trans.Except.Extra (newExceptT)
 
 import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 
 import           Database.Persist.Sql (SqlBackend)
 
@@ -170,6 +175,26 @@ handleLedgerEvents tracer lenv point =
           lift $ stashPoolRewards tracer lenv en rd
         LedgerMirDist md ->
           lift $ stashMirRewards tracer lenv md
+        LedgerPoolReap en drs ->
+          insertPoolDepositRefunds lenv (Generic.Rewards en $ convertPoolDepositReunds (leNetwork lenv) drs)
+
+convertPoolDepositReunds
+    :: Network -> Map (StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin)
+    -> Map Generic.StakeCred (Set Generic.Reward)
+convertPoolDepositReunds nw =
+    mapBimap (Generic.toStakeCred nw) (Set.fromList . map convert . Map.toList)
+  where
+    convert :: (KeyHash 'StakePool StandardCrypto, Coin) -> Generic.Reward
+    convert (kh, coin) =
+      Generic.Reward
+        { Generic.rewardSource = DB.RwdDepositRefund
+        , Generic.rewardPool = Just (Generic.toStakePoolKeyHash kh)
+        , Generic.rewardAmount = coin
+        }
+
+mapBimap :: Ord k2 => (k1 -> k2) -> (a1 -> a2) -> Map k1 a1 -> Map k2 a2
+mapBimap fk fa = Map.fromAscList . map (bimap fk fa) . Map.toAscList
+
 
 hasEpochStartEvent :: [LedgerEvent] -> Bool
 hasEpochStartEvent = any isNewEpoch

cardano-db/src/Cardano/Db/Types.hs

@@ -97,6 +97,7 @@ data RewardSource
   | RwdMember
   | RwdReserves
   | RwdTreasury
+  | RwdDepositRefund
   deriving (Bounded, Enum, Eq, Ord, Show)
 
 data SyncState
@@ -159,6 +160,7 @@ readRewardSource str =
     "leader" -> RwdLeader
     "reserves" -> RwdReserves
     "treasury" -> RwdTreasury
+    "refund" -> RwdDepositRefund
     -- This should never happen. On the Postgres side we defined an ENUM with
     -- only the two values as above.
     _other -> error $ "readRewardSource: Unknown RewardSource " ++ Text.unpack str
@@ -208,6 +210,7 @@ showRewardSource rs =
     RwdLeader -> "leader"
     RwdReserves -> "reserves"
     RwdTreasury -> "treasury"
+    RwdDepositRefund -> "refund"
 
 renderScriptType :: ScriptType -> Text
 renderScriptType st =

cardano-sync/cardano-sync.cabal

@@ -57,6 +57,7 @@ library
                         Cardano.Sync.Era.Shelley.Generic.Rewards
                         Cardano.Sync.Era.Shelley.Generic.StakeCred
                         Cardano.Sync.Era.Shelley.Generic.StakeDist
+                        Cardano.Sync.Era.Shelley.Generic.StakePoolKeyHash
 
                         Cardano.Sync.Metrics
                         Cardano.Sync.Plugin

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

@@ -8,3 +8,4 @@ import           Cardano.Sync.Era.Shelley.Generic.ProtoParams as X
 import           Cardano.Sync.Era.Shelley.Generic.Rewards as X
 import           Cardano.Sync.Era.Shelley.Generic.StakeCred as X
 import           Cardano.Sync.Era.Shelley.Generic.StakeDist as X
+import           Cardano.Sync.Era.Shelley.Generic.StakePoolKeyHash as X

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Cardano.Sync.Era.Shelley.Generic.Rewards
   ( Reward (..)
   , Rewards (..)
@@ -12,8 +13,6 @@ module Cardano.Sync.Era.Shelley.Generic.Rewards
 
 import           Cardano.Prelude
 
-import           Cardano.Crypto.Hash (hashToBytes)
-
 import           Cardano.Db (RewardSource (..), rewardTypeToSource, textShow)
 
 import qualified Cardano.Ledger.Alonzo.PParams as Alonzo
@@ -22,19 +21,18 @@ import           Cardano.Ledger.Coin (Coin (..))
 import qualified Cardano.Ledger.Core as Ledger
 import qualified Cardano.Ledger.Credential as Ledger
 import           Cardano.Ledger.Era (Crypto)
-import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import qualified Cardano.Ledger.Keys as Ledger
 
 import           Cardano.Slotting.Slot (EpochNo (..))
 
 import           Cardano.Sync.Era.Shelley.Generic.StakeCred
-import           Cardano.Sync.Era.Shelley.Generic.StakeDist
+import           Cardano.Sync.Era.Shelley.Generic.StakePoolKeyHash
 import           Cardano.Sync.Types
 
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
-import           Ouroboros.Consensus.Cardano.Block (LedgerState (..))
+import           Ouroboros.Consensus.Cardano.Block (LedgerState (..), StandardCrypto)
 import           Ouroboros.Consensus.Cardano.CanHardFork ()
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
 import           Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyBlock)
@@ -106,7 +104,10 @@ rewardProtoVer lstate =
 
 -- -------------------------------------------------------------------------------------------------
 
-genericRewards :: forall era. Ledger.Network -> BlockEra -> EpochNo -> LedgerState (ShelleyBlock era) -> Maybe Rewards
+genericRewards
+    :: forall era. Crypto era ~ StandardCrypto
+    => Ledger.Network -> BlockEra -> EpochNo -> LedgerState (ShelleyBlock era)
+    -> Maybe Rewards
 genericRewards network era epoch lstate =
     fmap cleanup rewardUpdate
   where
@@ -121,7 +122,7 @@ genericRewards network era epoch lstate =
     rewardUpdate =
       completeRewardUpdate =<< Ledger.strictMaybeToMaybe (Shelley.nesRu $ Consensus.shelleyLedgerState lstate)
 
-    completeRewardUpdate :: Shelley.PulsingRewUpdate (Crypto era) -> Maybe (Map StakeCred (Set Reward))
+    completeRewardUpdate :: Shelley.PulsingRewUpdate StandardCrypto -> Maybe (Map StakeCred (Set Reward))
     completeRewardUpdate x =
       case x of
         Shelley.Pulsing {} -> Nothing -- Should never happen.
@@ -130,22 +131,18 @@ genericRewards network era epoch lstate =
                                         (getInstantaneousRewards network lstate)
 
     convertRewardMap
-        :: Map (Ledger.Credential 'Ledger.Staking (Crypto era)) (Set (Shelley.Reward (Crypto era)))
+        :: Map (Ledger.Credential 'Ledger.Staking StandardCrypto) (Set (Shelley.Reward StandardCrypto))
         -> Map StakeCred (Set Reward)
     convertRewardMap = mapBimap (toStakeCred network) (Set.map convertReward)
 
-    convertReward :: Shelley.Reward (Crypto era) -> Reward
+    convertReward :: Shelley.Reward StandardCrypto -> Reward
     convertReward sr =
       Reward
         { rewardSource = rewardTypeToSource $ Shelley.rewardType sr
         , rewardAmount = Shelley.rewardAmount sr
-        , rewardPool = Just $ convertStakePoolkeyHash (Shelley.rewardPool sr)
+        , rewardPool = Just $ toStakePoolKeyHash (Shelley.rewardPool sr)
         }
 
-    convertStakePoolkeyHash :: KeyHash 'StakePool (Crypto era) -> StakePoolKeyHash
-    convertStakePoolkeyHash (KeyHash h) = StakePoolKeyHash $ hashToBytes h
-
-
 mapBimap :: Ord k2 => (k1 -> k2) -> (a1 -> a2) -> Map k1 a1 -> Map k2 a2
 mapBimap fk fa = Map.fromAscList . map (bimap fk fa) . Map.toAscList
 

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

@@ -3,7 +3,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Cardano.Sync.Era.Shelley.Generic.StakeDist
   ( StakeDist (..)
-  , StakePoolKeyHash (..)
   , epochStakeDist
   , stakeDistPoolHashKeys
   , stakeDistStakeCreds
@@ -21,6 +20,7 @@ import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import           Cardano.Slotting.Slot (EpochNo (..))
 
 import           Cardano.Sync.Era.Shelley.Generic.StakeCred
+import           Cardano.Sync.Era.Shelley.Generic.StakePoolKeyHash
 import           Cardano.Sync.Types
 
 import qualified Data.Map.Strict as Map
@@ -41,10 +41,6 @@ data StakeDist = StakeDist
   , sdistStakeMap :: !(Map StakeCred (Coin, StakePoolKeyHash))
   } deriving Eq
 
-newtype StakePoolKeyHash
-  = StakePoolKeyHash { unStakePoolKeyHash :: ByteString }
-  deriving (Eq, Ord, Show)
-
 epochStakeDist :: Ledger.Network -> EpochNo -> ExtLedgerState CardanoBlock -> Maybe StakeDist
 epochStakeDist network epoch els =
   case ledgerState els of

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

@@ -0,0 +1,23 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Cardano.Sync.Era.Shelley.Generic.StakePoolKeyHash
+  ( StakePoolKeyHash (..)
+  , toStakePoolKeyHash
+  ) where
+
+import           Cardano.Prelude
+
+import           Cardano.Crypto.Hash (hashToBytes)
+
+import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
+
+import           Ouroboros.Consensus.Cardano.Block (StandardCrypto)
+
+
+newtype StakePoolKeyHash
+  = StakePoolKeyHash { unStakePoolKeyHash :: ByteString }
+  deriving (Eq, Ord, Show)
+
+toStakePoolKeyHash :: KeyHash 'StakePool StandardCrypto -> StakePoolKeyHash
+toStakePoolKeyHash (KeyHash h) = StakePoolKeyHash $ hashToBytes h

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

@@ -17,6 +17,7 @@ import qualified Cardano.Ledger.Core as Ledger
 import qualified Cardano.Ledger.Credential as Ledger
 import           Cardano.Ledger.Crypto (StandardCrypto)
 import           Cardano.Ledger.Era (Crypto)
+import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
 import           Cardano.Slotting.Slot (EpochNo (..))
 import qualified Cardano.Sync.Era.Shelley.Generic as Generic
 import           Cardano.Sync.Types
@@ -37,8 +38,10 @@ import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, ShelleyLedger
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
 import           Shelley.Spec.Ledger.API (InstantaneousRewards (..))
+import           Shelley.Spec.Ledger.STS.Epoch (EpochEvent (PoolReapEvent))
 import           Shelley.Spec.Ledger.STS.Mir (MirEvent (..))
 import           Shelley.Spec.Ledger.STS.NewEpoch (NewEpochEvent (..))
+import           Shelley.Spec.Ledger.STS.PoolReap (PoolreapEvent (..))
 import           Shelley.Spec.Ledger.STS.Tick (TickEvent (..))
 
 data LedgerEvent
@@ -49,6 +52,7 @@ data LedgerEvent
 
   | LedgerRewardDist !EpochNo !(Map (Ledger.StakeCredential StandardCrypto) Coin)
   | LedgerMirDist !(Map (Ledger.StakeCredential StandardCrypto) Coin)
+  | LedgerPoolReap !EpochNo !(Map (Ledger.StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin))
   deriving Eq
 
 convertAuxLedgerEvent :: OneEraLedgerEvent (CardanoEras StandardCrypto) -> Maybe LedgerEvent
@@ -71,13 +75,16 @@ instance
     , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera
     , Event (Ledger.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera
     , Event (Ledger.EraRule "MIR" ledgerera) ~ MirEvent ledgerera
+    , Event (Ledger.EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera
+    , Event (Ledger.EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera
     ) =>
   ConvertLedgerEvent (ShelleyBlock ledgerera)
   where
     toLedgerEvent evt =
       case unwrapLedgerEvent evt of
         LESumRewards e m -> Just $ LedgerRewardDist e m
         LEMirTransfer rp tp _rtt _ttr -> Just $ LedgerMirDist (Map.unionWith plusCoin rp tp)
+        LERetiredPools r _u en -> Just $ LedgerPoolReap en r
         ShelleyLedgerEventBBODY {} -> Nothing
         ShelleyLedgerEventTICK {} -> Nothing
 
@@ -121,3 +128,25 @@ pattern LEMirTransfer rp tp rtt ttr <-
               )
           )
       )
+
+pattern LERetiredPools
+  :: ( Crypto ledgerera ~ StandardCrypto
+     , Event (Ledger.EraRule "TICK" ledgerera) ~ TickEvent ledgerera
+     , Event (Ledger.EraRule "NEWEPOCH" ledgerera) ~ NewEpochEvent ledgerera
+     , Event (Ledger.EraRule "EPOCH" ledgerera) ~ EpochEvent ledgerera
+     , Event (Ledger.EraRule "POOLREAP" ledgerera) ~ PoolreapEvent ledgerera
+     )
+  => Map (Ledger.StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin)
+  -> Map (Ledger.StakeCredential StandardCrypto) (Map (KeyHash 'StakePool StandardCrypto) Coin)
+  -> EpochNo
+  -> AuxLedgerEvent (LedgerState (ShelleyBlock ledgerera))
+pattern LERetiredPools r u e <-
+  ShelleyLedgerEventTICK
+    ( NewEpochEvent
+        ( EpochEvent
+            ( PoolReapEvent
+                ( RetiredPools r u e
+                  )
+              )
+          )
+      )

schema/migration-1-0005-20210311.sql

@@ -11,7 +11,7 @@ BEGIN
 
 	-- Would normally put this inside an "EXECUTE" statement, but that does not work for some
 	-- reason and this does. In Haskell code this is the RewardSource type.
-    CREATE TYPE rewardtype AS ENUM ('leader', 'member', 'reserves', 'treasury');
+    CREATE TYPE rewardtype AS ENUM ('leader', 'member', 'reserves', 'treasury', 'refund');
 
     UPDATE "schema_version" SET stage_one = next_version;
     RAISE NOTICE 'DB has been migrated to stage_one version %', next_version;