{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Ouroboros.Consensus.Peras.Cert.V1
( PerasCert (..)
, PerasCertVoters (..)
) where
import Cardano.Binary
( FromCBOR (..)
, ToCBOR (..)
, decodeListLenOf
, encodeListLen
)
import Control.Monad (when)
import Control.Monad.Error.Class (MonadError (..))
import Data.Containers.NonEmpty (HasNonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.NonEmpty as NEMap
import Data.Map.Strict (Map)
import Data.Maybe (catMaybes)
import Data.Word (Word16)
import Ouroboros.Consensus.Block.SupportsPeras
( PerasBoostedBlock
, PerasRoundNo
, PerasSeatIndex (..)
)
import Ouroboros.Consensus.Committee.Crypto
( CryptoSupportsAggregateVoteSigning (..)
)
import Ouroboros.Consensus.Peras.Crypto.BLS
( PerasBLSCrypto
, VRFOutput
)
import Ouroboros.Consensus.Peras.Vote.V1 (PerasVoteEligibilityProof (..))
import Ouroboros.Consensus.Util.Bitmap (Bitmap)
import qualified Ouroboros.Consensus.Util.Bitmap as Bitmap
data PerasCert
= PerasCert
{ PerasCert -> PerasRoundNo
pcRoundNo :: !PerasRoundNo
, PerasCert -> PerasBoostedBlock
pcBoostedBlock :: !PerasBoostedBlock
, PerasCert -> PerasCertVoters
pcVoters :: !PerasCertVoters
, PerasCert -> AggregateVoteSignature PerasBLSCrypto
pcSignature :: !(AggregateVoteSignature PerasBLSCrypto)
}
deriving (Int -> PerasCert -> ShowS
[PerasCert] -> ShowS
PerasCert -> String
(Int -> PerasCert -> ShowS)
-> (PerasCert -> String)
-> ([PerasCert] -> ShowS)
-> Show PerasCert
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasCert -> ShowS
showsPrec :: Int -> PerasCert -> ShowS
$cshow :: PerasCert -> String
show :: PerasCert -> String
$cshowList :: [PerasCert] -> ShowS
showList :: [PerasCert] -> ShowS
Show, PerasCert -> PerasCert -> Bool
(PerasCert -> PerasCert -> Bool)
-> (PerasCert -> PerasCert -> Bool) -> Eq PerasCert
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerasCert -> PerasCert -> Bool
== :: PerasCert -> PerasCert -> Bool
$c/= :: PerasCert -> PerasCert -> Bool
/= :: PerasCert -> PerasCert -> Bool
Eq)
instance FromCBOR PerasCert where
fromCBOR :: forall s. Decoder s PerasCert
fromCBOR = do
Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
4
pcRoundNo <- Decoder s PerasRoundNo
forall s. Decoder s PerasRoundNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
pcBoostedBlock <- fromCBOR
pcVoters <- fromCBOR
pcSignature <- fromCBOR
pure
PerasCert
{ pcRoundNo
, pcBoostedBlock
, pcVoters
, pcSignature
}
instance ToCBOR PerasCert where
toCBOR :: PerasCert -> Encoding
toCBOR PerasCert
cert =
Word -> Encoding
encodeListLen Word
4
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasRoundNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (PerasCert -> PerasRoundNo
pcRoundNo PerasCert
cert)
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasBoostedBlock -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (PerasCert -> PerasBoostedBlock
pcBoostedBlock PerasCert
cert)
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasCertVoters -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (PerasCert -> PerasCertVoters
pcVoters PerasCert
cert)
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasBLSCryptoAggregateVoteSignature -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (PerasCert -> AggregateVoteSignature PerasBLSCrypto
pcSignature PerasCert
cert)
newtype PerasCertVoters
= PerasCertVoters
{ PerasCertVoters
-> NE (Map PerasSeatIndex PerasVoteEligibilityProof)
unPerasCertVoters ::
NE (Map PerasSeatIndex PerasVoteEligibilityProof)
}
deriving (PerasCertVoters -> PerasCertVoters -> Bool
(PerasCertVoters -> PerasCertVoters -> Bool)
-> (PerasCertVoters -> PerasCertVoters -> Bool)
-> Eq PerasCertVoters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerasCertVoters -> PerasCertVoters -> Bool
== :: PerasCertVoters -> PerasCertVoters -> Bool
$c/= :: PerasCertVoters -> PerasCertVoters -> Bool
/= :: PerasCertVoters -> PerasCertVoters -> Bool
Eq, Int -> PerasCertVoters -> ShowS
[PerasCertVoters] -> ShowS
PerasCertVoters -> String
(Int -> PerasCertVoters -> ShowS)
-> (PerasCertVoters -> String)
-> ([PerasCertVoters] -> ShowS)
-> Show PerasCertVoters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasCertVoters -> ShowS
showsPrec :: Int -> PerasCertVoters -> ShowS
$cshow :: PerasCertVoters -> String
show :: PerasCertVoters -> String
$cshowList :: [PerasCertVoters] -> ShowS
showList :: [PerasCertVoters] -> ShowS
Show)
instance FromCBOR PerasCertVoters where
fromCBOR :: forall s. Decoder s PerasCertVoters
fromCBOR = do
Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
votersBitmap <- Decoder s (Bitmap Word16)
forall s. Decoder s (Bitmap Word16)
forall a s. FromCBOR a => Decoder s a
fromCBOR
nonPersistentSigs <- fromCBOR
either fail pure
. fromCompactRepr
$ CompactPerasCertVoters
{ votersBitmap
, nonPersistentSigs
}
instance ToCBOR PerasCertVoters where
toCBOR :: PerasCertVoters -> Encoding
toCBOR PerasCertVoters
voters =
Word -> Encoding
encodeListLen Word
2
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bitmap Word16 -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Bitmap Word16
votersBitmap
Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [VRFOutput PerasBLSCrypto] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR [VRFOutput PerasBLSCrypto]
nonPersistentSigs
where
CompactPerasCertVoters
{ Bitmap Word16
votersBitmap :: CompactPerasCertVoters -> Bitmap Word16
votersBitmap :: Bitmap Word16
votersBitmap
, [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: CompactPerasCertVoters -> [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: [VRFOutput PerasBLSCrypto]
nonPersistentSigs
} =
PerasCertVoters -> CompactPerasCertVoters
toCompactRepr PerasCertVoters
voters
data CompactPerasCertVoters
= CompactPerasCertVoters
{ CompactPerasCertVoters -> Bitmap Word16
votersBitmap :: !(Bitmap Word16)
, CompactPerasCertVoters -> [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: ![VRFOutput PerasBLSCrypto]
}
deriving (CompactPerasCertVoters -> CompactPerasCertVoters -> Bool
(CompactPerasCertVoters -> CompactPerasCertVoters -> Bool)
-> (CompactPerasCertVoters -> CompactPerasCertVoters -> Bool)
-> Eq CompactPerasCertVoters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompactPerasCertVoters -> CompactPerasCertVoters -> Bool
== :: CompactPerasCertVoters -> CompactPerasCertVoters -> Bool
$c/= :: CompactPerasCertVoters -> CompactPerasCertVoters -> Bool
/= :: CompactPerasCertVoters -> CompactPerasCertVoters -> Bool
Eq, Int -> CompactPerasCertVoters -> ShowS
[CompactPerasCertVoters] -> ShowS
CompactPerasCertVoters -> String
(Int -> CompactPerasCertVoters -> ShowS)
-> (CompactPerasCertVoters -> String)
-> ([CompactPerasCertVoters] -> ShowS)
-> Show CompactPerasCertVoters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompactPerasCertVoters -> ShowS
showsPrec :: Int -> CompactPerasCertVoters -> ShowS
$cshow :: CompactPerasCertVoters -> String
show :: CompactPerasCertVoters -> String
$cshowList :: [CompactPerasCertVoters] -> ShowS
showList :: [CompactPerasCertVoters] -> ShowS
Show)
fromCompactRepr ::
CompactPerasCertVoters ->
Either String PerasCertVoters
fromCompactRepr :: CompactPerasCertVoters -> Either String PerasCertVoters
fromCompactRepr
CompactPerasCertVoters
{ Bitmap Word16
votersBitmap :: CompactPerasCertVoters -> Bitmap Word16
votersBitmap :: Bitmap Word16
votersBitmap
, [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: CompactPerasCertVoters -> [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: [VRFOutput PerasBLSCrypto]
nonPersistentSigs
} = do
let voterSeatIndices :: [PerasSeatIndex]
voterSeatIndices =
Word16 -> PerasSeatIndex
PerasSeatIndex (Word16 -> PerasSeatIndex) -> [Word16] -> [PerasSeatIndex]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bitmap Word16 -> [Word16]
forall a. Integral a => Bitmap a -> [a]
Bitmap.toIndices Bitmap Word16
votersBitmap
Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PerasSeatIndex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PerasSeatIndex]
voterSeatIndices) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Invalid Peras certificate: empty voters bitmap"
Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([VRFOutput PerasBLSCrypto] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VRFOutput PerasBLSCrypto]
nonPersistentSigs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [PerasSeatIndex] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PerasSeatIndex]
voterSeatIndices) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
String -> Either String ()
forall a. String -> Either String a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ String
"Invalid Peras certificate:"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" more non-persistent voter eligibility proofs were provided"
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" than the number of voters in the certificate"
, String
" * number of voters: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([PerasSeatIndex] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PerasSeatIndex]
voterSeatIndices)
, String
" * number of proofs: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([VRFOutput PerasBLSCrypto] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VRFOutput PerasBLSCrypto]
nonPersistentSigs)
]
let numPersistentVoters :: Int
numPersistentVoters =
[PerasSeatIndex] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PerasSeatIndex]
voterSeatIndices Int -> Int -> Int
forall a. Num a => a -> a -> a
- [VRFOutput PerasBLSCrypto] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [VRFOutput PerasBLSCrypto]
nonPersistentSigs
let persistentProofs :: [PerasVoteEligibilityProof]
persistentProofs =
Int -> [PerasVoteEligibilityProof] -> [PerasVoteEligibilityProof]
forall a. Int -> [a] -> [a]
take Int
numPersistentVoters (PerasVoteEligibilityProof -> [PerasVoteEligibilityProof]
forall a. a -> [a]
repeat PerasVoteEligibilityProof
PersistentPerasVoteEligibilityProof)
let nonPersistentProofs :: [PerasVoteEligibilityProof]
nonPersistentProofs =
(VRFOutput PerasBLSCrypto -> PerasVoteEligibilityProof)
-> [VRFOutput PerasBLSCrypto] -> [PerasVoteEligibilityProof]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VRFOutput PerasBLSCrypto -> PerasVoteEligibilityProof
NonPersistentPerasVoteEligibilityProof [VRFOutput PerasBLSCrypto]
nonPersistentSigs
let voters :: NEMap PerasSeatIndex PerasVoteEligibilityProof
voters =
NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof)
-> NEMap PerasSeatIndex PerasVoteEligibilityProof
forall k a. Eq k => NonEmpty (k, a) -> NEMap k a
NEMap.fromAscList
(NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof)
-> NEMap PerasSeatIndex PerasVoteEligibilityProof)
-> ([PerasVoteEligibilityProof]
-> NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof))
-> [PerasVoteEligibilityProof]
-> NEMap PerasSeatIndex PerasVoteEligibilityProof
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PerasSeatIndex, PerasVoteEligibilityProof)]
-> NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof)
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList
([(PerasSeatIndex, PerasVoteEligibilityProof)]
-> NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof))
-> ([PerasVoteEligibilityProof]
-> [(PerasSeatIndex, PerasVoteEligibilityProof)])
-> [PerasVoteEligibilityProof]
-> NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PerasSeatIndex]
-> [PerasVoteEligibilityProof]
-> [(PerasSeatIndex, PerasVoteEligibilityProof)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PerasSeatIndex]
voterSeatIndices
([PerasVoteEligibilityProof]
-> NEMap PerasSeatIndex PerasVoteEligibilityProof)
-> [PerasVoteEligibilityProof]
-> NEMap PerasSeatIndex PerasVoteEligibilityProof
forall a b. (a -> b) -> a -> b
$ [PerasVoteEligibilityProof]
persistentProofs [PerasVoteEligibilityProof]
-> [PerasVoteEligibilityProof] -> [PerasVoteEligibilityProof]
forall a. Semigroup a => a -> a -> a
<> [PerasVoteEligibilityProof]
nonPersistentProofs
PerasCertVoters -> Either String PerasCertVoters
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NE (Map PerasSeatIndex PerasVoteEligibilityProof)
-> PerasCertVoters
PerasCertVoters NEMap PerasSeatIndex PerasVoteEligibilityProof
NE (Map PerasSeatIndex PerasVoteEligibilityProof)
voters)
toCompactRepr ::
PerasCertVoters ->
CompactPerasCertVoters
toCompactRepr :: PerasCertVoters -> CompactPerasCertVoters
toCompactRepr (PerasCertVoters NE (Map PerasSeatIndex PerasVoteEligibilityProof)
voters) =
CompactPerasCertVoters
{ Bitmap Word16
votersBitmap :: Bitmap Word16
votersBitmap :: Bitmap Word16
votersBitmap
, [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: [VRFOutput PerasBLSCrypto]
nonPersistentSigs :: [VRFOutput PerasBLSCrypto]
nonPersistentSigs
}
where
logicalUpperBound :: Word16
logicalUpperBound =
PerasSeatIndex -> Word16
unPerasSeatIndex ((PerasSeatIndex, PerasVoteEligibilityProof) -> PerasSeatIndex
forall a b. (a, b) -> a
fst (NEMap PerasSeatIndex PerasVoteEligibilityProof
-> (PerasSeatIndex, PerasVoteEligibilityProof)
forall k a. NEMap k a -> (k, a)
NEMap.findMax NEMap PerasSeatIndex PerasVoteEligibilityProof
NE (Map PerasSeatIndex PerasVoteEligibilityProof)
voters))
votersByAscSeatIndex :: [(PerasSeatIndex, PerasVoteEligibilityProof)]
votersByAscSeatIndex =
NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof)
-> [(PerasSeatIndex, PerasVoteEligibilityProof)]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NEMap PerasSeatIndex PerasVoteEligibilityProof
-> NonEmpty (PerasSeatIndex, PerasVoteEligibilityProof)
forall k a. NEMap k a -> NonEmpty (k, a)
NEMap.toAscList NEMap PerasSeatIndex PerasVoteEligibilityProof
NE (Map PerasSeatIndex PerasVoteEligibilityProof)
voters)
votersSeatIndices :: [Word16]
votersSeatIndices =
((PerasSeatIndex, PerasVoteEligibilityProof) -> Word16)
-> [(PerasSeatIndex, PerasVoteEligibilityProof)] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PerasSeatIndex -> Word16
unPerasSeatIndex (PerasSeatIndex -> Word16)
-> ((PerasSeatIndex, PerasVoteEligibilityProof) -> PerasSeatIndex)
-> (PerasSeatIndex, PerasVoteEligibilityProof)
-> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PerasSeatIndex, PerasVoteEligibilityProof) -> PerasSeatIndex
forall a b. (a, b) -> a
fst) [(PerasSeatIndex, PerasVoteEligibilityProof)]
votersByAscSeatIndex
votersBitmap :: Bitmap Word16
votersBitmap =
Word16 -> [Word16] -> Bitmap Word16
forall a. Integral a => a -> [a] -> Bitmap a
Bitmap.fromIndices Word16
logicalUpperBound [Word16]
votersSeatIndices
nonPersistentSigs :: [VRFOutput PerasBLSCrypto]
nonPersistentSigs =
[Maybe (VRFOutput PerasBLSCrypto)] -> [VRFOutput PerasBLSCrypto]
forall a. [Maybe a] -> [a]
catMaybes (((PerasSeatIndex, PerasVoteEligibilityProof)
-> Maybe (VRFOutput PerasBLSCrypto))
-> [(PerasSeatIndex, PerasVoteEligibilityProof)]
-> [Maybe (VRFOutput PerasBLSCrypto)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PerasSeatIndex, PerasVoteEligibilityProof)
-> Maybe (VRFOutput PerasBLSCrypto)
forall {a}.
(a, PerasVoteEligibilityProof) -> Maybe (VRFOutput PerasBLSCrypto)
getNonPersistentSig [(PerasSeatIndex, PerasVoteEligibilityProof)]
votersByAscSeatIndex)
getNonPersistentSig :: (a, PerasVoteEligibilityProof) -> Maybe (VRFOutput PerasBLSCrypto)
getNonPersistentSig = \case
(a
_, PerasVoteEligibilityProof
PersistentPerasVoteEligibilityProof) -> Maybe (VRFOutput PerasBLSCrypto)
forall a. Maybe a
Nothing
(a
_, NonPersistentPerasVoteEligibilityProof VRFOutput PerasBLSCrypto
p) -> VRFOutput PerasBLSCrypto -> Maybe (VRFOutput PerasBLSCrypto)
forall a. a -> Maybe a
Just VRFOutput PerasBLSCrypto
p