{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Cardano.Protocol.TPraos.Arbitrary (
genBHeader,
genBlock,
genCoherentBlock,
) where
import qualified Cardano.Crypto.DSIGN.Class as DSIGN (Signable)
import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.Util (SignableRepresentation)
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.BaseTypes (BlockNo (..), Nonce, Seed, SlotNo (..))
import Cardano.Ledger.Block (Block (Block))
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto (KES, VRF), DSIGN)
import Cardano.Ledger.Keys (signedKES)
import Cardano.Protocol.TPraos.API (PraosCrypto)
import Cardano.Protocol.TPraos.BHeader (
BHBody (BHBody),
BHeader (BHeader),
HashHeader (HashHeader),
PrevHash (BlockHash, GenesisHash),
)
import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod), OCert (..), OCertSignable (..))
import Cardano.Protocol.TPraos.Rules.Overlay (OBftSlot)
import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState)
import Cardano.Protocol.TPraos.Rules.Tickn (TicknState)
import Generic.Random (genericArbitraryU)
import Test.Cardano.Ledger.Binary.Arbitrary ()
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Ledger.Shelley.Arbitrary ()
import Test.Cardano.Protocol.TPraos.Create (AllIssuerKeys, mkBHBody, mkBHeader, mkBlock, mkOCert)
instance Crypto c => Arbitrary (HashHeader c) where
arbitrary :: Gen (HashHeader c)
arbitrary = forall c. Hash c EraIndependentBlockHeader -> HashHeader c
HashHeader forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
instance Arbitrary TicknState where
arbitrary :: Gen TicknState
arbitrary = forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
shrink :: TicknState -> [TicknState]
shrink = forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink
instance Crypto c => Arbitrary (PrtclState c) where
arbitrary :: Gen (PrtclState c)
arbitrary = forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
shrink :: PrtclState c -> [PrtclState c]
shrink = forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink
instance Crypto c => Arbitrary (OBftSlot c) where
arbitrary :: Gen (OBftSlot c)
arbitrary = forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
shrink :: OBftSlot c -> [OBftSlot c]
shrink = forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink
instance
( Crypto c
, VRF.Signable (VRF c) ~ SignableRepresentation
, KES.Signable (KES c) ~ SignableRepresentation
) =>
Arbitrary (BHeader c)
where
arbitrary :: Gen (BHeader c)
arbitrary = do
BHBody c
bhBody <- forall a. Arbitrary a => Gen a
arbitrary
SignKeyKES (KES c)
hotKey <- forall a. Arbitrary a => Gen a
arbitrary
let sig :: SignedKES (KES c) (BHBody c)
sig = forall v a.
(KESAlgorithm v, Signable v a) =>
ContextKES v -> Period -> a -> SignKeyKES v -> SignedKES v a
signedKES () Period
1 BHBody c
bhBody SignKeyKES (KES c)
hotKey
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c.
Crypto c =>
BHBody c -> SignedKES c (BHBody c) -> BHeader c
BHeader BHBody c
bhBody SignedKES (KES c) (BHBody c)
sig
genBHeader ::
( DSIGN.Signable (DSIGN c) (OCertSignable c)
, VRF.Signable (VRF c) Seed
, KES.Signable (KES c) (BHBody c)
, Crypto c
) =>
[AllIssuerKeys c r] ->
Gen (BHeader c)
[AllIssuerKeys c r]
aiks = do
HashHeader c
prevHash <- forall a. Arbitrary a => Gen a
arbitrary
AllIssuerKeys c r
allPoolKeys <- forall a. HasCallStack => [a] -> Gen a
elements [AllIssuerKeys c r]
aiks
SlotNo
slotNo <- forall a. Arbitrary a => Gen a
arbitrary
BlockNo
blockNo <- forall a. Arbitrary a => Gen a
arbitrary
Nonce
epochNonce <- forall a. Arbitrary a => Gen a
arbitrary
Word32
bodySize <- forall a. Arbitrary a => Gen a
arbitrary
Hash (HASH c) EraIndependentBlockBody
bodyHash <- forall a. Arbitrary a => Gen a
arbitrary
ProtVer
protVer <- forall a. Arbitrary a => Gen a
arbitrary
let kesPeriod :: Period
kesPeriod = Period
1
keyRegKesPeriod :: Period
keyRegKesPeriod = Period
1
oCert :: OCert c
oCert = forall c (r :: KeyRole).
(Crypto c, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys c r
allPoolKeys Word64
1 (Period -> KESPeriod
KESPeriod Period
kesPeriod)
bhBody :: BHBody c
bhBody =
forall v (r :: KeyRole).
(ContextVRF (VRF v) ~ (), Signable (VRF v) Seed,
VRFAlgorithm (VRF v)) =>
ProtVer
-> HashHeader v
-> AllIssuerKeys v r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert v
-> Word32
-> Hash v EraIndependentBlockBody
-> BHBody v
mkBHBody ProtVer
protVer HashHeader c
prevHash AllIssuerKeys c r
allPoolKeys SlotNo
slotNo BlockNo
blockNo Nonce
epochNonce OCert c
oCert Word32
bodySize Hash (HASH c) EraIndependentBlockBody
bodyHash
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole).
(Crypto c, Signable (KES c) (BHBody c)) =>
AllIssuerKeys c r -> Period -> Period -> BHBody c -> BHeader c
mkBHeader AllIssuerKeys c r
allPoolKeys Period
kesPeriod Period
keyRegKesPeriod BHBody c
bhBody
instance
( Crypto c
, VRF.Signable (VRF c) ~ SignableRepresentation
) =>
Arbitrary (BHBody c)
where
arbitrary :: Gen (BHBody c)
arbitrary =
forall c.
BlockNo
-> SlotNo
-> PrevHash c
-> VKey 'BlockIssuer c
-> VerKeyVRF c
-> CertifiedVRF c Nonce
-> CertifiedVRF c Nat
-> Word32
-> Hash c EraIndependentBlockBody
-> OCert c
-> ProtVer
-> BHBody c
BHBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
instance Crypto c => Arbitrary (PrevHash c) where
arbitrary :: Gen (PrevHash c)
arbitrary = do
HashHeader c
hash <- forall a. Arbitrary a => Gen a
arbitrary
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall c. PrevHash c
GenesisHash), (Int
9999, forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall c. HashHeader c -> PrevHash c
BlockHash HashHeader c
hash))]
instance Crypto c => Arbitrary (OCert c) where
arbitrary :: Gen (OCert c)
arbitrary =
forall c.
VerKeyKES c
-> Word64
-> KESPeriod
-> SignedDSIGN c (OCertSignable c)
-> OCert c
OCert
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
deriving newtype instance Arbitrary KESPeriod
instance
( Era era
, c ~ EraCrypto era
, EraSegWits era
, KES.Signable (KES c) ~ SignableRepresentation
, VRF.Signable (VRF c) ~ SignableRepresentation
, Arbitrary (Tx era)
) =>
Arbitrary (Block (BHeader c) era)
where
arbitrary :: Gen (Block (BHeader c) era)
arbitrary = forall era h.
(Era era, EncCBORGroup (TxSeq era), EncCBOR h) =>
h -> TxSeq era -> Block h era
Block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
genBlock ::
( DSIGN.Signable (DSIGN c) (OCertSignable c)
, VRF.Signable (VRF c) Seed
, KES.Signable (KES c) (BHBody c)
, EraSegWits era
, Arbitrary (Tx era)
, c ~ EraCrypto era
) =>
[AllIssuerKeys c r] ->
Gen (Block (BHeader c) era)
genBlock :: forall c era (r :: KeyRole).
(Signable (DSIGN c) (OCertSignable c), Signable (VRF c) Seed,
Signable (KES c) (BHBody c), EraSegWits era, Arbitrary (Tx era),
c ~ EraCrypto era) =>
[AllIssuerKeys c r] -> Gen (Block (BHeader c) era)
genBlock [AllIssuerKeys c r]
aiks = forall era h.
(Era era, EncCBORGroup (TxSeq era), EncCBOR h) =>
h -> TxSeq era -> Block h era
Block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (r :: KeyRole).
(Signable (DSIGN c) (OCertSignable c), Signable (VRF c) Seed,
Signable (KES c) (BHBody c), Crypto c) =>
[AllIssuerKeys c r] -> Gen (BHeader c)
genBHeader [AllIssuerKeys c r]
aiks forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
genCoherentBlock ::
forall era r.
( EraSegWits era
, Arbitrary (Tx era)
, KES.Signable (KES (EraCrypto era)) ~ SignableRepresentation
, DSIGN.Signable (DSIGN (EraCrypto era)) ~ SignableRepresentation
, PraosCrypto (EraCrypto era)
) =>
[AllIssuerKeys (EraCrypto era) r] ->
Gen (Block (BHeader (EraCrypto era)) era)
genCoherentBlock :: forall era (r :: KeyRole).
(EraSegWits era, Arbitrary (Tx era),
Signable (KES (EraCrypto era)) ~ SignableRepresentation,
Signable (DSIGN (EraCrypto era)) ~ SignableRepresentation,
PraosCrypto (EraCrypto era)) =>
[AllIssuerKeys (EraCrypto era) r]
-> Gen (Block (BHeader (EraCrypto era)) era)
genCoherentBlock [AllIssuerKeys (EraCrypto era) r]
aiks = do
HashHeader (EraCrypto era)
prevHash <- forall a. Arbitrary a => Gen a
arbitrary :: Gen (HashHeader (EraCrypto era))
AllIssuerKeys (EraCrypto era) r
allPoolKeys <- forall a. HasCallStack => [a] -> Gen a
elements [AllIssuerKeys (EraCrypto era) r]
aiks
[Tx era]
txs <- forall a. Arbitrary a => Gen a
arbitrary
SlotNo
curSlotNo <- Word64 -> SlotNo
SlotNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
10)
BlockNo
curBlockNo <- Word64 -> BlockNo
BlockNo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
100)
Nonce
epochNonce <- forall a. Arbitrary a => Gen a
arbitrary :: Gen Nonce
let kesPeriod :: Period
kesPeriod = Period
1
keyRegKesPeriod :: Period
keyRegKesPeriod = Period
1
ocert :: OCert (EraCrypto era)
ocert = forall c (r :: KeyRole).
(Crypto c, Signable (DSIGN c) (OCertSignable c)) =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys (EraCrypto era) r
allPoolKeys Word64
1 (Period -> KESPeriod
KESPeriod Period
kesPeriod)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall era (r :: KeyRole).
(EraSegWits era, Signable (VRF (EraCrypto era)) Seed,
Signable (KES (EraCrypto era)) (BHBody (EraCrypto era))) =>
HashHeader (EraCrypto era)
-> AllIssuerKeys (EraCrypto era) r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Period
-> Period
-> OCert (EraCrypto era)
-> Block (BHeader (EraCrypto era)) era
mkBlock
HashHeader (EraCrypto era)
prevHash
AllIssuerKeys (EraCrypto era) r
allPoolKeys
[Tx era]
txs
SlotNo
curSlotNo
BlockNo
curBlockNo
Nonce
epochNonce
Period
kesPeriod
Period
keyRegKesPeriod
OCert (EraCrypto era)
ocert