{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Binary.GoldenSpec (spec) where

import Cardano.Crypto.DSIGN (
  createPossessionProofDSIGN,
  deriveVerKeyDSIGN,
  genKeyDSIGN,
  seedSizeDSIGN,
  signDSIGN,
 )
import Cardano.Crypto.Leios (
  LeiosCert,
  LeiosCommittee (..),
  LeiosDSIGN,
  LeiosSeat (..),
  LeiosSeatId (..),
  LeiosSignature,
  LeiosSigningKey,
  Weight,
  aggregateLeiosCert,
  leiosSignContext,
  mkLeiosCommittee,
 )
import Cardano.Crypto.Seed (mkSeedFromBytes)
import Cardano.Ledger.Binary (getVersion, natVersion)
import Control.Monad (forM_)
import qualified Data.ByteString as BS
import Data.Foldable (Foldable (..))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Proxy (Proxy (..))
import Data.Ratio ((%))
import qualified Data.Vector.Strict as V
import Data.Word
import Paths_cardano_ledger_binary (getDataFileName)
import Test.Cardano.Ledger.Binary.Golden (cborGoldenSpec)
import Test.Hspec (Spec, describe)

spec :: Spec
spec :: Spec
spec =
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"Golden" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    [Version] -> (Version -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @12 .. Version
forall a. Bounded a => a
maxBound] ((Version -> Spec) -> Spec) -> (Version -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \Version
version -> [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe (Version -> [Char]
forall a. Show a => a -> [Char]
show Version
version) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
      let fileName :: [Char]
fileName = [Char]
"golden/LeiosCertPV" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word32 -> [Char]
forall a. Show a => a -> [Char]
show (forall i. Integral i => Version -> i
getVersion @Word32 Version
version) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".cbor"
          exampleLeiosCert :: LeiosCert
exampleLeiosCert =
            let sk :: SignKeyDSIGN LeiosDSIGN
sk = Seed -> SignKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0))
                vk :: VerKeyDSIGN LeiosDSIGN
vk = SignKeyDSIGN LeiosDSIGN -> VerKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN LeiosDSIGN
sk
                pop :: PossessionProofDSIGN LeiosDSIGN
pop = ContextDSIGN LeiosDSIGN
-> SignKeyDSIGN LeiosDSIGN -> PossessionProofDSIGN LeiosDSIGN
forall v.
(DSIGNAggregatable v, HasCallStack) =>
ContextDSIGN v -> SignKeyDSIGN v -> PossessionProofDSIGN v
createPossessionProofDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext SignKeyDSIGN LeiosDSIGN
sk
                committee :: LeiosCommittee
committee = Vector
  (StrictMaybe
     (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN),
   Weight)
-> LeiosCommittee
mkLeiosCommittee ([(StrictMaybe
    (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN),
  Weight)]
-> Vector
     (StrictMaybe
        (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN),
      Weight)
forall a. [a] -> Vector a
V.fromList [((VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN)
-> StrictMaybe
     (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN)
forall a. a -> StrictMaybe a
SJust (VerKeyDSIGN LeiosDSIGN
vk, PossessionProofDSIGN LeiosDSIGN
pop), Integer
1 Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Integer
1)])
                msg :: ByteString
msg = ByteString
"golden" :: BS.ByteString
                sigs :: Map LeiosSeatId (SigDSIGN LeiosDSIGN)
sigs = LeiosSeatId
-> SigDSIGN LeiosDSIGN -> Map LeiosSeatId (SigDSIGN LeiosDSIGN)
forall k a. k -> a -> Map k a
Map.singleton (Word16 -> LeiosSeatId
LeiosSeatId Word16
0) (ContextDSIGN LeiosDSIGN
-> ByteString -> SignKeyDSIGN LeiosDSIGN -> SigDSIGN LeiosDSIGN
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 -> SignKeyDSIGN LeiosDSIGN -> SigDSIGN LeiosDSIGN
signDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext ByteString
msg SignKeyDSIGN LeiosDSIGN
sk)
             in case LeiosCommittee
-> Map LeiosSeatId (SigDSIGN LeiosDSIGN)
-> Either AggregationError LeiosCert
aggregateLeiosCert LeiosCommittee
committee Map LeiosSeatId (SigDSIGN LeiosDSIGN)
sigs of
                  Right LeiosCert
cert -> LeiosCert
cert
                  Left AggregationError
e -> [Char] -> LeiosCert
forall a. HasCallStack => [Char] -> a
error ([Char]
"exampleLeiosCert: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AggregationError -> [Char]
forall a. Show a => a -> [Char]
show AggregationError
e)
       in ([Char] -> IO [Char]) -> [Char] -> Version -> LeiosCert -> Spec
forall a.
(Eq a, Show a, EncCBOR a, DecCBOR a, HasCallStack) =>
([Char] -> IO [Char]) -> [Char] -> Version -> a -> Spec
cborGoldenSpec [Char] -> IO [Char]
getDataFileName [Char]
fileName Version
version LeiosCert
exampleLeiosCert
      let fileName :: [Char]
fileName = [Char]
"golden/LeiosSeatPV" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word32 -> [Char]
forall a. Show a => a -> [Char]
show (forall i. Integral i => Version -> i
getVersion @Word32 Version
version) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".cbor"
          exampleLeiosSeat :: LeiosSeat
exampleLeiosSeat =
            LeiosSeat
              { seatWeight :: Weight
seatWeight = Integer
1 Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Integer
3
              , seatVKey :: StrictMaybe (VerKeyDSIGN LeiosDSIGN)
seatVKey = VerKeyDSIGN LeiosDSIGN -> StrictMaybe (VerKeyDSIGN LeiosDSIGN)
forall a. a -> StrictMaybe a
SJust (SignKeyDSIGN LeiosDSIGN -> VerKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (Seed -> SignKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0))))
              }
       in ([Char] -> IO [Char]) -> [Char] -> Version -> LeiosSeat -> Spec
