{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Dijkstra.Rules.PoolReap (
  POOLREAP,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin, CompactForm)
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Era (DijkstraEra, POOLREAP)
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
import Cardano.Ledger.Shelley.Rules (
  ShelleyPoolreapEvent (..),
  ShelleyPoolreapState (..),
  poolReapAssertions,
  renderPoolReapViolation,
 )
import Cardano.Ledger.State
import Cardano.Ledger.Val ((<+>), (<->))
import Control.State.Transition (
  Assertion (..),
  AssertionViolation (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  tellEvent,
 )
import Data.Default (Default)
import Data.Foldable (fold)
import Data.Foldable as F (foldl')
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Void (Void)
import Lens.Micro

-- The `POOLREAP` rule of the Dijkstra era mirrors the Shelley one, except for how it keeps
-- `psVRFKeyHashes` and `psBlsKeyHashes` in sync with the registered stake pools. Dropping
-- the VRF key hashes that a re-registration supersedes, the way Shelley does, loses the
-- references that other pools still hold to the same hash. Instead, every pool that
-- switches to a different VRF key hash releases a single reference to its active one,
-- just like every retired pool releases a single reference to the VRF key hash it uses.
-- The BLS key hashes that pools stop using in the same way are removed from
-- `psBlsKeyHashes`.
-- The `POOLREAP` rule type itself is declared in "Cardano.Ledger.Dijkstra.Era".
type instance EraRuleEvent "POOLREAP" DijkstraEra = ShelleyPoolreapEvent DijkstraEra

instance
  ( Default (ShelleyPoolreapState era)
  , EraPParams era
  , EraGov era
  , EraCertState era
  ) =>
  STS (POOLREAP era)
  where
  type State (POOLREAP era) = ShelleyPoolreapState era
  type Signal (POOLREAP era) = EpochNo
  type Environment (POOLREAP era) = ()
  type BaseM (POOLREAP era) = ShelleyBase
  type PredicateFailure (POOLREAP era) = Void
  type Event (POOLREAP era) = ShelleyPoolreapEvent era
  transitionRules :: [TransitionRule (POOLREAP era)]
transitionRules = [TransitionRule (POOLREAP era)
forall era. EraCertState era => TransitionRule (POOLREAP era)
poolReapTransition]

  renderAssertionViolation :: AssertionViolation (POOLREAP era) -> String
renderAssertionViolation AssertionViolation (POOLREAP era)
av =
    AssertionViolation (POOLREAP era) -> String
forall era t.
(EraGov era, State t ~ ShelleyPoolreapState era,
 EraCertState era) =>
AssertionViolation t -> String
renderPoolReapViolation AssertionViolation (POOLREAP era)
av String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (ShelleyPoolreapState era -> String)
-> Maybe (ShelleyPoolreapState era) -> String
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ShelleyPoolreapState era -> String
forall era. EraCertState era => ShelleyPoolreapState era -> String
renderKeyHashes (AssertionViolation (POOLREAP era) -> Maybe (State (POOLREAP era))
forall sts. AssertionViolation sts -> Maybe (State sts)
avState AssertionViolation (POOLREAP era)
av)
  assertions :: [Assertion (POOLREAP era)]
assertions =
    [Assertion (POOLREAP era)]
forall era t.
(EraGov era, State t ~ ShelleyPoolreapState era,
 EraCertState era) =>
[Assertion t]
poolReapAssertions
      [Assertion (POOLREAP era)]
-> [Assertion (POOLREAP era)] -> [Assertion (POOLREAP era)]
forall a. Semigroup a => a -> a -> a
<> [ String
-> (TRC (POOLREAP era) -> State (POOLREAP era) -> Bool)
-> Assertion (POOLREAP era)
forall sts.
String -> (TRC sts -> State sts -> Bool) -> Assertion sts
PostCondition
             String
"VRF and BLS key hashes must match those recomputed from the stake pools (PoolReap)"
             (\TRC (POOLREAP era)
_trc -> (PState era -> PState era -> Bool)
-> (PState era, PState era) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PState era -> PState era -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((PState era, PState era) -> Bool)
-> (ShelleyPoolreapState era -> (PState era, PState era))
-> ShelleyPoolreapState era
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyPoolreapState era -> (PState era, PState era)
forall era.
EraCertState era =>
ShelleyPoolreapState era -> (PState era, PState era)
recomputedKeyHashes)
         ]

-- | The pool state that @POOLREAP@ leaves behind, together with the same state with its VRF
-- and BLS key hashes recomputed from the stake pools that remain registered. Its
-- post-condition requires them to be equal.
recomputedKeyHashes :: EraCertState era => ShelleyPoolreapState era -> (PState era, PState era)
recomputedKeyHashes :: forall era.
EraCertState era =>
ShelleyPoolreapState era -> (PState era, PState era)
recomputedKeyHashes ShelleyPoolreapState era
st = (PState era
ps, PState era -> PState era
forall era. PState era -> PState era
populateBlsKeyHashes (PState era -> PState era
forall era. PState era -> PState era
populateVRFKeyHashes PState era
ps))
  where
    ps :: PState era
ps = ShelleyPoolreapState era -> CertState era
forall era. ShelleyPoolreapState era -> CertState era
prCertState ShelleyPoolreapState era
st CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL

renderKeyHashes :: EraCertState era => ShelleyPoolreapState era -> String
renderKeyHashes :: forall era. EraCertState era => ShelleyPoolreapState era -> String
renderKeyHashes ShelleyPoolreapState era
st =
  String
"\nVRF key hash counts (psVRFKeyHashes) = "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map (VRFVerKeyHash StakePoolVRF) Word64 -> String
forall a. Show a => a -> String
show (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes PState era
ps)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nVRF key hash counts recomputed from the stake pools (populateVRFKeyHashes) = "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map (VRFVerKeyHash StakePoolVRF) Word64 -> String
forall a. Show a => a -> String
show (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero (NonZero Word64 -> Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes PState era
recomputed)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nBLS key hashes (psBlsKeyHashes) = "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set BlsVerKeyHash -> String
forall a. Show a => a -> String
show (PState era -> Set BlsVerKeyHash
forall era. PState era -> Set BlsVerKeyHash
psBlsKeyHashes PState era
ps)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nBLS key hashes recomputed from the stake pools (populateBlsKeyHashes) = "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Set BlsVerKeyHash -> String
forall a. Show a => a -> String
show (PState era -> Set BlsVerKeyHash
forall era. PState era -> Set BlsVerKeyHash
psBlsKeyHashes PState era
recomputed)
  where
    (PState era
ps, PState era
recomputed) = ShelleyPoolreapState era -> (PState era, PState era)
forall era.
EraCertState era =>
ShelleyPoolreapState era -> (PState era, PState era)
recomputedKeyHashes ShelleyPoolreapState era
st

poolReapTransition :: forall era. EraCertState era => TransitionRule (POOLREAP era)
poolReapTransition :: forall era. EraCertState era => TransitionRule (POOLREAP era)
poolReapTransition = do
  TRC (_, PoolreapState us a cs0, e) <- Rule
  (POOLREAP era) 'Transition (RuleContext 'Transition (POOLREAP era))
F (Clause (POOLREAP era) 'Transition) (TRC (POOLREAP era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let
    ps0 = CertState era
cs0 CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    -- The keys that pools stop using, as given by `activeKey` and `futureKey` for their
    -- active and future parameters: a pool whose future parameters change its key stops
    -- using the active one once they are adopted, and a retiring pool stops using the one
    -- it has by then. A key that several of these pools share is listed once for each of
    -- them.
    releasedKeys :: Eq k => (StakePoolState -> k) -> (StakePoolParams era -> k) -> [k]
    releasedKeys StakePoolState -> k
activeKey StakePoolParams era -> k
futureKey =
      Map (KeyHash StakePool) k -> [k]
forall k a. Map k a -> [a]
Map.elems
        ( SimpleWhenMissing (KeyHash StakePool) StakePoolState k
-> SimpleWhenMissing (KeyHash StakePool) (StakePoolParams era) k
-> SimpleWhenMatched
     (KeyHash StakePool) StakePoolState (StakePoolParams era) k
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) (StakePoolParams era)
-> Map (KeyHash StakePool) k
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
            SimpleWhenMissing (KeyHash StakePool) StakePoolState k
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
            SimpleWhenMissing (KeyHash StakePool) (StakePoolParams era) k
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
            ( (KeyHash StakePool
 -> StakePoolState -> StakePoolParams era -> Maybe k)
-> SimpleWhenMatched
     (KeyHash StakePool) StakePoolState (StakePoolParams era) k
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> Maybe z) -> WhenMatched f k x y z
Map.zipWithMaybeMatched ((KeyHash StakePool
  -> StakePoolState -> StakePoolParams era -> Maybe k)
 -> SimpleWhenMatched
      (KeyHash StakePool) StakePoolState (StakePoolParams era) k)
-> (KeyHash StakePool
    -> StakePoolState -> StakePoolParams era -> Maybe k)
-> SimpleWhenMatched
     (KeyHash StakePool) StakePoolState (StakePoolParams era) k
forall a b. (a -> b) -> a -> b
$ \KeyHash StakePool
_ StakePoolState
sps StakePoolParams era
sppF ->
                let key :: k
key = StakePoolState -> k
activeKey StakePoolState
sps in if k
key k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/= StakePoolParams era -> k
futureKey StakePoolParams era
sppF then k -> Maybe k
forall a. a -> Maybe a
Just k
key else Maybe k
forall a. Maybe a
Nothing
            )
            (PState era
ps0 PState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (PState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (KeyHash StakePool) StakePoolState)
  (PState era)
  (Map (KeyHash StakePool) StakePoolState)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL)
            (PState era
ps0 PState era
-> Getting
     (Map (KeyHash StakePool) (StakePoolParams era))
     (PState era)
     (Map (KeyHash StakePool) (StakePoolParams era))
-> Map (KeyHash StakePool) (StakePoolParams era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (KeyHash StakePool) (StakePoolParams era))
  (PState era)
  (Map (KeyHash StakePool) (StakePoolParams era))
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) (StakePoolParams era)
 -> f (Map (KeyHash StakePool) (StakePoolParams era)))
-> PState era -> f (PState era)
psFutureStakePoolParamsL)
        )
        [k] -> [k] -> [k]
