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

-- | Unit tests for properties of the V1 Peras cert
module Test.Consensus.Peras.Cert.V1 (tests) where

import Cardano.Binary (serialize)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LazyByteString
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.NonEmpty as NEMap
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import qualified Ouroboros.Consensus.Committee.Crypto.BLS as BLS
import Ouroboros.Consensus.Peras.Cert.V1
  ( PerasCert (..)
  , PerasCertVoters (..)
  , perasCertNumberOfNonPersistentVoters
  , perasCertNumberOfVoters
  , perasCertSizeUpperBound
  )
import Ouroboros.Consensus.Peras.Crypto.BLS (VRFOutput (..))
import Ouroboros.Consensus.Peras.Types
  ( PerasCertSize (..)
  , PerasSeatIndex (..)
  )
import Ouroboros.Consensus.Peras.Vote.V1
  ( PerasVoteEligibilityProof (..)
  )
import Test.QuickCheck.Gen (chooseInt)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck
  ( Gen
  , Property
  , counterexample
  , forAll
  , testProperty
  )
import Test.Util.Peras.V1 (genPerasCert)
import Test.Util.TestEnv (adjustQuickCheckTests)

{-------------------------------------------------------------------------------
  Tests
-------------------------------------------------------------------------------}

tests :: TestTree
tests :: TestTree
tests =
  (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestTree] -> TestTree
testGroup
      TestName
"V1 Peras certificate"
      [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"has accurate upper bound" Property
prop_accurateUpperBound
      ]

