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

-- | Validation rules for registering votes and confirming proposals
--
--   This is an implementation of the rules defined in the Byron ledger
--   specification
module Cardano.Chain.Update.Validation.Voting
  ( Environment (..),
    RegistrationEnvironment (..),
    State (..),
    Error (..),
    registerVoteWithConfirmation,
  )
where

import Cardano.Binary
  ( Annotated,
    Decoder,
    DecoderError (..),
    FromCBOR (..),
    ToCBOR (..),
    decodeListLen,
    decodeWord8,
    encodeListLen,
    matchSize,
  )
import Cardano.Chain.Common (KeyHash, hashKey)
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.Slotting (SlotNumber)
import Cardano.Chain.Update.Proposal (UpId)
import Cardano.Chain.Update.Vote
  ( AVote (..),
    proposalId,
    recoverSignedBytes,
  )
import Cardano.Crypto
  ( ProtocolMagicId,
    SignTag (SignUSVote),
    verifySignatureDecoded,
  )
import Cardano.Prelude hiding (State)
import qualified Data.Map.Strict as M
import qualified Data.Set as Set

-- | Environment used to register votes and confirm proposals
data Environment = Environment
  { Environment -> SlotNumber
veCurrentSlot :: SlotNumber,
    Environment -> Int
veConfirmationThreshold :: Int,
    Environment -> RegistrationEnvironment
veVotingRegistrationEnvironment :: RegistrationEnvironment
  }
  deriving (Environment -> Environment -> Bool
(Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool) -> Eq Environment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c== :: Environment -> Environment -> Bool
Eq, Int -> Environment -> ShowS
[Environment] -> ShowS
Environment -> String
(Int -> Environment -> ShowS)
-> (Environment -> String)
-> ([Environment] -> ShowS)
-> Show Environment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environment] -> ShowS
$cshowList :: [Environment] -> ShowS
show :: Environment -> String
$cshow :: Environment -> String
showsPrec :: Int -> Environment -> ShowS
$cshowsPrec :: Int -> Environment -> ShowS
Show, (forall x. Environment -> Rep Environment x)
-> (forall x. Rep Environment x -> Environment)
-> Generic Environment
forall x. Rep Environment x -> Environment
forall x. Environment -> Rep Environment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Environment x -> Environment
$cfrom :: forall x. Environment -> Rep Environment x
Generic)
  deriving anyclass (Environment -> ()
(Environment -> ()) -> NFData Environment
forall a. (a -> ()) -> NFData a
rnf :: Environment -> ()
$crnf :: Environment -> ()
NFData)

-- | Environment required to validate and register a vote
data RegistrationEnvironment = RegistrationEnvironment
  { RegistrationEnvironment -> Set UpId
vreRegisteredUpdateProposal :: !(Set UpId),
    RegistrationEnvironment -> Map
vreDelegationMap :: !Delegation.Map
  }
  deriving (RegistrationEnvironment -> RegistrationEnvironment -> Bool
(RegistrationEnvironment -> RegistrationEnvironment -> Bool)
-> (RegistrationEnvironment -> RegistrationEnvironment -> Bool)
-> Eq RegistrationEnvironment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegistrationEnvironment -> RegistrationEnvironment -> Bool
$c/= :: RegistrationEnvironment -> RegistrationEnvironment -> Bool
== :: RegistrationEnvironment -> RegistrationEnvironment -> Bool
$c== :: RegistrationEnvironment -> RegistrationEnvironment -> Bool
Eq, Int -> RegistrationEnvironment -> ShowS
[RegistrationEnvironment] -> ShowS
RegistrationEnvironment -> String
(Int -> RegistrationEnvironment -> ShowS)
-> (RegistrationEnvironment -> String)
-> ([RegistrationEnvironment] -> ShowS)
-> Show RegistrationEnvironment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegistrationEnvironment] -> ShowS
$cshowList :: [RegistrationEnvironment] -> ShowS
show :: RegistrationEnvironment -> String
$cshow :: RegistrationEnvironment -> String
showsPrec :: Int -> RegistrationEnvironment -> ShowS
$cshowsPrec :: Int -> RegistrationEnvironment -> ShowS
Show, (forall x.
 RegistrationEnvironment -> Rep RegistrationEnvironment x)
-> (forall x.
    Rep RegistrationEnvironment x -> RegistrationEnvironment)
-> Generic RegistrationEnvironment
forall x. Rep RegistrationEnvironment x -> RegistrationEnvironment
forall x. RegistrationEnvironment -> Rep RegistrationEnvironment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RegistrationEnvironment x -> RegistrationEnvironment
$cfrom :: forall x. RegistrationEnvironment -> Rep RegistrationEnvironment x
Generic)
  deriving anyclass (RegistrationEnvironment -> ()
(RegistrationEnvironment -> ()) -> NFData RegistrationEnvironment
forall a. (a -> ()) -> NFData a
rnf :: RegistrationEnvironment -> ()
$crnf :: RegistrationEnvironment -> ()
NFData)

