{-# 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,
  VRFNatVal (..),
) where

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.Protocol.Crypto (Crypto (KES, VRF), StandardCrypto)
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 (..))
import Cardano.Protocol.TPraos.Rules.Overlay (OBftSlot)
import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState)
import Cardano.Protocol.TPraos.Rules.Tickn (TicknState)
import Data.Proxy (Proxy (Proxy))
import Generic.Random (genericArbitraryU)
import Numeric.Natural (Natural)
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)

newtype VRFNatVal = VRFNatVal Natural
  deriving (Int -> VRFNatVal -> ShowS
[VRFNatVal] -> ShowS
VRFNatVal -> String
(Int -> VRFNatVal -> ShowS)
-> (VRFNatVal -> String)
-> ([VRFNatVal] -> ShowS)
-> Show VRFNatVal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VRFNatVal -> ShowS
showsPrec :: Int -> VRFNatVal -> ShowS
$cshow :: VRFNatVal -> String
show :: VRFNatVal -> String
$cshowList :: [VRFNatVal] -> ShowS
showList :: [VRFNatVal] -> ShowS
Show)

instance Arbitrary VRFNatVal where
  arbitrary :: Gen VRFNatVal
arbitrary =
    Natural -> VRFNatVal
VRFNatVal (Natural -> VRFNatVal)
-> (Integer -> Natural) -> Integer -> VRFNatVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      (Integer -> VRFNatVal) -> Gen Integer -> Gen VRFNatVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose @Integer
        ( Integer
0
        , Integer
2
            Integer -> Word -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ ( Word
8
                  Word -> Word -> Word
forall a. Num a => a -> a -> a
* Proxy PraosVRF -> Word
forall v (proxy :: * -> *). VRFAlgorithm v => proxy v -> Word
forall (proxy :: * -> *). proxy PraosVRF -> Word
VRF.sizeOutputVRF
                    (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(VRF StandardCrypto))
              )
        )
  shrink :: VRFNatVal -> [VRFNatVal]
shrink (VRFNatVal Natural
v) = Natural -> VRFNatVal
VRFNatVal (Natural -> VRFNatVal) -> [Natural] -> [VRFNatVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [Natural]
forall a. Integral a => a -> [a]
shrinkIntegral Natural
v

instance Arbitrary HashHeader where
  arbitrary :: Gen HashHeader
arbitrary = Hash HASH EraIndependentBlockHeader -> HashHeader
HashHeader (Hash HASH EraIndependentBlockHeader -> HashHeader)
-> Gen (Hash HASH EraIndependentBlockHeader) -> Gen HashHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Hash HASH EraIndependentBlockHeader)
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary TicknState where
  arbitrary :: Gen TicknState
arbitrary = Gen TicknState
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
  shrink :: TicknState -> [TicknState]
