-- | A Leios committee of four equal seats that needs half the weight, and the
-- certificates its seats make.
module Test.Consensus.Leios.Committee
  ( certOf
  , testCommittee
  , testQuorumStakeThreshold
  ) where

import Cardano.Crypto.DSIGN.Class
  ( createPossessionProofDSIGN
  , deriveVerKeyDSIGN
  , genKeyDSIGN
  , signDSIGN
  )
import Cardano.Crypto.Leios
  ( LeiosCert
  , LeiosCommittee
  , LeiosSeatId (..)
  , LeiosSigningKey
  , aggregateLeiosCert
  , leiosSignContext
  , mkLeiosCommittee
  )
import Cardano.Crypto.Seed (mkSeedFromBytes)
import Cardano.Ledger.BaseTypes (UnitInterval, boundRational)
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Maybe.Strict (StrictMaybe (..))
import qualified Data.Vector.Strict as V
import Data.Word (Word16)
import Ouroboros.Consensus.Leios.Types (RankingBlockHash)

signingKeys :: [LeiosSigningKey]
signingKeys :: [LeiosSigningKey]
signingKeys = [Seed -> LeiosSigningKey
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
i)) | Word8
i <- [Word8
0 .. Word8
3]]

testCommittee :: LeiosCommittee
testCommittee :: LeiosCommittee
testCommittee =
  Vector
  (StrictMaybe (LeiosVerificationKey, LeiosProofOfPossession),
   Ratio Integer)
-> LeiosCommittee
mkLeiosCommittee (Vector
   (StrictMaybe (LeiosVerificationKey, LeiosProofOfPossession),
    Ratio Integer)
 -> LeiosCommittee)
-> Vector
     (StrictMaybe (LeiosVerificationKey, LeiosProofOfPossession),
      Ratio Integer)
-> LeiosCommittee
forall a b. (a -> b) -> a -> b
$
    [(StrictMaybe (LeiosVerificationKey, LeiosProofOfPossession),
  Ratio Integer)]
-> Vector
     (StrictMaybe (LeiosVerificationKey, LeiosProofOfPossession),
      Ratio Integer)
forall a. [a] -> Vector a
V.fromList
      [ ((LeiosVerificationKey, LeiosProofOfPossession)
-> StrictMaybe (LeiosVerificationKey, LeiosProofOfPossession)
forall a. a -> StrictMaybe a
SJust (LeiosSigningKey -> LeiosVerificationKey
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN LeiosSigningKey
sk, ContextDSIGN LeiosDSIGN
-> LeiosSigningKey -> LeiosProofOfPossession
forall v.
(DSIGNAggregatable v, HasCallStack) =>
ContextDSIGN v -> SignKeyDSIGN v -> PossessionProofDSIGN v
createPossessionProofDSIGN ContextDSIGN LeiosDSIGN
BLS12381SignContext
leiosSignContext LeiosSigningKey
sk), Ratio Integer
1 Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Ratio Integer
4)
      | LeiosSigningKey
sk <- [LeiosSigningKey]
signingKeys
      ]

testQuorumStakeThreshold :: UnitInterval
testQuorumStakeThreshold :: UnitInterval
testQuorumStakeThreshold =
  UnitInterval -> Maybe UnitInterval -> UnitInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> UnitInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"not a unit interval") (Ratio Integer -> Maybe UnitInterval
forall r. BoundedRational r => Ratio Integer -> Maybe r
boundRational (Ratio Integer
1 Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Ratio Integer
2))

-- | The certificate the given seats make of the given announcing block.
certOf :: RankingBlockHash -> [Word16] -> LeiosCert
certOf :: RankingBlockHash -> [Word16] -> LeiosCert
certOf RankingBlockHash
rbHash [Word16]
seats =
  (AggregationError -> LeiosCert)
-> (LeiosCert -> LeiosCert)
-> Either AggregationError LeiosCert
-> LeiosCert
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> LeiosCert
forall a. HasCallStack => [Char] -> a
error ([Char] -> LeiosCert)
-> (AggregationError -> [Char]) -> AggregationError -> LeiosCert
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AggregationError -> [Char]
forall a. Show a => a -> [Char]
show) LeiosCert -> LeiosCert
forall a. a -> a
id (Either AggregationError LeiosCert -> LeiosCert)
-> Either AggregationError LeiosCert -> LeiosCert
forall a b. (a -> b) -> a -> b
$
    LeiosCommittee
-> Map LeiosSeatId LeiosSignature
-> Either AggregationError LeiosCert
aggregateLeiosCert LeiosCommittee
testCommittee (Map LeiosSeatId LeiosSignature
 -> Either AggregationError LeiosCert)
-> Map LeiosSeatId LeiosSignature
-> Either AggregationError LeiosCert
forall a b. (a -> b) -> a -> b
$
      [(LeiosSeatId, LeiosSignature)] -> Map LeiosSeatId LeiosSignature
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Word16 -> LeiosSeatId
LeiosSeatId Word16
seat, ContextDSIGN LeiosDSIGN
-> RankingBlockHash -> 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 RankingBlockHash
rbHash LeiosSigningKey
sk)
        | (Word16
seat, LeiosSigningKey
sk) <- [Word16] -> [LeiosSigningKey] -> [(Word16, LeiosSigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word16
0 ..] [LeiosSigningKey]
signingKeys
        , Word16
seat Word16 -> [Word16] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Word16]
seats
        ]