{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Babbage.Imp.PoolSpec (babbageEraSpecificSpec) where

import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.State
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential
import Cardano.Ledger.Rewards
import Cardano.Ledger.Shelley.Rules
import Control.Monad (zipWithM_)
import Data.Coerce
import Data.Map ((!))
import qualified Data.Set as Set
import Data.Typeable (cast)
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Babbage.ImpTest
import Test.Cardano.Ledger.Imp.Common

babbageEraSpecificSpec ::
  forall era.
  ( BabbageEraImp era
  , ShelleyEraAccounts era
  , Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
babbageEraSpecificSpec :: forall era.
(BabbageEraImp era, ShelleyEraAccounts era,
 Event (EraRule "NEWEPOCH" era) ~ ShelleyNewEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
babbageEraSpecificSpec = do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Pool to pool member rewards" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- This test attempts to reproduce the issue that appeared with the release of
    -- `cardano-db-sync-10.6.1` (using `cardano-ledger-shelley-1.17.0.0`),
    -- where all of a sudden some rewards gone missing.
    -- Pools didn't receive member rewards when their reward accounts were delegated
    -- to other pools. This was only observed pre-Conway, see the `simpleRewards` test here:
    -- https://github.com/IntersectMBO/cardano-db-sync/blob/b8748fbbcb8c2d7e7a69e771914cc077bcdb3fa6/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Babbage/Reward.hs
    -- Also consult the genesis file which we try to immitate with the setup below:
    -- https://github.com/IntersectMBO/cardano-db-sync/blob/b8748fbbcb8c2d7e7a69e771914cc077bcdb3fa6/cardano-chain-gen/test/testfiles/config/genesis.json

    pools@[p1, p2, p3] <- Int
-> ImpM (LedgerSpec era) (KeyHash StakePool)
-> ImpM (LedgerSpec era) [KeyHash StakePool]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    poolSCreds@[s3, s7, _s8] <- replicateM 3 (KeyHashObj <$> freshKeyHash)
    screds@[s2, s4, s5] <- replicateM 3 (KeyHashObj <$> freshKeyHash)
    pcreds <- replicateM 6 (freshKeyHash @Payment)
    let addrs = (KeyHash Payment -> Credential Staking -> Addr)
-> [KeyHash Payment] -> [Credential Staking] -> [Addr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith KeyHash Payment -> Credential Staking -> Addr
forall p s.
(MakeCredential p Payment, MakeStakeReference s) =>
p -> s -> Addr
mkAddr [KeyHash Payment]
pcreds ([Credential Staking] -> [Addr]) -> [Credential Staking] -> [Addr]
forall a b. (a -> b) -> a -> b
$ [Credential Staking]
poolSCreds [Credential Staking]
-> [Credential Staking] -> [Credential Staking]
forall a. Semigroup a => a -> a -> a
<> [Credential Staking]
screds
        -- Pledge 0 makes the (pledge <= ownerStake) check in mkPoolRewardInfo
        -- trivially true, guaranteeing rewards flow. A nonzero pledge exceeding
        -- the owners' delegated stake would zero out the pool's rewards.
        registerPoolWithZeroPledge KeyHash StakePool
pk AccountAddress
rewAcc = do
          pps <- KeyHash StakePool -> AccountAddress -> ImpTestM era StakePoolParams
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> AccountAddress -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
pk AccountAddress
rewAcc
          submitTx_ $
            mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert pps {sppPledge = Coin 0}]

    rewAccs <- mapM registerStakeCredential poolSCreds >>= \[AccountAddress]
ras -> [AccountAddress]
ras [AccountAddress]
-> ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) [AccountAddress]
forall a b. a -> ImpM (LedgerSpec era) b -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ImpM (LedgerSpec era) [AccountAddress] -> ImpM (LedgerSpec era) ()
forall era a.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era a -> ImpTestM era ()
withTxsInBlock_ ([AccountAddress] -> ImpM (LedgerSpec era) [AccountAddress]
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [AccountAddress]
ras)
    withTxsInBlock_ $ mapM_ registerStakeCredential screds
    withTxsInBlock_ $ zipWithM_ registerPoolWithZeroPledge pools rewAccs
    withTxsInBlock_ $
      delegateStake s4 (coerce p3)
        >> delegateStake s5 (coerce p1)
        >> delegateStake s7 (coerce p3)
        >> delegateStake s3 (coerce p1)
        >> delegateStake s2 (coerce p2)

    -- Some transactions in order to fill up the fees pot and to make sure
    -- that our pools produce blocks so they can hand out rewards.
    forM_ pools $ \KeyHash StakePool
p ->
      KeyHash BlockIssuer
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(HasCallStack, ShelleyEraImp era) =>
KeyHash BlockIssuer -> ImpTestM era a -> ImpTestM era ()
withIssuerAndTxsInBlock_ (KeyHash StakePool -> KeyHash BlockIssuer
forall a b. Coercible a b => a -> b
coerce KeyHash StakePool
p) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        (Addr -> ImpM (LedgerSpec era) ())
-> [Addr] -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Addr -> Coin -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era ()
`sendCoinTo_` Integer -> Coin
Coin Integer
300_000_000) [Addr]
addrs

    passNEpochs 3

    -- Some more transactions in order to fill up the fees pot and to make sure
    -- that our pools produce blocks so they can hand out rewards.
    forM_ pools $ \KeyHash StakePool
p ->
      KeyHash BlockIssuer
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a.
(HasCallStack, ShelleyEraImp era) =>
KeyHash BlockIssuer -> ImpTestM era a -> ImpTestM era ()
withIssuerAndTxsInBlock_ (KeyHash StakePool -> KeyHash BlockIssuer
forall a b. Coercible a b => a -> b
coerce KeyHash StakePool
p) (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        (Addr -> ImpM (LedgerSpec era) ())
-> [Addr] -> ImpM (LedgerSpec era) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Addr -> Coin -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era ()
`sendCoinTo_` Integer -> Coin
Coin Integer
30_000_000) [Addr]
addrs

    -- We want to make sure that `s7`, the reward account associated with `p2`, receives
    -- member rewards (because they delegated to `p3`, which is producing blocks).
    let
      isMemberRewardEvent (SomeSTSEvent Event (EraRule rule era)
ev)
        | Just (TickNewEpochEvent (TotalRewardEvent EpochNo
_ Map (Credential Staking) (Set Reward)
m) :: ShelleyTickEvent era) <- Event (EraRule rule era) -> Maybe (ShelleyTickEvent era)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Event (EraRule rule era)
ev =
            Set Reward -> Int
forall a. Set a -> Int
Set.size ((Reward -> Bool) -> Set Reward -> Set Reward
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((RewardType -> RewardType -> Bool
forall a. Eq a => a -> a -> Bool
== RewardType
MemberReward) (RewardType -> Bool) -> (Reward -> RewardType) -> Reward -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reward -> RewardType
rewardType) (Map (Credential Staking) (Set Reward)
m Map (Credential Staking) (Set Reward)
-> Credential Staking -> Set Reward
forall k a. Ord k => Map k a -> k -> a
! Item [Credential Staking]
Credential Staking
s7)) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
      isMemberRewardEvent SomeSTSEvent era
_ = Bool
False

    passEpoch
    finalEvs <- impEventsFrom passEpoch
    let res = (SomeSTSEvent era -> Bool)
-> [SomeSTSEvent era] -> [SomeSTSEvent era]
forall a. (a -> Bool) -> [a] -> [a]
filter SomeSTSEvent era -> Bool
forall {era}. SomeSTSEvent era -> Bool
isMemberRewardEvent [SomeSTSEvent era]
finalEvs

    -- This assertion should fail if pool-to-pool delegation
    -- fails to yield member rewards. However, that is not the
    -- case here, so ultimately I could not reproduce the behaviour
    -- that was observed in `cardano-db-syn-10.6.1`.
    length res `shouldBe` 1