{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

-- | Cryptographic data types and operations used in Leios per CIP-164. Leios
-- uses BLS12-381 MinSig as its signature scheme and defines a 'LeiosCert' that
-- can be included into blocks. This module deliberately not includes a
-- 'LeiosVote' because the vote itself is not an artifact that is on-chain.
module Cardano.Crypto.Leios (
  -- * Cryptographic primitives
  LeiosDSIGN,
  LeiosSigningKey,
  LeiosVerificationKey,
  LeiosSignature,
  leiosSignContext,
  leiosSignatureSize,
  leiosSignatureToBytes,

  -- * Voting committee
  Weight,
  LeiosVoterId (..),
  encodeLeiosVoterId,
  decodeLeiosVoterId,
  LeiosVoter (..),
  LeiosCommittee (..),
  leiosCommitteeSize,
  resolveLeiosVoter,
  getLeiosVoterId,

  -- * Leios certificates
  LeiosCert (..),
  encodeLeiosCert,
  decodeLeiosCert,

  -- ** Construction
  AggregationError (..),
  aggregateLeiosCert,

  -- ** Verification
  VerificationError (..),
  verifyLeiosCert,

  -- * Bitfield wire-format helpers
  BitField,
  encodeBitField,
  decodeBitField,
) where

import Cardano.Base.Bytes (byteArrayFromByteString)
import Cardano.Binary (matchSize, toCBOR)
import Cardano.Crypto.DSIGN (
  DSIGNAggregatable (aggregateSigsDSIGN, uncheckedAggregateVerKeysDSIGN),
  DSIGNAlgorithm (rawSerialiseSigDSIGN),
  SigDSIGN,
  SignKeyDSIGN,
  VerKeyDSIGN,
  decodeSigDSIGN,
  encodeSigDSIGN,
  verifyDSIGN,
 )
import Cardano.Crypto.DSIGN.BLS12381 (BLS12381MinSigDSIGN, BLS12381SignContext, minSigPoPDST)
import Cardano.Crypto.DSIGN.Class (sigSizeDSIGN)
import Cardano.Crypto.Util (SignableRepresentation)
import Codec.CBOR.Decoding (Decoder, decodeBreakOr, decodeBytes, decodeListLenOrIndef, decodeWord16)
import Codec.CBOR.Encoding (Encoding, encodeListLen, encodeWord16)
import Control.DeepSeq (NFData)
import Control.Monad (forM_, unless, when)
import Data.Array.Byte (ByteArray)
import Data.Bifunctor (first)
import Data.Bits (setBit, shiftR, testBit, (.&.))
import Data.ByteString (ByteString)
import Data.Data (Proxy (..))
import Data.Foldable (foldrM)
import Data.Function ((&))
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isNothing)
import Data.Primitive.ByteArray (
  fillByteArray,
  indexByteArray,
  newByteArray,
  readByteArray,
  runByteArray,
  sizeofByteArray,
  writeByteArray,
 )
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector.Strict (Vector)
import qualified Data.Vector.Strict as V
import Data.Word (Word16, Word8)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))

type LeiosDSIGN = BLS12381MinSigDSIGN

type LeiosSigningKey = SignKeyDSIGN LeiosDSIGN

type LeiosVerificationKey = VerKeyDSIGN LeiosDSIGN

type LeiosSignature = SigDSIGN LeiosDSIGN

-- | The BLS12-381 MinSig proof-of-possession ciphersuite DST used by Leios,
-- per CIP-164. Pass this as the 'ContextDSIGN' to 'signDSIGN' / 'verifyDSIGN'.
leiosSignContext :: BLS12381SignContext
leiosSignContext :: BLS12381SignContext
leiosSignContext = BLS12381SignContext
minSigPoPDST

-- | Size of a Leios signature in the chosen signature scheme.
leiosSignatureSize :: Word
leiosSignatureSize :: Word
leiosSignatureSize = Proxy LeiosDSIGN -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sigSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @LeiosDSIGN)

-- | Get the bytes of a Leios signature.
leiosSignatureToBytes :: LeiosSignature -> ByteString
leiosSignatureToBytes :: SigDSIGN LeiosDSIGN -> ByteString
leiosSignatureToBytes = SigDSIGN LeiosDSIGN -> ByteString
forall v. DSIGNAlgorithm v => SigDSIGN v -> ByteString
rawSerialiseSigDSIGN

-- | A weight assigned to a committee voter, normalised so the total over a
-- committee sums to @1@. Threshold checks in 'verifyLeiosCert' are against
-- this same scale.
type Weight = Rational

