Merge pull request IntersectMBO#1272 from input-output-hk/erikd/db-tool-report

db-tool: Update/improve/fix reward queries

Author: erikd

cardano-db-tool/app/cardano-db-tool.hs

@@ -219,7 +219,10 @@ pReport =
     pReward :: Parser Report
     pReward =
       Opt.subparser $ mconcat
-        [ Opt.command "latest"
+        [ Opt.command "epoch"
+            $ Opt.info (ReportEpochRewards <$> pEpochNo <*> pStakeAddress)
+                (Opt.progDesc "Report the rewards fof the gievn epoch and stake address (or addresses)")
+        , Opt.command "latest"
             $ Opt.info (ReportLatestRewards <$> pStakeAddress)
                 (Opt.progDesc "Report the latest epoch rewards for a given stake address (or addresses)")
         , Opt.command "history"
@@ -234,3 +237,11 @@ pReport =
             (  Opt.long "stake-address"
             <> Opt.help "Either a single stake address or a comma separated list."
             )
+
+    pEpochNo :: Parser Word64
+    pEpochNo =
+      Opt.option Opt.auto $ mconcat
+        [ Opt.long "epoch"
+        , Opt.metavar "WORD"
+        , Opt.help "The epoch number."
+        ]

cardano-db-tool/cardano-db-tool.cabal

@@ -82,6 +82,7 @@ library
                       , random
                       , random-shuffle
                       , text
+                      , text-icu
                       , time
                       , transformers
                       , transformers-except

cardano-db-tool/src/Cardano/DbTool/Report.hs

@@ -5,17 +5,19 @@ module Cardano.DbTool.Report
   ) where
 
 import           Cardano.DbTool.Report.Balance (reportBalance)
-import           Cardano.DbTool.Report.StakeReward (reportLatestStakeRewards,
-                   reportStakeRewardHistory)
+import           Cardano.DbTool.Report.StakeReward (reportEpochStakeRewards,
+                   reportLatestStakeRewards, reportStakeRewardHistory)
 import           Cardano.DbTool.Report.Synced as X
 import           Cardano.DbTool.Report.Transactions (reportTransactions)
 
 import           Data.Text (Text)
+import           Data.Word (Word64)
 
 
 data Report
   = ReportAllRewards [Text]
   | ReportBalance [Text]
+  | ReportEpochRewards Word64 [Text]
   | ReportLatestRewards [Text]
   | ReportTransactions [Text]
 
@@ -25,5 +27,6 @@ runReport report = do
   case report of
     ReportAllRewards sas -> mapM_ reportStakeRewardHistory sas
     ReportBalance sas -> reportBalance sas
+    ReportEpochRewards ep sas -> reportEpochStakeRewards ep sas
     ReportLatestRewards sas -> reportLatestStakeRewards sas
     ReportTransactions sas -> reportTransactions sas

cardano-db-tool/src/Cardano/DbTool/Report/Display.hs

@@ -1,19 +1,28 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Cardano.DbTool.Report.Display
   ( leftPad
+  , rightPad
   , separator
   , spaces
   ) where
 
+import qualified Data.List as List
 import           Data.Text (Text)
 import qualified Data.Text as Text
-
+import qualified Data.Text.ICU as ICU
 
 leftPad :: Int -> Text -> Text
-leftPad width txt = Text.take (width - Text.length txt) spaces <> txt
+leftPad width txt = Text.take (width - textDisplayLen txt) spaces <> txt
+
+rightPad :: Int -> Text -> Text
+rightPad width txt = txt <> Text.take (width - textDisplayLen txt) spaces
 
 separator :: Text
 separator = " | "
 
 spaces :: Text
 spaces = "                                                        "
+
+-- Calculates the screen character count a `Text` object will use when printed.
+textDisplayLen :: Text -> Int
+textDisplayLen = List.length . ICU.breaks (ICU.breakCharacter ICU.Root)

cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs

@@ -9,20 +9,20 @@ module Cardano.DbTool.Report.StakeReward.History
 import           Cardano.Db
 import           Cardano.DbTool.Report.Display
 
+import           Control.Monad (join)
 import           Control.Monad.IO.Class (MonadIO)
 import           Control.Monad.Trans.Reader (ReaderT)
 
 import qualified Data.List as List
-import           Data.Maybe (fromMaybe, mapMaybe)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
 import           Data.Time.Clock (UTCTime)
 import           Data.Word (Word64)
 
-import           Database.Esqueleto.Experimental (SqlBackend, Value (..), asc, from, innerJoin,
-                   max_, on, orderBy, select, table, type (:&) ((:&)), val, where_, (<=.), (==.),
-                   (^.))
+import           Database.Esqueleto.Experimental (SqlBackend, Value (..), asc, desc, from,
+                   innerJoin, max_, on, orderBy, select, table, type (:&) ((:&)), unSqlBackendKey,
+                   val, where_, (<=.), (==.), (^.))
 
 import           Text.Printf (printf)
 
@@ -49,52 +49,63 @@ data EpochReward = EpochReward
   , erEpochNo :: !Word64
   , erDate :: !UTCTime
   , erAddress :: !Text
+  , erPoolId :: !Word64
+  , erPoolTicker :: !Text
   , erReward :: !Ada
   , erDelegated :: !Ada
   , erPercent :: !Double
   }
