{-# 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)
genBHeader :: 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 = 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)

-- | Use supplied keys to generate a Block.
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)

-- | 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.
  ( 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