{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Chain.Update.Vote
  ( -- * Vote
    AVote (..),
    Vote,
    VoteId,

    -- * Vote Constructors
    mkVote,
    signVote,
    signatureForVote,
    unsafeVote,

    -- * Vote Accessors
    proposalId,
    recoverVoteId,

    -- * Vote Binary Serialization
    recoverSignedBytes,

    -- * Vote Formatting
    formatVoteShort,
    shortVoteF,
  )
where

import Cardano.Binary
  ( Annotated (Annotated, unAnnotated),
    ByteSpan,
    Decoded (..),
    FromCBOR (..),
    ToCBOR (..),
    annotatedDecoder,
    encodeListLen,
    enforceSize,
    fromCBORAnnotated,
  )
import qualified Cardano.Binary as Binary (annotation)
import Cardano.Chain.Common (addressHash)
import Cardano.Chain.Update.Proposal (Proposal, UpId)
import Cardano.Crypto
  ( Hash,
    ProtocolMagicId,
    SafeSigner,
    SignTag (SignUSVote),
    Signature,
    SigningKey,
    VerificationKey,
    hashDecoded,
    safeSign,
    safeToVerification,
    shortHashF,
    sign,
    toVerification,
  )
import Cardano.Prelude
import Data.Aeson (ToJSON)
import Data.Text.Lazy.Builder (Builder)
import Formatting (Format, bprint, build, later)
import qualified Formatting.Buildable as B

--------------------------------------------------------------------------------
-- Vote
--------------------------------------------------------------------------------

-- | An update proposal vote identifier (the 'Hash' of a 'Vote').
type VoteId = Hash Vote

type Vote = AVote ()

-- | Vote for update proposal
--
--   Invariant: The signature is valid.
data AVote a = UnsafeVote
  { -- | Verification key casting the vote
    AVote a -> VerificationKey
voterVK :: !VerificationKey,
    -- | Proposal to which this vote applies
    AVote a -> Annotated UpId a
aProposalId :: !(Annotated UpId a),
    -- | Signature of (Update proposal, Approval/rejection bit)
    AVote a -> Signature (UpId, Bool)
signature :: !(Signature (UpId, Bool)),
    AVote a -> a
annotation :: !a
  }
  deriving (AVote a -> AVote a -> Bool
(AVote a -> AVote a -> Bool)
-> (AVote a -> AVote a -> Bool) -> Eq (AVote a)
forall a. Eq a => AVote a -> AVote a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AVote a -> AVote a -> Bool
$c/= :: forall a. Eq a => AVote a -> AVote a -> Bool
== :: AVote a -> AVote a -> Bool
$c== :: forall a. Eq a => AVote a -> AVote a -> Bool
Eq, Int -> AVote a -> ShowS
[AVote a] -> ShowS
AVote a -> String
(Int -> AVote a -> ShowS)
-> (AVote a -> String) -> ([AVote a] -> ShowS) -> Show (AVote a)
forall a. Show a => Int -> AVote a -> ShowS
forall a. Show a => [AVote a] -> ShowS
forall a. Show a => AVote a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AVote a] -> ShowS
$cshowList :: forall a. Show a => [AVote a] -> ShowS
show :: AVote a -> String
$cshow :: forall a. Show a => AVote a -> String
showsPrec :: Int -> AVote a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AVote a -> ShowS
Show, (forall x. AVote a -> Rep (AVote a) x)
-> (forall x. Rep (AVote a) x -> AVote a) -> Generic (AVote a)
forall x. Rep (AVote a) x -> AVote a
forall x. AVote a -> Rep (AVote a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (AVote a) x -> AVote a
forall a x. AVote a -> Rep (AVote a) x
$cto :: forall a x. Rep (AVote a) x -> AVote a
$cfrom :: forall a x. AVote a -> Rep (AVote a) x
Generic, a -> AVote b -> AVote a
(a -> b) -> AVote a -> AVote b
(forall a b. (a -> b) -> AVote a -> AVote b)
-> (forall a b. a -> AVote b -> AVote a) -> Functor AVote
forall a b. a -> AVote b -> AVote a
forall a b. (a -> b) -> AVote a -> AVote b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> AVote b -> AVote a
$c<$ :: forall a b. a -> AVote b -> AVote a
fmap :: (a -> b) -> AVote a -> AVote b
$cfmap :: forall a b. (a -> b) -> AVote a -> AVote b
Functor)
  deriving anyclass (AVote a -> ()
(AVote a -> ()) -> NFData (AVote a)
forall a. NFData a => AVote a -> ()
forall a. (a -> ()) -> NFData a
rnf :: AVote a -> ()
$crnf :: forall a. NFData a => AVote a -> ()
NFData)

-- Used for debugging purposes only
instance ToJSON a => ToJSON (AVote a)

--------------------------------------------------------------------------------
-- Vote Constructors
--------------------------------------------------------------------------------

-- | A safe constructor for 'UnsafeVote'
mkVote ::
  ProtocolMagicId ->
  -- | The voter
  SigningKey ->
  -- | Proposal which is voted for
  UpId ->
  -- | Approval/rejection bit
  Bool ->
  Vote
mkVote :: ProtocolMagicId -> SigningKey -> UpId -> Bool -> Vote
mkVote ProtocolMagicId
pm SigningKey
sk UpId
upId Bool
decision =
  VerificationKey
-> Annotated UpId () -> Signature (UpId, Bool) -> () -> Vote
forall a.
VerificationKey
-> Annotated UpId a -> Signature (UpId, Bool) -> a -> AVote a
UnsafeVote
    (SigningKey -> VerificationKey
toVerification SigningKey
sk)
    (UpId -> () -> Annotated UpId ()
forall b a. b -> a -> Annotated b a
Annotated UpId
upId ())
    (ProtocolMagicId
-> SignTag -> SigningKey -> (UpId, Bool) -> Signature (UpId, Bool)
forall a.
ToCBOR a =>
ProtocolMagicId -> SignTag -> SigningKey -> a -> Signature a
sign ProtocolMagicId
pm SignTag
SignUSVote SigningKey
sk (UpId
upId, Bool
decision))
    ()

-- | Create a vote for the given update proposal id, signing it with the
-- provided safe signer.
signVote ::
  ProtocolMagicId ->
  -- | Proposal which is voted for
  UpId ->
  -- | Approval/rejection bit
  Bool ->
  -- | The voter
  SafeSigner ->
  Vote
signVote :: ProtocolMagicId -> UpId -> Bool -> SafeSigner -> Vote
signVote ProtocolMagicId
protocolMagicId UpId
upId Bool
decision SafeSigner
safeSigner =
  VerificationKey -> UpId -> Signature (UpId, Bool) -> Vote
unsafeVote
    (SafeSigner -> VerificationKey
safeToVerification SafeSigner
safeSigner)
    UpId
upId
    (ProtocolMagicId
-> UpId -> Bool -> SafeSigner -> Signature (UpId, Bool)
signatureForVote ProtocolMagicId
protocolMagicId UpId
upId Bool
decision SafeSigner
safeSigner)

signatureForVote ::
  ProtocolMagicId ->
  UpId ->
  Bool ->
  SafeSigner ->
  Signature (UpId, Bool)
signatureForVote :: ProtocolMagicId
-> UpId -> Bool -> SafeSigner -> Signature (UpId, Bool)
signatureForVote ProtocolMagicId
protocolMagicId UpId
upId Bool
decision SafeSigner
safeSigner =
  ProtocolMagicId
-> SignTag -> SafeSigner -> (UpId, Bool) -> Signature (UpId, Bool)
forall a.
ToCBOR a =>
ProtocolMagicId -> SignTag -> SafeSigner -> a -> Signature a
safeSign ProtocolMagicId
protocolMagicId SignTag
SignUSVote SafeSigner
safeSigner (UpId
upId, Bool
decision)

-- | Create a vote for the given update proposal id using the provided
-- signature.
--
-- For the meaning of the parameters see 'signVote'.
unsafeVote ::
  VerificationKey ->
  UpId ->
  Signature (UpId, Bool) ->
  Vote
unsafeVote :: VerificationKey -> UpId -> Signature (UpId, Bool) -> Vote
unsafeVote VerificationKey
vk UpId
upId Signature (UpId, Bool)
voteSignature =
  VerificationKey
-> Annotated UpId () -> Signature (UpId, Bool) -> () -> Vote
forall a.
VerificationKey
-> Annotated UpId a -> Signature (UpId, Bool) -> a -> AVote a
UnsafeVote VerificationKey
vk (UpId -> () -> Annotated UpId ()
forall b a. b -> a -> Annotated b a
Annotated UpId
upId ()) Signature (UpId, Bool)
voteSignature ()

--------------------------------------------------------------------------------
-- Vote Accessors
--------------------------------------------------------------------------------

proposalId :: AVote a -> UpId
proposalId :: AVote a -> UpId
proposalId = Annotated UpId a -> UpId
forall b a. Annotated b a -> b
unAnnotated (Annotated UpId a -> UpId)
-> (AVote a -> Annotated UpId a) -> AVote a -> UpId
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AVote a -> Annotated UpId a
forall a. AVote a -> Annotated UpId a
aProposalId

recoverVoteId :: AVote ByteString -> VoteId
recoverVoteId :: AVote ByteString -> VoteId
recoverVoteId = AVote ByteString -> VoteId
forall t. Decoded t => t -> Hash (BaseType t)
hashDecoded

--------------------------------------------------------------------------------
-- Vote Binary Serialization
--------------------------------------------------------------------------------

instance ToCBOR Vote where
  toCBOR :: Vote -> Encoding
toCBOR Vote
uv =
    Word -> Encoding
encodeListLen Word
4
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VerificationKey -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Vote -> VerificationKey
forall a. AVote a -> VerificationKey
voterVK Vote
uv)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UpId -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Vote -> UpId
forall a. AVote a -> UpId
proposalId Vote
uv)
      -- We encode @True@ here because we removed the decision bit. This is safe
      -- because we know that all @Vote@s on mainnet use this encoding and any
      -- changes to the encoding in our implementation will be picked up by
      -- golden tests.
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bool -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Bool
True
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Signature (UpId, Bool) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Vote -> Signature (UpId, Bool)
forall a. AVote a -> Signature (UpId, Bool)
signature Vote
uv)