-- | Test that the upper bound on the size of Peras certificates is
-- indeed an upper bound, and does not over-approximate more than 15%.
prop_accurateUpperBound :: Property
prop_accurateUpperBound :: Property
prop_accurateUpperBound = Gen (PerasCert ()) -> (PerasCert () -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (PerasCert ())
genPerasCertWithCustomVoters ((PerasCert () -> Property) -> Property)
-> (PerasCert () -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \PerasCert ()
cert -> do
  let
    upperBound :: PerasCertSize
upperBound = PerasCert () -> PerasCertSize
forall blk. PerasCert blk -> PerasCertSize
perasCertSizeUpperBound PerasCert ()
cert
    lowerBound :: PerasCertSize
lowerBound = (PerasCertSize
upperBound PerasCertSize -> PerasCertSize -> PerasCertSize
forall a. Num a => a -> a -> a
* PerasCertSize
85) PerasCertSize -> PerasCertSize -> PerasCertSize
forall a. Integral a => a -> a -> a
`div` PerasCertSize
100
    actualSize :: PerasCertSize
actualSize = PerasCert () -> PerasCertSize
serializedSize PerasCert ()
cert
    numVoters :: Int
numVoters = PerasCert () -> Int
forall blk. PerasCert blk -> Int
perasCertNumberOfVoters PerasCert ()
cert
    numNonPersistentVoters :: Int
numNonPersistentVoters = PerasCert () -> Int
forall blk. PerasCert blk -> Int
perasCertNumberOfNonPersistentVoters PerasCert ()
cert
    counterexampleMsg :: TestName
counterexampleMsg =
      [TestName] -> TestName
unlines
        [ TestName
"Number of voters: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Int -> TestName
forall a. Show a => a -> TestName
show Int
numVoters
        , TestName
"Number of non-persistent voters: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> Int -> TestName
forall a. Show a => a -> TestName
show Int
numNonPersistentVoters
        , TestName
"Upper bound: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> PerasCertSize -> TestName
forall a. Show a => a -> TestName
show PerasCertSize
upperBound
        , TestName
"Lower bound: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> PerasCertSize -> TestName
forall a. Show a => a -> TestName
show PerasCertSize
lowerBound
        , TestName
"Actual size: " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> PerasCertSize -> TestName
forall a. Show a => a -> TestName
show PerasCertSize
actualSize
        ]
  TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
counterexampleMsg (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    PerasCertSize
upperBound PerasCertSize -> PerasCertSize -> Bool
forall a. Ord a => a -> a -> Bool
>= PerasCertSize
actualSize
      Bool -> Bool -> Bool
&& ( PerasCertSize
actualSize PerasCertSize -> PerasCertSize -> Bool
forall a. Ord a => a -> a -> Bool
>= PerasCertSize
lowerBound
             -- For small certificates, we allow some leeway for the upper bound
             Bool -> Bool -> Bool
|| PerasCertSize
upperBound PerasCertSize -> PerasCertSize -> Bool
forall a. Ord a => a -> a -> Bool
<= PerasCertSize
512
         )

serializedSize :: PerasCert () -> PerasCertSize
serializedSize :: PerasCert () -> PerasCertSize
serializedSize = Int64 -> PerasCertSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> PerasCertSize)
-> (PerasCert () -> Int64) -> PerasCert () -> PerasCertSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
LazyByteString.length (ByteString -> Int64)
-> (PerasCert () -> ByteString) -> PerasCert () -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasCert () -> ByteString
forall a. ToCBOR a => a -> ByteString
serialize

{-------------------------------------------------------------------------------
  Arbitrary helpers
-------------------------------------------------------------------------------}

-- * Peras cert

-- We don't care about the phantom type here, so we arbitrarily use ().
genPerasCertWithCustomVoters :: Gen (PerasCert ())
genPerasCertWithCustomVoters :: Gen (PerasCert ())
genPerasCertWithCustomVoters = do
  baseCert <- Bool -> Gen (PerasCert (ZonkAny 0))
forall tag. Bool -> Gen (PerasCert tag)
genPerasCert Bool
False
  persistentVoters <- chooseInt (1, 1000)
  nonPersistentVoters <- chooseInt (0, 3000)
  pure $
    baseCert
      { pcVoters =
          PerasCertVoters
            . NEMap.fromList
            . fromMaybe (error "test certificates require at least one voter")
            . NonEmpty.nonEmpty
            $ [ (seatIndex voter, PersistentPerasVoteEligibilityProof)
              | voter <- [0 .. persistentVoters - 1]
              ]
              <> [ ( seatIndex voter
                   , NonPersistentPerasVoteEligibilityProof proof
                   )
                 | voter <-
                     [ persistentVoters
                     .. persistentVoters + nonPersistentVoters - 1
                     ]
                 ]
      }
 where
  proof :: VRFOutput PerasBLSCrypto
proof =
    Signature VRF -> VRFOutput PerasBLSCrypto
PerasBLSCryptoVRFOutput (Signature VRF -> VRFOutput PerasBLSCrypto)
-> Signature VRF -> VRFOutput PerasBLSCrypto
forall a b. (a -> b) -> a -> b
$
      PrivateKey VRF -> ByteString -> Signature VRF
forall (r :: KeyRole) msg.
(SignableRepresentation msg, HasBLSContext r) =>
PrivateKey r -> msg -> Signature r
BLS.signWithRole
        (Proxy VRF -> PrivateKey VRF
forall {p} {r :: KeyRole}. p -> PrivateKey r
privateKey (forall {k} (t :: k). Proxy t
forall (t :: KeyRole). Proxy t
Proxy @BLS.VRF))
        (ByteString
"proof" :: ByteString)
  privateKey :: p -> PrivateKey r
privateKey p
_ =
    PrivateKey r -> Maybe (PrivateKey r) -> PrivateKey r
forall a. a -> Maybe a -> a
fromMaybe (TestName -> PrivateKey r
forall a. HasCallStack => TestName -> a
error TestName
"invalid BLS private key") (Maybe (PrivateKey r) -> PrivateKey r)
-> Maybe (PrivateKey r) -> PrivateKey r
forall a b. (a -> b) -> a -> b
$
      ByteString -> ByteString -> Maybe (PrivateKey r)
forall (r :: KeyRole).
ByteString -> ByteString -> Maybe (PrivateKey r)
BLS.rawDeserialisePrivateKey
        (ByteString
"TEST" :: ByteString)
        (Int -> Word8 -> ByteString
ByteString.replicate Int
32 Word8
1)
  seatIndex :: a -> PerasSeatIndex
seatIndex a
i = Word16 -> PerasSeatIndex
PerasSeatIndex (a -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)