{-# LANGUAGE PatternSynonyms #-}

module Test.Cardano.Chain.Block.Gen (
  genBlockSignature,
  genHeaderHash,
  genHeader,
  genBody,
  genProof,
  genToSign,
  genBlock,
  genBlockWithEpochSlots,
  genBoundaryBlock,
  genBoundaryHeader,
  genABlockOrBoundaryHdr,
)
where

import Cardano.Chain.Block (
  ABlockOrBoundaryHdr (..),
  ABlockSignature (..),
  ABoundaryBlock (..),
  ABoundaryBody (..),
  ABoundaryHeader (..),
  AHeader,
  Block,
  BlockSignature,
  Body,
  Header,
  HeaderHash,
  Proof (..),
  ToSign (..),
  decCBORABoundaryHeader,
  decCBORAHeader,
  encCBORABoundaryHeader,
  encCBORHeader,
  hashHeader,
  mkABoundaryHeader,
  mkBlockExplicit,
  mkHeaderExplicit,
  pattern Body,
 )
import Cardano.Chain.Byron.API (reAnnotateUsing)
import Cardano.Chain.Delegation (signCertificate)
import Cardano.Chain.Genesis (GenesisHash (..))
import Cardano.Chain.Slotting (
  EpochNumber (..),
  EpochSlots,
  WithEpochSlots (WithEpochSlots),
 )
import Cardano.Chain.Ssc (SscPayload (..), SscProof (..))
import Cardano.Crypto (
  ProtocolMagicId,
  SignTag (SignBlock),
  noPassSafeSigner,
  safeToVerification,
  sign,
  toVerification,
 )
import Cardano.Prelude
import Data.Coerce (coerce)
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Cardano.Chain.Common.Gen (
  genChainDifficulty,
 )
import qualified Test.Cardano.Chain.Delegation.Gen as Delegation
import Test.Cardano.Chain.Slotting.Gen (
  genEpochAndSlotCount,
  genEpochNumber,
  genEpochSlots,
  genSlotNumber,
 )
import Test.Cardano.Chain.UTxO.Gen (genTxPayload, genTxProof)
import qualified Test.Cardano.Chain.Update.Gen as Update
import Test.Cardano.Crypto.Gen (
  genAbstractHash,
  genSafeSigner,
  genSigningKey,
  genTextHash,
 )

genBlockSignature :: ProtocolMagicId -> EpochSlots -> Gen BlockSignature
genBlockSignature :: ProtocolMagicId -> EpochSlots -> Gen BlockSignature
genBlockSignature ProtocolMagicId
pm EpochSlots
epochSlots =
  SafeSigner -> SigningKey -> EpochNumber -> ToSign -> BlockSignature
mkBlockSignature
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SafeSigner
genSafeSigner
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SigningKey
genSigningKey
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpochNumber
genEpochNumber
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> EpochSlots -> Gen ToSign
genToSign ProtocolMagicId
pm EpochSlots
epochSlots
  where
    mkBlockSignature :: SafeSigner -> SigningKey -> EpochNumber -> ToSign -> BlockSignature
mkBlockSignature SafeSigner
issuerSafeSigner SigningKey
delegateSK EpochNumber
epoch ToSign
toSign =
      let cert :: Certificate
cert =
            ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
signCertificate ProtocolMagicId
pm (SigningKey -> VerificationKey
toVerification SigningKey
delegateSK) EpochNumber
epoch SafeSigner
issuerSafeSigner
          issuerVK :: VerificationKey
issuerVK = SafeSigner -> VerificationKey
safeToVerification SafeSigner
issuerSafeSigner
          sig :: Signature ToSign
sig = forall a.
EncCBOR a =>
ProtocolMagicId -> SignTag -> SigningKey -> a -> Signature a
sign ProtocolMagicId
pm (VerificationKey -> SignTag
SignBlock VerificationKey
issuerVK) SigningKey
delegateSK ToSign
toSign
       in forall a. ACertificate a -> Signature ToSign -> ABlockSignature a
ABlockSignature Certificate
cert Signature ToSign
sig

genHeaderHash :: Gen HeaderHash
genHeaderHash :: Gen HeaderHash
genHeaderHash = coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Hash Text)
genTextHash

genBody :: ProtocolMagicId -> Gen Body
genBody :: ProtocolMagicId -> Gen Body
genBody ProtocolMagicId
pm =
  TxPayload -> SscPayload -> Payload -> Payload -> Body
Body
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> Gen TxPayload
genTxPayload ProtocolMagicId
pm
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SscPayload
SscPayload
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> Gen Payload
Delegation.genPayload ProtocolMagicId
pm
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> Gen Payload
Update.genPayload ProtocolMagicId
pm

genHeader :: ProtocolMagicId -> EpochSlots -> Gen Header
genHeader :: ProtocolMagicId -> EpochSlots -> Gen Header
genHeader ProtocolMagicId
protocolMagicId EpochSlots
epochSlots =
  HeaderHash