shrink = TicknState -> [TicknState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance Arbitrary PrtclState where
  arbitrary :: Gen PrtclState
arbitrary = Gen PrtclState
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
  shrink :: PrtclState -> [PrtclState]
shrink = PrtclState -> [PrtclState]
forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance Arbitrary OBftSlot where
  arbitrary :: Gen OBftSlot
arbitrary = Gen OBftSlot
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
  shrink :: OBftSlot -> [OBftSlot]
shrink = OBftSlot -> [OBftSlot]
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 <- Gen (BHBody c)
forall a. Arbitrary a => Gen a
arbitrary
    UnsoundPureSignKeyKES (KES c)
hotKey <- Gen (UnsoundPureSignKeyKES (KES c))
forall a. Arbitrary a => Gen a
arbitrary
    let sig :: SignedKES (KES c) (BHBody c)
sig = ContextKES (KES c)
-> Word
-> BHBody c
-> UnsoundPureSignKeyKES (KES c)
-> SignedKES (KES c) (BHBody c)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v
-> Word -> a -> UnsoundPureSignKeyKES v -> SignedKES v a
KES.unsoundPureSignedKES () Word
1 BHBody c
bhBody UnsoundPureSignKeyKES (KES c)
hotKey
    BHeader c -> Gen (BHeader c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BHeader c -> Gen (BHeader c)) -> BHeader c -> Gen (BHeader c)
forall a b. (a -> b) -> a -> b
$ BHBody c -> SignedKES (KES c) (BHBody c) -> BHeader c
forall c.
Crypto c =>
BHBody c -> SignedKES (KES c) (BHBody c) -> BHeader c
BHeader BHBody c
bhBody SignedKES (KES c) (BHBody c)
sig

genBHeader ::
  ( VRF.Signable (VRF c) Seed
  , KES.Signable (KES c) (BHBody c)
  , Crypto c
  ) =>
  [AllIssuerKeys c r] ->
  Gen (BHeader c)
genBHeader :: forall c (r :: KeyRole).
(Signable (VRF c) Seed, Signable (KES c) (BHBody c), Crypto c) =>
[AllIssuerKeys c r] -> Gen (BHeader c)
genBHeader [AllIssuerKeys c r]
aiks = do
  HashHeader
prevHash <- Gen HashHeader
forall a. Arbitrary a => Gen a
arbitrary
  AllIssuerKeys c r
allPoolKeys <- [AllIssuerKeys c r] -> Gen (AllIssuerKeys c r)
forall a. HasCallStack => [a] -> Gen a
elements [AllIssuerKeys c r]
aiks
  SlotNo
slotNo <- Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary
  BlockNo
blockNo <- Gen BlockNo
forall a. Arbitrary a => Gen a
arbitrary
  Nonce
epochNonce <- Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary
  Word32
bodySize <- Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
  Hash HASH EraIndependentBlockBody
bodyHash <- Gen (Hash HASH EraIndependentBlockBody)
forall a. Arbitrary a => Gen a
arbitrary
  ProtVer
protVer <- Gen ProtVer
forall a. Arbitrary a => Gen a
arbitrary
  let kesPeriod :: Word
kesPeriod = Word
1
      keyRegKesPeriod :: Word
keyRegKesPeriod = Word
1
      oCert :: OCert c
oCert = AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys c r
allPoolKeys Word64
1 (Word -> KESPeriod
KESPeriod Word
kesPeriod)
      bhBody :: BHBody c
bhBody =
        ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
forall c (r :: KeyRole).
(ContextVRF (VRF c) ~ (), Signable (VRF c) Seed,
 VRFAlgorithm (VRF c)) =>
ProtVer
-> HashHeader
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert c
-> Word32
-> Hash HASH EraIndependentBlockBody
-> BHBody c
mkBHBody ProtVer
protVer HashHeader
prevHash AllIssuerKeys c r
allPoolKeys SlotNo
slotNo BlockNo
blockNo Nonce
epochNonce OCert c
oCert Word32
bodySize Hash HASH EraIndependentBlockBody
bodyHash
  BHeader c -> Gen (BHeader c)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (BHeader c -> Gen (BHeader c)) -> BHeader c -> Gen (BHeader c)
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
forall c (r :: KeyRole).
(Crypto c, Signable (KES c) (BHBody c)) =>
AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
mkBHeader AllIssuerKeys c r
allPoolKeys Word
kesPeriod Word
keyRegKesPeriod BHBody c
bhBody

instance
  ( Crypto c
  , VRF.Signable (VRF c) ~ SignableRepresentation
  ) =>
  Arbitrary (BHBody c)
  where
  arbitrary :: Gen (BHBody c)
arbitrary =
    BlockNo
-> SlotNo
-> PrevHash
-> VKey 'BlockIssuer
-> VerKeyVRF (VRF c)
-> CertifiedVRF (VRF c) Nonce
-> CertifiedVRF (VRF c) Natural
-> Word32
-> Hash HASH EraIndependentBlockBody
-> OCert c
-> ProtVer
-> BHBody c
forall c.
BlockNo
-> SlotNo
-> PrevHash
-> VKey 'BlockIssuer
-> VerKeyVRF (VRF c)
-> CertifiedVRF (VRF c) Nonce
-> CertifiedVRF (VRF c) Natural
-> Word32
-> Hash HASH EraIndependentBlockBody
-> OCert c
-> ProtVer
-> BHBody c
BHBody
      (BlockNo
 -> SlotNo
 -> PrevHash
 -> VKey 'BlockIssuer
 -> VerKeyVRF (VRF c)
 -> CertifiedVRF (VRF c) Nonce
 -> CertifiedVRF (VRF c) Natural
 -> Word32
 -> Hash HASH EraIndependentBlockBody
 -> OCert c
 -> ProtVer
 -> BHBody c)
-> Gen BlockNo
-> Gen
     (SlotNo
      -> PrevHash
      -> VKey 'BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) Nonce
      -> CertifiedVRF (VRF c) Natural
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen BlockNo
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (SlotNo
   -> PrevHash
   -> VKey 'BlockIssuer
   -> VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) Nonce
   -> CertifiedVRF (VRF c) Natural
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen SlotNo
-> Gen
     (PrevHash
      -> VKey 'BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) Nonce
      -> CertifiedVRF (VRF c) Natural
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (PrevHash
   -> VKey 'BlockIssuer
   -> VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) Nonce
   -> CertifiedVRF (VRF c) Natural
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen PrevHash
-> Gen
     (VKey 'BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) Nonce
      -> CertifiedVRF (VRF c) Natural
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PrevHash
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (VKey 'BlockIssuer
   -> VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) Nonce
   -> CertifiedVRF (VRF c) Natural
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen (VKey 'BlockIssuer)
-> Gen
     (VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) Nonce
      -> CertifiedVRF (VRF c) Natural
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (VKey 'BlockIssuer)
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) Nonce
   -> CertifiedVRF (VRF c) Natural
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen (VerKeyVRF (VRF c))
-> Gen
     (CertifiedVRF (VRF c) Nonce
      -> CertifiedVRF (VRF c) Natural
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (VerKeyVRF (VRF c))
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (CertifiedVRF (VRF c) Nonce
   -> CertifiedVRF (VRF c) Natural
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen (CertifiedVRF (VRF c) Nonce)
-> Gen
     (CertifiedVRF (VRF c) Natural
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (CertifiedVRF (VRF c) Nonce)
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (CertifiedVRF (VRF c) Natural
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen (CertifiedVRF (VRF c) Natural)
-> Gen
     (Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (CertifiedVRF (VRF c) Natural)
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> BHBody c)
-> Gen Word32
-> Gen
     (Hash HASH EraIndependentBlockBody
      -> OCert c -> ProtVer -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Hash HASH EraIndependentBlockBody
   -> OCert c -> ProtVer -> BHBody c)
-> Gen (Hash HASH EraIndependentBlockBody)
-> Gen (OCert c -> ProtVer -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Hash HASH EraIndependentBlockBody)
forall a. Arbitrary a => Gen a
arbitrary
      Gen (OCert c -> ProtVer -> BHBody c)
-> Gen (OCert c) -> Gen (ProtVer -> BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (OCert c)
forall a. Arbitrary a => Gen a
arbitrary
      Gen (ProtVer -> BHBody c) -> Gen ProtVer -> Gen (BHBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ProtVer
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary PrevHash where
  arbitrary :: Gen PrevHash
arbitrary = do
    HashHeader
hash <- Gen HashHeader
forall a. Arbitrary a => Gen a
arbitrary
    [(Int, Gen PrevHash)] -> Gen PrevHash
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
1, PrevHash -> Gen PrevHash
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrevHash
GenesisHash), (Int
9999, PrevHash -> Gen PrevHash
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashHeader -> PrevHash
BlockHash HashHeader
hash))]

instance Crypto c => Arbitrary (OCert c) where
  arbitrary :: Gen (OCert c)
arbitrary =
    VerKeyKES (KES c)
-> Word64
-> KESPeriod
-> SignedDSIGN DSIGN (OCertSignable c)
-> OCert c
forall c.
VerKeyKES (KES c)
-> Word64
-> KESPeriod
-> SignedDSIGN DSIGN (OCertSignable c)
-> OCert c
OCert
      (VerKeyKES (KES c)
 -> Word64
 -> KESPeriod
 -> SignedDSIGN DSIGN (OCertSignable c)
 -> OCert c)
-> Gen (VerKeyKES (KES c))
-> Gen
     (Word64
      -> KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (VerKeyKES (KES c))
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Word64
   -> KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
-> Gen Word64
-> Gen
     (KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
      Gen (KESPeriod -> SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
-> Gen KESPeriod
-> Gen (SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen KESPeriod
forall a. Arbitrary a => Gen a
arbitrary
      Gen (SignedDSIGN DSIGN (OCertSignable c) -> OCert c)
-> Gen (SignedDSIGN DSIGN (OCertSignable c)) -> Gen (OCert c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (SignedDSIGN DSIGN (OCertSignable c))
forall a. Arbitrary a => Gen a
arbitrary

deriving newtype instance Arbitrary KESPeriod

instance
  ( Crypto c
  , 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 = BHeader c -> TxSeq era -> Block (BHeader c) era
forall h era. h -> TxSeq era -> Block h era
Block (BHeader c -> TxSeq era -> Block (BHeader c) era)
-> Gen (BHeader c) -> Gen (TxSeq era -> Block (BHeader c) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (BHeader c)
forall a. Arbitrary a => Gen a
arbitrary Gen (TxSeq era -> Block (BHeader c) era)
-> Gen (TxSeq era) -> Gen (Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (StrictSeq (Tx era) -> TxSeq era
forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq (StrictSeq (Tx era) -> TxSeq era)
-> Gen (StrictSeq (Tx era)) -> Gen (TxSeq era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StrictSeq (Tx era))
forall a. Arbitrary a => Gen a
arbitrary)

-- | Use supplied keys to generate a Block.
genBlock ::
  ( Crypto c
  , VRF.Signable (VRF c) Seed
  , KES.Signable (KES c) (BHBody c)
  , EraSegWits era
  , Arbitrary (Tx era)
  ) =>
  [AllIssuerKeys c r] ->
  Gen (Block (BHeader c) era)
genBlock :: forall c era (r :: KeyRole).
(Crypto c, Signable (VRF c) Seed, Signable (KES c) (BHBody c),
 EraSegWits era, Arbitrary (Tx era)) =>
[AllIssuerKeys c r] -> Gen (Block (BHeader c) era)
genBlock [AllIssuerKeys c r]
aiks = BHeader c -> TxSeq era -> Block (BHeader c) era
forall h era. h -> TxSeq era -> Block h era
Block (BHeader c -> TxSeq era -> Block (BHeader c) era)
-> Gen (BHeader c) -> Gen (TxSeq era -> Block (BHeader c) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c r] -> Gen (BHeader c)
forall c (r :: KeyRole).
(Signable (VRF c) Seed, Signable (KES c) (BHBody c), Crypto c) =>
[AllIssuerKeys c r] -> Gen (BHeader c)
genBHeader [AllIssuerKeys c r]
aiks Gen (TxSeq era -> Block (BHeader c) era)
-> Gen (TxSeq era) -> Gen (Block (BHeader c) era)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (StrictSeq (Tx era) -> TxSeq era
forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
toTxSeq (StrictSeq (Tx era) -> TxSeq era)
-> Gen (StrictSeq (Tx era)) -> Gen (TxSeq era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (StrictSeq (Tx era))
forall a. Arbitrary a => Gen a
arbitrary)

-- | For some purposes, a totally random block generator may not be suitable.
-- There are tests in the ouroboros-network repository, for instance, that
-- perform some integrity checks on the generated blocks.
--
-- For other purposes, such as the serialization tests in this repository,
-- 'genBlock' is more appropriate.
--
-- This generator uses 'mkBlock' provide more coherent blocks.
genCoherentBlock ::
  forall era r c.
  ( EraSegWits era
  , Arbitrary (Tx era)
  , KES.Signable (KES c) ~ SignableRepresentation
  , PraosCrypto c
  ) =>
  [AllIssuerKeys c r] ->
  Gen (Block (BHeader c) era)
genCoherentBlock :: forall era (r :: KeyRole) c.
(EraSegWits era, Arbitrary (Tx era),
 Signable (KES c) ~ SignableRepresentation, PraosCrypto c) =>
[AllIssuerKeys c r] -> Gen (Block (BHeader c) era)
genCoherentBlock [AllIssuerKeys c r]
aiks = do
  HashHeader
prevHash <- Gen HashHeader
forall a. Arbitrary a => Gen a
arbitrary :: Gen HashHeader
  AllIssuerKeys c r
allPoolKeys <- [AllIssuerKeys c r] -> Gen (AllIssuerKeys c r)
forall a. HasCallStack => [a] -> Gen a
elements [AllIssuerKeys c r]
aiks
  [Tx era]
txs <- Gen [Tx era]
forall a. Arbitrary a => Gen a
arbitrary
  SlotNo
curSlotNo <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
10)
  BlockNo
curBlockNo <- Word64 -> BlockNo
BlockNo (Word64 -> BlockNo) -> Gen Word64 -> Gen BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
100)
  Nonce
epochNonce <- Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary :: Gen Nonce
  let kesPeriod :: Word
kesPeriod = Word
1
      keyRegKesPeriod :: Word
keyRegKesPeriod = Word
1
      ocert :: OCert c
ocert = AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
forall c (r :: KeyRole).
Crypto c =>
AllIssuerKeys c r -> Word64 -> KESPeriod -> OCert c
mkOCert AllIssuerKeys c r
allPoolKeys Word64
1 (Word -> KESPeriod
KESPeriod Word
kesPeriod)
  Block (BHeader c) era -> Gen (Block (BHeader c) era)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Block (BHeader c) era -> Gen (Block (BHeader c) era))
-> Block (BHeader c) era -> Gen (Block (BHeader c) era)
forall a b. (a -> b) -> a -> b
$
    HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
forall era (r :: KeyRole) c.
(Crypto c, EraSegWits era, Signable (VRF c) Seed,
 Signable (KES c) (BHBody c)) =>
HashHeader
-> AllIssuerKeys c r
-> [Tx era]
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Block (BHeader c) era
mkBlock
      HashHeader
prevHash
      AllIssuerKeys c r
allPoolKeys
      [Tx era]
txs
      SlotNo
curSlotNo
      BlockNo
curBlockNo
      Nonce
epochNonce
      Word
kesPeriod
      Word
keyRegKesPeriod
      OCert c
ocert