-- | A committee member's seat index. The index is the voter's position in
-- 'leiosCommitteeVoters' and determines its bit in the 'LeiosCert' @leiosCertSigners@
-- bitfield (MSB-first within each byte, so voter @i@ ↔ bit @7-(i mod 8)@ of
-- byte @i \`div\` 8@).
newtype LeiosVoterId = LeiosVoterId {LeiosVoterId -> Word16
leiosVoterIndex :: Word16}
  deriving stock (LeiosVoterId -> LeiosVoterId -> Bool
(LeiosVoterId -> LeiosVoterId -> Bool)
-> (LeiosVoterId -> LeiosVoterId -> Bool) -> Eq LeiosVoterId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeiosVoterId -> LeiosVoterId -> Bool
== :: LeiosVoterId -> LeiosVoterId -> Bool
$c/= :: LeiosVoterId -> LeiosVoterId -> Bool
/= :: LeiosVoterId -> LeiosVoterId -> Bool
Eq, Eq LeiosVoterId
Eq LeiosVoterId =>
(LeiosVoterId -> LeiosVoterId -> Ordering)
-> (LeiosVoterId -> LeiosVoterId -> Bool)
-> (LeiosVoterId -> LeiosVoterId -> Bool)
-> (LeiosVoterId -> LeiosVoterId -> Bool)
-> (LeiosVoterId -> LeiosVoterId -> Bool)
-> (LeiosVoterId -> LeiosVoterId -> LeiosVoterId)
-> (LeiosVoterId -> LeiosVoterId -> LeiosVoterId)
-> Ord LeiosVoterId
LeiosVoterId -> LeiosVoterId -> Bool
LeiosVoterId -> LeiosVoterId -> Ordering
LeiosVoterId -> LeiosVoterId -> LeiosVoterId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LeiosVoterId -> LeiosVoterId -> Ordering
compare :: LeiosVoterId -> LeiosVoterId -> Ordering
$c< :: LeiosVoterId -> LeiosVoterId -> Bool
< :: LeiosVoterId -> LeiosVoterId -> Bool
$c<= :: LeiosVoterId -> LeiosVoterId -> Bool
<= :: LeiosVoterId -> LeiosVoterId -> Bool
$c> :: LeiosVoterId -> LeiosVoterId -> Bool
> :: LeiosVoterId -> LeiosVoterId -> Bool
$c>= :: LeiosVoterId -> LeiosVoterId -> Bool
>= :: LeiosVoterId -> LeiosVoterId -> Bool
$cmax :: LeiosVoterId -> LeiosVoterId -> LeiosVoterId
max :: LeiosVoterId -> LeiosVoterId -> LeiosVoterId
$cmin :: LeiosVoterId -> LeiosVoterId -> LeiosVoterId
min :: LeiosVoterId -> LeiosVoterId -> LeiosVoterId
Ord, Int -> LeiosVoterId -> ShowS
[LeiosVoterId] -> ShowS
LeiosVoterId -> String
(Int -> LeiosVoterId -> ShowS)
-> (LeiosVoterId -> String)
-> ([LeiosVoterId] -> ShowS)
-> Show LeiosVoterId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosVoterId -> ShowS
showsPrec :: Int -> LeiosVoterId -> ShowS
$cshow :: LeiosVoterId -> String
show :: LeiosVoterId -> String
$cshowList :: [LeiosVoterId] -> ShowS
showList :: [LeiosVoterId] -> ShowS
Show, (forall x. LeiosVoterId -> Rep LeiosVoterId x)
-> (forall x. Rep LeiosVoterId x -> LeiosVoterId)
-> Generic LeiosVoterId
forall x. Rep LeiosVoterId x -> LeiosVoterId
forall x. LeiosVoterId -> Rep LeiosVoterId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeiosVoterId -> Rep LeiosVoterId x
from :: forall x. LeiosVoterId -> Rep LeiosVoterId x
$cto :: forall x. Rep LeiosVoterId x -> LeiosVoterId
to :: forall x. Rep LeiosVoterId x -> LeiosVoterId
Generic)
  deriving newtype (LeiosVoterId -> ()
(LeiosVoterId -> ()) -> NFData LeiosVoterId
forall a. (a -> ()) -> NFData a
$crnf :: LeiosVoterId -> ()
rnf :: LeiosVoterId -> ()
NFData, Context -> LeiosVoterId -> IO (Maybe ThunkInfo)
Proxy LeiosVoterId -> String
(Context -> LeiosVoterId -> IO (Maybe ThunkInfo))
-> (Context -> LeiosVoterId -> IO (Maybe ThunkInfo))
-> (Proxy LeiosVoterId -> String)
-> NoThunks LeiosVoterId
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LeiosVoterId -> IO (Maybe ThunkInfo)
noThunks :: Context -> LeiosVoterId -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LeiosVoterId -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LeiosVoterId -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LeiosVoterId -> String
showTypeOf :: Proxy LeiosVoterId -> String
NoThunks)

-- | Plain CBOR encoder for 'LeiosVoterId'.
encodeLeiosVoterId :: LeiosVoterId -> Encoding
encodeLeiosVoterId :: LeiosVoterId -> Encoding
encodeLeiosVoterId (LeiosVoterId Word16
idx) = Word16 -> Encoding
encodeWord16 Word16
idx

-- | Plain CBOR decoder for 'LeiosVoterId'.
decodeLeiosVoterId :: Decoder s LeiosVoterId
decodeLeiosVoterId :: forall s. Decoder s LeiosVoterId
decodeLeiosVoterId = Word16 -> LeiosVoterId
LeiosVoterId (Word16 -> LeiosVoterId)
-> Decoder s Word16 -> Decoder s LeiosVoterId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word16
forall s. Decoder s Word16
decodeWord16

-- | A single seat in a 'LeiosCommittee': a voter's normalised weight paired with
-- its BLS verification key.
data LeiosVoter = LeiosVoter
  { LeiosVoter -> Weight
voterWeight :: !Weight
  , LeiosVoter -> LeiosVerificationKey
voterVKey :: !LeiosVerificationKey
  }
  deriving stock (Int -> LeiosVoter -> ShowS
[LeiosVoter] -> ShowS
LeiosVoter -> String
(Int -> LeiosVoter -> ShowS)
-> (LeiosVoter -> String)
-> ([LeiosVoter] -> ShowS)
-> Show LeiosVoter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosVoter -> ShowS
showsPrec :: Int -> LeiosVoter -> ShowS
$cshow :: LeiosVoter -> String
show :: LeiosVoter -> String
$cshowList :: [LeiosVoter] -> ShowS
showList :: [LeiosVoter] -> ShowS
Show, LeiosVoter -> LeiosVoter -> Bool
(LeiosVoter -> LeiosVoter -> Bool)
-> (LeiosVoter -> LeiosVoter -> Bool) -> Eq LeiosVoter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeiosVoter -> LeiosVoter -> Bool
== :: LeiosVoter -> LeiosVoter -> Bool
$c/= :: LeiosVoter -> LeiosVoter -> Bool
/= :: LeiosVoter -> LeiosVoter -> Bool
Eq, (forall x. LeiosVoter -> Rep LeiosVoter x)
-> (forall x. Rep LeiosVoter x -> LeiosVoter) -> Generic LeiosVoter
forall x. Rep LeiosVoter x -> LeiosVoter
forall x. LeiosVoter -> Rep LeiosVoter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeiosVoter -> Rep LeiosVoter x
from :: forall x. LeiosVoter -> Rep LeiosVoter x
$cto :: forall x. Rep LeiosVoter x -> LeiosVoter
to :: forall x. Rep LeiosVoter x -> LeiosVoter
Generic)
  deriving anyclass (LeiosVoter -> ()
(LeiosVoter -> ()) -> NFData LeiosVoter
forall a. (a -> ()) -> NFData a
$crnf :: LeiosVoter -> ()
rnf :: LeiosVoter -> ()
NFData, Context -> LeiosVoter -> IO (Maybe ThunkInfo)
Proxy LeiosVoter -> String
(Context -> LeiosVoter -> IO (Maybe ThunkInfo))
-> (Context -> LeiosVoter -> IO (Maybe ThunkInfo))
-> (Proxy LeiosVoter -> String)
-> NoThunks LeiosVoter
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LeiosVoter -> IO (Maybe ThunkInfo)
noThunks :: Context -> LeiosVoter -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LeiosVoter -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LeiosVoter -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LeiosVoter -> String
showTypeOf :: Proxy LeiosVoter -> String
NoThunks)

-- | The voting committee for a Leios epoch: an ordered vector of
-- 'LeiosVoter' seats.
--
-- Ixition determines the voter's 'LeiosVoterId' and its bit in the certificate's
-- bitfield, so callers must keep the order stable between construction and
-- verification of any cert.
--
-- This package intentionally does not provide committee selection — sampling
-- voters from the active stake distribution lives in consensus/ledger.
-- However, callers are responsible for ensuring that every voter's BLS
-- proof-of-possession has been verified before a 'LeiosCommittee' value is built;
-- 'verifyLeiosCert' and 'aggregateLeiosCert' both rely on this invariant to
-- skip per-key PoP checks (they use 'uncheckedAggregateVerKeysDSIGN' /
-- 'aggregateSigsDSIGN' under the hood). Passing in unchecked keys defeats
-- the security of the aggregate signature.
newtype LeiosCommittee = LeiosCommittee {LeiosCommittee -> Vector LeiosVoter
leiosCommitteeVoters :: Vector LeiosVoter}
  deriving stock (Int -> LeiosCommittee -> ShowS
[LeiosCommittee] -> ShowS
LeiosCommittee -> String
(Int -> LeiosCommittee -> ShowS)
-> (LeiosCommittee -> String)
-> ([LeiosCommittee] -> ShowS)
-> Show LeiosCommittee
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosCommittee -> ShowS
showsPrec :: Int -> LeiosCommittee -> ShowS
$cshow :: LeiosCommittee -> String
show :: LeiosCommittee -> String
$cshowList :: [LeiosCommittee] -> ShowS
showList :: [LeiosCommittee] -> ShowS
Show, LeiosCommittee -> LeiosCommittee -> Bool
(LeiosCommittee -> LeiosCommittee -> Bool)
-> (LeiosCommittee -> LeiosCommittee -> Bool) -> Eq LeiosCommittee
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeiosCommittee -> LeiosCommittee -> Bool
== :: LeiosCommittee -> LeiosCommittee -> Bool
$c/= :: LeiosCommittee -> LeiosCommittee -> Bool
/= :: LeiosCommittee -> LeiosCommittee -> Bool
Eq, (forall x. LeiosCommittee -> Rep LeiosCommittee x)
-> (forall x. Rep LeiosCommittee x -> LeiosCommittee)
-> Generic LeiosCommittee
forall x. Rep LeiosCommittee x -> LeiosCommittee
forall x. LeiosCommittee -> Rep LeiosCommittee x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeiosCommittee -> Rep LeiosCommittee x
from :: forall x. LeiosCommittee -> Rep LeiosCommittee x
$cto :: forall x. Rep LeiosCommittee x -> LeiosCommittee
to :: forall x. Rep LeiosCommittee x -> LeiosCommittee
Generic)
  deriving newtype (LeiosCommittee -> ()
(LeiosCommittee -> ()) -> NFData LeiosCommittee
forall a. (a -> ()) -> NFData a
$crnf :: LeiosCommittee -> ()
rnf :: LeiosCommittee -> ()
NFData)
  -- 'nothunks' ships no instance for 'Data.Vector.Strict.Vector' and we don't
  -- want to add an orphan. A WHNF-only check on the wrapper is sufficient here:
  -- the strict 'Vector' forces every cell to WHNF, and a WHNF 'LeiosVoter'
  -- forces both of its strict fields, so "LeiosCommittee in WHNF" structurally
  -- implies no thunks anywhere inside.
  deriving (Context -> LeiosCommittee -> IO (Maybe ThunkInfo)
Proxy LeiosCommittee -> String
(Context -> LeiosCommittee -> IO (Maybe ThunkInfo))
-> (Context -> LeiosCommittee -> IO (Maybe ThunkInfo))
-> (Proxy LeiosCommittee -> String)
-> NoThunks LeiosCommittee
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LeiosCommittee -> IO (Maybe ThunkInfo)
noThunks :: Context -> LeiosCommittee -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LeiosCommittee -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LeiosCommittee -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LeiosCommittee -> String
showTypeOf :: Proxy LeiosCommittee -> String
NoThunks) via OnlyCheckWhnfNamed "LeiosCommittee" LeiosCommittee

-- | Number of seats in the committee.
leiosCommitteeSize :: LeiosCommittee -> Int
leiosCommitteeSize :: LeiosCommittee -> Int
leiosCommitteeSize LeiosCommittee {Vector LeiosVoter
leiosCommitteeVoters :: LeiosCommittee -> Vector LeiosVoter
leiosCommitteeVoters :: Vector LeiosVoter
leiosCommitteeVoters} = Vector LeiosVoter -> Int
forall a. Vector a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector LeiosVoter
leiosCommitteeVoters

-- | Resolve a 'LeiosVoterId' to its 'LeiosVoter' on the 'LeiosCommittee', or 'Nothing'
-- if the index is past the committee bound.
resolveLeiosVoter :: LeiosCommittee -> LeiosVoterId -> Maybe LeiosVoter
resolveLeiosVoter :: LeiosCommittee -> LeiosVoterId -> Maybe LeiosVoter
resolveLeiosVoter LeiosCommittee
committee LeiosVoterId
voterId =
  LeiosCommittee
committee.leiosCommitteeVoters Vector LeiosVoter -> Int -> Maybe LeiosVoter
forall a. Vector a -> Int -> Maybe a
V.!? Int
idx
  where
    idx :: Int
idx = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int LeiosVoterId
voterId.leiosVoterIndex

-- | Find a voter's 'LeiosVoterId' on the 'LeiosCommittee' by its
-- 'LeiosVerificationKey', or 'Nothing' if the key is not on the committee.
--
-- If the committee carries duplicate verification keys, returns the smallest
-- index matching @vk@ (committee selection is expected to deduplicate, but
-- this module does not enforce it).
--
-- Errors if the matching index does not fit in 'Word16'. The wire format of
-- 'LeiosCert' indexes voters by a 16-bit field, so a committee with more than
-- @2^16@ seats is already malformed. NOTE: this partiality could later be
-- avoided by introducing a smart constructor for 'LeiosCommittee' (or for the
-- committee-selection step in consensus) that rejects oversized committees
-- up front.
getLeiosVoterId :: HasCallStack => LeiosVerificationKey -> LeiosCommittee -> Maybe LeiosVoterId
getLeiosVoterId :: HasCallStack =>
LeiosVerificationKey -> LeiosCommittee -> Maybe LeiosVoterId
getLeiosVoterId LeiosVerificationKey
vk LeiosCommittee
committee =
  Int -> LeiosVoterId
toVoterId (Int -> LeiosVoterId) -> Maybe Int -> Maybe LeiosVoterId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LeiosVoter -> Bool) -> Vector LeiosVoter -> Maybe Int
forall a. (a -> Bool) -> Vector a -> Maybe Int
V.findIndex ((LeiosVerificationKey -> LeiosVerificationKey -> Bool
forall a. Eq a => a -> a -> Bool
== LeiosVerificationKey
vk) (LeiosVerificationKey -> Bool)
-> (LeiosVoter -> LeiosVerificationKey) -> LeiosVoter -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosVoter -> LeiosVerificationKey
voterVKey) LeiosCommittee
committee.leiosCommitteeVoters
  where
    toVoterId :: Int -> LeiosVoterId
toVoterId Int
i
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int Word16
forall a. Bounded a => a
maxBound =
          String -> LeiosVoterId
forall a. HasCallStack => String -> a
error (String -> LeiosVoterId) -> String -> LeiosVoterId
forall a b. (a -> b) -> a -> b
$
            String
"Cardano.Crypto.Leios.getLeiosVoterId: committee index "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not fit in Word16"
      | Bool
otherwise = Word16 -> LeiosVoterId
LeiosVoterId (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word16 Int
i)

-- | A Leios certificate over an endorser block, as specified in CIP-164

-- The committee is derived deterministically from the active stake
-- distribution for the epoch of the announcing RB, so individual voter
-- identities and eligibility proofs are not carried in the certificate;
-- 'leiosCertSigners' is a @⌈N\/8⌉@-byte bitfield over the committee where bit @i@ is
-- set iff voter index @i@ signed.
--
-- Producers should build 'LeiosCert' values via 'aggregateLeiosCert' and
-- consumers verify them via 'verifyLeiosCert'; the bitfield layout is an
-- implementation detail of the wire format.
--
-- XXX: This says it's over an EB, but this modules does not specify the
-- "message" that is signed anymore and only it's usage within a block will add
-- these semantics.
data LeiosCert = LeiosCert
  { LeiosCert -> BitField
leiosCertSigners :: !BitField
  , LeiosCert -> SigDSIGN LeiosDSIGN
leiosCertSignature :: !LeiosSignature
  }
  deriving stock (Int -> LeiosCert -> ShowS
[LeiosCert] -> ShowS
LeiosCert -> String
(Int -> LeiosCert -> ShowS)
-> (LeiosCert -> String)
-> ([LeiosCert] -> ShowS)
-> Show LeiosCert
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosCert -> ShowS
showsPrec :: Int -> LeiosCert -> ShowS
$cshow :: LeiosCert -> String
show :: LeiosCert -> String
$cshowList :: [LeiosCert] -> ShowS
showList :: [LeiosCert] -> ShowS
Show, LeiosCert -> LeiosCert -> Bool
(LeiosCert -> LeiosCert -> Bool)
-> (LeiosCert -> LeiosCert -> Bool) -> Eq LeiosCert
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeiosCert -> LeiosCert -> Bool
== :: LeiosCert -> LeiosCert -> Bool
$c/= :: LeiosCert -> LeiosCert -> Bool
/= :: LeiosCert -> LeiosCert -> Bool
Eq, (forall x. LeiosCert -> Rep LeiosCert x)
-> (forall x. Rep LeiosCert x -> LeiosCert) -> Generic LeiosCert
forall x. Rep LeiosCert x -> LeiosCert
forall x. LeiosCert -> Rep LeiosCert x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeiosCert -> Rep LeiosCert x
from :: forall x. LeiosCert -> Rep LeiosCert x
$cto :: forall x. Rep LeiosCert x -> LeiosCert
to :: forall x. Rep LeiosCert x -> LeiosCert
Generic)
  deriving anyclass (LeiosCert -> ()
(LeiosCert -> ()) -> NFData LeiosCert
forall a. (a -> ()) -> NFData a
$crnf :: LeiosCert -> ()
rnf :: LeiosCert -> ()
NFData, Context -> LeiosCert -> IO (Maybe ThunkInfo)
Proxy LeiosCert -> String
(Context -> LeiosCert -> IO (Maybe ThunkInfo))
-> (Context -> LeiosCert -> IO (Maybe ThunkInfo))
-> (Proxy LeiosCert -> String)
-> NoThunks LeiosCert
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> LeiosCert -> IO (Maybe ThunkInfo)
noThunks :: Context -> LeiosCert -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> LeiosCert -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> LeiosCert -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy LeiosCert -> String
showTypeOf :: Proxy LeiosCert -> String
NoThunks)

-- | Plain CBOR encoder for 'LeiosCert', matching the CDDL in 'LeiosCert'.
encodeLeiosCert :: LeiosCert -> Encoding
encodeLeiosCert :: LeiosCert -> Encoding
encodeLeiosCert LeiosCert
cert =
  Word -> Encoding
encodeListLen Word
2
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BitField -> Encoding
encodeBitField LeiosCert
cert.leiosCertSigners
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SigDSIGN LeiosDSIGN -> Encoding
forall v. DSIGNAlgorithm v => SigDSIGN v -> Encoding
encodeSigDSIGN LeiosCert
cert.leiosCertSignature

-- | Plain CBOR decoder for 'LeiosCert', matching the CDDL in 'LeiosCert'.
-- Accepts both definite-length and indefinite-length encodings of the
-- outer 2-element array.
decodeLeiosCert :: Decoder s LeiosCert
decodeLeiosCert :: forall s. Decoder s LeiosCert
decodeLeiosCert = do
  Bool
isIndef <-
    Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef Decoder s (Maybe Int)
-> (Maybe Int -> Decoder s Bool) -> Decoder s Bool
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Int
n -> Bool
False Bool -> Decoder s () -> Decoder s Bool
forall a b. a -> Decoder s b -> Decoder s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"LeiosCert" Int
2 Int
n
      Maybe Int
Nothing -> Bool -> Decoder s Bool
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  LeiosCert
cert <-
    BitField -> SigDSIGN LeiosDSIGN -> LeiosCert
LeiosCert
      (BitField -> SigDSIGN LeiosDSIGN -> LeiosCert)
-> Decoder s BitField
-> Decoder s (SigDSIGN LeiosDSIGN -> LeiosCert)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s BitField
forall s. Decoder s BitField
decodeBitField
      Decoder s (SigDSIGN LeiosDSIGN -> LeiosCert)
-> Decoder s (SigDSIGN LeiosDSIGN) -> Decoder s LeiosCert
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (SigDSIGN LeiosDSIGN)
forall v s. DSIGNAlgorithm v => Decoder s (SigDSIGN v)
decodeSigDSIGN
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isIndef (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
isBreak <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
    Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isBreak (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
      String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"LeiosCert: expected break after 2 elements of indefinite-length list"
  LeiosCert -> Decoder s LeiosCert
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LeiosCert
cert

data AggregationError
  = -- | One or more voter indices in the sigs are past the committee bound.
    VoterIdsOutOfBounds (NonEmpty LeiosVoterId)
  | -- | BLS signature aggregation failed (e.g. malformed input signature).
    BLSAggregationFailed Text
  deriving stock (AggregationError -> AggregationError -> Bool
(AggregationError -> AggregationError -> Bool)
-> (AggregationError -> AggregationError -> Bool)
-> Eq AggregationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AggregationError -> AggregationError -> Bool
== :: AggregationError -> AggregationError -> Bool
$c/= :: AggregationError -> AggregationError -> Bool
/= :: AggregationError -> AggregationError -> Bool
Eq, Int -> AggregationError -> ShowS
[AggregationError] -> ShowS
AggregationError -> String
(Int -> AggregationError -> ShowS)
-> (AggregationError -> String)
-> ([AggregationError] -> ShowS)
-> Show AggregationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AggregationError -> ShowS
showsPrec :: Int -> AggregationError -> ShowS
$cshow :: AggregationError -> String
show :: AggregationError -> String
$cshowList :: [AggregationError] -> ShowS
showList :: [AggregationError] -> ShowS
Show, (forall x. AggregationError -> Rep AggregationError x)
-> (forall x. Rep AggregationError x -> AggregationError)
-> Generic AggregationError
forall x. Rep AggregationError x -> AggregationError
forall x. AggregationError -> Rep AggregationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AggregationError -> Rep AggregationError x
from :: forall x. AggregationError -> Rep AggregationError x
$cto :: forall x. Rep AggregationError x -> AggregationError
to :: forall x. Rep AggregationError x -> AggregationError
Generic)
  deriving anyclass (AggregationError -> ()
(AggregationError -> ()) -> NFData AggregationError
forall a. (a -> ()) -> NFData a
$crnf :: AggregationError -> ()
rnf :: AggregationError -> ()
NFData)

-- | Build a 'LeiosCert' from the sigs of committee members.
--
-- == Caller obligations
--
-- All signatures must be over the same message. Individual 'LeiosSignature'
-- values are not verified here, and once aggregated they cannot be told apart.
-- Feeding signatures cast over different messages produces a 'LeiosCert' that
-- will silently fail 'verifyLeiosCert' with no indication of which contribution
-- was wrong.
--
-- == What this function does
--
--   * Range-checks each 'LeiosVoterId' against the committee.
--   * Encodes the bitfield over the committee and aggregates the input
--     signatures.
--
-- This is the only way to construct a 'LeiosCert' from outside the package;
-- the bitfield layout is an internal wire-format detail.
aggregateLeiosCert ::
  LeiosCommittee ->
  Map LeiosVoterId LeiosSignature ->
  Either AggregationError LeiosCert
aggregateLeiosCert :: LeiosCommittee
-> Map LeiosVoterId (SigDSIGN LeiosDSIGN)
-> Either AggregationError LeiosCert
aggregateLeiosCert LeiosCommittee
committee Map LeiosVoterId (SigDSIGN LeiosDSIGN)
sigs = do
  case [LeiosVoterId] -> Maybe (NonEmpty LeiosVoterId)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [LeiosVoterId]
outOfBoundsVoterIds of
    Just NonEmpty LeiosVoterId
vs -> AggregationError -> Either AggregationError ()
forall a b. a -> Either a b
Left (NonEmpty LeiosVoterId -> AggregationError
VoterIdsOutOfBounds NonEmpty LeiosVoterId
vs)
    Maybe (NonEmpty LeiosVoterId)
Nothing -> () -> Either AggregationError ()
forall a. a -> Either AggregationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  SigDSIGN LeiosDSIGN
leiosCertSignature <-
    (String -> AggregationError)
-> Either String (SigDSIGN LeiosDSIGN)
-> Either AggregationError (SigDSIGN LeiosDSIGN)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> AggregationError
BLSAggregationFailed (Text -> AggregationError)
-> (String -> Text) -> String -> AggregationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) (Either String (SigDSIGN LeiosDSIGN)
 -> Either AggregationError (SigDSIGN LeiosDSIGN))
-> Either String (SigDSIGN LeiosDSIGN)
-> Either AggregationError (SigDSIGN LeiosDSIGN)
forall a b. (a -> b) -> a -> b
$
      [SigDSIGN LeiosDSIGN] -> Either String (SigDSIGN LeiosDSIGN)
forall v.
(DSIGNAggregatable v, HasCallStack) =>
[SigDSIGN v] -> Either String (SigDSIGN v)
aggregateSigsDSIGN (Map LeiosVoterId (SigDSIGN LeiosDSIGN) -> [SigDSIGN LeiosDSIGN]
forall k a. Map k a -> [a]
Map.elems Map LeiosVoterId (SigDSIGN LeiosDSIGN)
sigs)
  LeiosCert -> Either AggregationError LeiosCert
forall a. a -> Either AggregationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LeiosCert {BitField
leiosCertSigners :: BitField
leiosCertSigners :: BitField
leiosCertSigners, SigDSIGN LeiosDSIGN
leiosCertSignature :: SigDSIGN LeiosDSIGN
leiosCertSignature :: SigDSIGN LeiosDSIGN
leiosCertSignature}
  where
    outOfBoundsVoterIds :: [LeiosVoterId]
outOfBoundsVoterIds =
      [LeiosVoterId
vid | LeiosVoterId
vid <- Map LeiosVoterId (SigDSIGN LeiosDSIGN) -> [LeiosVoterId]
forall k a. Map k a -> [k]
Map.keys Map LeiosVoterId (SigDSIGN LeiosDSIGN)
sigs, Maybe LeiosVoter -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe LeiosVoter -> Bool) -> Maybe LeiosVoter -> Bool
forall a b. (a -> b) -> a -> b
$ LeiosCommittee -> LeiosVoterId -> Maybe LeiosVoter
resolveLeiosVoter LeiosCommittee
committee LeiosVoterId
vid]

    -- Builds directly into a mutable 'ByteArray' via a single allocation and
    -- writes one bit per member of the input set.
    leiosCertSigners :: BitField
leiosCertSigners = ByteArray -> BitField
BitField (ByteArray -> BitField) -> ByteArray -> BitField
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (MutableByteArray s)) -> ByteArray
runByteArray ((forall s. ST s (MutableByteArray s)) -> ByteArray)
-> (forall s. ST s (MutableByteArray s)) -> ByteArray
forall a b. (a -> b) -> a -> b
$ do
      MutableByteArray s
mba <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
len
      MutableByteArray (PrimState (ST s))
-> Int -> Int -> Word8 -> ST s ()
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> Int -> Int -> Word8 -> m ()
fillByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
mba Int
0 Int
len Word8
0
      [LeiosVoterId] -> (LeiosVoterId -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map LeiosVoterId (SigDSIGN LeiosDSIGN) -> [LeiosVoterId]
forall k a. Map k a -> [k]
Map.keys Map LeiosVoterId (SigDSIGN LeiosDSIGN)
sigs) ((LeiosVoterId -> ST s ()) -> ST s ())
-> (LeiosVoterId -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(LeiosVoterId Word16
i) -> do
        let idx :: Int
idx = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int Word16
i
        Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
          let byteIx :: Int
byteIx = Int
idx Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
3
              bitIx :: Int
bitIx = Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
idx Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
7)
          Word8
b <- forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray @Word8 MutableByteArray s
MutableByteArray (PrimState (ST s))
mba Int
byteIx
          MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
mba Int
byteIx (Word8
b Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`setBit` Int
bitIx)
      MutableByteArray s -> ST s (MutableByteArray s)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableByteArray s
mba

    n :: Int
n = LeiosCommittee -> Int
leiosCommitteeSize LeiosCommittee
committee

    len :: Int
len = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8

data VerificationError
  = -- | 'leiosCertSigners' bitfield is longer than @⌈leiosCommitteeSize/8⌉@ bytes.
    MalformedSigners
  | -- | The aggregate-BLS verification failed (wrong message, tampered
    -- signature, or a bitfield/aggregate mismatch).
    InvalidSignature
  | -- | Sum of signers' weights is below the required threshold.
    InsufficientWeight Weight
  deriving stock (VerificationError -> VerificationError -> Bool
(VerificationError -> VerificationError -> Bool)
-> (VerificationError -> VerificationError -> Bool)
-> Eq VerificationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerificationError -> VerificationError -> Bool
== :: VerificationError -> VerificationError -> Bool
$c/= :: VerificationError -> VerificationError -> Bool
/= :: VerificationError -> VerificationError -> Bool
Eq, Int -> VerificationError -> ShowS
[VerificationError] -> ShowS
VerificationError -> String
(Int -> VerificationError -> ShowS)
-> (VerificationError -> String)
-> ([VerificationError] -> ShowS)
-> Show VerificationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationError -> ShowS
showsPrec :: Int -> VerificationError -> ShowS
$cshow :: VerificationError -> String
show :: VerificationError -> String
$cshowList :: [VerificationError] -> ShowS
showList :: [VerificationError] -> ShowS
Show, (forall x. VerificationError -> Rep VerificationError x)
-> (forall x. Rep VerificationError x -> VerificationError)
-> Generic VerificationError
forall x. Rep VerificationError x -> VerificationError
forall x. VerificationError -> Rep VerificationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VerificationError -> Rep VerificationError x
from :: forall x. VerificationError -> Rep VerificationError x
$cto :: forall x. Rep VerificationError x -> VerificationError
to :: forall x. Rep VerificationError x -> VerificationError
Generic)
  deriving anyclass (VerificationError -> ()
(VerificationError -> ()) -> NFData VerificationError
forall a. (a -> ()) -> NFData a
$crnf :: VerificationError -> ()
rnf :: VerificationError -> ()
NFData)

-- | Verify a 'LeiosCert' against a 'LeiosCommittee', a weight threshold, and the
-- message the signers were supposed to have signed.
--
-- == Caller obligations
--
-- Every voter in the 'LeiosCommittee' must have had its BLS proof-of-possession
-- verified beforehand (when the committee was selected). 'verifyLeiosCert'
-- uses 'uncheckedAggregateVerKeysDSIGN' and does not re-check PoPs; passing
-- in an unchecked committee breaks the security of the aggregate signature.
--
-- == What this function does
--
--   1. Decodes the 'leiosCertSigners' bitfield to the list of contributing voter
--      indices, rejecting too small or big bitfield with 'MalformedSigners'.
--
--   2. Sums those voters' weights from the committee; short-circuits with
--      'InsufficientWeight' if the sum is below the threshold.
--
--   3. Aggregates the contributing verification keys and verifies the
--      certificate's 'leiosCertSignature' against the aggregate key over
--      @msg@.
verifyLeiosCert ::
  SignableRepresentation msg =>
  LeiosCommittee ->
  -- | Minimum signer weight required to accept the cert.
  Weight ->
  -- | The message the signers signed.
  msg ->
  LeiosCert ->
  -- | Total weight of the contributing signers on success.
  Either VerificationError Weight
verifyLeiosCert :: forall msg.
SignableRepresentation msg =>
LeiosCommittee
-> Weight -> msg -> LeiosCert -> Either VerificationError Weight
verifyLeiosCert LeiosCommittee
committee Weight
weightRequired msg
msg LeiosCert
cert = do
  -- The bitfield must be exactly the canonical 'committee-many bits, padded
  -- to a whole byte' length. Trailing bytes (zero-padded or otherwise) are
  -- not accepted; the wire form is fixed for a given committee size.
  Bool -> Either VerificationError () -> Either VerificationError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteArray -> Int
sizeofByteArray (BitField -> ByteArray
bitFieldBytes LeiosCert
cert.leiosCertSigners) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) (Either VerificationError () -> Either VerificationError ())
-> Either VerificationError () -> Either VerificationError ()
forall a b. (a -> b) -> a -> b
$
    VerificationError -> Either VerificationError ()
forall a b. a -> Either a b
Left VerificationError
MalformedSigners
  (Weight
weightReceived, [LeiosVerificationKey]
vks) <- (LeiosVoterId
 -> (Weight, [LeiosVerificationKey])
 -> Either VerificationError (Weight, [LeiosVerificationKey]))
-> (Weight, [LeiosVerificationKey])
-> [LeiosVoterId]
-> Either VerificationError (Weight, [LeiosVerificationKey])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LeiosVoterId
-> (Weight, [LeiosVerificationKey])
-> Either VerificationError (Weight, [LeiosVerificationKey])
accumSigner (Weight
0, []) ([LeiosVoterId]
 -> Either VerificationError (Weight, [LeiosVerificationKey]))
-> [LeiosVoterId]
-> Either VerificationError (Weight, [LeiosVerificationKey])
forall a b. (a -> b) -> a -> b
$ BitField -> [LeiosVoterId]
bitFieldMembers LeiosCert
cert.leiosCertSigners
  Bool -> Either VerificationError () -> Either VerificationError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Weight
weightReceived Weight -> Weight -> Bool
forall a. Ord a => a -> a -> Bool
< Weight
weightRequired) (Either VerificationError () -> Either VerificationError ())
-> Either VerificationError () -> Either VerificationError ()
forall a b. (a -> b) -> a -> b
$
    VerificationError -> Either VerificationError ()
forall a b. a -> Either a b
Left (Weight -> VerificationError
InsufficientWeight Weight
weightReceived)
  LeiosVerificationKey
aggVk <-
    [LeiosVerificationKey] -> Either String LeiosVerificationKey
forall v.
(DSIGNAggregatable v, HasCallStack) =>
[VerKeyDSIGN v] -> Either String (VerKeyDSIGN v)
uncheckedAggregateVerKeysDSIGN [LeiosVerificationKey]
vks
      Either String LeiosVerificationKey
-> (Either String LeiosVerificationKey
    -> Either VerificationError LeiosVerificationKey)
-> Either VerificationError LeiosVerificationKey
forall a b. a -> (a -> b) -> b
& (String -> VerificationError)
-> Either String LeiosVerificationKey
-> Either VerificationError LeiosVerificationKey
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (VerificationError -> String -> VerificationError
forall a b. a -> b -> a
const VerificationError
InvalidSignature)
  ContextDSIGN LeiosDSIGN
-> LeiosVerificationKey
-> msg
-> SigDSIGN LeiosDSIGN
-> Either String ()
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SigDSIGN v -> Either String ()
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN
-> LeiosVerificationKey
-> a
-> SigDSIGN LeiosDSIGN
-> Either String ()
verifyDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext LeiosVerificationKey
aggVk msg
msg LeiosCert
cert.leiosCertSignature
    Either String ()
-> (Either String () -> Either VerificationError ())
-> Either VerificationError ()
forall a b. a -> (a -> b) -> b
& (String -> VerificationError)
-> Either String () -> Either VerificationError ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (VerificationError -> String -> VerificationError
forall a b. a -> b -> a
const VerificationError
InvalidSignature)
  Weight -> Either VerificationError Weight
forall a. a -> Either VerificationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Weight
weightReceived
  where
    n :: Int
n = LeiosCommittee -> Int
leiosCommitteeSize LeiosCommittee
committee

    accumSigner :: LeiosVoterId
-> (Weight, [LeiosVerificationKey])
-> Either VerificationError (Weight, [LeiosVerificationKey])
accumSigner LeiosVoterId
vid (!Weight
w, ![LeiosVerificationKey]
ks) =
      case LeiosCommittee -> LeiosVoterId -> Maybe LeiosVoter
resolveLeiosVoter LeiosCommittee
committee LeiosVoterId
vid of
        Maybe LeiosVoter
Nothing -> VerificationError
-> Either VerificationError (Weight, [LeiosVerificationKey])
forall a b. a -> Either a b
Left VerificationError
MalformedSigners
        Just (LeiosVoter Weight
w' LeiosVerificationKey
vk) -> (Weight, [LeiosVerificationKey])
-> Either VerificationError (Weight, [LeiosVerificationKey])
forall a b. b -> Either a b
Right (Weight
w Weight -> Weight -> Weight
forall a. Num a => a -> a -> a
+ Weight
w', LeiosVerificationKey
vk LeiosVerificationKey
-> [LeiosVerificationKey] -> [LeiosVerificationKey]
forall a. a -> [a] -> [a]
: [LeiosVerificationKey]
ks)

    bitFieldMembers :: BitField -> [LeiosVoterId]
bitFieldMembers (BitField ByteArray
ba) =
      [ Word16 -> LeiosVoterId
LeiosVoterId (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word16 Int
globalIx)
      | Int
byteIx <- [Int
0 .. ByteArray -> Int
sizeofByteArray ByteArray
ba Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      , let byte :: Word8
byte = ByteArray -> Int -> Word8
forall a. Prim a => ByteArray -> Int -> a
indexByteArray ByteArray
ba Int
byteIx :: Word8
      , Int
bitIx <- [Int
0 .. Int
7]
      , let globalIx :: Int
globalIx = Int
byteIx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bitIx
      , Int
globalIx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
      , Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
byte (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bitIx)
      ]

-- | The @leiosCertSigners@ bitfield of a 'LeiosCert': a @⌈leiosCommitteeSize\/8⌉@-byte
-- MSB-first packed-bits representation of which committee voters contributed
-- to the aggregate signature.
--
-- A 'newtype' wrapper around 'ByteArray' so type signatures throughout the
-- aggregate / verify path say what they're working on, and so the on-wire
-- form cannot be accidentally confused with arbitrary @bytes@.
newtype BitField = BitField {BitField -> ByteArray
bitFieldBytes :: ByteArray}
  deriving stock (Int -> BitField -> ShowS
[BitField] -> ShowS
BitField -> String
(Int -> BitField -> ShowS)
-> (BitField -> String) -> ([BitField] -> ShowS) -> Show BitField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BitField -> ShowS
showsPrec :: Int -> BitField -> ShowS
$cshow :: BitField -> String
show :: BitField -> String
$cshowList :: [BitField] -> ShowS
showList :: [BitField] -> ShowS
Show, BitField -> BitField -> Bool
(BitField -> BitField -> Bool)
-> (BitField -> BitField -> Bool) -> Eq BitField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BitField -> BitField -> Bool
== :: BitField -> BitField -> Bool
$c/= :: BitField -> BitField -> Bool
/= :: BitField -> BitField -> Bool
Eq, (forall x. BitField -> Rep BitField x)
-> (forall x. Rep BitField x -> BitField) -> Generic BitField
forall x. Rep BitField x -> BitField
forall x. BitField -> Rep BitField x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BitField -> Rep BitField x
from :: forall x. BitField -> Rep BitField x
$cto :: forall x. Rep BitField x -> BitField
to :: forall x. Rep BitField x -> BitField
Generic)
  deriving newtype (BitField -> ()
(BitField -> ()) -> NFData BitField
forall a. (a -> ()) -> NFData a
$crnf :: BitField -> ()
rnf :: BitField -> ()
NFData)
  deriving (Context -> BitField -> IO (Maybe ThunkInfo)
Proxy BitField -> String
(Context -> BitField -> IO (Maybe ThunkInfo))
-> (Context -> BitField -> IO (Maybe ThunkInfo))
-> (Proxy BitField -> String)
-> NoThunks BitField
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> BitField -> IO (Maybe ThunkInfo)
noThunks :: Context -> BitField -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> BitField -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BitField -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy BitField -> String
showTypeOf :: Proxy BitField -> String
NoThunks) via OnlyCheckWhnfNamed "BitField" BitField

-- | Encode a 'BitField' to CBOR bytes.
encodeBitField :: BitField -> Encoding
encodeBitField :: BitField -> Encoding
encodeBitField = ByteArray -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (ByteArray -> Encoding)
-> (BitField -> ByteArray) -> BitField -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitField -> ByteArray
bitFieldBytes

-- | Decode a 'BitField' from CBOR bytes.
decodeBitField :: Decoder s BitField
decodeBitField :: forall s. Decoder s BitField
decodeBitField = ByteArray -> BitField
BitField (ByteArray -> BitField)
-> (ByteString -> ByteArray) -> ByteString -> BitField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteArray
byteArrayFromByteString (ByteString -> BitField)
-> Decoder s ByteString -> Decoder s BitField
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBytes