{-# LANGUAGE TypeApplications #-}

-- | QuickCheck generators for 'Cardano.Crypto.Leios' types, intended for
-- downstream test suites (e.g. @cardano-ledger@) that want a real
-- structurally-valid 'LeiosCert' without depending on the BLS plumbing.
--
-- These generators produce values whose CBOR encoding round-trips, but they
-- do not attempt to satisfy 'verifyLeiosCert' against any particular
-- committee or message — the @signers@ bitfield is uncorrelated with the
-- aggregated signature. That makes them suitable for serialisation and
-- AST-shape tests, not for protocol-level acceptance tests.
module Test.Cardano.Crypto.Leios.Gen (
  genLeiosCert,
  genLeiosSignature,
  genLeiosSigningKey,
  generateWith,
) where

import Cardano.Crypto.DSIGN (
  DSIGNAlgorithm (deriveVerKeyDSIGN),
  genKeyDSIGN,
  seedSizeDSIGN,
  signDSIGN,
 )
import Cardano.Crypto.Leios (
  LeiosCert,
  LeiosCommittee (..),
  LeiosDSIGN,
  LeiosSignature,
  LeiosSigningKey,
  LeiosVoter (..),
  LeiosVoterId (..),
  aggregateLeiosCert,
  leiosSignContext,
 )
import Cardano.Crypto.Seed (mkSeedFromBytes)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (Proxy))
import Data.Ratio ((%))
import qualified Data.Vector.Strict as V
import Data.Word (Word16, Word64)
import Test.Cardano.Base.Bytes (genByteString)
import Test.QuickCheck (Gen, choose, chooseInt, elements, shuffle, vectorOf)
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen)

-- | Generate a 'LeiosSigningKey' from a uniformly random seed of the
-- algorithm's expected size.
genLeiosSigningKey :: Gen LeiosSigningKey
genLeiosSigningKey :: Gen LeiosSigningKey
genLeiosSigningKey = do
  let seedLen :: Int
seedLen = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int (Proxy LeiosDSIGN -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
seedSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @LeiosDSIGN))
  ByteString
seedBytes <- Int -> Gen ByteString
genByteString Int
seedLen
  LeiosSigningKey -> Gen LeiosSigningKey
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LeiosSigningKey -> Gen LeiosSigningKey)
-> LeiosSigningKey -> Gen LeiosSigningKey
forall a b. (a -> b) -> a -> b
$ forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN @LeiosDSIGN (ByteString -> Seed
mkSeedFromBytes ByteString
seedBytes)

-- | Generate a real BLS 'LeiosSignature' by signing a random message with a
-- freshly-generated signing key. Suitable as a byte-generator source for
-- CDDL specs that need on-wire bytes which round-trip through
-- 'Cardano.Crypto.DSIGN.rawDeserialiseSigDSIGN' — uniformly random 48-byte
-- strings do /not/ decode to valid BLS G1 points and will crash there.
genLeiosSignature :: Gen LeiosSignature
genLeiosSignature :: Gen LeiosSignature
genLeiosSignature = do
  LeiosSigningKey
sk <- Gen LeiosSigningKey
genLeiosSigningKey
  Int
msgLen <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
256)
  ByteString
msg <- Int -> Gen ByteString
genByteString Int
msgLen
  LeiosSignature -> Gen LeiosSignature
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LeiosSignature -> Gen LeiosSignature)
-> LeiosSignature -> Gen LeiosSignature
forall a b. (a -> b) -> a -> b
$ ContextDSIGN LeiosDSIGN
-> ByteString -> LeiosSigningKey -> LeiosSignature
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN -> a -> LeiosSigningKey -> LeiosSignature
signDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext ByteString
msg LeiosSigningKey
sk

