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

module Cardano.Ledger.Shelley.Rules.Rupd (
  ShelleyRUPD,
  RupdEnv (..),
  PredicateFailure,
  ShelleyRupdPredFailure,
  epochInfoRange,
  PulsingRewUpdate (..),
  startStep,
  pulseStep,
  completeStep,
  lift,
  Identity (..),
  RupdEvent (..),
)
where

import Cardano.Ledger.BaseTypes (
  BlocksMade,
  ShelleyBase,
  StrictMaybe (..),
  activeSlotCoeff,
  epochInfoPure,
  maxLovelaceSupply,
  randomnessStabilisationWindow,
  securityParameter,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Keys (KeyRole (Staking))
import Cardano.Ledger.Shelley.Era (ShelleyRUPD)
import Cardano.Ledger.Shelley.Governance (EraGov)
import Cardano.Ledger.Shelley.LedgerState (
  EpochState,
  PulsingRewUpdate (..),
  completeStep,
  pulseStep,
  startStep,
 )
import Cardano.Ledger.Slot (
  Duration (..),
  EpochNo (..),
  SlotNo,
  epochInfoEpoch,
  epochInfoFirst,
  epochInfoSize,
  (+*),
 )
import Cardano.Slotting.EpochInfo.API (epochInfoRange)
import Control.DeepSeq (NFData)
import Control.Monad.Identity (Identity (..))
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition (
  Rule,
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  liftSTS,
  tellEvent,
 )
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

data RupdEnv era
  = RupdEnv !(BlocksMade (EraCrypto era)) !(EpochState era)

data ShelleyRupdPredFailure era -- No predicate failures
  deriving (Int -> ShelleyRupdPredFailure era -> ShowS
forall era. Int -> ShelleyRupdPredFailure era -> ShowS
forall era. [ShelleyRupdPredFailure era] -> ShowS
forall era. ShelleyRupdPredFailure era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyRupdPredFailure era] -> ShowS
$cshowList :: forall era. [ShelleyRupdPredFailure era] -> ShowS
show :: ShelleyRupdPredFailure era -> String
$cshow :: forall era. ShelleyRupdPredFailure era -> String
showsPrec :: Int -> ShelleyRupdPredFailure era -> ShowS
$cshowsPrec :: forall era. Int -> ShelleyRupdPredFailure era -> ShowS
Show, ShelleyRupdPredFailure era -> ShelleyRupdPredFailure era -> Bool
forall era.
ShelleyRupdPredFailure era -> ShelleyRupdPredFailure era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyRupdPredFailure era -> ShelleyRupdPredFailure era -> Bool
$c/= :: forall era.
ShelleyRupdPredFailure era -> ShelleyRupdPredFailure era -> Bool
== :: ShelleyRupdPredFailure era -> ShelleyRupdPredFailure era -> Bool
$c== :: forall era.
ShelleyRupdPredFailure era -> ShelleyRupdPredFailure era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (ShelleyRupdPredFailure era) x -> ShelleyRupdPredFailure era
forall era x.
ShelleyRupdPredFailure era -> Rep (ShelleyRupdPredFailure era) x
$cto :: forall era x.
Rep (ShelleyRupdPredFailure era) x -> ShelleyRupdPredFailure era
$cfrom :: forall era x.
ShelleyRupdPredFailure era -> Rep (ShelleyRupdPredFailure era) x
Generic)

instance NoThunks (ShelleyRupdPredFailure era)

instance NFData (ShelleyRupdPredFailure era)

instance
  ( Era era
  , EraGov era
  ) =>
  STS (ShelleyRUPD era)
  where
  type State (ShelleyRUPD era) = StrictMaybe (PulsingRewUpdate (EraCrypto era))
  type Signal (ShelleyRUPD era) = SlotNo
  type Environment (ShelleyRUPD era) = RupdEnv era
  type BaseM (ShelleyRUPD era) = ShelleyBase
  type PredicateFailure (ShelleyRUPD era) = ShelleyRupdPredFailure era
  type Event (ShelleyRUPD era) = RupdEvent (EraCrypto era)

  initialRules :: [InitialRule (ShelleyRUPD era)]
initialRules = [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing]
  transitionRules :: [TransitionRule (ShelleyRUPD era)]
