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

module Cardano.Chain.Update.Validation.Endorsement (
  Environment (..),
  State (..),
  Endorsement (..),
  CandidateProtocolUpdate (..),
  register,
  Error (..),
) where

import Cardano.Chain.Common (BlockCount, KeyHash)
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.ProtocolConstants (kSlotSecurityParam)
import Cardano.Chain.Slotting (SlotNumber, addSlotCount)
import Cardano.Chain.Update.Proposal (UpId)
import Cardano.Chain.Update.ProtocolParameters (ProtocolParameters)
import Cardano.Chain.Update.ProtocolVersion (ProtocolVersion)
import qualified Cardano.Chain.Update.Validation.Registration as Registration
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecoderError (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeWord8,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  toByronCBOR,
 )
import Cardano.Prelude hiding (State, cborError)
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import NoThunks.Class (NoThunks (..))

data Environment = Environment
  { Environment -> BlockCount
k :: !BlockCount
  -- ^ Chain stability parameter.
  , Environment -> SlotNumber
currentSlot :: !SlotNumber
  , Environment -> Int
adoptionThreshold :: !Int
  , Environment -> Map
delegationMap :: !Delegation.Map
  , Environment -> Map UpId SlotNumber
confirmedProposals :: !(Map UpId SlotNumber)
  , Environment -> ProtocolUpdateProposals
registeredProtocolUpdateProposals :: !Registration.ProtocolUpdateProposals
  }

data State = State
  { State -> [CandidateProtocolUpdate]
candidateProtocolVersions :: ![CandidateProtocolUpdate]
  , State -> Set Endorsement
registeredEndorsements :: !(Set Endorsement)
  }

data CandidateProtocolUpdate = CandidateProtocolUpdate
  { CandidateProtocolUpdate -> SlotNumber
cpuSlot :: !SlotNumber
  -- ^ Slot at which this protocol version and parameters gathered enough
  -- endorsements and became a candidate. This is used to check which
  -- versions became candidates 2k slots before the end of an epoch (and only
  -- those can be adopted at that epoch). Versions that became candidates
  -- later than 2k slots before the end of an epoch can be adopted in
  -- following epochs.
  , CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion :: !ProtocolVersion
  , CandidateProtocolUpdate -> ProtocolParameters
cpuProtocolParameters :: !ProtocolParameters
  }
  deriving (CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
(CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool)
-> (CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool)
-> Eq CandidateProtocolUpdate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
== :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
$c/= :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
/= :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
Eq, Int -> CandidateProtocolUpdate -> ShowS
[CandidateProtocolUpdate] -> ShowS
CandidateProtocolUpdate -> String
(Int -> CandidateProtocolUpdate -> ShowS)
-> (CandidateProtocolUpdate -> String)
-> ([CandidateProtocolUpdate] -> ShowS)
-> Show CandidateProtocolUpdate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CandidateProtocolUpdate -> ShowS
showsPrec :: Int -> CandidateProtocolUpdate -> ShowS
$cshow :: CandidateProtocolUpdate -> String
show :: CandidateProtocolUpdate -> String
$cshowList :: [CandidateProtocolUpdate] -> ShowS
showList :: [CandidateProtocolUpdate] -> ShowS
Show, (forall x.
 CandidateProtocolUpdate -> Rep CandidateProtocolUpdate x)
-> (forall x.
    Rep CandidateProtocolUpdate x -> CandidateProtocolUpdate)
-> Generic CandidateProtocolUpdate
forall x. Rep CandidateProtocolUpdate x -> CandidateProtocolUpdate
forall x. CandidateProtocolUpdate -> Rep CandidateProtocolUpdate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CandidateProtocolUpdate -> Rep CandidateProtocolUpdate x
from :: forall x. CandidateProtocolUpdate -> Rep CandidateProtocolUpdate x
$cto :: forall x. Rep CandidateProtocolUpdate x -> CandidateProtocolUpdate
to :: forall x. Rep CandidateProtocolUpdate x -> CandidateProtocolUpdate
Generic)
  deriving anyclass (CandidateProtocolUpdate -> ()
(CandidateProtocolUpdate -> ()) -> NFData CandidateProtocolUpdate
forall a. (a -> ()) -> NFData a
$crnf :: CandidateProtocolUpdate -> ()
rnf :: CandidateProtocolUpdate -> ()
NFData, Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
Proxy CandidateProtocolUpdate -> String
(Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo))
-> (Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo))
-> (Proxy CandidateProtocolUpdate -> String)
-> NoThunks CandidateProtocolUpdate
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
noThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy CandidateProtocolUpdate -> String
showTypeOf :: Proxy CandidateProtocolUpdate -> String
NoThunks)

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

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

