{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Consensus.Protocol.Praos.SelectView (tests) where
import qualified Cardano.Crypto.Hash as Crypto
import qualified Cardano.Crypto.Util as Crypto
import Cardano.Crypto.VRF (OutputVRF, mkTestOutputVRF)
import qualified Cardano.Ledger.Keys as SL
import Cardano.Protocol.Crypto (Crypto (..), StandardCrypto)
import Codec.Serialise (encode)
import Control.Monad
import Data.Containers.ListUtils (nubOrdOn)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Protocol.Praos.Common
import Test.Cardano.Ledger.Binary.Arbitrary ()
import Test.Ouroboros.Consensus.Protocol
import Test.QuickCheck.Gen (Gen (..))
import Test.QuickCheck.Random (mkQCGen)
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.TestEnv
tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"PraosChainSelectView"
[ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
50)
(TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckMaxSize (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10)
(TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ Proxy (PraosChainSelectView StandardCrypto) -> TestTree
forall a.
(ChainOrder a, Typeable a, Arbitrary a, Show a,
Arbitrary (ChainOrderConfig a), Show (ChainOrderConfig a)) =>
Proxy a -> TestTree
tests_chainOrder (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(PraosChainSelectView StandardCrypto))
]
instance Crypto c => Arbitrary (PraosChainSelectView c) where
arbitrary :: Gen (PraosChainSelectView c)
arbitrary = do
size <- Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Gen Int -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
getSize
csvChainLength <- BlockNo <$> choose (1, size)
csvSlotNo <- SlotNo <$> choose (1, size)
csvIssuer <- elements knownIssuers
csvIssueNo <- choose (1, 10)
pure PraosChainSelectView {
csvChainLength
, csvSlotNo
, csvIssuer
, csvIssueNo
, csvTieBreakVRF = mkVRFFor csvIssuer csvSlotNo
}
where
knownIssuers :: [SL.VKey SL.BlockIssuer]
knownIssuers :: [VKey 'BlockIssuer]
knownIssuers =
(VKey 'BlockIssuer -> KeyHash 'BlockIssuer)
-> [VKey 'BlockIssuer] -> [VKey 'BlockIssuer]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOrdOn VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey
([VKey 'BlockIssuer] -> [VKey 'BlockIssuer])
-> [VKey 'BlockIssuer] -> [VKey 'BlockIssuer]
forall a b. (a -> b) -> a -> b
$ Gen [VKey 'BlockIssuer] -> QCGen -> Int -> [VKey 'BlockIssuer]
forall a. Gen a -> QCGen -> Int -> a
unGen (Int -> Gen (VKey 'BlockIssuer) -> Gen [VKey 'BlockIssuer]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
numIssuers (VerKeyDSIGN DSIGN -> VKey 'BlockIssuer
forall (kd :: KeyRole). VerKeyDSIGN DSIGN -> VKey kd
SL.VKey (VerKeyDSIGN DSIGN -> VKey 'BlockIssuer)
-> Gen (VerKeyDSIGN DSIGN) -> Gen (VKey 'BlockIssuer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerKeyDSIGN DSIGN)
forall a. Arbitrary a => Gen a
arbitrary)) QCGen
randomSeed Int
100
where
randomSeed :: QCGen
randomSeed = Int -> QCGen
mkQCGen Int
4
numIssuers :: Int
numIssuers = Int
10
mkVRFFor :: SL.VKey SL.BlockIssuer -> SlotNo -> OutputVRF (VRF c)
mkVRFFor :: VKey 'BlockIssuer -> SlotNo -> OutputVRF (VRF c)
mkVRFFor VKey 'BlockIssuer
issuer SlotNo
slot =
Natural -> OutputVRF (VRF c)
forall v. VRFAlgorithm v => Natural -> OutputVRF v
mkTestOutputVRF
(Natural -> OutputVRF (VRF c)) -> Natural -> OutputVRF (VRF c)
forall a b. (a -> b) -> a -> b
$ ByteString -> Natural
Crypto.bytesToNatural
(ByteString -> Natural) -> ByteString -> Natural
forall a b. (a -> b) -> a -> b
$ Hash ADDRHASH SlotNo -> ByteString
forall h a. Hash h a -> ByteString
Crypto.hashToBytes
(Hash ADDRHASH SlotNo -> ByteString)
-> Hash ADDRHASH SlotNo -> ByteString
forall a b. (a -> b) -> a -> b
$ Hash ADDRHASH SlotNo
-> Hash ADDRHASH SlotNo -> Hash ADDRHASH SlotNo
forall h a. Hash h a -> Hash h a -> Hash h a
Crypto.xor (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> Hash ADDRHASH SlotNo
forall h a b. Hash h a -> Hash h b
Crypto.castHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
issuerHash)
(Hash ADDRHASH SlotNo -> Hash ADDRHASH SlotNo)
-> Hash ADDRHASH SlotNo -> Hash ADDRHASH SlotNo
forall a b. (a -> b) -> a -> b
$ (SlotNo -> Encoding) -> SlotNo -> Hash ADDRHASH SlotNo
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
Crypto.hashWithSerialiser SlotNo -> Encoding
forall a. Serialise a => a -> Encoding
encode SlotNo
slot
where
SL.KeyHash Hash ADDRHASH (VerKeyDSIGN DSIGN)
issuerHash = VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey VKey 'BlockIssuer
issuer
instance Arbitrary VRFTiebreakerFlavor where
arbitrary :: Gen VRFTiebreakerFlavor
arbitrary = [Gen VRFTiebreakerFlavor] -> Gen VRFTiebreakerFlavor
forall a. HasCallStack => [Gen a] -> Gen a
oneof
[ VRFTiebreakerFlavor -> Gen VRFTiebreakerFlavor
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker
, do
size <- Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
1 (Word64 -> Word64) -> (Int -> Word64) -> Int -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Gen Int -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
getSize
RestrictedVRFTiebreaker . SlotNo <$> choose (1, size)
]
shrink :: VRFTiebreakerFlavor -> [VRFTiebreakerFlavor]
shrink = \case
VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker -> []
RestrictedVRFTiebreaker SlotNo
maxDist ->
VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker
VRFTiebreakerFlavor
-> [VRFTiebreakerFlavor] -> [VRFTiebreakerFlavor]
forall a. a -> [a] -> [a]
: (SlotNo -> VRFTiebreakerFlavor
RestrictedVRFTiebreaker (SlotNo -> VRFTiebreakerFlavor)
-> [SlotNo] -> [VRFTiebreakerFlavor]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> [SlotNo]
forall a. Arbitrary a => a -> [a]
shrink SlotNo
maxDist)