transitionRules = [forall era. EraGov era => TransitionRule (ShelleyRUPD era)
rupdTransition]

data RupdEvent c
  = RupdEvent
      !EpochNo
      !(Map.Map (Credential 'Staking c) (Set (Reward c)))
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (RupdEvent c) x -> RupdEvent c
forall c x. RupdEvent c -> Rep (RupdEvent c) x
$cto :: forall c x. Rep (RupdEvent c) x -> RupdEvent c
$cfrom :: forall c x. RupdEvent c -> Rep (RupdEvent c) x
Generic, RupdEvent c -> RupdEvent c -> Bool
forall c. RupdEvent c -> RupdEvent c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RupdEvent c -> RupdEvent c -> Bool
$c/= :: forall c. RupdEvent c -> RupdEvent c -> Bool
== :: RupdEvent c -> RupdEvent c -> Bool
$c== :: forall c. RupdEvent c -> RupdEvent c -> Bool
Eq)

instance NFData (RupdEvent c)

-- | tell a RupdEvent only if the map is non-empty
tellRupd :: String -> RupdEvent (EraCrypto era) -> Rule (ShelleyRUPD era) rtype ()
tellRupd :: forall era (rtype :: RuleType).
String
-> RupdEvent (EraCrypto era) -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
_ (RupdEvent EpochNo
_ Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
m) | forall k a. Map k a -> Bool
Map.null Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
tellRupd String
_message RupdEvent (EraCrypto era)
x = forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent RupdEvent (EraCrypto era)
x

-- | The Goldilocks labeling of when to do the reward calculation.
data RewardTiming = RewardsTooEarly | RewardsJustRight | RewardsTooLate

determineRewardTiming :: SlotNo -> SlotNo -> SlotNo -> RewardTiming
determineRewardTiming :: SlotNo -> SlotNo -> SlotNo -> RewardTiming
determineRewardTiming SlotNo
currentSlot SlotNo
startAfterSlot SlotNo
endSlot
  | SlotNo
currentSlot forall a. Ord a => a -> a -> Bool
> SlotNo
endSlot = RewardTiming
RewardsTooLate
  | SlotNo
currentSlot forall a. Ord a => a -> a -> Bool
<= SlotNo
startAfterSlot = RewardTiming
RewardsTooEarly
  | Bool
otherwise = RewardTiming
RewardsJustRight

rupdTransition :: EraGov era => TransitionRule (ShelleyRUPD era)
rupdTransition :: forall era. EraGov era => TransitionRule (ShelleyRUPD era)
rupdTransition = do
  TRC (RupdEnv BlocksMade (EraCrypto era)
b EpochState era
es, State (ShelleyRUPD era)
ru, Signal (ShelleyRUPD era)
s) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  (EpochSize
slotsPerEpoch, SlotNo
slot, SlotNo
slotForce, Word64
maxLL, ActiveSlotCoeff
asc, Word64
k, EpochNo
e) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ do
    EpochInfo Identity
ei <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo Identity
epochInfoPure
    Word64
sr <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
randomnessStabilisationWindow
    EpochNo
e <- HasCallStack => EpochInfo Identity -> SlotNo -> ShelleyBase EpochNo
epochInfoEpoch EpochInfo Identity
ei Signal (ShelleyRUPD era)
s
    EpochSize
slotsPerEpoch <- HasCallStack =>
EpochInfo Identity -> EpochNo -> ShelleyBase EpochSize
epochInfoSize EpochInfo Identity
ei EpochNo
e
    SlotNo
slot <- HasCallStack =>
EpochInfo Identity -> EpochNo -> ReaderT Globals Identity SlotNo
epochInfoFirst EpochInfo Identity
ei EpochNo
e forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SlotNo -> Duration -> SlotNo
+* Word64 -> Duration
Duration Word64
sr)
    Word64
maxLL <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
maxLovelaceSupply
    ActiveSlotCoeff
asc <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> ActiveSlotCoeff
activeSlotCoeff
    Word64
k <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
securityParameter -- Maximum number of blocks we are allowed to roll back
    forall (m :: * -> *) a. Monad m => a -> m a
return (EpochSize
slotsPerEpoch, SlotNo
slot, SlotNo
slot SlotNo -> Duration -> SlotNo
+* Word64 -> Duration
Duration Word64
sr, Word64
maxLL, ActiveSlotCoeff
asc, Word64
k, EpochNo
e)
  let maxsupply :: Coin