-> ChainDifficulty
-> SlotNumber
-> Body
-> ProtocolVersion
-> SoftwareVersion
-> SigningKey
-> Header
mkHeaderExplicit'
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeaderHash
genHeaderHash
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ChainDifficulty
genChainDifficulty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SlotNumber
genSlotNumber
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> Gen Body
genBody ProtocolMagicId
protocolMagicId
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ProtocolVersion
Update.genProtocolVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SoftwareVersion
Update.genSoftwareVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SigningKey
genSigningKey
  where
    mkHeaderExplicit' :: HeaderHash
-> ChainDifficulty
-> SlotNumber
-> Body
-> ProtocolVersion
-> SoftwareVersion
-> SigningKey
-> Header
mkHeaderExplicit'
      HeaderHash
headerHash
      ChainDifficulty
chainDifficulty
      SlotNumber
slotNumber
      Body
body
      ProtocolVersion
protocolVersion
      SoftwareVersion
softwareVersion
      SigningKey
signingKey =
        ProtocolMagicId
-> HeaderHash
-> ChainDifficulty
-> EpochSlots
-> SlotNumber
-> SigningKey
-> Certificate
-> Body
-> ProtocolVersion
-> SoftwareVersion
-> Header
mkHeaderExplicit
          ProtocolMagicId
protocolMagicId
          HeaderHash
headerHash
          ChainDifficulty
chainDifficulty
          EpochSlots
epochSlots
          SlotNumber
slotNumber
          SigningKey
signingKey
          ( ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
signCertificate
              ProtocolMagicId
protocolMagicId
              (SigningKey -> VerificationKey
toVerification SigningKey
signingKey)
              (Word64 -> EpochNumber
EpochNumber Word64
0)
              (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
signingKey)
          )
          Body
body
          ProtocolVersion
protocolVersion
          SoftwareVersion
softwareVersion

genProof :: ProtocolMagicId -> Gen Proof
genProof :: ProtocolMagicId -> Gen Proof
genProof ProtocolMagicId
pm =
  TxProof -> SscProof -> Hash Payload -> Proof -> Proof
Proof
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> Gen TxProof
genTxProof ProtocolMagicId
pm
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SscProof
SscProof
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a algo.
(EncCBOR a, HashAlgorithm algo) =>
Gen a -> Gen (AbstractHash algo a)
genAbstractHash (ProtocolMagicId -> Gen Payload
Delegation.genPayload ProtocolMagicId
pm)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> Gen Proof
Update.genProof ProtocolMagicId
pm

genToSign :: ProtocolMagicId -> EpochSlots -> Gen ToSign
genToSign :: ProtocolMagicId -> EpochSlots -> Gen ToSign
genToSign ProtocolMagicId
pm EpochSlots
epochSlots =
  HeaderHash
-> Proof
-> EpochAndSlotCount
-> ChainDifficulty
-> ProtocolVersion
-> SoftwareVersion
-> ToSign
ToSign
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Header -> HeaderHash
mkAbstractHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> EpochSlots -> Gen Header
genHeader ProtocolMagicId
pm EpochSlots
epochSlots)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> Gen Proof
genProof ProtocolMagicId
pm
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EpochSlots -> Gen EpochAndSlotCount
genEpochAndSlotCount EpochSlots
epochSlots
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ChainDifficulty
genChainDifficulty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ProtocolVersion
Update.genProtocolVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SoftwareVersion
Update.genSoftwareVersion
  where
    mkAbstractHash :: Header -> HeaderHash
    mkAbstractHash :: Header -> HeaderHash
mkAbstractHash = EpochSlots -> Header -> HeaderHash
hashHeader EpochSlots
epochSlots

genBlockWithEpochSlots :: ProtocolMagicId -> Gen (WithEpochSlots Block)
genBlockWithEpochSlots :: ProtocolMagicId -> Gen (WithEpochSlots Block)
genBlockWithEpochSlots ProtocolMagicId
pm = do
  EpochSlots
epochSlots <- Gen EpochSlots
genEpochSlots
  forall a. EpochSlots -> a -> WithEpochSlots a
WithEpochSlots EpochSlots
epochSlots forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> EpochSlots -> Gen Block
genBlock ProtocolMagicId
pm EpochSlots
epochSlots

genBlock :: ProtocolMagicId -> EpochSlots -> Gen Block
genBlock :: ProtocolMagicId -> EpochSlots -> Gen Block
genBlock ProtocolMagicId
protocolMagicId EpochSlots
epochSlots =
  ProtocolVersion
-> SoftwareVersion
-> HeaderHash
-> ChainDifficulty
-> SlotNumber
-> Body
-> SigningKey
-> Block
mkBlockExplicit'
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ProtocolVersion
Update.genProtocolVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SoftwareVersion
Update.genSoftwareVersion
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen HeaderHash
genHeaderHash
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ChainDifficulty
genChainDifficulty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SlotNumber
genSlotNumber
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProtocolMagicId -> Gen Body
genBody ProtocolMagicId
protocolMagicId
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SigningKey
genSigningKey
  where
    mkBlockExplicit' :: ProtocolVersion