instance DecCBOR CandidateProtocolUpdate where
  decCBOR :: forall s. Decoder s CandidateProtocolUpdate
decCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"CandidateProtocolUpdate" Int
3
    SlotNumber
-> ProtocolVersion -> ProtocolParameters -> CandidateProtocolUpdate
CandidateProtocolUpdate
      (SlotNumber
 -> ProtocolVersion
 -> ProtocolParameters
 -> CandidateProtocolUpdate)
-> Decoder s SlotNumber
-> Decoder
     s
     (ProtocolVersion -> ProtocolParameters -> CandidateProtocolUpdate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s SlotNumber
forall s. Decoder s SlotNumber
forall a s. DecCBOR a => Decoder s a
decCBOR
      Decoder
  s
  (ProtocolVersion -> ProtocolParameters -> CandidateProtocolUpdate)
-> Decoder s ProtocolVersion
-> Decoder s (ProtocolParameters -> CandidateProtocolUpdate)
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)
-> Decoder s ProtocolParameters
-> Decoder s CandidateProtocolUpdate
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

instance EncCBOR CandidateProtocolUpdate where
  encCBOR :: CandidateProtocolUpdate -> Encoding
encCBOR CandidateProtocolUpdate
cpu =
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNumber -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (CandidateProtocolUpdate -> SlotNumber
cpuSlot CandidateProtocolUpdate
cpu)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolVersion -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion CandidateProtocolUpdate
cpu)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolParameters -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (CandidateProtocolUpdate -> ProtocolParameters
cpuProtocolParameters CandidateProtocolUpdate
cpu)

