{-# LANGUAGE BangPatterns #-}
{-# 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.Binary
  ( Annotated,
    Decoder,
    DecoderError (..),
    FromCBOR (..),
    ToCBOR (..),
    decodeListLen,
    decodeWord8,
    encodeListLen,
    enforceSize,
    matchSize,
  )
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.Prelude hiding (State)
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),
    -- | 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 -> BlockCount
k :: !BlockCount,
    Environment -> SlotNumber
currentSlot :: !SlotNumber,
    -- | 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 -> Word8
numGenKeys :: !Word8,
    Environment -> Map
delegationMap :: !Delegation.Map
  }

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

instance FromCBOR State where
  fromCBOR :: Decoder s State
fromCBOR = 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 a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ProtocolVersion
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ProtocolParameters
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s [CandidateProtocolUpdate]
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ApplicationVersions
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s ProtocolUpdateProposals
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s SoftwareUpdateProposals
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map UpId SlotNumber)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map UpId (Set KeyHash))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (Set Endorsement -> Map UpId SlotNumber -> State)
-> Decoder s (Set Endorsement)
-> Decoder s (Map UpId SlotNumber -> State)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Set Endorsement)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (Map UpId SlotNumber -> State)
-> Decoder s (Map UpId SlotNumber) -> Decoder s State
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (Map UpId SlotNumber)
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance ToCBOR State where
  toCBOR :: State -> Encoding
toCBOR State
s =
    Word -> Encoding
encodeListLen Word
11
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> EpochNumber
currentEpoch State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolVersion -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> ProtocolVersion
adoptedProtocolVersion State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolParameters -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> ProtocolParameters
adoptedProtocolParameters State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [CandidateProtocolUpdate] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> [CandidateProtocolUpdate]
candidateProtocolUpdates State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ApplicationVersions -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> ApplicationVersions
appVersions State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolUpdateProposals -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SoftwareUpdateProposals -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map UpId SlotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> Map UpId SlotNumber
confirmedProposals State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map UpId (Set KeyHash) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> Map UpId (Set KeyHash)
proposalVotes State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Set Endorsement -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (State -> Set Endorsement
registeredEndorsements State
s)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map UpId SlotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (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
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: 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
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance ToCBOR Error where
  toCBOR :: Error -> Encoding
toCBOR 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. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Error
registrationErr
    Voting Error
votingErr ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Error
votingErr
    Endorsement Error
endorsementErr ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
2 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Error -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR 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. ToCBOR a => a -> Encoding
toCBOR (Word8
3 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TooLarge Int -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR TooLarge Int
tooLarge

instance FromCBOR Error where
  fromCBOR :: Decoder s Error
fromCBOR = do
    Int
len <- Decoder s Int
forall s. Decoder s Int
decodeListLen
    let checkSize :: Int -> Decoder s ()
        checkSize :: 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 (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 a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
1 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
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 a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
2 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
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 a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
3 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
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 a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
_ -> DecoderError -> Decoder s Error
forall e s a. Buildable e => e -> Decoder s 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 :: EpochNumber
-> ProtocolVersion
-> ProtocolParameters
-> [CandidateProtocolUpdate]
-> ApplicationVersions
-> ProtocolUpdateProposals
-> SoftwareUpdateProposals
-> Map UpId SlotNumber
-> Map UpId (Set KeyHash)
-> Set Endorsement
-> Map UpId SlotNumber
-> State
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 :: Environment -> State -> Signal -> m State
registerUpdate Environment
env State
st Signal {Maybe (AProposal ByteString)
proposal :: Maybe (AProposal ByteString)
proposal :: Signal -> Maybe (AProposal ByteString)
proposal, [AVote ByteString]
votes :: [AVote ByteString]
votes :: Signal -> [AVote ByteString]
votes, Endorsement
endorsement :: Endorsement
endorsement :: Signal -> Endorsement
endorsement} = do
  -- Register proposal if it exists
  State
st' <- case Maybe (AProposal ByteString)
proposal of
    Maybe (AProposal ByteString)
Nothing -> State -> m State
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
st
      { registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = ProtocolUpdateProposals
registeredProtocolUpdateProposals',
        registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals = SoftwareUpdateProposals
registeredSoftwareUpdateProposals',
        proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot =
          UpId -> SlotNumber -> Map UpId SlotNumber -> Map UpId SlotNumber
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (AProposal ByteString -> UpId
recoverUpId AProposal ByteString
proposal) SlotNumber
currentSlot Map UpId SlotNumber
proposalRegistrationSlot
      }
  where
    Environment
      { Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic,
        SlotNumber
currentSlot :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot,
        Map
delegationMap :: Map
delegationMap :: Environment -> Map
delegationMap
      } = Environment
env

    State
      { ProtocolVersion
adoptedProtocolVersion :: ProtocolVersion
adoptedProtocolVersion :: State -> ProtocolVersion
adoptedProtocolVersion,
        ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters,
        ApplicationVersions
appVersions :: ApplicationVersions
appVersions :: State -> ApplicationVersions
appVersions,
        ProtocolUpdateProposals
registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals :: State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals,
        SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals,
        Map UpId SlotNumber
proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot :: State -> 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 :: 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 :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot
        } = Environment
env

      State
        { Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals :: State -> Map UpId SlotNumber
confirmedProposals,
          ApplicationVersions
appVersions :: ApplicationVersions
appVersions :: State -> ApplicationVersions
appVersions,
          SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: State -> 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 (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 (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 :: ApplicationVersions
appVersions = ApplicationVersions -> ApplicationVersions -> ApplicationVersions
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union ApplicationVersions
appVersions' ApplicationVersions
appVersions,
        -- TODO: consider using the `Relation` instances from `cardano-ledger` (see `Ledger.Core`)
        registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals =
          SoftwareUpdateProposals -> Set UpId -> SoftwareUpdateProposals
forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys
            SoftwareUpdateProposals
registeredSoftwareUpdateProposals
            (Map UpId SlotNumber -> Set UpId
forall k a. Map k a -> Set k
M.keysSet Map UpId SlotNumber
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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
st
      { confirmedProposals :: Map UpId SlotNumber
confirmedProposals = Map UpId SlotNumber
confirmedProposals',
        proposalVotes :: Map UpId (Set KeyHash)
proposalVotes = Map UpId (Set KeyHash)
proposalVotes'
      }
  where
    Environment
      { Annotated ProtocolMagicId ByteString
protocolMagic :: Annotated ProtocolMagicId ByteString
protocolMagic :: Environment -> Annotated ProtocolMagicId ByteString
protocolMagic,
        SlotNumber
currentSlot :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot,
        Word8
numGenKeys :: Word8
numGenKeys :: Environment -> Word8
numGenKeys,
        Map
delegationMap :: Map
delegationMap :: Environment -> Map
delegationMap
      } = Environment
env

    State
      { ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters,
        Map UpId SlotNumber
proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot :: State -> Map UpId SlotNumber
proposalRegistrationSlot,
        Map UpId (Set KeyHash)
proposalVotes :: Map UpId (Set KeyHash)
proposalVotes :: State -> Map UpId (Set KeyHash)
proposalVotes,
        Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals :: State -> 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 :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure
    (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$! State
st
      { candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates = [CandidateProtocolUpdate] -> [CandidateProtocolUpdate]
forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF [CandidateProtocolUpdate]
candidateProtocolUpdates',
        registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = ProtocolUpdateProposals
registeredProtocolUpdateProposals',
        registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals =
          SoftwareUpdateProposals -> Set UpId -> SoftwareUpdateProposals
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys SoftwareUpdateProposals
registeredSoftwareUpdateProposals Set UpId
pidsKeep,
        proposalVotes :: Map UpId (Set KeyHash)
proposalVotes =
          Map UpId (Set KeyHash) -> Set UpId -> Map UpId (Set KeyHash)
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys Map UpId (Set KeyHash)
proposalVotes Set UpId
pidsKeep,
        registeredEndorsements :: Set Endorsement
registeredEndorsements =
          (Endorsement -> Bool) -> Set Endorsement -> Set Endorsement
forall a. (a -> Bool) -> Set a -> Set a
S.filter ((ProtocolVersion -> Set ProtocolVersion -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ProtocolVersion
vsKeep) (ProtocolVersion -> Bool)
-> (Endorsement -> ProtocolVersion) -> Endorsement -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Endorsement -> ProtocolVersion
endorsementProtocolVersion) Set Endorsement
registeredEndorsements',
        proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot =
          Map UpId SlotNumber -> Set UpId -> Map UpId SlotNumber
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys Map UpId SlotNumber
proposalRegistrationSlot Set UpId
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 :: BlockCount
k :: Environment -> BlockCount
k,
        SlotNumber
currentSlot :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot,
        Word8
numGenKeys :: Word8
numGenKeys :: Environment -> Word8
numGenKeys,
        Map
delegationMap :: Map
delegationMap :: Environment -> Map
delegationMap
      } = Environment
env

    State
      { ProtocolParameters
adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters :: State -> ProtocolParameters
adoptedProtocolParameters,
        Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals :: State -> Map UpId SlotNumber
confirmedProposals,
        ProtocolUpdateProposals
registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals :: State -> ProtocolUpdateProposals
registeredProtocolUpdateProposals,
        SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals :: State -> SoftwareUpdateProposals
registeredSoftwareUpdateProposals,
        [CandidateProtocolUpdate]
candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates :: State -> [CandidateProtocolUpdate]
candidateProtocolUpdates,
        Map UpId (Set KeyHash)
proposalVotes :: Map UpId (Set KeyHash)
proposalVotes :: State -> Map UpId (Set KeyHash)
proposalVotes,
        Set Endorsement
registeredEndorsements :: Set Endorsement
registeredEndorsements :: State -> Set Endorsement
registeredEndorsements,
        Map UpId SlotNumber
proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot :: State -> 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 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 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 :: ProtocolVersion
adoptedProtocolVersion = ProtocolVersion
adoptedProtocolVersion',
          adoptedProtocolParameters :: ProtocolParameters
adoptedProtocolParameters = ProtocolParameters
nextProtocolParameters',
          candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates = [],
          registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = ProtocolUpdateProposals
forall k a. Map k a
M.empty,
          registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals = SoftwareUpdateProposals
forall k a. Map k a
M.empty,
          confirmedProposals :: Map UpId SlotNumber
confirmedProposals = Map UpId SlotNumber
forall k a. Map k a
M.empty,
          proposalVotes :: Map UpId (Set KeyHash)
proposalVotes = Map UpId (Set KeyHash)
forall k a. Map k a
M.empty,
          registeredEndorsements :: Set Endorsement
registeredEndorsements = Set Endorsement
forall a. Set a
S.empty,
          proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot = Map UpId SlotNumber
forall k a. Map k a
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 :: BlockCount
k :: Environment -> BlockCount
k
      } = Environment
env

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