{-# 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.Prelude hiding (State)

import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import NoThunks.Class (NoThunks (..))

import Cardano.Chain.ProtocolConstants (kSlotSecurityParam)
import Cardano.Binary
  ( DecoderError(..)
  , FromCBOR(..)
  , ToCBOR(..)
  , decodeWord8
  , encodeListLen
  , enforceSize
  )
import Cardano.Chain.Common (BlockCount, KeyHash)
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.Slotting (SlotNumber, subSlotCount)
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


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
/= :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
$c/= :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
== :: CandidateProtocolUpdate -> CandidateProtocolUpdate -> Bool
$c== :: 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
showList :: [CandidateProtocolUpdate] -> ShowS
$cshowList :: [CandidateProtocolUpdate] -> ShowS
show :: CandidateProtocolUpdate -> String
$cshow :: CandidateProtocolUpdate -> String
showsPrec :: Int -> CandidateProtocolUpdate -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep CandidateProtocolUpdate x -> CandidateProtocolUpdate
$cfrom :: forall x. CandidateProtocolUpdate -> Rep CandidateProtocolUpdate x
Generic)
    deriving anyclass (CandidateProtocolUpdate -> ()
(CandidateProtocolUpdate -> ()) -> NFData CandidateProtocolUpdate
forall a. (a -> ()) -> NFData a
rnf :: CandidateProtocolUpdate -> ()
$crnf :: 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
showTypeOf :: Proxy CandidateProtocolUpdate -> String
$cshowTypeOf :: Proxy CandidateProtocolUpdate -> String
wNoThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
noThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> CandidateProtocolUpdate -> IO (Maybe ThunkInfo)
NoThunks)

instance FromCBOR CandidateProtocolUpdate where
  fromCBOR :: Decoder s CandidateProtocolUpdate
fromCBOR = 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 a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder
  s
  (ProtocolVersion -> ProtocolParameters -> CandidateProtocolUpdate)
-> Decoder s ProtocolVersion
-> Decoder s (ProtocolParameters -> CandidateProtocolUpdate)
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)
-> Decoder s ProtocolParameters
-> Decoder s CandidateProtocolUpdate
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

instance ToCBOR CandidateProtocolUpdate where
  toCBOR :: CandidateProtocolUpdate -> Encoding
toCBOR CandidateProtocolUpdate
cpu =
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNumber -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (CandidateProtocolUpdate -> SlotNumber
cpuSlot CandidateProtocolUpdate
cpu)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolVersion -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion CandidateProtocolUpdate
cpu)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProtocolParameters -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (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
/= :: Endorsement -> Endorsement -> Bool
$c/= :: Endorsement -> Endorsement -> Bool
== :: Endorsement -> Endorsement -> Bool
$c== :: 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
showList :: [Endorsement] -> ShowS
$cshowList :: [Endorsement] -> ShowS
show :: Endorsement -> String
$cshow :: Endorsement -> String
showsPrec :: Int -> Endorsement -> ShowS
$cshowsPrec :: Int -> 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
min :: Endorsement -> Endorsement -> Endorsement
$cmin :: Endorsement -> Endorsement -> Endorsement
max :: Endorsement -> Endorsement -> Endorsement
$cmax :: Endorsement -> Endorsement -> Endorsement
>= :: Endorsement -> Endorsement -> Bool
$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
compare :: Endorsement -> Endorsement -> Ordering
$ccompare :: Endorsement -> Endorsement -> Ordering
$cp1Ord :: Eq 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
$cto :: forall x. Rep Endorsement x -> Endorsement
$cfrom :: forall x. Endorsement -> Rep Endorsement x
Generic)
    deriving anyclass (Endorsement -> ()
(Endorsement -> ()) -> NFData Endorsement
forall a. (a -> ()) -> NFData a
rnf :: Endorsement -> ()
$crnf :: 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
showTypeOf :: Proxy Endorsement -> String
$cshowTypeOf :: Proxy Endorsement -> String
wNoThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
noThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Endorsement -> IO (Maybe ThunkInfo)
NoThunks)

instance FromCBOR Endorsement where
  fromCBOR :: Decoder s Endorsement
fromCBOR = 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 a s. FromCBOR a => Decoder s a
fromCBOR
      Decoder s (KeyHash -> Endorsement)
-> Decoder s KeyHash -> Decoder s Endorsement
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s KeyHash
forall a s. FromCBOR a => Decoder s a
fromCBOR

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

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

instance FromCBOR Error where
  fromCBOR :: Decoder s Error
fromCBOR = 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 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
"Endorsement.Error" Word8
tag

-- | Register an endorsement.
--
-- This corresponds to the @UPEND@ rule.
register
  :: MonadError Error m => Environment -> State -> Endorsement -> m State
register :: 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 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 (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
        -- Register the endorsement and adopt the proposal in the next epoch
        then do
          let
            cpu :: CandidateProtocolUpdate
cpu = CandidateProtocolUpdate :: SlotNumber
-> ProtocolVersion -> ProtocolParameters -> CandidateProtocolUpdate
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 (f :: * -> *) a. Applicative f => a -> f a
pure (State -> m State) -> State -> m State
forall a b. (a -> b) -> a -> b
$ State :: [CandidateProtocolUpdate] -> Set Endorsement -> State
State
            { candidateProtocolVersions :: [CandidateProtocolUpdate]
candidateProtocolVersions = [CandidateProtocolUpdate]
cpus'
            , registeredEndorsements :: Set Endorsement
registeredEndorsements    = Set Endorsement
registeredEndorsements'
            }

        -- Just register the endorsement if we cannot adopt
        else 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 { registeredEndorsements :: Set Endorsement
registeredEndorsements = Set Endorsement
registeredEndorsements' }

      -- Ignore the endorsement if the registration isn't stable
      else State -> m State
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 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 :: BlockCount
k :: Environment -> BlockCount
k
    , SlotNumber
currentSlot :: SlotNumber
currentSlot :: Environment -> SlotNumber
currentSlot
    , Int
adoptionThreshold :: Int
adoptionThreshold :: Environment -> Int
adoptionThreshold
    , Map
delegationMap :: Map
delegationMap :: Environment -> Map
delegationMap
    , Map UpId SlotNumber
confirmedProposals :: Map UpId SlotNumber
confirmedProposals :: Environment -> Map UpId SlotNumber
confirmedProposals
    , ProtocolUpdateProposals
registeredProtocolUpdateProposals :: ProtocolUpdateProposals
registeredProtocolUpdateProposals :: Environment -> 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 -> SlotNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNumber
stableAt) Map UpId SlotNumber
confirmedProposals
    stableAt :: SlotNumber
stableAt = SlotCount -> SlotNumber -> SlotNumber
subSlotCount (BlockCount -> SlotCount
kSlotSecurityParam BlockCount
k) SlotNumber
currentSlot

  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 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 :: [CandidateProtocolUpdate]
candidateProtocolVersions :: State -> [CandidateProtocolUpdate]
candidateProtocolVersions, Set Endorsement
registeredEndorsements :: Set Endorsement
registeredEndorsements :: State -> 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
      -- 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.
   where
    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