data Endorsement = Endorsement
  { Endorsement -> ProtocolVersion
endorsementProtocolVersion :: !ProtocolVersion
  , Endorsement -> KeyHash
endorsementKeyHash :: !KeyHash
  }
  deriving (Endorsement -> Endorsement -> Bool
(Endorsement -> Endorsement -> Bool)
-> (Endorsement -> Endorsement -> Bool) -> Eq Endorsement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Endorsement -> Endorsement -> Bool
== :: Endorsement -> Endorsement -> Bool
$c/= :: Endorsement -> Endorsement -> Bool
/= :: Endorsement -> Endorsement -> Bool
Eq, Int -> Endorsement -> ShowS
[Endorsement] -> ShowS
Endorsement -> String
(Int -> Endorsement -> ShowS)
-> (Endorsement -> String)
-> ([Endorsement] -> ShowS)
-> Show Endorsement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Endorsement -> ShowS
showsPrec :: Int -> Endorsement -> ShowS
$cshow :: Endorsement -> String
show :: Endorsement -> String
$cshowList :: [Endorsement] -> ShowS
showList :: [Endorsement] -> ShowS
Show, Eq Endorsement
Eq Endorsement =>
(Endorsement -> Endorsement -> Ordering)
-> (Endorsement -> Endorsement -> Bool)
-> (Endorsement -> Endorsement -> Bool)
-> (Endorsement -> Endorsement -> Bool)
-> (Endorsement -> Endorsement -> Bool)
-> (Endorsement -> Endorsement -> Endorsement)
-> (Endorsement -> Endorsement -> Endorsement)
-> Ord Endorsement
Endorsement -> Endorsement -> Bool
Endorsement -> Endorsement -> Ordering
Endorsement -> Endorsement -> Endorsement
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Endorsement -> Endorsement -> Ordering
compare :: Endorsement -> Endorsement -> Ordering
$c< :: Endorsement -> Endorsement -> Bool
< :: Endorsement -> Endorsement -> Bool
$c<= :: Endorsement -> Endorsement -> Bool
<= :: Endorsement -> Endorsement -> Bool
$c> :: Endorsement -> Endorsement -> Bool
> :: Endorsement -> Endorsement -> Bool
$c>= :: Endorsement -> Endorsement -> Bool
>= :: Endorsement -> Endorsement -> Bool
$cmax :: Endorsement -> Endorsement -> Endorsement
max :: Endorsement -> Endorsement -> Endorsement
$cmin :: Endorsement -> Endorsement -> Endorsement
min :: Endorsement -> Endorsement -> Endorsement
Ord, (forall x. Endorsement -> Rep Endorsement x)
-> (forall x. Rep Endorsement x -> Endorsement)
-> Generic Endorsement
forall x. Rep Endorsement x -> Endorsement
forall x. Endorsement -> Rep Endorsement x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Endorsement -> Rep Endorsement x
from :: forall x. Endorsement -> Rep Endorsement x
$cto :: forall x. Rep Endorsement x -> Endorsement
to :: forall x. Rep Endorsement x -> Endorsement
Generic)
  deriving anyclass (Endorsement -> ()
(Endorsement -> ()) -> NFData Endorsement
forall a. (a -> ()) -> NFData a
$crnf :: Endorsement -> ()
rnf :: Endorsement -> ()
NFData, Context -> Endorsement -> IO (Maybe ThunkInfo)
Proxy Endorsement -> String
(Context -> Endorsement -> IO (Maybe ThunkInfo))
-> (Context -> Endorsement -> IO (Maybe ThunkInfo))
-> (Proxy Endorsement -> String)
-> NoThunks Endorsement
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
noThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Endorsement -> String
showTypeOf :: Proxy Endorsement -> String
NoThunks)

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

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

instance DecCBOR Endorsement where
  decCBOR :: forall s. Decoder s Endorsement
decCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Endorsement" Int
2
    ProtocolVersion -> KeyHash -> Endorsement
Endorsement
      (ProtocolVersion -> KeyHash -> Endorsement)
-> Decoder s ProtocolVersion -> Decoder s (KeyHash -> Endorsement)
forall (f :: * -> *) a b. Functor 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 (KeyHash -> Endorsement)
-> Decoder s KeyHash -> Decoder s Endorsement
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 KeyHash
forall s. Decoder s KeyHash
forall a s. DecCBOR a => Decoder s a
decCBOR

instance EncCBOR Endorsement where
  encCBOR :: Endorsement -> Encoding
encCBOR Endorsement
sh =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolVersion -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Endorsement -> ProtocolVersion
endorsementProtocolVersion Endorsement
sh)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (Endorsement -> KeyHash
endorsementKeyHash Endorsement
sh)

data Error
  = -- | Multiple proposals were found, which propose an update to the same
    -- protocol version.
    MultipleProposalsForProtocolVersion ProtocolVersion
  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 (MultipleProposalsForProtocolVersion ProtocolVersion
protocolVersion) =
    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
<> ProtocolVersion -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ProtocolVersion
protocolVersion

instance DecCBOR Error where
  decCBOR :: forall s. Decoder s Error
decCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Endorsement.Error" Int
2
    Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> ProtocolVersion -> Error
MultipleProposalsForProtocolVersion (ProtocolVersion -> Error)
-> Decoder s ProtocolVersion -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ProtocolVersion
forall s. Decoder s ProtocolVersion
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
"Endorsement.Error" Word8
tag

-- | Register an endorsement.
--
-- This corresponds to the @UPEND@ rule.
register ::
  MonadError Error m => Environment -> State -> Endorsement -> m State
register :: forall (m :: * -> *).
MonadError Error m =>
Environment -> State -> Endorsement -> m State
register Environment
env State
st Endorsement
endorsement =
  case ProtocolUpdateProposals -> [(UpId, ProtocolUpdateProposal)]