forall a. Semigroup a => a -> a -> a
<> (StakePoolState -> k
activeKey (StakePoolState -> k) -> [StakePoolState] -> [k]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (KeyHash StakePool) StakePoolState -> [StakePoolState]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash StakePool) StakePoolState
retiringPools)

    -- activate future stakePools
    ps =
      PState era
ps0
        { psStakePools =
            Map.merge
              Map.dropMissing
              Map.preserveMissing
              ( Map.zipWithMatched $ \KeyHash StakePool
_ StakePoolParams era
futureParams StakePoolState
currentState ->
                  EpochNo
-> StrictMaybe BlsKeyState
-> CompactForm Coin
-> Set (Credential Staking)
-> StakePoolParams era
-> StakePoolState
forall era.
EpochNo
-> StrictMaybe BlsKeyState
-> CompactForm Coin
-> Set (Credential Staking)
-> StakePoolParams era
-> StakePoolState
mkStakePoolState
                    EpochNo
Signal (POOLREAP era)
e
                    -- the pool keeps the epoch its voting key was registered in unless the re-registration actually rotates it
                    (StakePoolState
currentState StakePoolState
-> Getting
     (StrictMaybe BlsKeyState) StakePoolState (StrictMaybe BlsKeyState)
-> StrictMaybe BlsKeyState
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe BlsKeyState) StakePoolState (StrictMaybe BlsKeyState)
Lens' StakePoolState (StrictMaybe BlsKeyState)
spsBlsKeyL)
                    (StakePoolState
currentState StakePoolState
-> Getting (CompactForm Coin) StakePoolState (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) StakePoolState (CompactForm Coin)
Lens' StakePoolState (CompactForm Coin)
spsDepositL)
                    (StakePoolState
currentState StakePoolState
-> Getting
     (Set (Credential Staking))
     StakePoolState
     (Set (Credential Staking))
-> Set (Credential Staking)
forall s a. s -> Getting a s a -> a
^. Getting
  (Set (Credential Staking))
  StakePoolState
  (Set (Credential Staking))
Lens' StakePoolState (Set (Credential Staking))
spsDelegatorsL)
                    StakePoolParams era
futureParams
              )
              (ps0 ^. psFutureStakePoolParamsL)
              (ps0 ^. psStakePoolsL)
        , psFutureStakePoolParams = Map.empty
        }
    cs = CertState era