-- | State keeps track of registered votes and confirmed proposals
data State = State
  { State -> RegisteredVotes
vsVotes :: !RegisteredVotes,
    State -> Map UpId SlotNumber
vsConfirmedProposals :: !(Map UpId SlotNumber)
  }

type RegisteredVotes = Map UpId (Set KeyHash)

-- | Error captures the ways in which vote registration could fail
data Error
  = VotingInvalidSignature
  | VotingProposalNotRegistered UpId
  | VotingVoterNotDelegate KeyHash
  | VotingVoteAlreadyCast KeyHash
  deriving (Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

instance ToCBOR Error where
  toCBOR :: Error -> Encoding
toCBOR Error
err = case Error
err of
    Error
VotingInvalidSignature ->
      Word -> Encoding
encodeListLen Word
1
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
0 :: Word8)
    VotingProposalNotRegistered UpId
upId ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
1 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UpId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UpId
upId
    VotingVoterNotDelegate KeyHash
keyHash ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
2 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR KeyHash
keyHash
    VotingVoteAlreadyCast KeyHash
keyHash ->
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word8 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Word8
3 :: Word8)
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR KeyHash
keyHash

instance FromCBOR Error where
  fromCBOR :: Decoder s Error
fromCBOR = do
    Int
len <- Decoder s Int
forall s. Decoder s Int
decodeListLen
    let checkSize :: Int -> Decoder s ()
        checkSize :: Int -> Decoder s ()
checkSize Int
size = Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"Voting.Error" Int
size Int
len
    Word8
tag <- Decoder s Word8
forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
1 Decoder s () -> Decoder s Error -> Decoder s Error
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Error -> Decoder s Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure Error
VotingInvalidSignature
      Word8
1 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UpId -> Error
VotingProposalNotRegistered (UpId -> Error) -> Decoder s UpId -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s UpId
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
2 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KeyHash -> Error
VotingVoterNotDelegate (KeyHash -> Error) -> Decoder s KeyHash -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s KeyHash
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Word8
3 -> Int -> Decoder s ()
forall s. Int -> Decoder s ()
checkSize Int
2 Decoder s () -> Decoder s Error -> Decoder s Error
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KeyHash -> Error
VotingVoteAlreadyCast (KeyHash -> Error) -> Decoder s KeyHash -> Decoder s Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s KeyHash
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
"Voting.Error" Word8
tag

-- | Register a vote and confirm the corresponding proposal if it passes the
--   voting threshold. This corresponds to the @UPVOTE@ rules in the spec.
registerVoteWithConfirmation ::
  MonadError Error m =>
  Annotated ProtocolMagicId ByteString ->
  Environment ->
  State ->
  AVote ByteString ->
  m State
registerVoteWithConfirmation :: Annotated ProtocolMagicId ByteString
-> Environment -> State -> AVote ByteString -> m State
registerVoteWithConfirmation Annotated ProtocolMagicId ByteString
pm Environment
votingEnv State
vs AVote ByteString
vote = do
  -- Register the vote ignoring proposal confirmation
  RegisteredVotes
votes' <- Annotated ProtocolMagicId ByteString
-> RegistrationEnvironment
-> RegisteredVotes
-> AVote ByteString
-> m RegisteredVotes
forall (m :: * -> *).
MonadError Error m =>
Annotated ProtocolMagicId ByteString
-> RegistrationEnvironment
-> RegisteredVotes
-> AVote ByteString
-> m RegisteredVotes
registerVote Annotated ProtocolMagicId ByteString
pm RegistrationEnvironment
voteRegEnv RegisteredVotes
votes AVote ByteString
vote

  -- Confirm the proposal if it passes the threshold and isn't confirmed
  let confirmedProposals' :: Map UpId SlotNumber
confirmedProposals' =
        if RegisteredVotes -> Bool
pastThreshold RegisteredVotes
votes' Bool -> Bool -> Bool
&& Bool -> Bool
not (UpId -> Bool
isConfirmed UpId
upId)
          then UpId -> SlotNumber -> Map UpId SlotNumber -> Map UpId SlotNumber
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert UpId
upId SlotNumber
slot Map UpId SlotNumber
confirmedProposals
          else Map UpId SlotNumber
confirmedProposals

  -- Return the new state with additional vote and maybe confirmation
  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 :: RegisteredVotes -> Map UpId SlotNumber -> State
State
      { vsVotes :: RegisteredVotes
vsVotes = RegisteredVotes
votes',
        vsConfirmedProposals :: Map UpId SlotNumber
vsConfirmedProposals = Map UpId SlotNumber
confirmedProposals'
      }
  where
    Environment SlotNumber
slot Int
threshold RegistrationEnvironment
voteRegEnv = Environment
votingEnv
    State RegisteredVotes
votes Map UpId SlotNumber
confirmedProposals = State
vs

    pastThreshold :: RegisteredVotes -> Bool
    pastThreshold :: RegisteredVotes -> Bool
