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

module Cardano.Ledger.Shelley.Rules.Pool (
  ShelleyPOOL,
  PoolEvent (..),
  PoolEnv (..),
  PredicateFailure,
  ShelleyPoolPredFailure (..),
) where

import Cardano.Crypto.Hash.Class (sizeHash)
import Cardano.Ledger.Address (raNetwork)
import Cardano.Ledger.BaseTypes (
  EpochNo,
  Globals (..),
  Mismatch (..),
  Network,
  Relation (..),
  ShelleyBase,
  addEpochInterval,
  invalidKey,
  networkId,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  decodeRecordSum,
  encodeListLen,
 )
import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Era (
  ShelleyEra,
  ShelleyPOOL,
  hardforkAlonzoValidatePoolRewardAccountNetID,
  hardforkConwayDisallowDuplicatedVRFKeys,
 )
import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
import Cardano.Ledger.State
import Control.DeepSeq
import Control.Monad (forM_, when)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition (
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  liftSTS,
  tellEvent,
  (?!),
 )
import qualified Data.ByteString as BS
import Data.Kind (Type)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word8)
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

data PoolEnv era
  = PoolEnv EpochNo (PParams era)
  deriving ((forall x. PoolEnv era -> Rep (PoolEnv era) x)
-> (forall x. Rep (PoolEnv era) x -> PoolEnv era)
-> Generic (PoolEnv era)
forall x. Rep (PoolEnv era) x -> PoolEnv era
forall x. PoolEnv era -> Rep (PoolEnv era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PoolEnv era) x -> PoolEnv era
forall era x. PoolEnv era -> Rep (PoolEnv era) x
$cfrom :: forall era x. PoolEnv era -> Rep (PoolEnv era) x
from :: forall x. PoolEnv era -> Rep (PoolEnv era) x
$cto :: forall era x. Rep (PoolEnv era) x -> PoolEnv era
to :: forall x. Rep (PoolEnv era) x -> PoolEnv era
Generic)

instance EraPParams era => EncCBOR (PoolEnv era) where
  encCBOR :: PoolEnv era -> Encoding
encCBOR (PoolEnv EpochNo
e PParams era
pp) =
    Encode ('Closed 'Dense) (PoolEnv era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) (PoolEnv era) -> Encoding)
-> Encode ('Closed 'Dense) (PoolEnv era) -> Encoding
forall a b. (a -> b) -> a -> b
$
      (EpochNo -> PParams era -> PoolEnv era)
-> Encode ('Closed 'Dense) (EpochNo -> PParams era -> PoolEnv era)
forall t. t -> Encode ('Closed 'Dense) t
Rec EpochNo -> PParams era -> PoolEnv era
forall era. EpochNo -> PParams era -> PoolEnv era
PoolEnv
        Encode ('Closed 'Dense) (EpochNo -> PParams era -> PoolEnv era)
