{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Protocol.Leios.BlockHeader.Arbitrary (genHeader, genHeaderBody) where

import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.Util (SignableRepresentation)
import qualified Cardano.Crypto.VRF as VRF
import Cardano.Ledger.Binary (
  DecCBOR (..),
  Version,
  decodeFixedSized,
  decodeRecordNamed,
  natVersion,
 )
import Cardano.Ledger.Block (Block (Block), EbReferencesAnnouncement (EbReferencesAnnouncement))
import Cardano.Ledger.Core (BlockBody, EraBlockBody)
import Cardano.Ledger.MemoBytes (mkMemoized)
import Cardano.Protocol.Crypto (Crypto (KES, VRF))
import Cardano.Protocol.Leios.BlockHeader (
  Header (HeaderConstr),
  HeaderBody (HeaderBodyConstr),
  HeaderBodyRaw (HeaderBodyRaw),
  HeaderRaw (HeaderRaw),
 )
import Test.Cardano.Ledger.Binary.Arbitrary ()
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Core.Arbitrary ()
import Test.Cardano.Protocol.Praos.BlockHeader.Arbitrary ()
import Test.Crypto.Instances ()

instance Arbitrary EbReferencesAnnouncement where
  arbitrary :: Gen EbReferencesAnnouncement
arbitrary = SafeHash EraIndependentEbReferences
-> Word32 -> EbReferencesAnnouncement
EbReferencesAnnouncement (SafeHash EraIndependentEbReferences
 -> Word32 -> EbReferencesAnnouncement)
-> Gen (SafeHash EraIndependentEbReferences)
-> Gen (Word32 -> EbReferencesAnnouncement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SafeHash EraIndependentEbReferences)
forall a. Arbitrary a => Gen a
arbitrary Gen (Word32 -> EbReferencesAnnouncement)
-> Gen Word32 -> Gen EbReferencesAnnouncement
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

genHeaderBody ::
  (Crypto c, VRF.Signable (VRF c) ~ SignableRepresentation) =>
  Version ->
  Gen (HeaderBody c)
genHeaderBody :: forall c.
(Crypto c, Signable (VRF c) ~ SignableRepresentation) =>
Version -> Gen (HeaderBody c)
genHeaderBody Version
version =
  (HeaderBodyRaw c -> HeaderBody c)
-> Gen (HeaderBodyRaw c) -> Gen (HeaderBody c)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Version -> RawType (HeaderBody c) -> HeaderBody c
forall t.
(EncCBOR (RawType t), Memoized t) =>
Version -> RawType t -> t
mkMemoized Version
version) (Gen (HeaderBodyRaw c) -> Gen (HeaderBody c))
-> Gen (HeaderBodyRaw c) -> Gen (HeaderBody c)
forall a b. (a -> b) -> a -> b
$
    BlockNo
-> SlotNo
-> PrevHash
-> VKey BlockIssuer
-> VerKeyVRF (VRF c)
-> CertifiedVRF (VRF c) InputVRF
-> Word32
-> Hash HASH EraIndependentBlockBody
-> OCert c
-> BlockHeaderVersionInfo
-> Bool
-> StrictMaybe EbReferencesAnnouncement
-> HeaderBodyRaw c
forall crypto.
BlockNo
-> SlotNo
-> PrevHash
-> VKey BlockIssuer
-> VerKeyVRF (VRF crypto)
-> CertifiedVRF (VRF crypto) InputVRF
-> Word32
-> Hash HASH EraIndependentBlockBody
-> OCert crypto
-> BlockHeaderVersionInfo
-> Bool
-> StrictMaybe EbReferencesAnnouncement
-> HeaderBodyRaw crypto
HeaderBodyRaw
      (BlockNo
 -> SlotNo
 -> PrevHash
 -> VKey BlockIssuer
 -> VerKeyVRF (VRF c)
 -> CertifiedVRF (VRF c) InputVRF
 -> Word32
 -> Hash HASH EraIndependentBlockBody
 -> OCert c
 -> BlockHeaderVersionInfo
 -> Bool
 -> StrictMaybe EbReferencesAnnouncement
 -> HeaderBodyRaw c)