maxsupply = Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxLL)
  case SlotNo -> SlotNo -> SlotNo -> RewardTiming
determineRewardTiming Signal (ShelleyRUPD era)
s SlotNo
slot SlotNo
slotForce of
    -- Waiting for the stability point, do nothing, keep waiting
    RewardTiming
RewardsTooEarly -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing
    -- More blocks to come, get things started or take a step
    RewardTiming
RewardsJustRight ->
      case State (ShelleyRUPD era)
ru of
        StrictMaybe (PulsingRewUpdate (EraCrypto era))
State (ShelleyRUPD era)
SNothing ->
          -- This is the first opportunity to pulse, so start pulsing.
          -- SJust <$> tellLeaderEvents (e + 1) (fst (startStep slotsPerEpoch b es maxsupply asc k))
          (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> StrictMaybe a
SJust) (forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate (EraCrypto era)
startStep EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
b EpochState era
es Coin
maxsupply ActiveSlotCoeff
asc Word64
k)
        (SJust p :: PulsingRewUpdate (EraCrypto era)
p@(Pulsing RewardSnapShot (EraCrypto era)
_ Pulser (EraCrypto era)
_)) -> do
          -- We began pulsing earlier, so run another pulse
          (PulsingRewUpdate (EraCrypto era)
ans, Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
pulseStep PulsingRewUpdate (EraCrypto era)
p
          forall era (rtype :: RuleType).
String
-> RupdEvent (EraCrypto era) -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
"Pulsing Rupd" (forall c.
EpochNo
-> Map (Credential 'Staking c) (Set (Reward c)) -> RupdEvent c
RupdEvent (forall a. Enum a => a -> a
succ EpochNo
e) Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (EraCrypto era)
ans)
        (SJust p :: PulsingRewUpdate (EraCrypto era)
p@(Complete RewardUpdate (EraCrypto era)
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (EraCrypto era)
p)
    -- Time to force the completion of the pulser so that downstream tools such as db-sync
    -- have time to see the reward update before the epoch boundary rollover.
    RewardTiming
RewardsTooLate ->
      case State (ShelleyRUPD era)
ru of
        StrictMaybe (PulsingRewUpdate (EraCrypto era))
State (ShelleyRUPD era)
SNothing -> do
          -- Nothing has been done, so start, and then complete the pulser. We hope this is very rare.
          let pulser :: PulsingRewUpdate (EraCrypto era)
pulser = forall era.
EraGov era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate (EraCrypto era)
startStep EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
b EpochState era
es Coin
maxsupply ActiveSlotCoeff
asc Word64
k
          (PulsingRewUpdate (EraCrypto era)
reward, Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
completeStep PulsingRewUpdate (EraCrypto era)
pulser
          forall era (rtype :: RuleType).
String
-> RupdEvent (EraCrypto era) -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
"Starting too late" (forall c.
EpochNo
-> Map (Credential 'Staking c) (Set (Reward c)) -> RupdEvent c
RupdEvent (forall a. Enum a => a -> a
succ EpochNo
e) Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (EraCrypto era)
reward)
        SJust p :: PulsingRewUpdate (EraCrypto era)
p@(Pulsing RewardSnapShot (EraCrypto era)
_ Pulser (EraCrypto era)
_) -> do
          -- We have been pulsing, but we ran out of time, so complete the pulser.
          (PulsingRewUpdate (EraCrypto era)
reward, Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall c.
PulsingRewUpdate c
-> ShelleyBase (PulsingRewUpdate c, RewardEvent c)
completeStep PulsingRewUpdate (EraCrypto era)
p
          forall era (rtype :: RuleType).
String
-> RupdEvent (EraCrypto era) -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
"Completing too late" (forall c.
EpochNo
-> Map (Credential 'Staking c) (Set (Reward c)) -> RupdEvent c
RupdEvent (forall a. Enum a => a -> a
succ EpochNo
e) Map
  (Credential 'Staking (EraCrypto era))
  (Set (Reward (EraCrypto era)))
event)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate (EraCrypto era)
reward)
        complete :: State (ShelleyRUPD era)
complete@(SJust (Complete RewardUpdate (EraCrypto era)
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure State (ShelleyRUPD era)
complete