{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Dijkstra.Rules.Pool (
  POOL,
  poolTransition,
) where

import Cardano.Crypto.Hash.Class (hashSize)
import Cardano.Ledger.BaseTypes (
  Globals (..),
  Mismatch (..),
  ShelleyBase,
  addEpochInterval,
  knownNonZeroBounded,
  networkId,
 )
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Era (DijkstraEra, POOL)
import Cardano.Ledger.Shelley.Rules (
  PoolEnv (..),
  PoolEvent (..),
  ShelleyPoolPredFailure (..),
 )
import Cardano.Ledger.State
import Control.Monad (forM_)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition (
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  liftSTS,
  tellEvent,
  (?!),
 )
import qualified Data.Map as Map
import Data.Primitive.ByteArray (sizeofByteArray)
import Lens.Micro

type instance EraRuleFailure "POOL" DijkstraEra = ShelleyPoolPredFailure DijkstraEra

type instance EraRuleEvent "POOL" DijkstraEra = PoolEvent DijkstraEra

instance InjectRuleFailure "POOL" ShelleyPoolPredFailure DijkstraEra

instance InjectRuleEvent "POOL" PoolEvent DijkstraEra

instance
  ( EraPParams era
  , EraRule "POOL" era ~ POOL era
  , InjectRuleFailure "POOL" ShelleyPoolPredFailure era
  , InjectRuleEvent "POOL" PoolEvent era
  ) =>
  STS (POOL era)
  where
  type State (POOL era) = PState era

  type Signal (POOL era) = PoolCert era

  type Environment (POOL era) = PoolEnv era

  type BaseM (POOL era) = ShelleyBase
  type PredicateFailure (POOL era) = ShelleyPoolPredFailure era
  type Event (POOL era) = PoolEvent era

  transitionRules :: [TransitionRule (POOL era)]
transitionRules = [TransitionRule (EraRule "POOL" era)
TransitionRule (POOL era)
forall (rule :: Symbol) era.
(EraPParams era, Signal (EraRule rule era) ~ PoolCert era,
 Environment (EraRule rule era) ~ PoolEnv era,
 State (EraRule rule era) ~ PState era, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 InjectRuleFailure rule ShelleyPoolPredFailure era,
 InjectRuleEvent rule PoolEvent era) =>
TransitionRule (EraRule rule era)
poolTransition]

-- Invariant of `psVRFKeyHashes`: a VRF key hash maps to the number of
-- references held by registered stake pools, where a pool holds one reference
-- through its active parameters (`psStakePools`) and one more through its
-- future parameters (`psFutureStakePoolParams`) whenever the future VRF key
-- hash differs from the active one. A future VRF key hash that coincides with
-- the pool's active one is not counted separately.
--
-- POOLREAP follows the same accounting at the epoch boundary when it adopts
-- future parameters and retires pools, except that it drops a superseded
-- active VRF key hash entirely instead of decrementing its count. The two only
-- differ for VRF key hashes that several pools have shared since before their
-- uniqueness was enforced.
poolTransition ::
  forall rule era.
  ( EraPParams era
  , Signal (EraRule rule era) ~ PoolCert era
  , Environment (EraRule rule era) ~ PoolEnv era
  , State (EraRule rule era) ~ PState era
  , STS (EraRule rule era)
  , BaseM (EraRule rule era) ~ ShelleyBase
  , InjectRuleFailure rule ShelleyPoolPredFailure era
  , InjectRuleEvent rule PoolEvent era
  ) =>
  TransitionRule (EraRule rule era)
poolTransition :: forall (rule :: Symbol) era.
(EraPParams era, Signal (EraRule rule era) ~ PoolCert era,
 Environment (EraRule rule era) ~ PoolEnv era,
 State (EraRule rule era) ~ PState era, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 InjectRuleFailure rule ShelleyPoolPredFailure era,
 InjectRuleEvent rule PoolEvent era) =>
TransitionRule (EraRule rule era)
poolTransition = do
  TRC
    ( PoolEnv cEpoch pp
      , ps@PState {psStakePools, psFutureStakePoolParams, psVRFKeyHashes}
      , poolCert
      ) <-
    Rule
  (EraRule rule era)
  'Transition
  (RuleContext 'Transition (EraRule rule era))
F (Clause (EraRule rule era) 'Transition) (TRC (EraRule rule era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case poolCert of
    RegPool stakePoolParams :: StakePoolParams era
stakePoolParams@StakePoolParams {KeyHash StakePool
sppId :: KeyHash StakePool
sppId :: forall era. StakePoolParams era -> KeyHash StakePool
sppId, VRFVerKeyHash StakePoolVRF
sppVrf :: VRFVerKeyHash StakePoolVRF
sppVrf :: forall era. StakePoolParams era -> VRFVerKeyHash StakePoolVRF
sppVrf, AccountAddress
sppAccountAddress :: AccountAddress
sppAccountAddress :: forall era. StakePoolParams era -> AccountAddress
sppAccountAddress, StrictMaybe PoolMetadata
sppMetadata :: StrictMaybe PoolMetadata
sppMetadata :: forall era. StakePoolParams era -> StrictMaybe PoolMetadata
sppMetadata, Coin
sppCost :: Coin
sppCost :: forall era. StakePoolParams era -> Coin
sppCost} -> do
      actualNetID <- BaseM (EraRule rule era) Network
-> Rule (EraRule rule era) 'Transition Network
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (EraRule rule era) Network
 -> Rule (EraRule rule era) 'Transition Network)
-> BaseM (EraRule rule era) Network
-> Rule (EraRule rule era) 'Transition Network
forall a b. (a -> b) -> a -> b
$ (Globals -> Network) -> ReaderT Globals Identity Network
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Network
networkId
      let suppliedNetID = AccountAddress -> Network
aaNetworkId AccountAddress
sppAccountAddress
      actualNetID
        == suppliedNetID
          ?! injectFailure
            ( WrongNetworkPOOL
                Mismatch
                  { mismatchSupplied = suppliedNetID
                  , mismatchExpected = actualNetID
                  }
                sppId
            )

      forM_ sppMetadata $ \PoolMetadata
pmd ->
        let s :: Int
s = ByteArray -> Int
sizeofByteArray (ByteArray -> Int) -> ByteArray -> Int
forall a b. (a -> b) -> a -> b
$ PoolMetadata -> ByteArray
pmHash PoolMetadata
pmd
         in Int
s
              Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([HASH] -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
hashSize ([] @HASH))
                Bool
-> PredicateFailure (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! ShelleyPoolPredFailure era -> EraRuleFailure rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (KeyHash StakePool -> Int -> ShelleyPoolPredFailure era
forall era. KeyHash StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig KeyHash StakePool
sppId Int
s)

      let minPoolCost = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinPoolCostL
      sppCost
        >= minPoolCost
          ?! injectFailure
            ( StakePoolCostTooLowPOOL
                Mismatch
                  { mismatchSupplied = sppCost
                  , mismatchExpected = minPoolCost
                  }
            )
      case Map.lookup sppId psStakePools of
        -- register new, Pool-Reg
        Maybe StakePoolState
Nothing -> do
          VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember VRFVerKeyHash StakePoolVRF
sppVrf Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes
            Bool
-> PredicateFailure (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! ShelleyPoolPredFailure era -> EraRuleFailure rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
sppId VRFVerKeyHash StakePoolVRF
sppVrf)
          Event (EraRule rule era) -> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (EraRule rule era)
 -> Rule (EraRule rule era) 'Transition ())
-> Event (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PoolEvent era -> EraRuleEvent rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (PoolEvent era -> EraRuleEvent rule era)
-> PoolEvent era -> EraRuleEvent rule era
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> PoolEvent era
forall era. KeyHash StakePool -> PoolEvent era
RegisterPool KeyHash StakePool
sppId
          PState era
-> F (Clause (EraRule rule era) 'Transition) (PState era)
forall a. a -> F (Clause (EraRule rule era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era
 -> F (Clause (EraRule rule era) 'Transition) (PState era))
-> PState era
-> F (Clause (EraRule rule era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$
            PState era
State (EraRule rule era)
ps
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash StakePool) StakePoolState
 -> Identity (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
                ((Map (KeyHash StakePool) StakePoolState
  -> Identity (Map (KeyHash StakePool) StakePoolState))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Map (KeyHash StakePool) StakePoolState)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash StakePool
-> StakePoolState
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash StakePool
sppId (EpochNo
-> CompactForm Coin
-> Set (Credential Staking)
-> StakePoolParams era
-> StakePoolState
forall era.
EpochNo
-> CompactForm Coin
-> Set (Credential Staking)
-> StakePoolParams era
-> StakePoolState
mkStakePoolState EpochNo
cEpoch (PParams era
pp PParams era
-> Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (PParams era) (CompactForm Coin)
forall era.
EraPParams era =>
Lens' (PParams era) (CompactForm Coin)
Lens' (PParams era) (CompactForm Coin)
ppPoolDepositCompactL) Set (Credential Staking)
forall a. Monoid a => a
mempty StakePoolParams era
stakePoolParams)
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Identity (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> f (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
  -> Identity (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
 -> PState era -> Identity (PState era))
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
addVRFKeyHashOccurrence VRFVerKeyHash StakePoolVRF
sppVrf
        -- re-register Pool
        Just StakePoolState
stakePoolState -> do
          let activeVrf :: VRFVerKeyHash StakePoolVRF
activeVrf = StakePoolState
stakePoolState StakePoolState
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     StakePoolState
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  StakePoolState
  (VRFVerKeyHash StakePoolVRF)
Lens' StakePoolState (VRFVerKeyHash StakePoolVRF)
spsVrfL
              mbFutureVrf :: Maybe (VRFVerKeyHash StakePoolVRF)
mbFutureVrf = (StakePoolParams era
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL) (StakePoolParams era -> VRFVerKeyHash StakePoolVRF)
-> Maybe (StakePoolParams era)
-> Maybe (VRFVerKeyHash StakePoolVRF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash StakePool
-> Map (KeyHash StakePool) (StakePoolParams era)
-> Maybe (StakePoolParams era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
sppId Map (KeyHash StakePool) (StakePoolParams era)
psFutureStakePoolParams
              -- The only reference to this VRF key hash, if any, must be the
              -- pool's own, held through its active or its future parameters.
              expectedOccurrences :: Maybe (NonZero Word64)
expectedOccurrences
                | VRFVerKeyHash StakePoolVRF
sppVrf VRFVerKeyHash StakePoolVRF -> VRFVerKeyHash StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
== VRFVerKeyHash StakePoolVRF
activeVrf Bool -> Bool -> Bool
|| Maybe (VRFVerKeyHash StakePoolVRF)
mbFutureVrf Maybe (VRFVerKeyHash StakePoolVRF)
-> Maybe (VRFVerKeyHash StakePoolVRF) -> Bool
forall a. Eq a => a -> a -> Bool
== VRFVerKeyHash StakePoolVRF -> Maybe (VRFVerKeyHash StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash StakePoolVRF
sppVrf = NonZero Word64 -> Maybe (NonZero Word64)
forall a. a -> Maybe a
Just (forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1)
                | Bool
otherwise = Maybe (NonZero Word64)
forall a. Maybe a
Nothing
          VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Maybe (NonZero Word64)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup VRFVerKeyHash StakePoolVRF
sppVrf Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes
            Maybe (NonZero Word64) -> Maybe (NonZero Word64) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (NonZero Word64)
expectedOccurrences
              Bool
-> PredicateFailure (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! ShelleyPoolPredFailure era -> EraRuleFailure rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
sppId VRFVerKeyHash StakePoolVRF
sppVrf)
          let updateFutureVRFKeyHash :: Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
updateFutureVRFKeyHash
                | Maybe (VRFVerKeyHash StakePoolVRF)
mbFutureVrf Maybe (VRFVerKeyHash StakePoolVRF)
-> Maybe (VRFVerKeyHash StakePoolVRF) -> Bool
forall a. Eq a => a -> a -> Bool
/= VRFVerKeyHash StakePoolVRF -> Maybe (VRFVerKeyHash StakePoolVRF)
forall a. a -> Maybe a
Just VRFVerKeyHash StakePoolVRF
sppVrf =
                    -- The reference held by the future parameters moves from
                    -- `mbFutureVrf` to `sppVrf`. References that coincide with
                    -- the active VRF key hash are not counted separately, per
                    -- the invariant on `psVRFKeyHashes`.
                    let removeOldOccurrence :: Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeOldOccurrence = case Maybe (VRFVerKeyHash StakePoolVRF)
mbFutureVrf of
                          Just VRFVerKeyHash StakePoolVRF
oldFutureVrf
                            | VRFVerKeyHash StakePoolVRF
oldFutureVrf VRFVerKeyHash StakePoolVRF -> VRFVerKeyHash StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
/= VRFVerKeyHash StakePoolVRF
activeVrf -> VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeVRFKeyHashOccurrence VRFVerKeyHash StakePoolVRF
oldFutureVrf
                          Maybe (VRFVerKeyHash StakePoolVRF)
_ -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall a. a -> a
id
                        addNewOccurrence :: Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
addNewOccurrence
                          | VRFVerKeyHash StakePoolVRF
sppVrf VRFVerKeyHash StakePoolVRF -> VRFVerKeyHash StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
/= VRFVerKeyHash StakePoolVRF
activeVrf = VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
addVRFKeyHashOccurrence VRFVerKeyHash StakePoolVRF
sppVrf
                          | Bool
otherwise = Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall a. a -> a
id
                     in Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
addNewOccurrence (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
removeOldOccurrence
                | Bool
otherwise = Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall a. a -> a
id
          Event (EraRule rule era) -> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (EraRule rule era)
 -> Rule (EraRule rule era) 'Transition ())
-> Event (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall a b. (a -> b) -> a -> b
$ PoolEvent era -> EraRuleEvent rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (PoolEvent era -> EraRuleEvent rule era)
-> PoolEvent era -> EraRuleEvent rule era
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> PoolEvent era
forall era. KeyHash StakePool -> PoolEvent era
ReregisterPool KeyHash StakePool
sppId
          -- This `sppId` is already registered, so we want to reregister it.
          -- That means adding it to the futureStakePoolParams or overriding it  with the new 'poolParams'.
          -- We must also unretire it, if it has been scheduled for retirement.
          -- The deposit does not change.
          PState era
-> F (Clause (EraRule rule era) 'Transition) (PState era)
forall a. a -> F (Clause (EraRule rule era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era
 -> F (Clause (EraRule rule era) 'Transition) (PState era))
-> PState era
-> F (Clause (EraRule rule era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$
            PState era
State (EraRule rule era)
ps
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash StakePool) (StakePoolParams era)
 -> Identity (Map (KeyHash StakePool) (StakePoolParams era)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) (StakePoolParams era)
 -> f (Map (KeyHash StakePool) (StakePoolParams era)))
-> PState era -> f (PState era)
psFutureStakePoolParamsL
                ((Map (KeyHash StakePool) (StakePoolParams era)
  -> Identity (Map (KeyHash StakePool) (StakePoolParams era)))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) (StakePoolParams era)
    -> Map (KeyHash StakePool) (StakePoolParams era))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash StakePool
-> StakePoolParams era
-> Map (KeyHash StakePool) (StakePoolParams era)
-> Map (KeyHash StakePool) (StakePoolParams era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash StakePool
sppId StakePoolParams era
stakePoolParams
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash StakePool) EpochNo
 -> Identity (Map (KeyHash StakePool) EpochNo))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) EpochNo
 -> f (Map (KeyHash StakePool) EpochNo))
-> PState era -> f (PState era)
psRetiringL ((Map (KeyHash StakePool) EpochNo
  -> Identity (Map (KeyHash StakePool) EpochNo))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) EpochNo
    -> Map (KeyHash StakePool) EpochNo)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash StakePool
-> Map (KeyHash StakePool) EpochNo
-> Map (KeyHash StakePool) EpochNo
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete KeyHash StakePool
sppId
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Identity (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> f (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
  -> Identity (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
 -> PState era -> Identity (PState era))
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
updateFutureVRFKeyHash
    RetirePool KeyHash StakePool
sppId EpochNo
e -> do
      KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash StakePool
sppId Map (KeyHash StakePool) StakePoolState
psStakePools Bool
-> PredicateFailure (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! ShelleyPoolPredFailure era -> EraRuleFailure rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (KeyHash StakePool -> ShelleyPoolPredFailure era
forall era. KeyHash StakePool -> ShelleyPoolPredFailure era
StakePoolNotRegisteredOnKeyPOOL KeyHash StakePool
sppId)
      let maxEpoch :: EpochInterval
maxEpoch = PParams era
pp PParams era
-> Getting EpochInterval (PParams era) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams era) EpochInterval
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL
          limitEpoch :: EpochNo
limitEpoch = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
cEpoch EpochInterval
maxEpoch
      (EpochNo
cEpoch EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
< EpochNo
e Bool -> Bool -> Bool
&& EpochNo
e EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
<= EpochNo
limitEpoch)
        Bool
-> PredicateFailure (EraRule rule era)
-> Rule (EraRule rule era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! ShelleyPoolPredFailure era -> EraRuleFailure rule era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure
          ( Mismatch RelGT EpochNo
-> Mismatch RelLTEQ EpochNo -> ShelleyPoolPredFailure era
forall era.
Mismatch RelGT EpochNo
-> Mismatch RelLTEQ EpochNo -> ShelleyPoolPredFailure era
StakePoolRetirementWrongEpochPOOL
              Mismatch -- RelGT - The supplied value should be greater than the current epoch
                { mismatchSupplied :: EpochNo
mismatchSupplied = EpochNo
e
                , mismatchExpected :: EpochNo
mismatchExpected = EpochNo
cEpoch
                }
              Mismatch -- RelLTEQ - The supplied value should be less then or equal to ppEMax after the current epoch
                { mismatchSupplied :: EpochNo
mismatchSupplied = EpochNo
e
                , mismatchExpected :: EpochNo
mismatchExpected = EpochNo
limitEpoch
                }
          )
      -- We just schedule it for retirement. When it is retired we refund the deposit (see POOLREAP)
      PState era
-> F (Clause (EraRule rule era) 'Transition) (PState era)
forall a. a -> F (Clause (EraRule rule era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era
 -> F (Clause (EraRule rule era) 'Transition) (PState era))
-> PState era
-> F (Clause (EraRule rule era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$ PState era
State (EraRule rule era)
ps PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash StakePool) EpochNo
 -> Identity (Map (KeyHash StakePool) EpochNo))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) EpochNo
 -> f (Map (KeyHash StakePool) EpochNo))
-> PState era -> f (PState era)
psRetiringL ((Map (KeyHash StakePool) EpochNo
  -> Identity (Map (KeyHash StakePool) EpochNo))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) EpochNo
    -> Map (KeyHash StakePool) EpochNo)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyHash StakePool
-> EpochNo
-> Map (KeyHash StakePool) EpochNo
-> Map (KeyHash StakePool) EpochNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert KeyHash StakePool
sppId EpochNo
e