forall k a. Map k a -> [(k, a)]
M.toList
    ( (ProtocolUpdateProposal -> Bool)
-> ProtocolUpdateProposals -> ProtocolUpdateProposals
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter
        ((ProtocolVersion -> ProtocolVersion -> Bool
forall a. Eq a => a -> a -> Bool
== ProtocolVersion
pv) (ProtocolVersion -> Bool)
-> (ProtocolUpdateProposal -> ProtocolVersion)
-> ProtocolUpdateProposal
-> Bool
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
. ProtocolUpdateProposal -> ProtocolVersion
Registration.pupProtocolVersion)
        ProtocolUpdateProposals
registeredProtocolUpdateProposals
    ) of
    -- We ignore endorsement of proposals that aren't registered
    [] -> State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
    -- Try to register the endorsement and check if we can adopt the proposal
    [(UpId
upId, Registration.ProtocolUpdateProposal ProtocolVersion
_ ProtocolParameters
pps')] ->
      if UpId -> Bool
isConfirmedAndStable UpId
upId
        then
          if Int
numberOfEndorsements Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
adoptionThreshold
            then -- Register the endorsement and adopt the proposal in the next epoch
              do
                let cpu :: CandidateProtocolUpdate
cpu =
                      CandidateProtocolUpdate
                        { cpuSlot :: SlotNumber
cpuSlot = SlotNumber
currentSlot
                        , cpuProtocolVersion :: ProtocolVersion
cpuProtocolVersion = ProtocolVersion
pv
                        , cpuProtocolParameters :: ProtocolParameters
cpuProtocolParameters = ProtocolParameters
pps'
                        }
                    cpus' :: [CandidateProtocolUpdate]
cpus' =
                      [CandidateProtocolUpdate]
-> CandidateProtocolUpdate -> [CandidateProtocolUpdate]
updateCandidateProtocolUpdates [CandidateProtocolUpdate]
candidateProtocolVersions CandidateProtocolUpdate
cpu
                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
                    { candidateProtocolVersions :: [CandidateProtocolUpdate]
candidateProtocolVersions = [CandidateProtocolUpdate]
cpus'
                    , registeredEndorsements :: Set Endorsement
registeredEndorsements = Set Endorsement
registeredEndorsements'
                    }
            else -- Just register the endorsement if we cannot adopt
              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 {registeredEndorsements = registeredEndorsements'}
        else -- Ignore the endorsement if the registration isn't stable
          State -> m State
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure State
st
    -- Throw an error if there are multiple proposals for this protocol version
    [(UpId, ProtocolUpdateProposal)]
_ -> Error -> m State
forall a. Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error -> m State) -> Error -> m State
forall a b. (a -> b) -> a -> b
$ ProtocolVersion -> Error
MultipleProposalsForProtocolVersion ProtocolVersion
pv
  where
    Environment
      { BlockCount
k :: Environment -> BlockCount
k :: BlockCount
k
      , SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot :: SlotNumber
currentSlot
      , Int
adoptionThreshold :: Environment -> Int
adoptionThreshold :: Int
adoptionThreshold
      , Map
delegationMap :: Environment -> Map
delegationMap :: Map
delegationMap
      , Map UpId SlotNumber
confirmedProposals :: Environment -> Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals
      , ProtocolUpdateProposals
registeredProtocolUpdateProposals :: Environment -> ProtocolUpdateProposals
registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals
      } = Environment
env

    isConfirmedAndStable :: UpId -> Bool
isConfirmedAndStable UpId
upId = UpId
upId UpId -> Map UpId SlotNumber -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map UpId SlotNumber
scps
      where
        -- Stable and confirmed proposals.
        scps :: Map UpId SlotNumber
scps = (SlotNumber -> Bool) -> Map UpId SlotNumber -> Map UpId SlotNumber
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (\SlotNumber
x -> SlotCount -> SlotNumber -> SlotNumber
addSlotCount (BlockCount -> SlotCount
kSlotSecurityParam BlockCount
k) SlotNumber
x SlotNumber -> SlotNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNumber
currentSlot) Map UpId SlotNumber
confirmedProposals

    numberOfEndorsements :: Int
    numberOfEndorsements :: Int
numberOfEndorsements =
      Set Endorsement -> Int
forall a. HasLength a => a -> Int
length
        (Set Endorsement -> Int) -> Set Endorsement -> Int
forall a b. (a -> b) -> a -> b
$ (Endorsement -> Bool) -> Set Endorsement -> Set Endorsement
forall a. (a -> Bool) -> Set a -> Set a
Set.filter
          ((ProtocolVersion -> ProtocolVersion -> Bool
forall a. Eq a => a -> a -> Bool
== ProtocolVersion
pv) (ProtocolVersion -> Bool)
-> (Endorsement -> ProtocolVersion) -> Endorsement -> Bool
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
. Endorsement -> ProtocolVersion
endorsementProtocolVersion)
          Set Endorsement
registeredEndorsements'

    pv :: ProtocolVersion
pv = Endorsement -> ProtocolVersion
endorsementProtocolVersion Endorsement
endorsement

    State {[CandidateProtocolUpdate]
candidateProtocolVersions :: State -> [CandidateProtocolUpdate]
candidateProtocolVersions :: [CandidateProtocolUpdate]
candidateProtocolVersions, Set Endorsement
registeredEndorsements :: State -> Set Endorsement
registeredEndorsements :: Set Endorsement
registeredEndorsements} = State
st

    registeredEndorsements' :: Set Endorsement
registeredEndorsements' = case KeyHash -> Map -> Maybe KeyHash
Delegation.lookupR KeyHash
vk Map
delegationMap of
      Just KeyHash
vkS -> Endorsement -> Set Endorsement -> Set Endorsement
forall a. Ord a => a -> Set a -> Set a
Set.insert (ProtocolVersion -> KeyHash -> Endorsement
Endorsement ProtocolVersion
epv KeyHash
vkS) Set Endorsement
registeredEndorsements
      Maybe KeyHash
Nothing -> Set Endorsement
registeredEndorsements
      where
        -- Note that we do not throw an error if there is no corresponding
        -- delegate for the given endorsement keyHash. This is consistent
        -- with the @UPEND@ rules. The check that there is a delegator should be
        -- done in the rule that checks that the block issuer is a delegate of a
        -- genesis key.

        vk :: KeyHash
vk = Endorsement -> KeyHash
endorsementKeyHash Endorsement
endorsement
        epv :: ProtocolVersion
epv = Endorsement -> ProtocolVersion
endorsementProtocolVersion Endorsement
endorsement

-- | Add a newly endorsed protocol version to the 'CandidateProtocolUpdate's
--
--   We only add it to the list if the 'ProtocolVersion' is strictly greater
--   than all other `CandidateProtocolUpdate`s
--
-- This corresponds to the @FADS@ rule.
updateCandidateProtocolUpdates ::
  [CandidateProtocolUpdate] ->
  CandidateProtocolUpdate ->
  [CandidateProtocolUpdate]
updateCandidateProtocolUpdates :: [CandidateProtocolUpdate]
-> CandidateProtocolUpdate -> [CandidateProtocolUpdate]
updateCandidateProtocolUpdates [] CandidateProtocolUpdate
cpu = [CandidateProtocolUpdate
cpu]
updateCandidateProtocolUpdates cpus :: [CandidateProtocolUpdate]
cpus@(CandidateProtocolUpdate
cpu : [CandidateProtocolUpdate]
_) CandidateProtocolUpdate
cpu'
  | CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion CandidateProtocolUpdate
cpu ProtocolVersion -> ProtocolVersion -> Bool
forall a. Ord a => a -> a -> Bool
< CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion CandidateProtocolUpdate
cpu' = CandidateProtocolUpdate
cpu' CandidateProtocolUpdate
-> [CandidateProtocolUpdate] -> [CandidateProtocolUpdate]
forall a. a -> [a] -> [a]
: [CandidateProtocolUpdate]
cpus
  | Bool
otherwise = [CandidateProtocolUpdate]
cpus