{-# 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
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
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. 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: State -> ()
$crnf :: State -> ()
NFData, Context -> State -> IO (Maybe ThunkInfo)
Proxy State -> String
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 ToCBOR State where
  toCBOR :: State -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

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

instance DecCBOR State where
  decCBOR :: forall s. Decoder s State
decCBOR = do
    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
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR

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

instance FromCBOR Error where
  fromCBOR :: forall s. Decoder s Error
fromCBOR = 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
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Error
registrationErr
    Voting Error
votingErr ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
1 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Error
votingErr
    Endorsement Error
endorsementErr ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
2 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Error
endorsementErr
    NumberOfGenesisKeysTooLarge TooLarge Int
tooLarge ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
3 :: Word8)
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TooLarge Int
tooLarge

instance DecCBOR Error where
  decCBOR :: forall s. Decoder s Error
decCBOR = do
    Int
len <- forall s. Decoder s Int
decodeListLen
    let checkSize :: Int -> Decoder s ()
        checkSize :: forall s. Int -> Decoder s ()
checkSize Int
size = forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"Interface.Error" Int
size Int
len
    Word8
tag <- forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Error
Registration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Error
Voting forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
2 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Error
Endorsement forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
3 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TooLarge Int -> Error
NumberOfGenesisKeysTooLarge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError 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 = forall a. Monoid a => a
mempty
    , registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = forall a. Monoid a => a
mempty
    , registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals = forall a. Monoid a => a
mempty
    , confirmedProposals :: Map UpId SlotNumber
confirmedProposals = forall a. Monoid a => a
mempty
    , proposalVotes :: Map UpId (Set KeyHash)
proposalVotes = forall a. Monoid a => a
mempty
    , registeredEndorsements :: Set Endorsement
registeredEndorsements = forall a. Monoid a => a
mempty
    , proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot = 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 :: 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
    Just AProposal ByteString
p -> forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
registerProposal Environment
env State
st AProposal ByteString
p

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

  -- Register endorsement
  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' <-
    forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> AProposal ByteString -> m State
Registration.registerProposal Environment
subEnv State
subSt AProposal ByteString
proposal
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> Error
Registration
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$! State
st
      { registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = ProtocolUpdateProposals
registeredProtocolUpdateProposals'
      , registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals = SoftwareUpdateProposals
registeredSoftwareUpdateProposals'
      , proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot =
          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 :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> [AVote ByteString] -> m State
registerVotes Environment
env State
st [AVote ByteString]
votes = do
  State
st' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (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 =
        forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys
          SoftwareUpdateProposals
registeredSoftwareUpdateProposals
          (forall k a. Map k a -> Set k
M.keysSet Map UpId SlotNumber
confirmedProposals)
      appVersions' :: ApplicationVersions
appVersions' =
        forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
          forall a b. (a -> b) -> a -> b
$ [ (SoftwareVersion -> ApplicationName
svAppName SoftwareVersion
sv, ApplicationVersion
av)
            | (UpId
pid, SoftwareUpdateProposal
sup) <- forall k a. Map k a -> [(k, a)]
M.toList SoftwareUpdateProposals
registeredSoftwareUpdateProposals
            , UpId
pid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` 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
            ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    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 = 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 =
          forall k a. Ord k => Map k a -> Set k -> Map k a
M.withoutKeys
            SoftwareUpdateProposals
registeredSoftwareUpdateProposals
            (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 :: 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' <-
    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
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Error -> Error
Voting
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    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 = 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' <-
    forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Endorsement -> m State
Endorsement.register Environment
subEnv State
subSt Endorsement
endorsement
      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 forall a. Ord a => Set a -> Set a -> Set a
`union` Set UpId
confirmedPids

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

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

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

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

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$! State
st
      { candidateProtocolUpdates :: [CandidateProtocolUpdate]
candidateProtocolUpdates = forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF [CandidateProtocolUpdate]
candidateProtocolUpdates'
      , registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals = ProtocolUpdateProposals
registeredProtocolUpdateProposals'
      , registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals =
          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 =
          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 =
          forall a. (a -> Bool) -> Set a -> Set a
S.filter ((forall a. Ord a => a -> Set a -> Bool
`S.member` Set ProtocolVersion
vsKeep) 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 =
          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 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 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 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' 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 = forall k a. Map k a
M.empty
        , registeredSoftwareUpdateProposals :: SoftwareUpdateProposals
registeredSoftwareUpdateProposals = forall k a. Map k a
M.empty
        , confirmedProposals :: Map UpId SlotNumber
confirmedProposals = forall k a. Map k a
M.empty
        , proposalVotes :: Map UpId (Set KeyHash)
proposalVotes = forall k a. Map k a
M.empty
        , registeredEndorsements :: Set Endorsement
registeredEndorsements = forall a. Set a
S.empty
        , proposalRegistrationSlot :: Map UpId SlotNumber
proposalRegistrationSlot = 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