{-# 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.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.Ledger.Binary (
  Annotated (Annotated, unAnnotated),
  ByteSpan,
  DecCBOR (..),
  Decoded (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  annotatedDecoder,
  decCBORAnnotated,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  toByronCBOR,
 )
import qualified Cardano.Ledger.Binary as Binary (annotation)
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
  { forall a. AVote a -> VerificationKey
voterVK :: !VerificationKey
  -- ^ Verification key casting the vote
  , forall a. AVote a -> Annotated UpId a
aProposalId :: !(Annotated UpId a)
  -- ^ Proposal to which this vote applies
  , forall a. AVote a -> Signature (UpId, Bool)
signature :: !(Signature (UpId, Bool))
  -- ^ Signature of (Update proposal, Approval/rejection bit)
  , forall a. AVote a -> a
annotation :: !a
  }
  deriving (AVote a -> AVote a -> Bool
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
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 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, 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
<$ :: forall a b. a -> AVote b -> AVote a
$c<$ :: forall a b. a -> AVote b -> AVote a
fmap :: forall a b. (a -> b) -> AVote a -> AVote b
$cfmap :: forall a b. (a -> b) -> AVote a -> AVote b
Functor)
  deriving anyclass (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 =
  forall a.
VerificationKey
-> Annotated UpId a -> Signature (UpId, Bool) -> a -> AVote a
UnsafeVote
    (SigningKey -> VerificationKey
toVerification SigningKey
sk)
    (forall b a. b -> a -> Annotated b a
Annotated UpId
upId ())
    (forall a.
EncCBOR 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 =
  forall a.
EncCBOR 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 =
  forall a.
VerificationKey
-> Annotated UpId a -> Signature (UpId, Bool) -> a -> AVote a
UnsafeVote VerificationKey
vk (forall b a. b -> a -> Annotated b a
Annotated UpId
upId ()) Signature (UpId, Bool)
voteSignature ()

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

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

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

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

instance ToCBOR Vote where
  toCBOR :: Vote -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

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

instance EncCBOR Vote where
  encCBOR :: Vote -> Encoding
encCBOR Vote
uv =
    Word -> Encoding
encodeListLen Word
4
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. AVote a -> VerificationKey
voterVK Vote
uv)
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (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.
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Bool
True
      forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. AVote a -> Signature (UpId, Bool)
signature Vote
uv)

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

instance FromCBOR (AVote ByteSpan) where
  fromCBOR :: forall s. Decoder s (AVote ByteSpan)
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance DecCBOR (AVote ByteSpan) where
  decCBOR :: forall s. Decoder s (AVote ByteSpan)
decCBOR = do
    Annotated (VerificationKey
voterVK, Annotated UpId ByteSpan
aProposalId, Signature (UpId, Bool)
signature) ByteSpan
byteSpan <- forall s a. Decoder s a -> Decoder s (Annotated a ByteSpan)
annotatedDecoder forall a b. (a -> b) -> a -> b
$ do
      forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Vote" Int
4
      VerificationKey
voterVK <- forall a s. DecCBOR a => Decoder s a
decCBOR
      Annotated UpId ByteSpan
aProposalId <- forall a s. DecCBOR a => Decoder s (Annotated a ByteSpan)
decCBORAnnotated
      -- Drop the decision bit that previously allowed negative voting
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a s. DecCBOR a => Decoder s a
decCBOR @Bool
      Signature (UpId, Bool)
signature <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationKey
voterVK, Annotated UpId ByteSpan
aProposalId, Signature (UpId, Bool)
signature)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 = 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 =
        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
            forall b a. Annotated b a -> a
Binary.annotation forall a b. (a -> b) -> a -> b
$ 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 forall b a. b -> a -> Annotated b a
Annotated (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 =
    forall a. Format Builder a -> a
bprint
      ( Format
  (AbstractHash Blake2b_224 VerificationKey -> UpId -> Builder)
  (AbstractHash Blake2b_224 VerificationKey -> UpId -> Builder)
"Update Vote { voter: "
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Buildable a => Format r (a -> r)
build
          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: "
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Buildable a => Format r (a -> r)
build
          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
" }"
      )
      (forall a. EncCBOR a => a -> AddressHash a
addressHash forall a b. (a -> b) -> a -> b
$ forall a. AVote a -> VerificationKey
voterVK AVote a
uv)
      (forall a. AVote a -> UpId
proposalId AVote a
uv)

instance B.Buildable (Proposal, [Vote]) where
  build :: (AProposal (), [Vote]) -> Builder
build (AProposal ()
up, [Vote]
votes) =
    forall a. Format Builder a -> a
bprint (forall a r. Buildable a => Format r (a -> r)
build 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: " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (t :: * -> *) a r.
(Foldable t, Buildable a) =>
Format r (t a -> r)
listJson) AProposal ()
up (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 =
  forall a. Format Builder a -> a
bprint
    (Format
  (AbstractHash Blake2b_224 VerificationKey -> UpId -> Builder)
  (AbstractHash Blake2b_224 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
. forall r algo a. Format r (AbstractHash algo a -> r)
shortHashF 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)
" " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r algo a. Format r (AbstractHash algo a -> r)
shortHashF 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
")")
    (forall a. EncCBOR a => a -> AddressHash a
addressHash forall a b. (a -> b) -> a -> b
$ forall a. AVote a -> VerificationKey
voterVK Vote
uv)
    (forall a. AVote a -> UpId
proposalId Vote
uv)

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