-- | Generate a real, canonical 'LeiosCert' by building a fresh committee
-- and aggregating a non-empty subset of its members' signatures over a
-- random message. The cert is structurally valid (bitfield length matches
-- the committee, aggregate signature is well-formed) but the committee is
-- not returned — suitable for CBOR / AST-shape tests, not for
-- protocol-acceptance tests in downstream packages.
--
-- Coverage of bitfield byte-length boundaries (CBOR uint widths > 256
-- bytes) is not exercised here; that belongs in this package's own test
-- suite, not in the shared testlib.
genLeiosCert :: Gen LeiosCert
genLeiosCert :: Gen LeiosCert
genLeiosCert = do
  Int
n <- [Int] -> Gen Int
forall a. HasCallStack => [a] -> Gen a
elements [Int
1, Int
8, Int
9, Int
16, Int
17, Int
24]
  [LeiosSigningKey]
sks <- Int -> Gen LeiosSigningKey -> Gen [LeiosSigningKey]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
n Gen LeiosSigningKey
genLeiosSigningKey
  let committee :: LeiosCommittee
committee =
        Vector LeiosVoter -> LeiosCommittee
LeiosCommittee (Vector LeiosVoter -> LeiosCommittee)
-> ([LeiosVoter] -> Vector LeiosVoter)
-> [LeiosVoter]
-> LeiosCommittee
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LeiosVoter] -> Vector LeiosVoter
forall a. [a] -> Vector a
V.fromList ([LeiosVoter] -> LeiosCommittee) -> [LeiosVoter] -> LeiosCommittee
forall a b. (a -> b) -> a -> b
$
          [Weight -> LeiosVerificationKey -> LeiosVoter
LeiosVoter (Integer
1 Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n) (LeiosSigningKey -> LeiosVerificationKey
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN LeiosSigningKey
sk) | LeiosSigningKey
sk <- [LeiosSigningKey]
sks]
  Int
k <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
n)
  [Int]
signerIxs <- Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
k ([Int] -> [Int]) -> Gen [Int] -> Gen [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Gen [Int]
forall a. [a] -> Gen [a]
shuffle [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  Int
msgLen <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
64)
  ByteString
msg <- Int -> Gen ByteString
genByteString Int
msgLen
  let sigs :: Map LeiosVoterId LeiosSignature
sigs =
        [(LeiosVoterId, LeiosSignature)] -> Map LeiosVoterId LeiosSignature
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Word16 -> LeiosVoterId
LeiosVoterId (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word16 Int
i), ContextDSIGN LeiosDSIGN
-> ByteString -> LeiosSigningKey -> LeiosSignature
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
forall a.
(Signable LeiosDSIGN a, HasCallStack) =>
ContextDSIGN LeiosDSIGN -> a -> LeiosSigningKey -> LeiosSignature
signDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext ByteString
msg ([LeiosSigningKey]
sks [LeiosSigningKey] -> Int -> LeiosSigningKey
forall a. HasCallStack => [a] -> Int -> a
!! Int
i))
          | Int
i <- [Int]
signerIxs
          ]
  case LeiosCommittee
-> Map LeiosVoterId LeiosSignature
-> Either AggregationError LeiosCert
aggregateLeiosCert LeiosCommittee
committee Map LeiosVoterId LeiosSignature
sigs of
    Right LeiosCert
cert -> LeiosCert -> Gen LeiosCert
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LeiosCert
cert
    Left AggregationError
e -> [Char] -> Gen LeiosCert
forall a. HasCallStack => [Char] -> a
error ([Char]
"genLeiosCert: aggregation failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AggregationError -> [Char]
forall a. Show a => a -> [Char]
show AggregationError
e)

-- | Deterministically evaluate a QuickCheck 'Gen' at a fixed seed. Useful for
-- pinning a single value (e.g. for golden tests) without going through
-- 'Test.QuickCheck.generate' in 'IO'.
generateWith :: Gen a -> Word64 -> a
generateWith :: forall a. Gen a -> Word64 -> a
generateWith Gen a
gen Word64
seed = Gen a -> QCGen -> Int -> a
forall a. Gen a -> QCGen -> Int -> a
unGen Gen a
gen (Int -> QCGen
mkQCGen (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word64 @Int Word64
seed)) Int
30