cs0 CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> PState era -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PState era
ps

    ds = CertState era
cs CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    -- The set of pools retiring this epoch
    retired :: Set (KeyHash StakePool)
    retired = [KeyHash StakePool] -> Set (KeyHash StakePool)
forall a. [a] -> Set a
Set.fromDistinctAscList [KeyHash StakePool
k | (KeyHash StakePool
k, EpochNo
v) <- Map (KeyHash StakePool) EpochNo -> [(KeyHash StakePool, EpochNo)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (PState era -> Map (KeyHash StakePool) EpochNo
forall era. PState era -> Map (KeyHash StakePool) EpochNo
psRetiring PState era
ps), EpochNo
v EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
== EpochNo
Signal (POOLREAP era)
e]
    -- The Map of pools retiring this epoch
    retiringPools :: Map.Map (KeyHash StakePool) StakePoolState
    retiringPools = Map (KeyHash StakePool) StakePoolState
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
ps) Set (KeyHash StakePool)
retired

    -- Every pool releases a single reference to each VRF key hash it stops using, and the BLS
    -- key hashes that pools stop using are removed, which keeps the invariants documented in
    -- "Cardano.Ledger.Dijkstra.Rules.Pool".
    vrfKeyHashes =
      (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> VRFVerKeyHash StakePoolVRF
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> [VRFVerKeyHash StakePoolVRF]
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
        ((VRFVerKeyHash StakePoolVRF
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall a b c. (a -> b -> c) -> b -> a -> c
flip VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeVRFKeyHashOccurrence)
        (PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes PState era
ps0)
        ((StakePoolState -> VRFVerKeyHash StakePoolVRF)
-> (StakePoolParams era -> VRFVerKeyHash StakePoolVRF)
-> [VRFVerKeyHash StakePoolVRF]
forall k.
Eq k =>
(StakePoolState -> k) -> (StakePoolParams era -> k) -> [k]
releasedKeys StakePoolState -> VRFVerKeyHash StakePoolVRF
spsVrf StakePoolParams era -> VRFVerKeyHash StakePoolVRF
forall era. StakePoolParams era -> VRFVerKeyHash StakePoolVRF
sppVrf)
    blsKeyHashes =
      PState era -> Set BlsVerKeyHash
forall era. PState era -> Set BlsVerKeyHash
psBlsKeyHashes PState era
ps0
        Set BlsVerKeyHash -> Set BlsVerKeyHash -> Set BlsVerKeyHash
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [BlsVerKeyHash] -> Set BlsVerKeyHash
forall a. Ord a => [a] -> Set a
Set.fromList
          [ BlsVerKeyHash
blsKeyHash
          | SJust BlsVerKeyHash
blsKeyHash <-
              (StakePoolState -> StrictMaybe BlsVerKeyHash)
-> (StakePoolParams era -> StrictMaybe BlsVerKeyHash)
-> [StrictMaybe BlsVerKeyHash]
forall k.
Eq k =>
(StakePoolState -> k) -> (StakePoolParams era -> k) -> [k]
releasedKeys ((BlsKeyState -> BlsVerKeyHash)
-> StrictMaybe BlsKeyState -> StrictMaybe BlsVerKeyHash
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlsKey -> BlsVerKeyHash
hashBlsKey (BlsKey -> BlsVerKeyHash)
-> (BlsKeyState -> BlsKey) -> BlsKeyState -> BlsVerKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlsKeyState -> BlsKey
bksKey) (StrictMaybe BlsKeyState -> StrictMaybe BlsVerKeyHash)
-> (StakePoolState -> StrictMaybe BlsKeyState)
-> StakePoolState
-> StrictMaybe BlsVerKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolState -> StrictMaybe BlsKeyState
spsBlsKey) ((BlsKey -> BlsVerKeyHash)
-> StrictMaybe BlsKey -> StrictMaybe BlsVerKeyHash
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlsKey -> BlsVerKeyHash
hashBlsKey (StrictMaybe BlsKey -> StrictMaybe BlsVerKeyHash)
-> (StakePoolParams era -> StrictMaybe BlsKey)
-> StakePoolParams era
-> StrictMaybe BlsVerKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolParams era -> StrictMaybe BlsKey
forall era. StakePoolParams era -> StrictMaybe BlsKey
sppBlsKey)
          ]

    -- collect all of the potential refunds
    accountRefunds :: Map.Map (Credential Staking) (CompactForm Coin)
    accountRefunds =
      (CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> [(Credential Staking, CompactForm Coin)]
-> Map (Credential Staking) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>)
        [(AccountId -> Credential Staking
unAccountId (AccountId -> Credential Staking)
-> AccountId -> Credential Staking
forall a b. (a -> b) -> a -> b
$ StakePoolState -> AccountId
spsAccountId StakePoolState
sps, StakePoolState -> CompactForm Coin
spsDeposit StakePoolState
sps) | StakePoolState
sps <- Map (KeyHash StakePool) StakePoolState -> [StakePoolState]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash StakePool) StakePoolState
retiringPools]
    accounts = DState era
ds DState era
-> Getting (Accounts era) (DState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. Getting (Accounts era) (DState era) (Accounts era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
    -- Deposits that can be refunded and those that are unclaimed (to be deposited into the treasury).
    refunds, unclaimedDeposits :: Map.Map (Credential Staking) (CompactForm Coin)
    (refunds, unclaimedDeposits) =
      Map.partitionWithKey
        (\Credential Staking
stakeCred CompactForm Coin
_ -> Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
stakeCred Accounts era
accounts) -- (k ∈ dom (rewards ds))
        accountRefunds

    refunded = Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) (CompactForm Coin)
refunds
    unclaimed = Map (Credential Staking) (CompactForm Coin) -> CompactForm Coin
forall m. Monoid m => Map (Credential Staking) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential Staking) (CompactForm Coin)
unclaimedDeposits

  tellEvent $
    let rewardAccountsWithPool =
          (KeyHash StakePool
 -> StakePoolState
 -> Map
      (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
 -> Map
      (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin)))
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
-> Map (KeyHash StakePool) StakePoolState
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey'
            ( \KeyHash StakePool
poolId StakePoolState
sps ->
                let cred :: Credential Staking
cred = AccountId -> Credential Staking
unAccountId (AccountId -> Credential Staking)
-> AccountId -> Credential Staking
forall a b. (a -> b) -> a -> b
$ StakePoolState -> AccountId
spsAccountId StakePoolState
sps
                 in (Map (KeyHash StakePool) (CompactForm Coin)
 -> Map (KeyHash StakePool) (CompactForm Coin)
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> Credential Staking
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
-> Map
     (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((CompactForm Coin -> CompactForm Coin -> CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
-> Map (KeyHash StakePool) (CompactForm Coin)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
(<>)) Credential Staking
cred (KeyHash StakePool
-> CompactForm Coin -> Map (KeyHash StakePool) (CompactForm Coin)
forall k a. k -> a -> Map k a
Map.singleton KeyHash StakePool
poolId (StakePoolState -> CompactForm Coin
spsDeposit StakePoolState
sps))
            )
            Map
  (Credential Staking) (Map (KeyHash StakePool) (CompactForm Coin))
forall k a. Map k a
Map.empty
            Map (KeyHash StakePool) StakePoolState
retiringPools
        (refundPools', unclaimedPools') =
          Map.partitionWithKey
            (\Credential Staking
cred Map (KeyHash StakePool) (CompactForm Coin)
_ -> Credential Staking -> Accounts era -> Bool
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred Accounts era
accounts)
            rewardAccountsWithPool
     in RetiredPools
          { refundPools = refundPools'
          , unclaimedPools = unclaimedPools'
          , epochNo = e
          }
  pure $
    PoolreapState
      us {utxosDeposited = utxosDeposited us <-> fromCompact (unclaimed <> refunded)}
      a {casTreasury = casTreasury a <+> fromCompact unclaimed}
      ( cs
          & certDStateL . accountsL
            %~ removeStakePoolDelegations (delegsToClear cs retired)
              . addToBalanceAccounts refunds
          & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired)
          & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired)
          & certPStateL . psVRFKeyHashesL .~ vrfKeyHashes
          & certPStateL . psBlsKeyHashesL .~ blsKeyHashes
      )
  where
    delegsToClear :: CertState era
-> Set (KeyHash StakePool) -> Set (Credential Staking)
delegsToClear CertState era
cState Set (KeyHash StakePool)
pools =
      (StakePoolState -> Set (Credential Staking))
-> Map (KeyHash StakePool) StakePoolState
-> Set (Credential Staking)
forall m a. Monoid m => (a -> m) -> Map (KeyHash StakePool) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap StakePoolState -> Set (Credential Staking)
spsDelegators (Map (KeyHash StakePool) StakePoolState
 -> Set (Credential Staking))
-> Map (KeyHash StakePool) StakePoolState
-> Set (Credential Staking)
forall a b. (a -> b) -> a -> b
$
        Map (KeyHash StakePool) StakePoolState
-> Set (KeyHash StakePool)
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (CertState era
cState CertState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (CertState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL) Set (KeyHash StakePool)
pools