{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Generators suitable for serialisation. Note that these are not guaranteed
-- to be semantically correct at all, only structurally correct.
module Test.Consensus.Protocol.Serialisation.Generators () where

import Cardano.Crypto.KES (unsoundPureSignedKES)
import Cardano.Crypto.VRF (evalCertified)
import Cardano.Protocol.TPraos.BHeader (HashHeader, PrevHash (..))
import Cardano.Protocol.TPraos.OCert
  ( KESPeriod (KESPeriod)
  , OCert (OCert)
  )
import Cardano.Slotting.Block (BlockNo (BlockNo))
import Cardano.Slotting.Slot
  ( SlotNo (SlotNo)
  , WithOrigin (At, Origin)
  )
import Ouroboros.Consensus.Protocol.Praos (PraosState (PraosState))
import qualified Ouroboros.Consensus.Protocol.Praos as Praos
import Ouroboros.Consensus.Protocol.Praos.Header
  ( Header (Header)
  , HeaderBody (HeaderBody)
  )
import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF)
import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ()
import Test.Crypto.KES ()
import Test.Crypto.VRF ()
import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof)

instance Arbitrary InputVRF where
  arbitrary :: Gen InputVRF
arbitrary = SlotNo -> Nonce -> InputVRF
mkInputVRF (SlotNo -> Nonce -> InputVRF)
-> Gen SlotNo -> Gen (Nonce -> InputVRF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SlotNo
forall a. Arbitrary a => Gen a
arbitrary Gen (Nonce -> InputVRF) -> Gen Nonce -> Gen InputVRF
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary

instance Praos.PraosCrypto c => Arbitrary (HeaderBody c) where
  arbitrary :: Gen (HeaderBody c)
arbitrary =
    let ocert :: Gen (OCert c)
ocert =
          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
<*> (Word -> KESPeriod
KESPeriod (Word -> KESPeriod) -> Gen Word -> Gen KESPeriod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word
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

        certVrf :: Gen (CertifiedVRF (VRF c) InputVRF)
certVrf =
          ContextVRF (VRF c)
-> InputVRF -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) InputVRF
forall v a.
(VRFAlgorithm v, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> CertifiedVRF v a
evalCertified ()
            (InputVRF -> SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) InputVRF)
-> Gen InputVRF
-> Gen (SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) InputVRF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen InputVRF
forall a. Arbitrary a => Gen a
arbitrary :: Gen InputVRF)
            Gen (SignKeyVRF (VRF c) -> CertifiedVRF (VRF c) InputVRF)
-> Gen (SignKeyVRF (VRF c)) -> Gen (CertifiedVRF (VRF c) InputVRF)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (SignKeyVRF (VRF c))
forall a. Arbitrary a => Gen a
arbitrary
     in BlockNo
-> SlotNo
-> PrevHash
-> VKey 'BlockIssuer
-> VerKeyVRF (VRF c)
-> CertifiedVRF (VRF c) InputVRF
-> Word32
-> Hash HASH EraIndependentBlockBody
-> OCert c
-> ProtVer
-> HeaderBody c
forall crypto.
BlockNo
-> SlotNo
-> PrevHash
-> VKey 'BlockIssuer
-> VerKeyVRF (VRF crypto)
-> CertifiedVRF (VRF crypto) InputVRF
-> Word32
-> Hash HASH EraIndependentBlockBody
-> OCert crypto
-> ProtVer
-> HeaderBody crypto
HeaderBody
          (BlockNo
 -> SlotNo
 -> PrevHash
 -> VKey 'BlockIssuer
 -> VerKeyVRF (VRF c)
 -> CertifiedVRF (VRF c) InputVRF
 -> Word32
 -> Hash HASH EraIndependentBlockBody
 -> OCert c
 -> ProtVer
 -> HeaderBody c)
-> Gen BlockNo
-> Gen
     (SlotNo
      -> PrevHash
      -> VKey 'BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> HeaderBody c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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
1, Word64
10))
          Gen
  (SlotNo
   -> PrevHash
   -> VKey 'BlockIssuer
   -> VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> HeaderBody c)
-> Gen SlotNo
-> Gen
     (PrevHash
      -> VKey 'BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> HeaderBody c)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (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
1, Word64
10))
          Gen
  (PrevHash
   -> VKey 'BlockIssuer
   -> VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> HeaderBody c)
-> Gen PrevHash
-> Gen
     (VKey 'BlockIssuer
      -> VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> HeaderBody 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] -> Gen PrevHash
