{-# 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.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.Ledger.Binary (
  Annotated,
  DecCBOR (..),
  Decoder,
  DecoderError (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeListLen,
  decodeWord8,
  encodeListLen,
  fromByronCBOR,
  matchSize,
  toByronCBOR,
 )
import Cardano.Prelude hiding (State, cborError)
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
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
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. 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 -> ()
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
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
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. 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 -> ()
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
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
    Error
VotingInvalidSignature ->
      Word -> Encoding
encodeListLen Word
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (Word8
0 :: Word8)
    VotingProposalNotRegistered UpId
upId ->
      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 UpId
upId
    VotingVoterNotDelegate KeyHash
keyHash ->
      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 KeyHash
keyHash
    VotingVoteAlreadyCast KeyHash
keyHash ->
      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 KeyHash
keyHash

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
"Voting.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
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Error
VotingInvalidSignature
      Word8
1 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> UpId -> Error
VotingProposalNotRegistered 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
>> KeyHash -> Error
VotingVoterNotDelegate 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
>> KeyHash -> Error
VotingVoteAlreadyCast 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
"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 :: forall (m :: * -> *).
MonadError Error m =>
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' <- 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 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ 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' =
      forall a. HasLength a => a -> Int
length (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Set a
Set.empty UpId
upId RegisteredVotes
votes') forall a. Ord a => a -> a -> Bool
>= Int
threshold

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

    upId :: UpId
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 :: forall (m :: * -> *).
MonadError Error m =>
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 forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UpId
registeredProposals)
    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 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (KeyHash -> Error
VotingVoterNotDelegate KeyHash
voter)
    Just KeyHash
d -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyHash
d

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

  -- Check that the signature is valid
  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
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Error
VotingInvalidSignature

  -- Add the delegators to the set of votes for this proposal
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Ord a => Set a -> Set a -> Set a
Set.union UpId
upId (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 = 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