pastThreshold RegisteredVotes
votes' =
      Set KeyHash -> Int
forall a. HasLength a => a -> Int
length (Set KeyHash -> UpId -> RegisteredVotes -> Set KeyHash
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Set KeyHash
forall a. Set a
Set.empty UpId
upId RegisteredVotes
votes') Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
threshold

    isConfirmed :: UpId -> Bool
isConfirmed = (UpId -> Map UpId SlotNumber -> Bool)
-> Map UpId SlotNumber -> UpId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UpId -> Map UpId SlotNumber -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Map UpId SlotNumber
confirmedProposals

    upId :: UpId
upId = AVote ByteString -> UpId
forall a. AVote a -> UpId
proposalId AVote ByteString
vote

-- | Validate and register a vote
--
--   We check that
--
--   1) The vote is for a registered proposal
--   2) There is at least one genesis key delegating to the voter
--   3) The signature is valid
--   4) The vote has not already been cast
--
--   This corresponds to the `ADDVOTE` rule in the spec.
registerVote ::
  MonadError Error m =>
  Annotated ProtocolMagicId ByteString ->
  RegistrationEnvironment ->
  RegisteredVotes ->
  AVote ByteString ->
  m RegisteredVotes
registerVote :: Annotated ProtocolMagicId ByteString
-> RegistrationEnvironment
-> RegisteredVotes
-> AVote ByteString
-> m RegisteredVotes
registerVote Annotated ProtocolMagicId ByteString
pm RegistrationEnvironment
vre RegisteredVotes
votes AVote ByteString
vote = do
  -- Check that the proposal being voted on is registered
  (UpId
upId UpId -> Set UpId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UpId
registeredProposals)
    Bool -> Error -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` UpId -> Error
VotingProposalNotRegistered UpId
upId

  -- Check that the set of genesis keys is not empty
  KeyHash
delegator <- case KeyHash -> Map -> Maybe KeyHash
Delegation.lookupR KeyHash
voter Map
delegationMap of
    Maybe KeyHash
Nothing -> Error -> m KeyHash
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KeyHash -> Error
VotingVoterNotDelegate KeyHash
voter)
    Just KeyHash
d -> KeyHash -> m KeyHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash
d

  -- Check that the vote has not already been cast
  case UpId -> RegisteredVotes -> Maybe (Set KeyHash)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup UpId
upId RegisteredVotes
votes of
    Just Set KeyHash
khs | KeyHash
delegator KeyHash -> Set KeyHash -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set KeyHash
khs -> Error -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KeyHash -> Error
VotingVoteAlreadyCast KeyHash
delegator)
    Maybe (Set KeyHash)
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Check that the signature is valid
  Annotated ProtocolMagicId ByteString
-> SignTag
-> VerificationKey
-> Annotated (UpId, Bool) ByteString
-> Signature (BaseType (Annotated (UpId, Bool) ByteString))
-> Bool
forall t.
Decoded t =>
Annotated ProtocolMagicId ByteString
-> SignTag
-> VerificationKey
-> t
-> Signature (BaseType t)
-> Bool
verifySignatureDecoded Annotated ProtocolMagicId ByteString
pm SignTag
SignUSVote VerificationKey
voterVK Annotated (UpId, Bool) ByteString
signedBytes Signature (UpId, Bool)
Signature (BaseType (Annotated (UpId, Bool) ByteString))
signature
    Bool -> Error -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Error
VotingInvalidSignature

  -- Add the delegators to the set of votes for this proposal
  RegisteredVotes -> m RegisteredVotes
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RegisteredVotes -> m RegisteredVotes)
-> RegisteredVotes -> m RegisteredVotes
forall a b. (a -> b) -> a -> b
$ (Set KeyHash -> Set KeyHash -> Set KeyHash)
-> UpId -> Set KeyHash -> RegisteredVotes -> RegisteredVotes
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Set KeyHash -> Set KeyHash -> Set KeyHash
forall a. Ord a => Set a -> Set a -> Set a
Set.union UpId
upId (KeyHash -> Set KeyHash
forall a. a -> Set a
Set.singleton KeyHash
delegator) RegisteredVotes
votes
  where
    RegistrationEnvironment Set UpId
registeredProposals Map
delegationMap = RegistrationEnvironment
vre

    UnsafeVote {VerificationKey
voterVK :: forall a. AVote a -> VerificationKey
voterVK :: VerificationKey
voterVK, Signature (UpId, Bool)
signature :: forall a. AVote a -> Signature (UpId, Bool)
signature :: Signature (UpId, Bool)
signature} = AVote ByteString
vote

    voter :: KeyHash
voter = VerificationKey -> KeyHash
hashKey VerificationKey
voterVK

    upId :: UpId
upId = AVote ByteString -> UpId
forall a. AVote a -> UpId
proposalId AVote ByteString
vote

    signedBytes :: Annotated (UpId, Bool) ByteString
signedBytes = AVote ByteString -> Annotated (UpId, Bool) ByteString
recoverSignedBytes AVote ByteString
vote