{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VRFNatVal] -> ShowS
$cshowList :: [VRFNatVal] -> ShowS
show :: VRFNatVal -> String
$cshow :: VRFNatVal -> String
showsPrec :: Int -> VRFNatVal -> ShowS
$cshowsPrec :: Int -> VRFNatVal -> ShowS
Show)

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

instance Arbitrary HashHeader where
  arbitrary :: Gen HashHeader
arbitrary = Hash HASH EraIndependentBlockHeader -> HashHeader
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 Arbitrary PrtclState where
  arbitrary :: Gen PrtclState
arbitrary = forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
  shrink :: PrtclState -> [PrtclState]
shrink = forall a.
(Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a) =>
a -> [a]
genericShrink

instance Arbitrary OBftSlot where
  arbitrary :: Gen OBftSlot
arbitrary = forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
  shrink :: OBftSlot -> [OBftSlot]
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
    UnsoundPureSignKeyKES (KES c)
hotKey <- forall a. Arbitrary a => Gen a
arbitrary
    let sig :: SignedKES (KES c) (BHBody c)
sig = 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 <- 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 EraIndependentBlockBody
bodyHash <- forall a. Arbitrary a => Gen a
arbitrary
  ProtVer
protVer <- forall a. Arbitrary a => Gen a
arbitrary
  let kesPeriod :: Word
kesPeriod = Word
1
      keyRegKesPeriod :: Word
keyRegKesPeriod = Word
1
      oCert :: OCert c
oCert = 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 =
        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
  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 -> 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 =
    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
      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 Arbitrary PrevHash where
  arbitrary :: Gen PrevHash
arbitrary = do
    HashHeader
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 PrevHash
GenesisHash), (Int
9999, 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 =
    forall c.
VerKeyKES (KES c)
-> Word64
-> KESPeriod
-> SignedDSIGN DSIGN (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
  ( 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 = 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 ::
  ( 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 = 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 (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 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 <- forall a. Arbitrary a => Gen a
arbitrary :: Gen HashHeader
  AllIssuerKeys c r
allPoolKeys <- forall a. HasCallStack => [a] -> Gen a
elements [AllIssuerKeys c 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 :: Word
kesPeriod = Word
1
      keyRegKesPeriod :: Word
keyRegKesPeriod = Word
1
      ocert :: OCert c
ocert = 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)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    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