forall a. HasCallStack => [Gen a] -> Gen a
oneof
            [ PrevHash -> Gen PrevHash
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrevHash
GenesisHash
            , HashHeader -> PrevHash
BlockHash (HashHeader -> PrevHash) -> Gen HashHeader -> Gen PrevHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen HashHeader
forall a. Arbitrary a => Gen a
arbitrary :: Gen HashHeader)
            ]
          Gen
  (VKey 'BlockIssuer
   -> VerKeyVRF (VRF c)
   -> CertifiedVRF (VRF c) InputVRF
   -> Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> HeaderBody c)
-> Gen (VKey 'BlockIssuer)
-> Gen
     (VerKeyVRF (VRF c)
      -> CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> HeaderBody 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
   -> ProtVer
   -> HeaderBody c)
-> Gen (VerKeyVRF (VRF c))
-> Gen
     (CertifiedVRF (VRF c) InputVRF
      -> Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> HeaderBody 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
   -> ProtVer
   -> HeaderBody c)
-> Gen (CertifiedVRF (VRF c) InputVRF)
-> Gen
     (Word32
      -> Hash HASH EraIndependentBlockBody
      -> OCert c
      -> ProtVer
      -> HeaderBody 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)
certVrf
          Gen
  (Word32
   -> Hash HASH EraIndependentBlockBody
   -> OCert c
   -> ProtVer
   -> HeaderBody c)
-> Gen Word32
-> Gen
     (Hash HASH EraIndependentBlockBody
      -> OCert c -> ProtVer -> HeaderBody 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 -> HeaderBody c)
-> Gen (Hash HASH EraIndependentBlockBody)
-> Gen (OCert c -> ProtVer -> HeaderBody 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 -> HeaderBody c)
-> Gen (OCert c) -> Gen (ProtVer -> HeaderBody 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)
ocert
          Gen (ProtVer -> HeaderBody c) -> Gen ProtVer -> Gen (HeaderBody 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 Praos.PraosCrypto c => Arbitrary (Header c) where
  arbitrary :: Gen (Header c)
arbitrary = do
    hBody <- Gen (HeaderBody c)
forall a. Arbitrary a => Gen a
arbitrary
    period <- arbitrary
    sKey <- arbitrary
    let hSig = ContextKES (KES c)
-> Word
-> HeaderBody c
-> UnsoundPureSignKeyKES (KES c)
-> SignedKES (KES c) (HeaderBody c)
forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v
-> Word -> a -> UnsoundPureSignKeyKES v -> SignedKES v a
unsoundPureSignedKES () Word
period HeaderBody c
hBody UnsoundPureSignKeyKES (KES c)
sKey
    pure $ Header hBody hSig

instance Arbitrary PraosState where
  arbitrary :: Gen PraosState
arbitrary =
    WithOrigin SlotNo
-> Map (KeyHash 'BlockIssuer) Word64
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> Nonce
-> PraosState
PraosState
      (WithOrigin SlotNo
 -> Map (KeyHash 'BlockIssuer) Word64
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> Nonce
 -> PraosState)
-> Gen (WithOrigin SlotNo)
-> Gen
     (Map (KeyHash 'BlockIssuer) Word64
      -> Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen (WithOrigin SlotNo)] -> Gen (WithOrigin SlotNo)
forall a. HasCallStack => [Gen a] -> Gen a
oneof
        [ WithOrigin SlotNo -> Gen (WithOrigin SlotNo)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin SlotNo
forall t. WithOrigin t
Origin
        , SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (SlotNo -> WithOrigin SlotNo)
-> Gen SlotNo -> Gen (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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
1, Word64
10))
        ]
      Gen
  (Map (KeyHash 'BlockIssuer) Word64
   -> Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
-> Gen (Map (KeyHash 'BlockIssuer) Word64)
-> Gen (Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Map (KeyHash 'BlockIssuer) Word64)
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Nonce -> Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
-> Gen Nonce
-> Gen (Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Nonce -> Nonce -> Nonce -> Nonce -> PraosState)
-> Gen Nonce -> Gen (Nonce -> Nonce -> Nonce -> PraosState)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Nonce -> Nonce -> Nonce -> PraosState)
-> Gen Nonce -> Gen (Nonce -> Nonce -> PraosState)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Nonce -> Nonce -> PraosState)
-> Gen Nonce -> Gen (Nonce -> PraosState)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary
      Gen (Nonce -> PraosState) -> Gen Nonce -> Gen PraosState
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Nonce
forall a. Arbitrary a => Gen a
arbitrary