{-# 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.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 qualified Data.Map.Strict as Map
import Data.Set (Set)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

data RupdEnv era
  = RupdEnv !BlocksMade !(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
  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

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

instance NFData RupdEvent

-- | tell a RupdEvent only if the map is non-empty
tellRupd :: String -> RupdEvent -> Rule (ShelleyRUPD era) rtype ()
tellRupd :: forall era (rtype :: RuleType).
String -> RupdEvent -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
_ (RupdEvent EpochNo
_ Map (Credential 'Staking) (Set Reward)
m) | forall k a. Map k a -> Bool
Map.null Map (Credential 'Staking) (Set Reward)
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
tellRupd String
_message RupdEvent
x = forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent RupdEvent
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
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
    let e :: EpochNo
e = HasCallStack => EpochInfo Identity -> SlotNo -> EpochNo
epochInfoEpoch EpochInfo Identity
ei Signal (ShelleyRUPD era)
s
        slotsPerEpoch :: EpochSize
slotsPerEpoch = HasCallStack => EpochInfo Identity -> EpochNo -> EpochSize
epochInfoSize EpochInfo Identity
ei EpochNo
e
        slot :: SlotNo
slot = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst EpochInfo Identity
ei EpochNo
e 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
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
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate
startStep EpochSize
slotsPerEpoch BlocksMade
b EpochState era
es Coin
maxsupply ActiveSlotCoeff
asc Word64
k)
        (SJust p :: PulsingRewUpdate
p@(Pulsing RewardSnapShot
_ Pulser
_)) -> do
          -- We began pulsing earlier, so run another pulse
          (PulsingRewUpdate
ans, Map (Credential 'Staking) (Set Reward)
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate
-> ShelleyBase
     (PulsingRewUpdate, Map (Credential 'Staking) (Set Reward))
pulseStep PulsingRewUpdate
p
          forall era (rtype :: RuleType).
String -> RupdEvent -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
"Pulsing Rupd" (EpochNo -> Map (Credential 'Staking) (Set Reward) -> RupdEvent
RupdEvent (forall a. Enum a => a -> a
succ EpochNo
e) Map (Credential 'Staking) (Set Reward)
event)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate
ans)
        (SJust p :: PulsingRewUpdate
p@(Complete RewardUpdate
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate
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
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
pulser = forall era.
EraGov era =>
EpochSize
-> BlocksMade
-> EpochState era
-> Coin
-> ActiveSlotCoeff
-> Word64
-> PulsingRewUpdate
startStep EpochSize
slotsPerEpoch BlocksMade
b EpochState era
es Coin
maxsupply ActiveSlotCoeff
asc Word64
k
          (PulsingRewUpdate
reward, Map (Credential 'Staking) (Set Reward)
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate
-> ShelleyBase
     (PulsingRewUpdate, Map (Credential 'Staking) (Set Reward))
completeStep PulsingRewUpdate
pulser
          forall era (rtype :: RuleType).
String -> RupdEvent -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
"Starting too late" (EpochNo -> Map (Credential 'Staking) (Set Reward) -> RupdEvent
RupdEvent (forall a. Enum a => a -> a
succ EpochNo
e) Map (Credential 'Staking) (Set Reward)
event)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate
reward)
        SJust p :: PulsingRewUpdate
p@(Pulsing RewardSnapShot
_ Pulser
_) -> do
          -- We have been pulsing, but we ran out of time, so complete the pulser.
          (PulsingRewUpdate
reward, Map (Credential 'Staking) (Set Reward)
event) <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ PulsingRewUpdate
-> ShelleyBase
     (PulsingRewUpdate, Map (Credential 'Staking) (Set Reward))
completeStep PulsingRewUpdate
p
          forall era (rtype :: RuleType).
String -> RupdEvent -> Rule (ShelleyRUPD era) rtype ()
tellRupd String
"Completing too late" (EpochNo -> Map (Credential 'Staking) (Set Reward) -> RupdEvent
RupdEvent (forall a. Enum a => a -> a
succ EpochNo
e) Map (Credential 'Staking) (Set Reward)
event)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> StrictMaybe a
SJust PulsingRewUpdate
reward)
        complete :: State (ShelleyRUPD era)
complete@(SJust (Complete RewardUpdate
_)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure State (ShelleyRUPD era)
complete