-> Gen BlockNo
-> Gen
     (SlotNo
      -> PrevHash
      -> VKey BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen SlotNo
-> Gen
     (PrevHash
      -> VKey BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen PrevHash
-> Gen
     (VKey BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen (VKey BlockIssuer)
-> Gen
     (VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen (VerKeyVRF (VRF c))
-> Gen
     (CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen (CertifiedVRF (VRF c) InputVRF)
-> Gen
     (Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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) InputVRF)
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen Word32
-> Gen
     (Hash HASH EraIndependentBlockBody
      -> OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen (Hash HASH EraIndependentBlockBody)
-> Gen
     (OCert c
      -> BlockHeaderVersionInfo
      -> Bool
      -> StrictMaybe EbReferencesAnnouncement
      -> HeaderBodyRaw 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
   -> BlockHeaderVersionInfo
   -> Bool
   -> StrictMaybe EbReferencesAnnouncement
   -> HeaderBodyRaw c)
-> Gen (OCert c)
-> Gen
     (BlockHeaderVersionInfo
      -> Bool -> StrictMaybe EbReferencesAnnouncement -> HeaderBodyRaw 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
  (BlockHeaderVersionInfo
   -> Bool -> StrictMaybe EbReferencesAnnouncement -> HeaderBodyRaw c)
-> Gen BlockHeaderVersionInfo
-> Gen
     (Bool -> StrictMaybe EbReferencesAnnouncement -> HeaderBodyRaw 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 BlockHeaderVersionInfo
forall a. Arbitrary a => Gen a
arbitrary
      Gen
  (Bool -> StrictMaybe EbReferencesAnnouncement -> HeaderBodyRaw c)
-> Gen Bool
-> Gen (StrictMaybe EbReferencesAnnouncement -> HeaderBodyRaw 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 Bool
forall a. Arbitrary a => Gen a
arbitrary
      Gen (StrictMaybe EbReferencesAnnouncement -> HeaderBodyRaw c)
-> Gen (StrictMaybe EbReferencesAnnouncement)
-> Gen (HeaderBodyRaw 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 (StrictMaybe EbReferencesAnnouncement)
forall a. Arbitrary a => Gen a
arbitrary

instance
  (Crypto c, VRF.Signable (VRF c) ~ SignableRepresentation) =>
  Arbitrary (HeaderBody c)
  where
  arbitrary :: Gen (HeaderBody c)
arbitrary = Version -> Gen (HeaderBody c)
forall c.
(Crypto c, Signable (VRF c) ~ SignableRepresentation) =>
Version -> Gen (HeaderBody c)
genHeaderBody (Version -> Gen (HeaderBody c))
-> Gen Version -> Gen (HeaderBody c)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Version] -> Gen Version
forall a. HasCallStack => [a] -> Gen a
elements [forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @12 .. Version
forall a. Bounded a => a
maxBound]

genHeader ::
  ( Crypto c
  , VRF.Signable (VRF c) ~ SignableRepresentation
  , KES.Signable (KES c) ~ SignableRepresentation
  ) =>
  Version ->
  Gen (Header c)
genHeader :: forall c.
(Crypto c, Signable (VRF c) ~ SignableRepresentation,
 Signable (KES c) ~ SignableRepresentation) =>
Version -> Gen (Header c)
genHeader Version
version = do
  hBody <- Version -> Gen (HeaderBody c)
forall c.
(Crypto c, Signable (VRF c) ~ SignableRepresentation) =>
Version -> Gen (HeaderBody c)
genHeaderBody Version
version
  period <- arbitrary
  sKey <- arbitrary
  let hSig = ContextKES (KES c)
-> Period
-> HeaderBody c
-> UnsoundPureSignKeyKES (KES c)
-> SignedKES (KES c) (HeaderBody c)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v
-> Period -> a -> UnsoundPureSignKeyKES v -> SignedKES v a
KES.unsoundPureSignedKES () Period
period HeaderBody c
hBody UnsoundPureSignKeyKES (KES c)
sKey
  pure $ mkMemoized version $ HeaderRaw hBody hSig

instance
  ( Crypto c
  , VRF.Signable (VRF c) ~ SignableRepresentation
  , KES.Signable (KES c) ~ SignableRepresentation
  ) =>
  Arbitrary (Header c)
  where
  arbitrary :: Gen (Header c)
arbitrary = Version -> Gen (Header c)
forall c.
(Crypto c, Signable (VRF c) ~ SignableRepresentation,
 Signable (KES c) ~ SignableRepresentation) =>
Version -> Gen (Header c)
genHeader (Version -> Gen (Header c)) -> Gen Version -> Gen (Header c)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Version] -> Gen Version
forall a. HasCallStack => [a] -> Gen a
elements [forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @12 .. Version
forall a. Bounded a => a
maxBound]

deriving newtype instance Crypto c => DecCBOR (HeaderBody c)

instance Crypto c => DecCBOR (HeaderRaw c) where
  decCBOR :: forall s. Decoder s (HeaderRaw c)
decCBOR =
    Text
-> (HeaderRaw c -> Int)
-> Decoder s (HeaderRaw c)
-> Decoder s (HeaderRaw c)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"HeaderRaw" (Int -> HeaderRaw c -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (HeaderRaw c) -> Decoder s (HeaderRaw c))
-> Decoder s (HeaderRaw c) -> Decoder s (HeaderRaw c)
forall a b. (a -> b) -> a -> b
$
      HeaderBody c -> SignedKES (KES c) (HeaderBody c) -> HeaderRaw c
forall crypto.
HeaderBody crypto
-> SignedKES (KES crypto) (HeaderBody crypto) -> HeaderRaw crypto
HeaderRaw (HeaderBody c -> SignedKES (KES c) (HeaderBody c) -> HeaderRaw c)
-> Decoder s (HeaderBody c)
-> Decoder s (SignedKES (KES c) (HeaderBody c) -> HeaderRaw c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (HeaderBody c)
forall s. Decoder s (HeaderBody c)
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (SignedKES (KES c) (HeaderBody c) -> HeaderRaw c)
-> Decoder s (SignedKES (KES c) (HeaderBody c))
-> Decoder s (HeaderRaw c)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (SignedKES (KES c) (HeaderBody c))
forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized

deriving newtype instance Crypto c => DecCBOR (Header c)

instance
  ( Crypto c
  , EraBlockBody era
  , KES.Signable (KES c) ~ SignableRepresentation
  , VRF.Signable (VRF c) ~ SignableRepresentation
  , Arbitrary (BlockBody era)
  ) =>
  Arbitrary (Block (Header c) era)
  where
  arbitrary :: Gen (Block (Header c) era)
arbitrary = Header c -> BlockBody era -> Block (Header c) era
forall h era. h -> BlockBody era -> Block h era
Block (Header c -> BlockBody era -> Block (Header c) era)
-> Gen (Header c) -> Gen (BlockBody era -> Block (Header c) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version -> Gen (Header c)
forall c.
(Crypto c, Signable (VRF c) ~ SignableRepresentation,
 Signable (KES c) ~ SignableRepresentation) =>
Version -> Gen (Header c)
genHeader (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @12) Gen (BlockBody era -> Block (Header c) era)
-> Gen (BlockBody era) -> Gen (Block (Header 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
<*> Gen (BlockBody era)
forall a. Arbitrary a => Gen a
arbitrary