forall a.
(Eq a, Show a, EncCBOR a, DecCBOR a, HasCallStack) =>
([Char] -> IO [Char]) -> [Char] -> Version -> a -> Spec
cborGoldenSpec [Char] -> IO [Char]
getDataFileName [Char]
fileName Version
version LeiosSeat
exampleLeiosSeat
      let fileName :: [Char]
fileName = [Char]
"golden/LeiosCommitteePV" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word32 -> [Char]
forall a. Show a => a -> [Char]
show (forall i. Integral i => Version -> i
getVersion @Word32 Version
version) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".cbor"
          exampleLeiosCommittee :: LeiosCommittee
exampleLeiosCommittee =
            Vector LeiosSeat -> LeiosCommittee
UnsafeLeiosCommittee (Vector LeiosSeat -> LeiosCommittee)
-> Vector LeiosSeat -> LeiosCommittee
forall a b. (a -> b) -> a -> b
$
              [LeiosSeat] -> Vector LeiosSeat
forall a. [a] -> Vector a
V.fromList
                [ Weight -> StrictMaybe (VerKeyDSIGN LeiosDSIGN) -> LeiosSeat
LeiosSeat (Integer
1 Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Integer
2) StrictMaybe (VerKeyDSIGN LeiosDSIGN)
forall a. StrictMaybe a
SNothing
                , Weight -> StrictMaybe (VerKeyDSIGN LeiosDSIGN) -> LeiosSeat
LeiosSeat (Integer
1 Integer -> Integer -> Weight
forall a. Integral a => a -> a -> Ratio a
% Integer
2) (VerKeyDSIGN LeiosDSIGN -> StrictMaybe (VerKeyDSIGN LeiosDSIGN)
forall a. a -> StrictMaybe a
SJust (SignKeyDSIGN LeiosDSIGN -> VerKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (Seed -> SignKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
0)))))
                ]
       in ([Char] -> IO [Char])
-> [Char] -> Version -> LeiosCommittee -> Spec
forall a.
(Eq a, Show a, EncCBOR a, DecCBOR a, HasCallStack) =>
([Char] -> IO [Char]) -> [Char] -> Version -> a -> Spec
cborGoldenSpec [Char] -> IO [Char]
getDataFileName [Char]
fileName Version
version LeiosCommittee
exampleLeiosCommittee
      ([Char] -> IO [Char]) -> [Char] -> Version -> LeiosCert -> Spec
forall a.
(Eq a, Show a, EncCBOR a, DecCBOR a, HasCallStack) =>
([Char] -> IO [Char]) -> [Char] -> Version -> a -> Spec
cborGoldenSpec [Char] -> IO [Char]
getDataFileName [Char]
"test/golden/LeiosCert" Version
version LeiosCert
exampleCert

-- | Certificate over a fixed committee and message, pinned to the golden file that
-- originally lived in @cardano-base@'s @cardano-crypto-leios@ test suite. Its
-- construction must not change, otherwise the golden encoding no longer matches.
exampleCert :: LeiosCert
exampleCert :: LeiosCert
exampleCert = case LeiosCommittee
-> Map LeiosSeatId (SigDSIGN LeiosDSIGN)
-> Either AggregationError LeiosCert
aggregateLeiosCert LeiosCommittee
committee Map LeiosSeatId (SigDSIGN LeiosDSIGN)
contributions of
  Right LeiosCert
c -> LeiosCert
c
  Left AggregationError