-> SoftwareVersion
-> HeaderHash
-> ChainDifficulty
-> SlotNumber
-> Body
-> SigningKey
-> Block
mkBlockExplicit'
      ProtocolVersion
protocolVersion
      SoftwareVersion
softwareVersion
      HeaderHash
headerHash
      ChainDifficulty
chainDifficulty
      SlotNumber
slotNumber
      Body
body
      SigningKey
signingKey =
        ProtocolMagicId
-> ProtocolVersion
-> SoftwareVersion
-> HeaderHash
-> ChainDifficulty
-> EpochSlots
-> SlotNumber
-> SigningKey
-> Certificate
-> Body
-> Block
mkBlockExplicit
          ProtocolMagicId
protocolMagicId
          ProtocolVersion
protocolVersion
          SoftwareVersion
softwareVersion
          HeaderHash
headerHash
          ChainDifficulty
chainDifficulty
          EpochSlots
epochSlots
          SlotNumber
slotNumber
          SigningKey
signingKey
          ( ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
signCertificate
              ProtocolMagicId
protocolMagicId
              (SigningKey -> VerificationKey
toVerification SigningKey
signingKey)
              (Word64 -> EpochNumber
EpochNumber Word64
0)
              (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
signingKey)
          )
          Body
body

genBoundaryBlock :: Gen (ABoundaryBlock ())
genBoundaryBlock :: Gen (ABoundaryBlock ())
genBoundaryBlock =
  forall a.
Int64
-> ABoundaryHeader a -> ABoundaryBody a -> a -> ABoundaryBlock a
ABoundaryBlock
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
0
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (ABoundaryHeader ())
genBoundaryHeader
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> ABoundaryBody a
ABoundaryBody ())
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

genBoundaryHeader :: Gen (ABoundaryHeader ())
genBoundaryHeader :: Gen (ABoundaryHeader ())
genBoundaryHeader = do
  Word64
epoch <- forall (m :: * -> *). MonadGen m => Range Word64 -> m Word64
Gen.word64 (forall a. Integral a => a -> a -> Range a
Range.exponential Word64
0 forall a. Bounded a => a
maxBound)
  forall a.
Either GenesisHash HeaderHash
-> Word64 -> ChainDifficulty -> a -> ABoundaryHeader a
mkABoundaryHeader
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( if Word64
epoch forall a. Eq a => a -> a -> Bool
== Word64
0
            then forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Hash Raw -> GenesisHash
GenesisHash forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Hash Text)
genTextHash
            else
              forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
                [ forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen HeaderHash
genHeaderHash
                , forall a b. a -> Either a b
Left forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Hash Raw -> GenesisHash
GenesisHash forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Hash Text)
genTextHash
                ]
        )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
epoch
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ChainDifficulty
genChainDifficulty
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

genABlockOrBoundaryHdr ::
  ProtocolMagicId ->
  EpochSlots ->
  Gen (ABlockOrBoundaryHdr ByteString)
genABlockOrBoundaryHdr :: ProtocolMagicId
-> EpochSlots -> Gen (ABlockOrBoundaryHdr ByteString)
genABlockOrBoundaryHdr ProtocolMagicId
pm EpochSlots
es =
  forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
    [ forall a. AHeader a -> ABlockOrBoundaryHdr a
ABOBBlockHdr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Header -> AHeader ByteString
reAnnotateHdr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> EpochSlots -> Gen Header
genHeader ProtocolMagicId
pm EpochSlots
es
    , forall a. ABoundaryHeader a -> ABlockOrBoundaryHdr a
ABOBBoundaryHdr forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ABoundaryHeader () -> ABoundaryHeader ByteString
reAnnotateBoundaryHdr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ABoundaryHeader ())
genBoundaryHeader
    ]
  where
    reAnnotateHdr :: AHeader () -> AHeader ByteString
    reAnnotateHdr :: Header -> AHeader ByteString
reAnnotateHdr =
      forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
reAnnotateUsing
        (EpochSlots -> Header -> Encoding
encCBORHeader EpochSlots
es)
        (forall s. EpochSlots -> Decoder s (AHeader ByteSpan)
decCBORAHeader EpochSlots
es)

    reAnnotateBoundaryHdr :: ABoundaryHeader () -> ABoundaryHeader ByteString
    reAnnotateBoundaryHdr :: ABoundaryHeader () -> ABoundaryHeader ByteString
reAnnotateBoundaryHdr =
      forall (f :: * -> *) a.
Functor f =>
(f a -> Encoding)
-> (forall s. Decoder s (f ByteSpan)) -> f a -> f ByteString
reAnnotateUsing
        (forall a. ProtocolMagicId -> ABoundaryHeader a -> Encoding
encCBORABoundaryHeader ProtocolMagicId
pm)
        forall s. Decoder s (ABoundaryHeader ByteSpan)
decCBORABoundaryHeader