-
 queryHistoryStakeRewards :: MonadIO m => Text -> ReaderT SqlBackend m [EpochReward]
 queryHistoryStakeRewards address = do
-    maxEpoch <- queryMaxEpochRewardNo
+    maxEpoch <- queryLatestMemberRewardEpochNo
     mapM queryReward =<< queryDelegation maxEpoch
   where
     queryDelegation
         :: MonadIO m
-        => Word64 -> ReaderT SqlBackend m [(StakeAddressId, Word64, UTCTime, DbLovelace)]
+        => Word64 -> ReaderT SqlBackend m [(StakeAddressId, Word64, UTCTime, DbLovelace, PoolHashId)]
     queryDelegation maxEpoch = do
       res <- select $ do
-        (epoch :& es :& saddr) <-
-          from $ table @Epoch
-          `innerJoin` table @EpochStake
-          `on` (\(epoch :& es) -> epoch ^. EpochNo ==. es ^. EpochStakeEpochNo)
-          `innerJoin` table @StakeAddress
-          `on` (\(_epoch :& es :& saddr) ->saddr ^. StakeAddressId ==. es ^. EpochStakeAddrId)
-        where_ (saddr ^. StakeAddressView ==. val address)
-        where_ (es ^. EpochStakeEpochNo <=. val maxEpoch)
-        pure (es ^. EpochStakeAddrId, es ^. EpochStakeEpochNo, epoch ^.EpochEndTime, es ^. EpochStakeAmount)
-      pure $ map unValue4 res
+              (ep :& es :& saddr) <-
+                from $ table @Epoch
+                `innerJoin` table @EpochStake
+                  `on` (\(ep :& es) -> ep ^. EpochNo ==. es ^. EpochStakeEpochNo)
+                `innerJoin` table @StakeAddress
+                  `on` (\(_ep :& es :& saddr) ->saddr ^. StakeAddressId ==. es ^. EpochStakeAddrId)
+              where_ (saddr ^. StakeAddressView ==. val address)
+              where_ (es ^. EpochStakeEpochNo <=. val maxEpoch)
+              pure (es ^. EpochStakeAddrId, es ^. EpochStakeEpochNo, ep ^.EpochEndTime
+                    , es ^. EpochStakeAmount, es ^. EpochStakePoolId)
+      pure $ map unValue5 res
 
     queryReward
         :: MonadIO m
-        => (StakeAddressId, Word64, UTCTime, DbLovelace)
+        => (StakeAddressId, Word64, UTCTime, DbLovelace, PoolHashId)
         -> ReaderT SqlBackend m EpochReward
-    queryReward (saId, en, date, DbLovelace delegated) = do
+    queryReward (saId, en, date, DbLovelace delegated, poolId) = do
       res <- select $ do
-        ( saddr :& reward :& epoch) <-
-          from $ table @StakeAddress
-          `innerJoin` table @Reward
-          `on` (\(saddr :& reward) -> saddr ^. StakeAddressId ==. reward ^. RewardAddrId)
-          `innerJoin` table @Epoch
-          `on` (\(_saddr :& reward :& epoch) -> epoch ^. EpochNo ==. reward ^. RewardEarnedEpoch)
-        where_ (epoch ^. EpochNo ==. val en)
-        where_ (saddr ^. StakeAddressId ==. val saId)
-        orderBy [asc (epoch ^. EpochNo)]
-        pure  (reward ^. RewardAmount)
+              (saddr :& rwd :& ep) <-
+                  from $ table @StakeAddress
+                  `innerJoin` table @Reward
+                    `on` (\(saddr :& rwd) -> saddr ^. StakeAddressId ==. rwd ^. RewardAddrId)
+                  `innerJoin` table @Epoch
+                    `on` (\(_saddr :& rwd :& ep) -> ep ^. EpochNo ==. rwd ^. RewardEarnedEpoch)
+              where_ (ep ^. EpochNo ==. val en)
+              where_ (saddr ^. StakeAddressId ==. val saId)
+              orderBy [asc (ep ^. EpochNo)]
+              pure  (rwd ^. RewardAmount)
+
+      mtn <- select $ do
+              pod <- from $ table @PoolOfflineData
+              where_ (pod ^. PoolOfflineDataPoolId ==. val poolId)
+              -- Use the `id` column as a proxy for time where larger `id` means later time.
+              orderBy [desc (pod ^. PoolOfflineDataId)]
+              pure (pod ^. PoolOfflineDataTickerName)
 
       let reward = maybe 0 (unDbLovelace . unValue) (listToMaybe res)
       pure $ EpochReward
               { erAddressId = saId
+              , erPoolId = fromIntegral $ unSqlBackendKey (unPoolHashKey poolId)
+              , erPoolTicker = maybe "???" unValue (listToMaybe mtn)
               , erEpochNo = en
               , erDate = date
               , erAddress = address
@@ -103,20 +114,22 @@ queryHistoryStakeRewards address = do
               , erPercent = rewardPercent reward (if delegated == 0 then Nothing else Just delegated)
               }
 
-    queryMaxEpochRewardNo
-        :: MonadIO m
-        => ReaderT SqlBackend m Word64
-    queryMaxEpochRewardNo = do
+    -- Find the latest epoch where member rewards have been distributed.
+    -- Can't use the Reward table for this because that table may have been partially
+    -- populated for the next epcoh.
+    queryLatestMemberRewardEpochNo :: MonadIO m => ReaderT SqlBackend m Word64
+    queryLatestMemberRewardEpochNo = do
       res <- select $ do
-        reward <- from $ table @Reward
-        pure (max_ (reward ^. RewardEarnedEpoch))
-      pure $ fromMaybe 0 (listToMaybe $ mapMaybe unValue res)
+               blk <- from $ table @Block
+               where_ (isJust $ blk ^. BlockEpochNo)
+               pure $ max_ (blk ^. BlockEpochNo)
+      pure $ maybe 0 (pred . pred) (join $ unValue =<< listToMaybe res)
 
 renderRewards :: Text -> [EpochReward] -> IO ()
 renderRewards saddr xs = do
     Text.putStrLn $ mconcat [ "\nRewards for: ", saddr, "\n" ]
-    putStrLn " epoch |      reward_date        |     delegated  |     reward   |  RoS (%pa)"
-    putStrLn "-------+-------------------------+----------------+--------------+-----------"
+    putStrLn " epoch |      reward_date        |    delegated   | pool_id | ticker |   reward     | RoS (%pa)"
+    putStrLn "-------+-------------------------+----------------+---------+--------+--------------+-----------"
     mapM_ renderReward xs
     putStrLn ""
   where
@@ -129,6 +142,10 @@ renderRewards saddr xs = do
         , separator
         , leftPad 14 (renderAda (erDelegated er))
         , separator
+        , leftPad 7 (textShow $ erPoolId er)
+        , separator
+        , rightPad 6 (erPoolTicker er)
+        , separator
         , leftPad 12 (specialRenderAda (erReward er))
         , separator
         , Text.pack (if erPercent er == 0.0 then "   0.0" else printf "%8.3f" (erPercent er))