e -> [Char] -> LeiosCert
forall a. HasCallStack => [Char] -> a
error ([Char]
"exampleCert: aggregation failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> AggregationError -> [Char]
forall a. Show a => a -> [Char]
show AggregationError
e)
  where
    (NonEmpty (SignKeyDSIGN LeiosDSIGN)
sks, LeiosCommittee
committee) = Int -> (NonEmpty (SignKeyDSIGN LeiosDSIGN), LeiosCommittee)
fixedCommittee Int
1000
    msg :: ByteString
msg = ByteString
"leios-golden-message" :: BS.ByteString
    contributions :: Map LeiosSeatId (SigDSIGN LeiosDSIGN)
contributions = ByteString
-> [(Int, SignKeyDSIGN LeiosDSIGN)]
-> Map LeiosSeatId (SigDSIGN LeiosDSIGN)
signContribs ByteString
msg ([Int]
-> [SignKeyDSIGN LeiosDSIGN] -> [(Int, SignKeyDSIGN LeiosDSIGN)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] (NonEmpty (SignKeyDSIGN LeiosDSIGN) -> [SignKeyDSIGN LeiosDSIGN]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (SignKeyDSIGN LeiosDSIGN)
sks))

-- | Equal-weighted committee of @n@ voters derived from a fixed seed pattern.
-- Returns the signing keys alongside the committee so that contributions can be
-- produced.
fixedCommittee :: Int -> (NonEmpty LeiosSigningKey, LeiosCommittee)
fixedCommittee :: Int -> (NonEmpty (SignKeyDSIGN LeiosDSIGN), LeiosCommittee)
fixedCommittee Int
n =
  ( NonEmpty (SignKeyDSIGN LeiosDSIGN)
sks
  , Vector
  (StrictMaybe
     (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN),
   Weight)
-> LeiosCommittee
mkLeiosCommittee
      ( [(StrictMaybe
    (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN),
  Weight)]
-> Vector
     (StrictMaybe
        (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN),
      Weight)
forall a. [a] -> Vector a
V.fromList
          [ ( (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN)
-> StrictMaybe
     (VerKeyDSIGN LeiosDSIGN, PossessionProofDSIGN LeiosDSIGN)
forall a. a -> StrictMaybe a
SJust (SignKeyDSIGN LeiosDSIGN -> VerKeyDSIGN LeiosDSIGN
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN LeiosDSIGN
sk, ContextDSIGN LeiosDSIGN
-> SignKeyDSIGN LeiosDSIGN -> PossessionProofDSIGN LeiosDSIGN
forall v.
(DSIGNAggregatable v, HasCallStack) =>
ContextDSIGN v -> SignKeyDSIGN v -> PossessionProofDSIGN v
createPossessionProofDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext SignKeyDSIGN LeiosDSIGN
sk)
            , Weight
1 Weight -> Weight -> Weight
forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Weight Int
n
            )
          | SignKeyDSIGN LeiosDSIGN
sk <- NonEmpty (SignKeyDSIGN LeiosDSIGN) -> [SignKeyDSIGN LeiosDSIGN]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (SignKeyDSIGN LeiosDSIGN)
sks
          ]
      )
  )
  where
    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))
    sks :: NonEmpty (SignKeyDSIGN LeiosDSIGN)
sks =
      [SignKeyDSIGN LeiosDSIGN] -> NonEmpty (SignKeyDSIGN LeiosDSIGN)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList
        [ forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN @LeiosDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
seedLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word8 Int
i)))
        | Int
i <- [Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
n]
        ]

-- | Sign @msg@ with each of the given keys and pack them into a 'Map' keyed
-- by 'LeiosVoterId', matching the input shape of 'aggregateLeiosCert'.
signContribs :: BS.ByteString -> [(Int, LeiosSigningKey)] -> Map LeiosSeatId LeiosSignature
signContribs :: ByteString
-> [(Int, SignKeyDSIGN LeiosDSIGN)]
-> Map LeiosSeatId (SigDSIGN LeiosDSIGN)
signContribs ByteString
msg [(Int, SignKeyDSIGN LeiosDSIGN)]
pairs =
  [(LeiosSeatId, SigDSIGN LeiosDSIGN)]
-> Map LeiosSeatId (SigDSIGN LeiosDSIGN)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [(Word16 -> LeiosSeatId
LeiosSeatId (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word16 Int
i), ContextDSIGN LeiosDSIGN
-> ByteString -> SignKeyDSIGN LeiosDSIGN -> SigDSIGN LeiosDSIGN
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 -> SignKeyDSIGN LeiosDSIGN -> SigDSIGN LeiosDSIGN
signDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext ByteString
msg SignKeyDSIGN LeiosDSIGN
sk) | (Int
i, SignKeyDSIGN LeiosDSIGN
sk) <- [(Int, SignKeyDSIGN LeiosDSIGN)]
pairs]