{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Blockchain interface validation rules.
module Cardano.Chain.Update.Validation.Interface (
  -- * Environment
  Environment (..),

  -- * State
  State (..),
  initialState,

  -- * Signal
  Signal (..),

  -- * Error
  Error (..),

  -- * Interface functions
  registerUpdate,
  registerProposal,
  registerVote,
  registerEndorsement,
  registerEpoch,
) where

import Cardano.Chain.Common.BlockCount (BlockCount)
import Cardano.Chain.Common.KeyHash (KeyHash)
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Genesis as Genesis
import Cardano.Chain.ProtocolConstants (kEpochSlots)
import Cardano.Chain.Slotting (
  EpochNumber,
  SlotCount (SlotCount),
  SlotNumber,
  addSlotCount,
  epochFirstSlot,
  unSlotNumber,
 )
import Cardano.Chain.Update.Proposal (AProposal, UpId, recoverUpId)
import Cardano.Chain.Update.ProtocolParameters (
  ProtocolParameters,
  ppUpdateProposalTTL,
  upAdptThd,
 )
import Cardano.Chain.Update.ProtocolVersion (ProtocolVersion (..))
import Cardano.Chain.Update.SoftwareVersion (
  svAppName,
  svNumber,
 )
import Cardano.Chain.Update.Validation.Endorsement (
  CandidateProtocolUpdate,
  Endorsement,
  endorsementProtocolVersion,
 )
import qualified Cardano.Chain.Update.Validation.Endorsement as Endorsement
import Cardano.Chain.Update.Validation.Interface.ProtocolVersionBump (
  tryBumpVersion,
 )
import qualified Cardano.Chain.Update.Validation.Interface.ProtocolVersionBump as PVBump
import qualified Cardano.Chain.Update.Validation.Registration as Registration
import qualified Cardano.Chain.Update.Validation.Voting as Voting
import Cardano.Chain.Update.Vote (AVote)
import Cardano.Crypto (ProtocolMagicId)
import Cardano.Ledger.Binary (
  Annotated,
  DecCBOR (..),
  Decoder,
  DecoderError (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeListLen,
  decodeWord8,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  matchSize,
  toByronCBOR,
 )
import Cardano.Prelude hiding (State, cborError)
import qualified Data.Map.Strict as M
import Data.Set (union)
import qualified Data.Set as S
import NoThunks.Class (NoThunks (..))

data Environment = Environment
  { Environment -> Annotated ProtocolMagicId ByteString
protocolMagic :: !(Annotated ProtocolMagicId ByteString)
  , Environment -> BlockCount
k :: !BlockCount
  -- ^ TODO: this is the chain security parameter, a.k.a. @stableAfter@, it is not part
  -- of our protocol parameters, so it seems that we need to pass it in the
  -- environment. However we need to double-check this with others.
  , Environment -> SlotNumber
currentSlot :: !SlotNumber
  , Environment -> Word8
numGenKeys :: !Word8
  -- ^ Number of genesis keys. This is used to calculate the proportion of
  -- genesis keys that need to endorse a new protocol version for it to be
  -- considered for adoption. See
  -- @Cardano.Chain.Update.Validation.Endorsement.Environment@.
  , Environment -> Map
delegationMap :: !Delegation.Map
  }

-- | Update interface state.
data State = State
  { State -> EpochNumber
currentEpoch :: !EpochNumber
  -- ^ Current epoch
  , State -> ProtocolVersion
adoptedProtocolVersion :: !ProtocolVersion
  , State -> ProtocolParameters
adoptedProtocolParameters :: !ProtocolParameters
  -- ^ Adopted protocol parameters
  , State -> [CandidateProtocolUpdate]
candidateProtocolUpdates :: ![CandidateProtocolUpdate]
  -- ^ Candidate protocol versions
  , State -> ApplicationVersions
appVersions :: !Registration.ApplicationVersions
  -- ^ Current application versions
  , State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals :: !Registration.ProtocolUpdateProposals
  -- ^ Registered protocol update proposals
  , State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: !Registration.SoftwareUpdateProposals
  -- ^ Registered software update proposals
  , State -> Map UpId SlotNumber
confirmedProposals :: !(Map UpId SlotNumber)
  -- ^ Confirmed update proposals
  , State -> Map UpId (Set KeyHash)
proposalVotes :: !(Map UpId (Set KeyHash))
  -- ^ Update proposals votes
  , State -> Set Endorsement
registeredEndorsements :: !(Set Endorsement)
  -- ^ Update proposals endorsements
  , State -> Map UpId SlotNumber
proposalRegistrationSlot :: !(Map UpId SlotNumber)
  -- ^ Slot at which an update proposal was registered
  }
  deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: State -> State -> Bool
== :: State -> State -> Bool
$c/= :: State -> State -> Bool
/= :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> State -> ShowS
showsPrec :: Int -> State -> ShowS
$cshow :: State -> String
show :: State -> String
$cshowList :: [State] -> ShowS
showList :: [State] -> ShowS
Show, (forall x. State -> Rep State x)
-> (forall x. Rep State x -> State) -> Generic State
forall x. Rep State x -> State
forall x. State -> Rep State x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. State -> Rep State x
from :: forall x. State -> Rep State x
$cto :: forall x. Rep State x -> State
to :: forall x. Rep State x -> State
Generic)
  deriving anyclass (State -> ()
(State -> ()) -> NFData State
forall a. (a -> ()) -> NFData a
$crnf :: State -> ()
rnf :: State -> ()
NFData, Context -> State -> IO (Maybe ThunkInfo)
Proxy State -> String
(Context -> State -> IO (Maybe ThunkInfo))
-> (Context -> State -> IO (Maybe ThunkInfo))
-> (Proxy State -> String)
-> NoThunks State
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> State -> IO (Maybe ThunkInfo)
noThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> State -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy State -> String
showTypeOf :: Proxy State -> String
NoThunks)

instance ToCBOR State where
  toCBOR :: State -> Encoding
toCBOR = State -> Encoding
forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR State where
  fromCBOR :: forall s. Decoder s State
fromCBOR = Decoder s State
forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance DecCBOR State where
  decCBOR :: forall s. Decoder s State
decCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"State" Int
11
    EpochNumber
-> ProtocolVersion
-> ProtocolParameters
-> [CandidateProtocolUpdate]
-> ApplicationVersions
-> ProtocolUpdateProposals
-> SoftwareUpdateProposals
-> Map UpId SlotNumber
-> Map UpId (Set KeyHash)
-> Set Endorsement
-> Map UpId SlotNumber
-> State
State
      (EpochNumber
 -> ProtocolVersion
 -> ProtocolParameters
 -> [CandidateProtocolUpdate]
 -> ApplicationVersions
 -> ProtocolUpdateProposals
 -> SoftwareUpdateProposals
 -> Map UpId SlotNumber
 -> Map UpId (Set KeyHash)
 -> Set Endorsement
 -> Map UpId SlotNumber
 -> State)
-> Decoder s EpochNumber
-> Decoder
     s
     (ProtocolVersion
      -> ProtocolParameters
      -> [CandidateProtocolUpdate]
      -> ApplicationVersions
      -> ProtocolUpdateProposals
      -> SoftwareUpdateProposals
      -> Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s EpochNumber
forall s. Decoder s EpochNumber
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (ProtocolVersion
   -> ProtocolParameters
   -> [CandidateProtocolUpdate]
   -> ApplicationVersions
   -> ProtocolUpdateProposals
   -> SoftwareUpdateProposals
   -> Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s ProtocolVersion
-> Decoder
     s
     (ProtocolParameters
      -> [CandidateProtocolUpdate]
      -> ApplicationVersions
      -> ProtocolUpdateProposals
      -> SoftwareUpdateProposals
      -> Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ProtocolVersion
forall s. Decoder s ProtocolVersion
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (ProtocolParameters
   -> [CandidateProtocolUpdate]
   -> ApplicationVersions
   -> ProtocolUpdateProposals
   -> SoftwareUpdateProposals
   -> Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s ProtocolParameters
-> Decoder
     s
     ([CandidateProtocolUpdate]
      -> ApplicationVersions
      -> ProtocolUpdateProposals
      -> SoftwareUpdateProposals
      -> Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ProtocolParameters
forall s. Decoder s ProtocolParameters
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  ([CandidateProtocolUpdate]
   -> ApplicationVersions
   -> ProtocolUpdateProposals
   -> SoftwareUpdateProposals
   -> Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s [CandidateProtocolUpdate]
-> Decoder
     s
     (ApplicationVersions
      -> ProtocolUpdateProposals
      -> SoftwareUpdateProposals
      -> Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s [CandidateProtocolUpdate]
forall s. Decoder s [CandidateProtocolUpdate]
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (ApplicationVersions
   -> ProtocolUpdateProposals
   -> SoftwareUpdateProposals
   -> Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s ApplicationVersions
-> Decoder
     s
     (ProtocolUpdateProposals
      -> SoftwareUpdateProposals
      -> Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ApplicationVersions
forall s. Decoder s ApplicationVersions
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (ProtocolUpdateProposals
   -> SoftwareUpdateProposals
   -> Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s ProtocolUpdateProposals
-> Decoder
     s
     (SoftwareUpdateProposals
      -> Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ProtocolUpdateProposals
forall s. Decoder s ProtocolUpdateProposals
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (SoftwareUpdateProposals
   -> Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s SoftwareUpdateProposals
-> Decoder
     s
     (Map UpId SlotNumber
      -> Map UpId (Set KeyHash)
      -> Set Endorsement
      -> Map UpId SlotNumber
      -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s SoftwareUpdateProposals
forall s. Decoder s SoftwareUpdateProposals
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (Map UpId SlotNumber
   -> Map UpId (Set KeyHash)
   -> Set Endorsement
   -> Map UpId SlotNumber
   -> State)
-> Decoder s (Map UpId SlotNumber)
-> Decoder
     s
     (Map UpId (Set KeyHash)
      -> Set Endorsement -> Map UpId SlotNumber -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map UpId SlotNumber)
forall s. Decoder s (Map UpId SlotNumber)
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (Map UpId (Set KeyHash)
   -> Set Endorsement -> Map UpId SlotNumber -> State)
-> Decoder s (Map UpId (Set KeyHash))
-> Decoder s (Set Endorsement -> Map UpId SlotNumber -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map UpId (Set KeyHash))
forall s. Decoder s (Map UpId (Set KeyHash))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder s (Set Endorsement -> Map UpId SlotNumber -> State)
-> Decoder s (Set Endorsement)
-> Decoder s (Map UpId SlotNumber -> State)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Set Endorsement)
forall s. Decoder s (Set Endorsement)
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder s (Map UpId SlotNumber -> State)
-> Decoder s (Map UpId SlotNumber) -> Decoder s State
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map UpId SlotNumber)
forall s. Decoder s (Map UpId SlotNumber)
forall a s. DecCBOR a => Decoder s a
decCBOR

instance EncCBOR State where
  encCBOR :: State -> Encoding
encCBOR State
s =
    Word -> Encoding
encodeListLen Word
11
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNumber -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> EpochNumber
currentEpoch State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolVersion -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> ProtocolVersion
adoptedProtocolVersion State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolParameters -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> ProtocolParameters
adoptedProtocolParameters State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [CandidateProtocolUpdate] -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> [CandidateProtocolUpdate]
candidateProtocolUpdates State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ApplicationVersions -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> ApplicationVersions
appVersions State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolUpdateProposals -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SoftwareUpdateProposals -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map UpId SlotNumber -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> Map UpId SlotNumber
confirmedProposals State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map UpId (Set KeyHash) -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> Map UpId (Set KeyHash)
proposalVotes State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set Endorsement -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> Set Endorsement
registeredEndorsements State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map UpId SlotNumber -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (State -> Map UpId SlotNumber
proposalRegistrationSlot State
s)

data Error
  = Registration Registration.Error
  | Voting Voting.Error
  | Endorsement Endorsement.Error
  | NumberOfGenesisKeysTooLarge (Registration.TooLarge Int)
  deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show)

instance ToCBOR Error where
  toCBOR :: Error -> Encoding
toCBOR = Error -> Encoding
forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR Error where
  fromCBOR :: forall s. Decoder s Error
fromCBOR = Decoder s Error
forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR Error where
  encCBOR :: Error -> Encoding
encCBOR Error
err = case Error
err of
    Registration Error
registrationErr ->
      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
<> Error -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Error
registrationErr
    Voting Error
votingErr ->
      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
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Error
votingErr
    Endorsement Error
endorsementErr ->
      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
2 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Error
endorsementErr
    NumberOfGenesisKeysTooLarge TooLarge Int
tooLarge ->
      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
3 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TooLarge Int -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR TooLarge Int
tooLarge

instance DecCBOR Error where
  decCBOR :: forall s. Decoder s Error
decCBOR = do
    Int
len <- Decoder s Int
forall s. Decoder s Int
decodeListLen
    let checkSize :: Int -> Decoder s ()
        checkSize :: forall s. Int -> Decoder s ()
checkSize Int
size = Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"Interface.Error" Int
size Int
len
    Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall a b. Decoder s a -> Decoder s b -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Error
Registration (Error -> Error) -> Decoder s Error -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Error
forall s. Decoder s Error
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall a b. Decoder s a -> Decoder s b -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Error
Voting (Error -> Error) -> Decoder s Error -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Error
forall s. Decoder s Error
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
2 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall a b. Decoder s a -> Decoder s b -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Error
Endorsement (Error -> Error) -> Decoder s Error -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Error
forall s. Decoder s Error
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
3 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall a b. Decoder s a -> Decoder s b -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TooLarge Int -> Error
NumberOfGenesisKeysTooLarge (TooLarge Int -> Error)
-> Decoder s (TooLarge Int) -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (TooLarge Int)
forall s. Decoder s (TooLarge Int)
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
_ -> DecoderError -> Decoder s Error
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s Error)
-> DecoderError -> Decoder s Error
forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"Interface.Error" Word8
tag

-- | Signal combining signals from various rules
data Signal = Signal
  { Signal -> Maybe (AProposal ByteString)
proposal :: !(Maybe (AProposal ByteString))
  , Signal -> [AVote ByteString]
votes :: ![AVote ByteString]
  , Signal -> Endorsement
endorsement :: !Endorsement
  }

-- | Initial update interface state
initialState :: Genesis.Config -> State
initialState :: Config -> State
initialState Config
config =
  State
    { currentEpoch :: EpochNumber
currentEpoch = EpochNumber
0
    , adoptedProtocolVersion :: ProtocolVersion
adoptedProtocolVersion = Word16 -> Word16 -> Word8 -> ProtocolVersion
ProtocolVersion Word16
0 Word16
0 Word8
0
    , adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters = Config -> ProtocolParameters
Genesis.configProtocolParameters Config
config
    , candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates = []
    , appVersions :: ApplicationVersions
appVersions = ApplicationVersions
forall a. Monoid a => a
mempty
    , registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = ProtocolUpdateProposals
forall a. Monoid a => a
mempty
    , registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals = SoftwareUpdateProposals
forall a. Monoid a => a
mempty
    , confirmedProposals :: Map UpId SlotNumber
confirmedProposals = Map UpId SlotNumber
forall a. Monoid a => a
mempty
    , proposalVotes :: Map UpId (Set KeyHash)
proposalVotes = Map UpId (Set KeyHash)
forall a. Monoid a => a
mempty
    , registeredEndorsements :: Set Endorsement
registeredEndorsements = Set Endorsement
forall a. Monoid a => a
mempty
    , proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot = Map UpId SlotNumber
forall a. Monoid a => a
mempty
    }

-- | Group together the other registration rules in a single rule
--
--   This corresponds to the @BUPI@ rule in the Byron chain specification.
registerUpdate ::
  MonadError Error m => Environment -> State -> Signal -> m State
registerUpdate :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Signal -> m State
registerUpdate Environment
env State
st Signal {Maybe (AProposal ByteString)
proposal :: Signal -> Maybe (AProposal ByteString)
proposal :: Maybe (AProposal ByteString)
proposal, [AVote ByteString]
votes :: Signal -> [AVote ByteString]
votes :: [AVote ByteString]
votes, Endorsement
endorsement :: Signal -> Endorsement
endorsement :: Endorsement
endorsement} = do
  -- Register proposal if it exists
  State
st' <- case Maybe (AProposal ByteString)
proposal of
    Maybe (AProposal ByteString)
Nothing -> State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
    Just AProposal ByteString
p -> Environment -> State -> AProposal ByteString -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
registerProposal Environment
env State
st AProposal ByteString
p

  -- Register the votes
  State
st'' <- Environment -> State -> [AVote ByteString] -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [AVote ByteString] -> m State
registerVotes Environment
env State
st' [AVote ByteString]
votes

  -- Register endorsement
  Environment -> State -> Endorsement -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Endorsement -> m State
registerEndorsement Environment
env State
st'' Endorsement
endorsement

-- | Register an update proposal.
--
-- This corresponds to the @UPIREG@ rule in the Byron ledger specification.
registerProposal ::
  MonadError Error m =>
  Environment ->
  State ->
  AProposal ByteString ->
  m State
registerProposal :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
registerProposal Environment
env State
st AProposal ByteString
proposal = do
  Registration.State ProtocolUpdateProposals
registeredProtocolUpdateProposals' SoftwareUpdateProposals
registeredSoftwareUpdateProposals' <-
    Environment -> State -> AProposal ByteString -> Either Error State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
Registration.registerProposal Environment
subEnv State
subSt AProposal ByteString
proposal
      Either Error State -> (Error -> Error) -> m State
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> Error
Registration
  State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
st
      { registeredProtocolUpdateProposals = registeredProtocolUpdateProposals'
      , registeredSoftwareUpdateProposals = registeredSoftwareUpdateProposals'
      , proposalRegistrationSlot =
          M.insert (recoverUpId proposal) currentSlot proposalRegistrationSlot
      }
  where
    Environment
      { Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic
      , SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot :: SlotNumber
currentSlot
      , Map
delegationMap :: Environment -> Map
delegationMap :: Map
delegationMap
      } = Environment
env

    State
      { ProtocolVersion
adoptedProtocolVersion :: State -> ProtocolVersion
adoptedProtocolVersion :: ProtocolVersion
adoptedProtocolVersion
      , ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters
      , ApplicationVersions
appVersions :: State -> ApplicationVersions
appVersions :: ApplicationVersions
appVersions
      , ProtocolUpdateProposals
registeredProtocolUpdateProposals :: State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals
      , SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals
      , Map UpId SlotNumber
proposalRegistrationSlot :: State -> Map UpId SlotNumber
proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot
      } = State
st

    subEnv :: Environment
subEnv =
      Annotated ProtocolMagicId ByteString
-> SlotNumber
-> ProtocolVersion
-> ProtocolParameters
-> ApplicationVersions
-> Map
-> Environment
Registration.Environment
        Annotated ProtocolMagicId ByteString
protocolMagic
        SlotNumber
currentSlot
        ProtocolVersion
adoptedProtocolVersion
        ProtocolParameters
adoptedProtocolParameters
        ApplicationVersions
appVersions
        Map
delegationMap

    subSt :: State
subSt =
      ProtocolUpdateProposals -> SoftwareUpdateProposals -> State
Registration.State
        ProtocolUpdateProposals
registeredProtocolUpdateProposals
        SoftwareUpdateProposals
registeredSoftwareUpdateProposals

-- | Register a sequence of votes.
--
-- After applying the votes, we check for confirmed proposals, and update the
-- application versions according to the proposals that, in the new state, are
-- confirmed and stable.
--
-- This corresponds to the @UPIVOTES@ rule in the Byron ledger
-- specification.
registerVotes ::
  MonadError Error m =>
  Environment ->
  State ->
  [AVote ByteString] ->
  m State
registerVotes :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [AVote ByteString] -> m State
registerVotes Environment
env State
st [AVote ByteString]
votes = do
  State
st' <- (State -> AVote ByteString -> m State)
-> State -> [AVote ByteString] -> m State
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Environment -> State -> AVote ByteString -> m State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AVote ByteString -> m State
registerVote Environment
env) State
st [AVote ByteString]
votes
  let Environment
        { SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot :: SlotNumber
currentSlot
        } = Environment
env

      State
        { Map UpId SlotNumber
confirmedProposals :: State -> Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals
        , ApplicationVersions
appVersions :: State -> ApplicationVersions
appVersions :: ApplicationVersions
appVersions
        , SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals
        } = State
st'

      confirmedApplicationUpdates :: SoftwareUpdateProposals
confirmedApplicationUpdates =
        SoftwareUpdateProposals -> Set UpId -> SoftwareUpdateProposals
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys
          SoftwareUpdateProposals
registeredSoftwareUpdateProposals
          (Map UpId SlotNumber -> Set UpId
forall k a. Map k a -> Set k
M.keysSet Map UpId SlotNumber
confirmedProposals)
      appVersions' :: ApplicationVersions
appVersions' =
        [(ApplicationName, ApplicationVersion)] -> ApplicationVersions
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
          ([(ApplicationName, ApplicationVersion)] -> ApplicationVersions)
-> [(ApplicationName, ApplicationVersion)] -> ApplicationVersions
forall a b. (a -> b) -> a -> b
$ [ (SoftwareVersion -> ApplicationName
svAppName SoftwareVersion
sv, ApplicationVersion
av)
            | (UpId
pid, SoftwareUpdateProposal
sup) <- SoftwareUpdateProposals -> [(UpId, SoftwareUpdateProposal)]
forall k a. Map k a -> [(k, a)]
M.toList SoftwareUpdateProposals
registeredSoftwareUpdateProposals
            , UpId
pid UpId -> [UpId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SoftwareUpdateProposals -> [UpId]
forall k a. Map k a -> [k]
M.keys SoftwareUpdateProposals
confirmedApplicationUpdates
            , let Registration.SoftwareUpdateProposal SoftwareVersion
sv Metadata
metadata = SoftwareUpdateProposal
sup
                  av :: ApplicationVersion
av = NumSoftwareVersion -> SlotNumber -> Metadata -> ApplicationVersion
Registration.ApplicationVersion (SoftwareVersion -> NumSoftwareVersion
svNumber SoftwareVersion
sv) SlotNumber
currentSlot Metadata
metadata
            ]
  State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$ State
st' -- Note that it's important that the new application versions are passed
    -- as the first argument of @M.union@, since the values in this first
    -- argument overwrite the values in the second.
      { appVersions = M.union appVersions' appVersions
      , -- TODO: consider using the `Relation` instances from `cardano-ledger` (see `Ledger.Core`)
        registeredSoftwareUpdateProposals =
          M.withoutKeys
            registeredSoftwareUpdateProposals
            (M.keysSet confirmedProposals)
      }

-- | Register a vote for the given proposal.
--
-- This corresponds to the @UPIVOTE@ rule in the Byron ledger
registerVote ::
  MonadError Error m =>
  Environment ->
  State ->
  AVote ByteString ->
  m State
registerVote :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AVote ByteString -> m State
registerVote Environment
env State
st AVote ByteString
vote = do
  Voting.State Map UpId (Set KeyHash)
proposalVotes' Map UpId SlotNumber
confirmedProposals' <-
    Annotated ProtocolMagicId ByteString
-> Environment -> State -> AVote ByteString -> Either Error State
forall (m :: * -> *).
MonadError Error m =>
Annotated ProtocolMagicId ByteString
-> Environment -> State -> AVote ByteString -> m State
Voting.registerVoteWithConfirmation Annotated ProtocolMagicId ByteString
protocolMagic Environment
subEnv State
subSt AVote ByteString
vote
      Either Error State -> (Error -> Error) -> m State
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> Error
Voting
  State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
st
      { confirmedProposals = confirmedProposals'
      , proposalVotes = proposalVotes'
      }
  where
    Environment
      { Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic
      , SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot :: SlotNumber
currentSlot
      , Word8
numGenKeys :: Environment -> Word8
numGenKeys :: Word8
numGenKeys
      , Map
delegationMap :: Environment -> Map
delegationMap :: Map
delegationMap
      } = Environment
env

    State
      { ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters
      , Map UpId SlotNumber
proposalRegistrationSlot :: State -> Map UpId SlotNumber
proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot
      , Map UpId (Set KeyHash)
proposalVotes :: State -> Map UpId (Set KeyHash)
proposalVotes :: Map UpId (Set KeyHash)
proposalVotes
      , Map UpId SlotNumber
confirmedProposals :: State -> Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals
      } = State
st

    rups :: Set UpId
rups = Map UpId SlotNumber -> Set UpId
forall k a. Map k a -> Set k
M.keysSet Map UpId SlotNumber
proposalRegistrationSlot

    subEnv :: Environment
subEnv =
      SlotNumber -> Int -> RegistrationEnvironment -> Environment
Voting.Environment
        SlotNumber
currentSlot
        (Word8 -> ProtocolParameters -> Int
upAdptThd Word8
numGenKeys ProtocolParameters
adoptedProtocolParameters)
        (Set UpId -> Map -> RegistrationEnvironment
Voting.RegistrationEnvironment Set UpId
rups Map
delegationMap)

    subSt :: State
subSt = Map UpId (Set KeyHash) -> Map UpId SlotNumber -> State
Voting.State Map UpId (Set KeyHash)
proposalVotes Map UpId SlotNumber
confirmedProposals

-- | Register an endorsement.
--
-- An endorsement represents the fact that a genesis key is ready to start using
-- the protocol version being endorsed. In the decentralized era only genesis
-- key holders can endorse protocol versions.
--
-- This corresponds to the @UPIEND@ rule in the Byron ledger
-- specification.
registerEndorsement ::
  MonadError Error m =>
  Environment ->
  State ->
  Endorsement ->
  m State
registerEndorsement :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Endorsement -> m State
registerEndorsement Environment
env State
st Endorsement
endorsement = do
  Endorsement.State [CandidateProtocolUpdate]
candidateProtocolUpdates' Set Endorsement
registeredEndorsements' <-
    Environment -> State -> Endorsement -> Either Error State
forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Endorsement -> m State
Endorsement.register Environment
subEnv State
subSt Endorsement
endorsement
      Either Error State -> (Error -> Error) -> m State
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> Error
Endorsement
  let pidsKeep :: Set UpId
pidsKeep = Set UpId
nonExpiredPids Set UpId -> Set UpId -> Set UpId
forall a. Ord a => Set a -> Set a -> Set a
`union` Set UpId
confirmedPids

      nonExpiredPids :: Set UpId
nonExpiredPids =
        Map UpId SlotNumber -> Set UpId
forall k a. Map k a -> Set k
M.keysSet (Map UpId SlotNumber -> Set UpId)
-> Map UpId SlotNumber -> Set UpId
forall a b. (a -> b) -> a -> b
$ (SlotNumber -> Bool) -> Map UpId SlotNumber -> Map UpId SlotNumber
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\SlotNumber
s -> SlotNumber
currentSlot SlotNumber -> SlotNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotCount -> SlotNumber -> SlotNumber
addSlotCount SlotCount
u SlotNumber
s) Map UpId SlotNumber
proposalRegistrationSlot

      confirmedPids :: Set UpId
confirmedPids = Map UpId SlotNumber -> Set UpId
forall k a. Map k a -> Set k
M.keysSet Map UpId SlotNumber
confirmedProposals

      registeredProtocolUpdateProposals' :: ProtocolUpdateProposals
registeredProtocolUpdateProposals' =
        ProtocolUpdateProposals -> Set UpId -> ProtocolUpdateProposals
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys ProtocolUpdateProposals
registeredProtocolUpdateProposals Set UpId
pidsKeep

      vsKeep :: Set ProtocolVersion
vsKeep =
        [ProtocolVersion] -> Set ProtocolVersion
forall a. Ord a => [a] -> Set a
S.fromList
          ([ProtocolVersion] -> Set ProtocolVersion)
-> [ProtocolVersion] -> Set ProtocolVersion
forall a b. (a -> b) -> a -> b
$ ProtocolUpdateProposal -> ProtocolVersion
Registration.pupProtocolVersion
          (ProtocolUpdateProposal -> ProtocolVersion)
-> [ProtocolUpdateProposal] -> [ProtocolVersion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolUpdateProposals -> [ProtocolUpdateProposal]
forall k a. Map k a -> [a]
M.elems ProtocolUpdateProposals
registeredProtocolUpdateProposals'

  State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
st
      { candidateProtocolUpdates = forceElemsToWHNF candidateProtocolUpdates'
      , registeredProtocolUpdateProposals = registeredProtocolUpdateProposals'
      , registeredSoftwareUpdateProposals =
          M.restrictKeys registeredSoftwareUpdateProposals pidsKeep
      , proposalVotes =
          M.restrictKeys proposalVotes pidsKeep
      , registeredEndorsements =
          S.filter ((`S.member` vsKeep) . endorsementProtocolVersion) registeredEndorsements'
      , proposalRegistrationSlot =
          M.restrictKeys proposalRegistrationSlot pidsKeep
      }
  where
    subEnv :: Environment
subEnv =
      BlockCount
-> SlotNumber
-> Int
-> Map
-> Map UpId SlotNumber
-> ProtocolUpdateProposals
-> Environment
Endorsement.Environment
        BlockCount
k
        SlotNumber
currentSlot
        (Word8 -> ProtocolParameters -> Int
upAdptThd Word8
numGenKeys ProtocolParameters
adoptedProtocolParameters)
        Map
delegationMap
        Map UpId SlotNumber
confirmedProposals
        ProtocolUpdateProposals
registeredProtocolUpdateProposals

    Environment
      { BlockCount
k :: Environment -> BlockCount
k :: BlockCount
k
      , SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot :: SlotNumber
currentSlot
      , Word8
numGenKeys :: Environment -> Word8
numGenKeys :: Word8
numGenKeys
      , Map
delegationMap :: Environment -> Map
delegationMap :: Map
delegationMap
      } = Environment
env

    State
      { ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters
      , Map UpId SlotNumber
confirmedProposals :: State -> Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals
      , ProtocolUpdateProposals
registeredProtocolUpdateProposals :: State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals
      , SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals
      , [CandidateProtocolUpdate]
candidateProtocolUpdates :: State -> [CandidateProtocolUpdate]
candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates
      , Map UpId (Set KeyHash)
proposalVotes :: State -> Map UpId (Set KeyHash)
proposalVotes :: Map UpId (Set KeyHash)
proposalVotes
      , Set Endorsement
registeredEndorsements :: State -> Set Endorsement
registeredEndorsements :: Set Endorsement
registeredEndorsements
      , Map UpId SlotNumber
proposalRegistrationSlot :: State -> Map UpId SlotNumber
proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot
      } = State
st

    subSt :: State
subSt =
      [CandidateProtocolUpdate] -> Set Endorsement -> State
Endorsement.State
        [CandidateProtocolUpdate]
candidateProtocolUpdates
        Set Endorsement
registeredEndorsements

    u :: SlotCount
u = Word64 -> SlotCount
SlotCount (Word64 -> SlotCount)
-> (ProtocolParameters -> Word64)
-> ProtocolParameters
-> SlotCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SlotNumber -> Word64
unSlotNumber (SlotNumber -> Word64)
-> (ProtocolParameters -> SlotNumber)
-> ProtocolParameters
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolParameters -> SlotNumber
ppUpdateProposalTTL (ProtocolParameters -> SlotCount)
-> ProtocolParameters -> SlotCount
forall a b. (a -> b) -> a -> b
$ ProtocolParameters
adoptedProtocolParameters

-- | Register an epoch. Whenever an epoch number is seen on a block this epoch
-- number should be passed to this function so that on epoch change the
-- protocol parameters can be updated, provided that there is an update
-- candidate that was accepted and endorsed by a majority of the genesis keys.
--
-- This corresponds to the @UPIEC@ rules in the Byron ledger specification.
registerEpoch ::
  Environment ->
  State ->
  -- | Epoch seen on the block.
  EpochNumber ->
  State
registerEpoch :: Environment -> State -> EpochNumber -> State
registerEpoch Environment
env State
st EpochNumber
lastSeenEpoch = do
  let PVBump.State
        ProtocolVersion
adoptedProtocolVersion'
        ProtocolParameters
nextProtocolParameters' =
          Environment -> State -> State
tryBumpVersion Environment
subEnv State
subSt
  if ProtocolVersion
adoptedProtocolVersion' ProtocolVersion -> ProtocolVersion -> Bool
forall a. Eq a => a -> a -> Bool
== ProtocolVersion
adoptedProtocolVersion
    then -- Nothing changes in the state, since we are not changing protocol
    -- versions. This happens when either the epoch does not change (and
    -- therefore the protocol parameters cannot change) or there are no
    -- update proposals that can be adopted (either because there are no
    -- candidates or they do not fulfill the requirements for adoption).
      State
st
    else -- We have a new protocol version, so we update the current protocol
    -- version and parameters, and we perform a cleanup of the state
    -- variables.
      State
st
        { adoptedProtocolVersion = adoptedProtocolVersion'
        , adoptedProtocolParameters = nextProtocolParameters'
        , candidateProtocolUpdates = []
        , registeredProtocolUpdateProposals = M.empty
        , registeredSoftwareUpdateProposals = M.empty
        , confirmedProposals = M.empty
        , proposalVotes = M.empty
        , registeredEndorsements = S.empty
        , proposalRegistrationSlot = M.empty
        }
  where
    subEnv :: Environment
subEnv = BlockCount
-> SlotNumber -> [CandidateProtocolUpdate] -> Environment
PVBump.Environment BlockCount
k SlotNumber
firstSlotOfLastSeenEpoch [CandidateProtocolUpdate]
candidateProtocolUpdates

    subSt :: State
subSt =
      ProtocolVersion -> ProtocolParameters -> State
PVBump.State
        ProtocolVersion
adoptedProtocolVersion
        ProtocolParameters
adoptedProtocolParameters

    firstSlotOfLastSeenEpoch :: SlotNumber
firstSlotOfLastSeenEpoch = EpochSlots -> EpochNumber -> SlotNumber
epochFirstSlot (BlockCount -> EpochSlots
kEpochSlots BlockCount
k) EpochNumber
lastSeenEpoch

    Environment
      { BlockCount
k :: Environment -> BlockCount
k :: BlockCount
k
      } = Environment
env

    State
      { ProtocolVersion
adoptedProtocolVersion :: State -> ProtocolVersion
adoptedProtocolVersion :: ProtocolVersion
adoptedProtocolVersion
      , ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters
      , [CandidateProtocolUpdate]
candidateProtocolUpdates :: State -> [CandidateProtocolUpdate]
candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates
      } = State
st