instance FromCBOR Vote where
  fromCBOR :: Decoder s Vote
fromCBOR = AVote ByteSpan -> Vote
forall (f :: * -> *) a. Functor f => f a -> f ()
void (AVote ByteSpan -> Vote)
-> Decoder s (AVote ByteSpan) -> Decoder s Vote
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. FromCBOR (AVote ByteSpan) => Decoder s (AVote ByteSpan)
forall a s. FromCBOR a => Decoder s a
fromCBOR @(AVote ByteSpan)

instance FromCBOR (AVote ByteSpan) where
  fromCBOR :: Decoder s (AVote ByteSpan)
fromCBOR = do
    Annotated (VerificationKey
voterVK, Annotated UpId ByteSpan
aProposalId, Signature (UpId, Bool)
signature) ByteSpan
byteSpan <- Decoder
  s
  (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
-> Decoder
     s
     (Annotated
        (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
        ByteSpan)
forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder (Decoder
   s
   (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
 -> Decoder
      s
      (Annotated
         (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
         ByteSpan))
-> Decoder
     s
     (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
-> Decoder
     s
     (Annotated
        (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
        ByteSpan)
forall a b. (a -> b) -> a -> b
$ do
      Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Vote" Int
4
      VerificationKey
voterVK <- Decoder s VerificationKey
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Annotated UpId ByteSpan
aProposalId <- Decoder s (Annotated UpId ByteSpan)
forall a s. FromCBOR a => Decoder s (Annotated a ByteSpan)
fromCBORAnnotated
      -- Drop the decision bit that previously allowed negative voting
      Decoder s Bool -> Decoder s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Decoder s Bool -> Decoder s ()) -> Decoder s Bool -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ forall s. FromCBOR Bool => Decoder s Bool
forall a s. FromCBOR a => Decoder s a
fromCBOR @Bool
      Signature (UpId, Bool)
signature <- Decoder s (Signature (UpId, Bool))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
-> Decoder
     s
     (VerificationKey, Annotated UpId ByteSpan, Signature (UpId, Bool))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationKey
voterVK, Annotated UpId ByteSpan
aProposalId, Signature (UpId, Bool)
signature)
    AVote ByteSpan -> Decoder s (AVote ByteSpan)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AVote ByteSpan -> Decoder s (AVote ByteSpan))
-> AVote ByteSpan -> Decoder s (AVote ByteSpan)
forall a b. (a -> b) -> a -> b
$ VerificationKey
-> Annotated UpId ByteSpan
-> Signature (UpId, Bool)
-> ByteSpan
-> AVote ByteSpan
forall a.
VerificationKey
-> Annotated UpId a -> Signature (UpId, Bool) -> a -> AVote a
UnsafeVote VerificationKey
voterVK Annotated UpId ByteSpan
aProposalId Signature (UpId, Bool)
signature ByteSpan
byteSpan

instance Decoded (AVote ByteString) where
  type BaseType (AVote ByteString) = Vote
  recoverBytes :: AVote ByteString -> ByteString
recoverBytes = AVote ByteString -> ByteString
forall a. AVote a -> a
annotation

recoverSignedBytes :: AVote ByteString -> Annotated (UpId, Bool) ByteString
recoverSignedBytes :: AVote ByteString -> Annotated (UpId, Bool) ByteString
recoverSignedBytes AVote ByteString
v =
  let bytes :: ByteString
bytes =
        [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
          [ ByteString
"\130",
            -- The byte above is part of the signed payload, but is not part of the
            -- transmitted payload
            Annotated UpId ByteString -> ByteString
forall b a. Annotated b a -> a
Binary.annotation (Annotated UpId ByteString -> ByteString)
-> Annotated UpId ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ AVote ByteString -> Annotated UpId ByteString
forall a. AVote a -> Annotated UpId a
aProposalId AVote ByteString
v,
            ByteString
"\245"
            -- The byte above is the canonical encoding of @True@, which we hardcode,
            -- because we removed the possibility of negative voting
          ]
   in (UpId, Bool) -> ByteString -> Annotated (UpId, Bool) ByteString
forall b a. b -> a -> Annotated b a
Annotated (AVote ByteString -> UpId
forall a. AVote a -> UpId
proposalId AVote ByteString
v, Bool
True) ByteString
bytes

--------------------------------------------------------------------------------
-- Vote Formatting
--------------------------------------------------------------------------------

instance B.Buildable (AVote a) where
  build :: AVote a -> Builder
build AVote a
uv =
    Format Builder (AddressHash VerificationKey -> UpId -> Builder)
-> AddressHash VerificationKey -> UpId -> Builder
forall a. Format Builder a -> a
bprint
      ( Format
  (AddressHash VerificationKey -> UpId -> Builder)
  (AddressHash VerificationKey -> UpId -> Builder)
"Update Vote { voter: "
          Format
  (AddressHash VerificationKey -> UpId -> Builder)
  (AddressHash VerificationKey -> UpId -> Builder)
-> Format Builder (AddressHash VerificationKey -> UpId -> Builder)
-> Format Builder (AddressHash VerificationKey -> UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (UpId -> Builder) (AddressHash VerificationKey -> UpId -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
          Format
  (UpId -> Builder) (AddressHash VerificationKey -> UpId -> Builder)
-> Format Builder (UpId -> Builder)
-> Format Builder (AddressHash VerificationKey -> UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (UpId -> Builder) (UpId -> Builder)
", proposal id: "
          Format (UpId -> Builder) (UpId -> Builder)
-> Format Builder (UpId -> Builder)
-> Format Builder (UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (UpId -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
          Format Builder (UpId -> Builder)
-> Format Builder Builder -> Format Builder (UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
" }"
      )
      (VerificationKey -> AddressHash VerificationKey
forall a. ToCBOR a => a -> AddressHash a
addressHash (VerificationKey -> AddressHash VerificationKey)
-> VerificationKey -> AddressHash VerificationKey
forall a b. (a -> b) -> a -> b
$ AVote a -> VerificationKey
forall a. AVote a -> VerificationKey
voterVK AVote a
uv)
      (AVote a -> UpId
forall a. AVote a -> UpId
proposalId AVote a
uv)

instance B.Buildable (Proposal, [Vote]) where
  build :: (Proposal, [Vote]) -> Builder
build (Proposal
up, [Vote]
votes) =
    Format Builder (Proposal -> [Builder] -> Builder)
-> Proposal -> [Builder] -> Builder
forall a. Format Builder a -> a
bprint (Format ([Builder] -> Builder) (Proposal -> [Builder] -> Builder)
forall a r. Buildable a => Format r (a -> r)
build Format ([Builder] -> Builder) (Proposal -> [Builder] -> Builder)
-> Format Builder ([Builder] -> Builder)
-> Format Builder (Proposal -> [Builder] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format ([Builder] -> Builder) ([Builder] -> Builder)
" with votes: " Format ([Builder] -> Builder) ([Builder] -> Builder)
-> Format Builder ([Builder] -> Builder)
-> Format Builder ([Builder] -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder ([Builder] -> Builder)
forall (t :: * -> *) a r.
(Foldable t, Buildable a) =>
Format r (t a -> r)
listJson) Proposal
up ((Vote -> Builder) -> [Vote] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Vote -> Builder
formatVoteShort [Vote]
votes)

-- | Format 'Vote' compactly
formatVoteShort :: Vote -> Builder
formatVoteShort :: Vote -> Builder
formatVoteShort Vote
uv =
  Format Builder (AddressHash VerificationKey -> UpId -> Builder)
-> AddressHash VerificationKey -> UpId -> Builder
forall a. Format Builder a -> a
bprint
    (Format
  (AddressHash VerificationKey -> UpId -> Builder)
  (AddressHash VerificationKey -> UpId -> Builder)
"(" Format
  (AddressHash VerificationKey -> UpId -> Builder)
  (AddressHash VerificationKey -> UpId -> Builder)
-> Format Builder (AddressHash VerificationKey -> UpId -> Builder)
-> Format Builder (AddressHash VerificationKey -> UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format
  (UpId -> Builder) (AddressHash VerificationKey -> UpId -> Builder)
forall r algo a. Format r (AbstractHash algo a -> r)
shortHashF Format
  (UpId -> Builder) (AddressHash VerificationKey -> UpId -> Builder)
-> Format Builder (UpId -> Builder)
-> Format Builder (AddressHash VerificationKey -> UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (UpId -> Builder) (UpId -> Builder)
" " Format (UpId -> Builder) (UpId -> Builder)
-> Format Builder (UpId -> Builder)
-> Format Builder (UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (UpId -> Builder)
forall r algo a. Format r (AbstractHash algo a -> r)
shortHashF Format Builder (UpId -> Builder)
-> Format Builder Builder -> Format Builder (UpId -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
")")
    (VerificationKey -> AddressHash VerificationKey
forall a. ToCBOR a => a -> AddressHash a
addressHash (VerificationKey -> AddressHash VerificationKey)
-> VerificationKey -> AddressHash VerificationKey
forall a b. (a -> b) -> a -> b
$ Vote -> VerificationKey
forall a. AVote a -> VerificationKey
voterVK Vote
uv)
    (Vote -> UpId
forall a. AVote a -> UpId
proposalId Vote
uv)

-- | Formatter for 'Vote' which displays it compactly
shortVoteF :: Format r (Vote -> r)
shortVoteF :: Format r (Vote -> r)
shortVoteF = (Vote -> Builder) -> Format r (Vote -> r)
forall a r. (a -> Builder) -> Format r (a -> r)
later Vote -> Builder
formatVoteShort