{-# 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.Prelude

import Data.Aeson (ToJSON)
import Data.Text.Lazy.Builder (Builder)
import Formatting (Format, bprint, build, later)
import qualified Formatting.Buildable as B

import Cardano.Binary
  ( Annotated(Annotated, unAnnotated)
  , ByteSpan
  , Decoded(..)
  , FromCBOR(..)
  , ToCBOR(..)
  , annotatedDecoder
  , fromCBORAnnotated
  , encodeListLen
  , enforceSize
  )
import qualified Cardano.Binary as Binary (annotation)
import Cardano.Chain.Common (addressHash)
import Cardano.Chain.Update.Proposal (Proposal, UpId)
import Cardano.Crypto
  ( Hash
  , ProtocolMagicId
  , VerificationKey
  , SafeSigner
  , SigningKey
  , SignTag(SignUSVote)
  , Signature
  , hashDecoded
  , safeSign
  , safeToVerification
  , shortHashF
  , sign
  , toVerification
  )


--------------------------------------------------------------------------------
-- 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
  { AVote a -> VerificationKey
voterVK     :: !VerificationKey
  -- ^ Verification key casting the vote
  , AVote a -> Annotated UpId a
aProposalId :: !(Annotated UpId a)
  -- ^ Proposal to which this vote applies
  , AVote a -> Signature (UpId, Bool)
signature   :: !(Signature (UpId, Bool))
  -- ^ Signature of (Update proposal, Approval/rejection bit)
  , 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) where


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

-- | A safe constructor for 'UnsafeVote'
mkVote
  :: ProtocolMagicId
  -> SigningKey
  -- ^ The voter
  -> UpId
  -- ^ Proposal which is voted for
  -> Bool
  -- ^ Approval/rejection bit
  -> 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
  -> UpId
  -- ^ Proposal which is voted for
  -> Bool
  -- ^ Approval/rejection bit
  -> SafeSigner
  -- ^ The voter
  -> 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