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

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

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

instance EncCBOR CandidateProtocolUpdate where
  encCBOR :: CandidateProtocolUpdate -> Encoding
encCBOR CandidateProtocolUpdate
cpu =
    Word -> Encoding
encodeListLen Word
3
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (CandidateProtocolUpdate -> SlotNumber
cpuSlot CandidateProtocolUpdate
cpu)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion CandidateProtocolUpdate
cpu)
      forall a. Semigroup a => a -> a -> a
<> 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
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
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
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
Ord, 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 -> ()
forall a. (a -> ()) -> NFData a
rnf :: Endorsement -> ()
$crnf :: Endorsement -> ()
NFData, Context -> Endorsement -> IO (Maybe ThunkInfo)
Proxy Endorsement -> String
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 ToCBOR Endorsement where
  toCBOR :: Endorsement -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

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

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

instance EncCBOR Endorsement where
  encCBOR :: Endorsement -> Encoding
encCBOR Endorsement
sh =
    Word -> Encoding
encodeListLen Word
2
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Endorsement -> ProtocolVersion
endorsementProtocolVersion Endorsement
sh)
      forall a. Semigroup a => a -> a -> a
<> 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
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 (MultipleProposalsForProtocolVersion ProtocolVersion
protocolVersion) =
    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 ProtocolVersion
protocolVersion

instance DecCBOR Error where
  decCBOR :: forall s. Decoder s Error
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Endorsement.Error" Int
2
    Word8
tag <- forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> ProtocolVersion -> Error
MultipleProposalsForProtocolVersion 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
"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 forall k a. Map k a -> [(k, a)]
M.toList
    ( forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter
        ((forall a. Eq a => a -> a -> Bool
== ProtocolVersion
pv) 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
    [] -> 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 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
                forall (f :: * -> *) a. Applicative f => a -> f a
pure
                  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
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ State
st {registeredEndorsements :: Set Endorsement
registeredEndorsements = Set Endorsement
registeredEndorsements'}
        else -- Ignore the endorsement if the registration isn't stable
          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)]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 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 = 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 forall a. Ord a => a -> a -> Bool
<= SlotNumber
currentSlot) Map UpId SlotNumber
confirmedProposals

    numberOfEndorsements :: Int
    numberOfEndorsements :: Int
numberOfEndorsements =
      forall a. HasLength a => a -> Int
length
        forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Set a -> Set a
Set.filter
          ((forall a. Eq a => a -> a -> Bool
== ProtocolVersion
pv) 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 -> 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 forall a. Ord a => a -> a -> Bool
< CandidateProtocolUpdate -> ProtocolVersion
cpuProtocolVersion CandidateProtocolUpdate
cpu' = CandidateProtocolUpdate
cpu' forall a. a -> [a] -> [a]
: [CandidateProtocolUpdate]
cpus
  | Bool
otherwise = [CandidateProtocolUpdate]
cpus