-> Encode ('Closed 'Dense) EpochNo
-> Encode ('Closed 'Dense) (PParams era -> PoolEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> EpochNo -> Encode ('Closed 'Dense) EpochNo
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
e
        Encode ('Closed 'Dense) (PParams era -> PoolEnv era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode ('Closed 'Dense) (PoolEnv era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PParams era -> Encode ('Closed 'Dense) (PParams era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
pp

deriving instance Show (PParams era) => Show (PoolEnv era)

deriving instance Eq (PParams era) => Eq (PoolEnv era)

instance NFData (PParams era) => NFData (PoolEnv era)

data ShelleyPoolPredFailure era
  = StakePoolNotRegisteredOnKeyPOOL
      -- | KeyHash which cannot be retired since it is not registered
      (KeyHash 'StakePool)
  | StakePoolRetirementWrongEpochPOOL
      (Mismatch 'RelGT EpochNo)
      (Mismatch 'RelLTEQ EpochNo)
  | StakePoolCostTooLowPOOL
      (Mismatch 'RelGTEQ Coin)
  | WrongNetworkPOOL
      (Mismatch 'RelEQ Network)
      -- | Stake Pool ID
      (KeyHash 'StakePool)
  | PoolMedataHashTooBig
      -- | Stake Pool ID
      (KeyHash 'StakePool)
      -- | Size of the metadata hash
      Int
  | VRFKeyHashAlreadyRegistered
      -- | Stake Pool ID
      (KeyHash 'StakePool)
      -- | VRF key attempted to use, that has already been registered
      (VRFVerKeyHash 'StakePoolVRF)
  deriving (ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
(ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool)
-> (ShelleyPoolPredFailure era
    -> ShelleyPoolPredFailure era -> Bool)
-> Eq (ShelleyPoolPredFailure era)
forall era.
ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
== :: ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
$c/= :: forall era.
ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
/= :: ShelleyPoolPredFailure era -> ShelleyPoolPredFailure era -> Bool
Eq, Int -> ShelleyPoolPredFailure era -> ShowS
[ShelleyPoolPredFailure era] -> ShowS
ShelleyPoolPredFailure era -> String
(Int -> ShelleyPoolPredFailure era -> ShowS)
-> (ShelleyPoolPredFailure era -> String)
-> ([ShelleyPoolPredFailure era] -> ShowS)
-> Show (ShelleyPoolPredFailure era)
forall era. Int -> ShelleyPoolPredFailure era -> ShowS
forall era. [ShelleyPoolPredFailure era] -> ShowS
forall era. ShelleyPoolPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. Int -> ShelleyPoolPredFailure era -> ShowS
showsPrec :: Int -> ShelleyPoolPredFailure era -> ShowS
$cshow :: forall era. ShelleyPoolPredFailure era -> String
show :: ShelleyPoolPredFailure era -> String
$cshowList :: forall era. [ShelleyPoolPredFailure era] -> ShowS
showList :: [ShelleyPoolPredFailure era] -> ShowS
Show, (forall x.
 ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x)
-> (forall x.
    Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era)
-> Generic (ShelleyPoolPredFailure era)
forall x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
forall x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
forall era x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
$cfrom :: forall era x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
from :: forall x.
ShelleyPoolPredFailure era -> Rep (ShelleyPoolPredFailure era) x
$cto :: forall era x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
to :: forall x.
Rep (ShelleyPoolPredFailure era) x -> ShelleyPoolPredFailure era
Generic)

type instance EraRuleFailure "POOL" ShelleyEra = ShelleyPoolPredFailure ShelleyEra

instance InjectRuleFailure "POOL" ShelleyPoolPredFailure ShelleyEra

instance NoThunks (ShelleyPoolPredFailure era)

instance NFData (ShelleyPoolPredFailure era)

instance (ShelleyEraTxCert era, EraPParams era) => STS (ShelleyPOOL era) where
  type State (ShelleyPOOL era) = PState era

  type Signal (ShelleyPOOL era) = PoolCert

  type Environment (ShelleyPOOL era) = PoolEnv era

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

  transitionRules :: [TransitionRule (ShelleyPOOL era)]
transitionRules = [TransitionRule (ShelleyPOOL era)
forall (ledger :: * -> *) era.
(EraPParams era, Signal (ledger era) ~ PoolCert,
 Environment (ledger era) ~ PoolEnv era,
 State (ledger era) ~ PState era, STS (ledger era),
 Event (ledger era) ~ PoolEvent era,
 BaseM (ledger era) ~ ShelleyBase,
 PredicateFailure (ledger era) ~ ShelleyPoolPredFailure era) =>
TransitionRule (ledger era)
poolDelegationTransition]

data PoolEvent era
  = RegisterPool (KeyHash 'StakePool)
  | ReregisterPool (KeyHash 'StakePool)
  deriving ((forall x. PoolEvent era -> Rep (PoolEvent era) x)
-> (forall x. Rep (PoolEvent era) x -> PoolEvent era)
-> Generic (PoolEvent era)
forall x. Rep (PoolEvent era) x -> PoolEvent era
forall x. PoolEvent era -> Rep (PoolEvent era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PoolEvent era) x -> PoolEvent era
forall era x. PoolEvent era -> Rep (PoolEvent era) x
$cfrom :: forall era x. PoolEvent era -> Rep (PoolEvent era) x
from :: forall x. PoolEvent era -> Rep (PoolEvent era) x
$cto :: forall era x. Rep (PoolEvent era) x -> PoolEvent era
to :: forall x. Rep (PoolEvent era) x -> PoolEvent era
Generic, PoolEvent era -> PoolEvent era -> Bool
(PoolEvent era -> PoolEvent era -> Bool)
-> (PoolEvent era -> PoolEvent era -> Bool) -> Eq (PoolEvent era)
forall era. PoolEvent era -> PoolEvent era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era. PoolEvent era -> PoolEvent era -> Bool
== :: PoolEvent era -> PoolEvent era -> Bool
$c/= :: forall era. PoolEvent era -> PoolEvent era -> Bool
/= :: PoolEvent era -> PoolEvent era -> Bool
Eq)

instance NFData (PoolEvent era)

instance Era era => EncCBOR (ShelleyPoolPredFailure era) where
  encCBOR :: ShelleyPoolPredFailure era -> Encoding
encCBOR = \case
    StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
kh ->
      Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
kh
    StakePoolRetirementWrongEpochPOOL (Mismatch EpochNo
_ EpochNo
gtExpected) (Mismatch EpochNo
ltSupplied EpochNo
ltExpected) ->
      Word -> Encoding
encodeListLen Word
4
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
gtExpected
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
ltSupplied
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR EpochNo
ltExpected
    StakePoolCostTooLowPOOL (Mismatch Coin
supplied Coin
expected) ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
3 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
supplied Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Coin
expected
    WrongNetworkPOOL (Mismatch Network
supplied Network
expected) KeyHash 'StakePool
c ->
      Word -> Encoding
encodeListLen Word
4 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
4 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Network
expected Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Network -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Network
supplied Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
c
    PoolMedataHashTooBig KeyHash 'StakePool
a Int
b ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
5 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Int
b
    VRFKeyHashAlreadyRegistered KeyHash 'StakePool
a VRFVerKeyHash 'StakePoolVRF
b ->
      Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
6 :: Word8) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'StakePool -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'StakePool
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VRFVerKeyHash 'StakePoolVRF -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR VRFVerKeyHash 'StakePoolVRF
b

-- `ShelleyPoolPredFailure` is used in Conway POOL rule, so we need to keep the serialization unchanged
instance Era era => DecCBOR (ShelleyPoolPredFailure era) where
  decCBOR :: forall s. Decoder s (ShelleyPoolPredFailure era)
decCBOR = Text
-> (Word -> Decoder s (Int, ShelleyPoolPredFailure era))
-> Decoder s (ShelleyPoolPredFailure era)
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"PredicateFailure (POOL era)" ((Word -> Decoder s (Int, ShelleyPoolPredFailure era))
 -> Decoder s (ShelleyPoolPredFailure era))
-> (Word -> Decoder s (Int, ShelleyPoolPredFailure era))
-> Decoder s (ShelleyPoolPredFailure era)
forall a b. (a -> b) -> a -> b
$
    \case
      Word
0 -> do
        KeyHash 'StakePool
kh <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> ShelleyPoolPredFailure era
StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
kh)
      Word
1 -> do
        EpochNo
gtExpected <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
        EpochNo
ltSupplied <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
        EpochNo
ltExpected <- Decoder s EpochNo
forall s. Decoder s EpochNo
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ( Int
4
          , Mismatch 'RelGT EpochNo
-> Mismatch 'RelLTEQ EpochNo -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelGT EpochNo
-> Mismatch 'RelLTEQ EpochNo -> ShelleyPoolPredFailure era
StakePoolRetirementWrongEpochPOOL
              (EpochNo -> EpochNo -> Mismatch 'RelGT EpochNo
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch EpochNo
ltSupplied EpochNo
gtExpected)
              (EpochNo -> EpochNo -> Mismatch 'RelLTEQ EpochNo
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch EpochNo
ltSupplied EpochNo
ltExpected)
          )
      Word
2 -> String -> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"WrongCertificateTypePOOL has been removed as impossible case"
      Word
3 -> do
        Coin
supplied <- Decoder s Coin
forall s. Decoder s Coin
forall a s. DecCBOR a => Decoder s a
decCBOR
        Coin
expected <- Decoder s Coin
forall s. Decoder s Coin
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
forall era. Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
StakePoolCostTooLowPOOL (Coin -> Coin -> Mismatch 'RelGTEQ Coin
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
supplied Coin
expected))
      Word
4 -> do
        Network
expectedNetId <- Decoder s Network
forall s. Decoder s Network
forall a s. DecCBOR a => Decoder s a
decCBOR
        Network
suppliedNetId <- Decoder s Network
forall s. Decoder s Network
forall a s. DecCBOR a => Decoder s a
decCBOR
        KeyHash 'StakePool
poolId <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
4, Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
WrongNetworkPOOL (Network -> Network -> Mismatch 'RelEQ Network
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Network
suppliedNetId Network
expectedNetId) KeyHash 'StakePool
poolId)
      Word
5 -> do
        KeyHash 'StakePool
poolID <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        Int
s <- Decoder s Int
forall s. Decoder s Int
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig KeyHash 'StakePool
poolID Int
s)
      Word
6 -> do
        KeyHash 'StakePool
poolID <- Decoder s (KeyHash 'StakePool)
forall s. Decoder s (KeyHash 'StakePool)
forall a s. DecCBOR a => Decoder s a
decCBOR
        VRFVerKeyHash 'StakePoolVRF
vrfKeyHash <- Decoder s (VRFVerKeyHash 'StakePoolVRF)
forall s. Decoder s (VRFVerKeyHash 'StakePoolVRF)
forall a s. DecCBOR a => Decoder s a
decCBOR
        (Int, ShelleyPoolPredFailure era)
-> Decoder s (Int, ShelleyPoolPredFailure era)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
poolID VRFVerKeyHash 'StakePoolVRF
vrfKeyHash)
      Word
k -> Word -> Decoder s (Int, ShelleyPoolPredFailure era)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k

poolDelegationTransition ::
  forall (ledger :: Type -> Type) era.
  ( EraPParams era
  , Signal (ledger era) ~ PoolCert
  , Environment (ledger era) ~ PoolEnv era
  , State (ledger era) ~ PState era
  , STS (ledger era)
  , Event (ledger era) ~ PoolEvent era
  , BaseM (ledger era) ~ ShelleyBase
  , PredicateFailure (ledger era) ~ ShelleyPoolPredFailure era
  ) =>
  TransitionRule (ledger era)
poolDelegationTransition :: forall (ledger :: * -> *) era.
(EraPParams era, Signal (ledger era) ~ PoolCert,
 Environment (ledger era) ~ PoolEnv era,
 State (ledger era) ~ PState era, STS (ledger era),
 Event (ledger era) ~ PoolEvent era,
 BaseM (ledger era) ~ ShelleyBase,
 PredicateFailure (ledger era) ~ ShelleyPoolPredFailure era) =>
TransitionRule (ledger era)
poolDelegationTransition = do
  TRC
    ( PoolEnv EpochNo
cEpoch PParams era
pp
      , ps :: State (ledger era)
ps@PState {Map (KeyHash 'StakePool) StakePoolState
psStakePools :: Map (KeyHash 'StakePool) StakePoolState
psStakePools :: forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psStakePools, Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools :: Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools :: forall era. PState era -> Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools, Set (VRFVerKeyHash 'StakePoolVRF)
psVRFKeyHashes :: Set (VRFVerKeyHash 'StakePoolVRF)
psVRFKeyHashes :: forall era. PState era -> Set (VRFVerKeyHash 'StakePoolVRF)
psVRFKeyHashes}
      , Signal (ledger era)
poolCert
      ) <-
    Rule
  (ledger era) 'Transition (RuleContext 'Transition (ledger era))
F (Clause (ledger era) 'Transition) (TRC (ledger era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case Signal (ledger era)
poolCert of
    RegPool poolParams :: PoolParams
poolParams@PoolParams {KeyHash 'StakePool
ppId :: KeyHash 'StakePool
ppId :: PoolParams -> KeyHash 'StakePool
ppId, VRFVerKeyHash 'StakePoolVRF
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppVrf, RewardAccount
ppRewardAccount :: RewardAccount
ppRewardAccount :: PoolParams -> RewardAccount
ppRewardAccount, StrictMaybe PoolMetadata
ppMetadata :: StrictMaybe PoolMetadata
ppMetadata :: PoolParams -> StrictMaybe PoolMetadata
ppMetadata, Coin
ppCost :: Coin
ppCost :: PoolParams -> Coin
ppCost} -> do
      let pv :: ProtVer
pv = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
      Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
hardforkAlonzoValidatePoolRewardAccountNetID ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ do
        Network
actualNetID <- BaseM (ledger era) Network -> Rule (ledger era) 'Transition Network
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (ledger era) Network
 -> Rule (ledger era) 'Transition Network)
-> BaseM (ledger era) Network
-> Rule (ledger 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 :: Network
suppliedNetID = RewardAccount -> Network
raNetwork RewardAccount
ppRewardAccount
        Network
actualNetID
          Network -> Network -> Bool
forall a. Eq a => a -> a -> Bool
== Network
suppliedNetID
            Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era.
Mismatch 'RelEQ Network
-> KeyHash 'StakePool -> ShelleyPoolPredFailure era
WrongNetworkPOOL
              Mismatch
                { mismatchSupplied :: Network
mismatchSupplied = Network
suppliedNetID
                , mismatchExpected :: Network
mismatchExpected = Network
actualNetID
                }
              KeyHash 'StakePool
ppId

      Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
SoftForks.restrictPoolMetadataHash ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        StrictMaybe PoolMetadata
-> (PoolMetadata -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ StrictMaybe PoolMetadata
ppMetadata ((PoolMetadata -> F (Clause (ledger era) 'Transition) ())
 -> F (Clause (ledger era) 'Transition) ())
-> (PoolMetadata -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ \PoolMetadata
pmd ->
          let s :: Int
s = ByteString -> Int
BS.length (PoolMetadata -> ByteString
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
sizeHash ([] @HASH))
                  Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> Int -> ShelleyPoolPredFailure era
PoolMedataHashTooBig KeyHash 'StakePool
ppId Int
s

      let minPoolCost :: Coin
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 => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinPoolCostL
      Coin
ppCost
        Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
minPoolCost
          Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
forall era. Mismatch 'RelGTEQ Coin -> ShelleyPoolPredFailure era
StakePoolCostTooLowPOOL
            Mismatch
              { mismatchSupplied :: Coin
mismatchSupplied = Coin
ppCost
              , mismatchExpected :: Coin
mismatchExpected = Coin
minPoolCost
              }
      case KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
ppId Map (KeyHash 'StakePool) StakePoolState
psStakePools of
        -- register new, Pool-Reg
        Maybe StakePoolState
Nothing -> do
          Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ do
            VRFVerKeyHash 'StakePoolVRF
-> Set (VRFVerKeyHash 'StakePoolVRF) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember VRFVerKeyHash 'StakePoolVRF
ppVrf Set (VRFVerKeyHash 'StakePoolVRF)
psVRFKeyHashes Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
ppId VRFVerKeyHash 'StakePoolVRF
ppVrf
          let updateVRFKeyHash :: Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
updateVRFKeyHash
                | ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv = VRFVerKeyHash 'StakePoolVRF
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => a -> Set a -> Set a
Set.insert VRFVerKeyHash 'StakePoolVRF
ppVrf
                | Bool
otherwise = Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> a
id
          Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ledger era) -> F (Clause (ledger era) 'Transition) ())
-> Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> PoolEvent era
forall era. KeyHash 'StakePool -> PoolEvent era
RegisterPool KeyHash 'StakePool
ppId
          PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a. a -> F (Clause (ledger era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> F (Clause (ledger era) 'Transition) (PState era))
-> PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$
            PState era
State (ledger 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
ppId (CompactForm Coin -> PoolParams -> StakePoolState
mkStakePoolState (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) PoolParams
poolParams)
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Set (VRFVerKeyHash 'StakePoolVRF)
 -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Set (VRFVerKeyHash 'StakePoolVRF)
 -> f (Set (VRFVerKeyHash 'StakePoolVRF)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Set (VRFVerKeyHash 'StakePoolVRF)
  -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
 -> PState era -> Identity (PState era))
-> (Set (VRFVerKeyHash 'StakePoolVRF)
    -> Set (VRFVerKeyHash 'StakePoolVRF))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
updateVRFKeyHash
        -- re-register Pool
        Just StakePoolState
stakePoolState -> do
          Bool
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv) (F (Clause (ledger era) 'Transition) ()
 -> F (Clause (ledger era) 'Transition) ())
-> F (Clause (ledger era) 'Transition) ()
-> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ do
            VRFVerKeyHash 'StakePoolVRF
ppVrf VRFVerKeyHash 'StakePoolVRF -> VRFVerKeyHash 'StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
== 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
              Bool -> Bool -> Bool
|| VRFVerKeyHash 'StakePoolVRF
-> Set (VRFVerKeyHash 'StakePoolVRF) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember VRFVerKeyHash 'StakePoolVRF
ppVrf Set (VRFVerKeyHash 'StakePoolVRF)
psVRFKeyHashes Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash 'StakePool
-> VRFVerKeyHash 'StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash 'StakePool
ppId VRFVerKeyHash 'StakePoolVRF
ppVrf
          let updateFutureVRFKeyHash :: Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
updateFutureVRFKeyHash
                | ProtVer -> Bool
hardforkConwayDisallowDuplicatedVRFKeys ProtVer
pv =
                    -- If a pool re-registers with a fresh VRF, we have to add it to the list,
                    -- but also remove the previous VRFHashKey potentially stored in previous re-registration within the same epoch,
                    -- which we retrieve from futureStakePools.
                    case KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool
ppId Map (KeyHash 'StakePool) StakePoolState
psFutureStakePools of
                      Maybe StakePoolState
Nothing -> VRFVerKeyHash 'StakePoolVRF
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => a -> Set a -> Set a
Set.insert VRFVerKeyHash 'StakePoolVRF
ppVrf
                      Just StakePoolState
futureStakePoolState
                        | StakePoolState
futureStakePoolState 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 VRFVerKeyHash 'StakePoolVRF -> VRFVerKeyHash 'StakePoolVRF -> Bool
forall a. Eq a => a -> a -> Bool
/= VRFVerKeyHash 'StakePoolVRF
ppVrf ->
                            VRFVerKeyHash 'StakePoolVRF
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => a -> Set a -> Set a
Set.insert VRFVerKeyHash 'StakePoolVRF
ppVrf (Set (VRFVerKeyHash 'StakePoolVRF)
 -> Set (VRFVerKeyHash 'StakePoolVRF))
-> (Set (VRFVerKeyHash 'StakePoolVRF)
    -> Set (VRFVerKeyHash 'StakePoolVRF))
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VRFVerKeyHash 'StakePoolVRF
-> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. Ord a => a -> Set a -> Set a
Set.delete (StakePoolState
futureStakePoolState 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)
                        | Bool
otherwise -> Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> a
id
                | Bool
otherwise = Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
forall a. a -> a
id
          Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (Event (ledger era) -> F (Clause (ledger era) 'Transition) ())
-> Event (ledger era) -> F (Clause (ledger era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> PoolEvent era
forall era. KeyHash 'StakePool -> PoolEvent era
ReregisterPool KeyHash 'StakePool
ppId
          -- NOTE: The `ppId` is already registered, so we want to reregister
          -- it. That means adding it to the Future Stake Pools (if it is not
          -- there already), and overriding its range with the new 'poolParams',
          -- if it is.
          --
          -- We must also unretire it, if it has been scheduled for retirement.
          --
          -- The deposit does not change. One pays the deposit just once. Only
          -- if it is fully retired (i.e. it's deposit has been refunded, and it
          -- has been removed from the registered pools).  does it need to pay a
          -- new deposit (at the current deposit amount). But of course, if that
          -- has happened, we cannot be in this branch of the case statement.
          PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a. a -> F (Clause (ledger era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> F (Clause (ledger era) 'Transition) (PState era))
-> PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$
            PState era
State (ledger 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)
psFutureStakePoolsL ((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
ppId (CompactForm Coin -> PoolParams -> StakePoolState
mkStakePoolState (StakePoolState
stakePoolState 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) PoolParams
poolParams)
              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
ppId
              PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Set (VRFVerKeyHash 'StakePoolVRF)
 -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Set (VRFVerKeyHash 'StakePoolVRF)
 -> f (Set (VRFVerKeyHash 'StakePoolVRF)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Set (VRFVerKeyHash 'StakePoolVRF)
  -> Identity (Set (VRFVerKeyHash 'StakePoolVRF)))
 -> PState era -> Identity (PState era))
-> (Set (VRFVerKeyHash 'StakePoolVRF)
    -> Set (VRFVerKeyHash 'StakePoolVRF))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Set (VRFVerKeyHash 'StakePoolVRF)
-> Set (VRFVerKeyHash 'StakePoolVRF)
updateFutureVRFKeyHash
    RetirePool KeyHash 'StakePool
ppId EpochNo
e -> do
      KeyHash 'StakePool
-> Map (KeyHash 'StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member KeyHash 'StakePool
ppId Map (KeyHash 'StakePool) StakePoolState
psStakePools Bool
-> PredicateFailure (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! KeyHash 'StakePool -> ShelleyPoolPredFailure era
forall era. KeyHash 'StakePool -> ShelleyPoolPredFailure era
StakePoolNotRegisteredOnKeyPOOL KeyHash 'StakePool
ppId
      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 (ledger era)
-> F (Clause (ledger era) 'Transition) ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! 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 (ledger era) 'Transition) (PState era)
forall a. a -> F (Clause (ledger era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> F (Clause (ledger era) 'Transition) (PState era))
-> PState era -> F (Clause (ledger era) 'Transition) (PState era)
forall a b. (a -> b) -> a -> b
$ PState era
State (ledger 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
ppId EpochNo
e