Merge pull request #962 from input-output-hk/erikd/more-rewards

Another rewards accounting issue

Author: erikd

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

@@ -762,7 +762,7 @@ insertTxMetadata tracer txId metadata =
     insert (key, md) = do
       let jsonbs = LBS.toStrict $ Aeson.encode (metadataValueToJsonNoSchema md)
           singleKeyCBORMetadata = serialiseToCBOR $ makeTransactionMetadata (Map.singleton key md)
-      mjson <- safeDecodeToJson tracer "insertTxMetdata" jsonbs
+      mjson <- safeDecodeToJson tracer "insertTxMetadata" jsonbs
 
       void . lift . DB.insertTxMetadata $
         DB.TxMetadata

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

@@ -62,15 +62,15 @@ finalizeEpochBulkOps lenv = do
   mapM_ (insertEpochInterleaved (leTrace lenv)) bops
 
 -- | This gets called with the full set of rewards. If there are no blocks produced in the last 20%
--- of the slots within an epoch, the rewards are updated in the normal way so they will be inserted
--- here.
+-- of the slots within an epoch, the rewards will not be updated in the normal way so they will be
+-- inserted here.
 forceInsertRewards
     :: (MonadBaseControl IO m, MonadIO m)
     => Trace IO Text -> LedgerEnv -> Generic.Rewards -> ReaderT SqlBackend m ()
 forceInsertRewards tracer lenv rwds = do
-  let mapSize = Map.size $ Generic.rwdRewards rwds
-  hasEntry <- DB.queryHasRewardsForEpoch $ unEpochNo (Generic.rwdEpoch rwds)
-  when (mapSize > 0 && not hasEntry) $ do
+  let mapSize = Generic.elemCount rwds
+  count <- fromIntegral <$> DB.queryEpochRewardCount (unEpochNo $ Generic.rwdEpoch rwds)
+  when (mapSize > count) $ do
     liftIO . logWarning tracer $ mconcat
                                 [ "forceInsertRewards: ", textShow mapSize, " rewards for epoch "
                                 , textShow (unEpochNo $ Generic.rwdEpoch rwds), " is "

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

@@ -17,14 +17,14 @@ module Cardano.Db.Query
   , queryBlocksAfterSlot
   , queryCalcEpochEntry
   , queryCheckPoints
+  , queryCurrentEpochNo
   , queryDepositUpToBlockNo
   , queryEpochEntry
   , queryEpochNo
-  , queryCurrentEpochNo
+  , queryEpochRewardCount
   , queryFeesUpToBlockNo
   , queryFeesUpToSlotNo
   , queryGenesisSupply
-  , queryHasRewardsForEpoch
   , queryShelleyGenesisSupply
   , queryLatestBlock
   , queryLatestCachedEpochNo
@@ -335,6 +335,13 @@ queryCurrentEpochNo = do
               pure $ max_ (blk ^. BlockEpochNo)
     pure $ join (unValue =<< listToMaybe res)
 
+queryEpochRewardCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64
+queryEpochRewardCount epochNum = do
+  res <- select . from $ \ rwds -> do
+            where_ (rwds ^. RewardSpendableEpoch ==. val epochNum)
+            pure countRows
+  pure $ maybe 0 unValue (listToMaybe res)
+
 -- | Get the fees paid in all block from genesis up to and including the specified block.
 queryFeesUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada
 queryFeesUpToBlockNo blkNo = do
@@ -363,13 +370,6 @@ queryGenesisSupply = do
                 pure $ sum_ (txOut ^. TxOutValue)
     pure $ unValueSumAda (listToMaybe res)
 
-queryHasRewardsForEpoch :: MonadIO m => Word64 -> ReaderT SqlBackend m Bool
-queryHasRewardsForEpoch epochNum = do
-  res <- select . from $ \ rwds -> do
-            where_ (rwds ^. RewardSpendableEpoch ==. val epochNum)
-            pure countRows
-  pure $ maybe False (\c -> unValue c > 0) (listToMaybe res :: Maybe (Value Word64))
-
 -- | Return the total Shelley Genesis coin supply. The Shelley Genesis Block
 -- is the unique which has a non-null PreviousId, but has null Epoch.
 queryShelleyGenesisSupply :: MonadIO m => ReaderT SqlBackend m Ada

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

@@ -6,6 +6,7 @@
 module Cardano.Sync.Era.Shelley.Generic.Rewards
   ( Reward (..)
   , Rewards (..)
+  , elemCount
   , epochRewards
   , mergeRewards
   , rewardsPoolHashKeys
@@ -59,6 +60,9 @@ data Rewards = Rewards
   , rwdRewards :: !(Map StakeCred (Set Reward))
   } deriving Eq
 
+elemCount :: Rewards -> Int
+elemCount = sum . map Set.size . Map.elems . rwdRewards
+
 epochRewards :: Ledger.Network -> EpochNo -> ExtLedgerState CardanoBlock -> Maybe Rewards
 epochRewards nw epoch lstate =
     case ledgerState lstate of
@@ -75,7 +79,7 @@ mergeRewards :: Rewards -> Rewards -> Rewards
 mergeRewards amap bmap =
   Rewards
     { rwdEpoch = max (rwdEpoch amap) (rwdEpoch bmap)
-    , rwdRewards = Map.unionWith Set.union (rwdRewards amap) (rwdRewards bmap)
+    , rwdRewards = Map.unionWith mappend (rwdRewards amap) (rwdRewards bmap)
     }
 
 rewardsPoolHashKeys :: Rewards -> Set StakePoolKeyHash

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

@@ -116,7 +116,7 @@ convertMirRewards nw resPay trePay =
     convertResPay = mapBimap (Generic.toStakeCred nw) (mkPayment RwdReserves)
 
     convertTrePay :: Map (Ledger.StakeCredential StandardCrypto) Coin -> Map Generic.StakeCred (Set Generic.Reward)
-    convertTrePay = mapBimap (Generic.toStakeCred nw) (mkPayment RwdReserves)
+    convertTrePay = mapBimap (Generic.toStakeCred nw) (mkPayment RwdTreasury)
 
     mkPayment :: RewardSource -> Coin -> Set Generic.Reward
     mkPayment src coin =