{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.Cardano.Chain.Block.CBOR (
  tests,
  exampleBlockSignature,
  exampleBody,
  exampleHeader,
  exampleProof,
  exampleToSign,
) where

import Cardano.Chain.Block (
  ABlockSignature (..),
  ABoundaryBlock (boundaryBlockLength),
  Block,
  BlockSignature,
  Body,
  Header,
  HeaderHash,
  Proof (..),
  ToSign (..),
  decCBORABOBBlock,
  decCBORABoundaryBlock,
  decCBORABoundaryHeader,
  decCBORBoundaryConsensusData,
  decCBORHeader,
  decCBORHeaderToHash,
  dropBoundaryBody,
  encCBORABOBBlock,
  encCBORABoundaryBlock,
  encCBORHeader,
  encCBORHeaderToHash,
  mkHeaderExplicit,
  pattern Body,
 )
import qualified Cardano.Chain.Delegation as Delegation
import Cardano.Chain.Slotting (
  EpochNumber (..),
  EpochSlots (EpochSlots),
  WithEpochSlots (WithEpochSlots),
  unWithEpochSlots,
 )
import Cardano.Chain.Ssc (SscPayload (..), SscProof (..))
import Cardano.Crypto (
  ProtocolMagicId (..),
  SignTag (..),
  abstractHash,
  noPassSafeSigner,
  serializeCborHash,
  sign,
  toVerification,
 )
import Cardano.Ledger.Binary (byronProtVer, decodeFullDecoder, dropBytes, serialize)
import Cardano.Prelude
import Data.Coerce (coerce)
import Data.Maybe (fromJust)
import Hedgehog (Property)
import qualified Hedgehog as H
import Test.Cardano.Chain.Block.Gen
import Test.Cardano.Chain.Common.Example (exampleChainDifficulty)
import Test.Cardano.Chain.Delegation.Example (exampleCertificates)
import Test.Cardano.Chain.Slotting.Example (exampleEpochAndSlotCount, exampleSlotNumber)
import Test.Cardano.Chain.Slotting.Gen (feedPMEpochSlots, genWithEpochSlots)
import Test.Cardano.Chain.UTxO.Example (exampleTxPayload, exampleTxProof)
import qualified Test.Cardano.Chain.Update.Example as Update
import Test.Cardano.Crypto.Example (exampleSigningKeys)
import Test.Cardano.Crypto.Gen (feedPM)
import Test.Cardano.Ledger.Binary.Vintage.Helpers.GoldenRoundTrip (
  deprecatedGoldenDecode,
  goldenTestCBOR,
  goldenTestCBORExplicit,
  roundTripsCBORBuildable,
  roundTripsCBORShow,
 )
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, concatTSGroups, eachOfTS)

--------------------------------------------------------------------------------
-- Header
--------------------------------------------------------------------------------

-- | Number of slots-per-epoch to be used throughout the examples in this
-- module.
exampleEs :: EpochSlots
exampleEs :: EpochSlots
exampleEs = Word64 -> EpochSlots
EpochSlots Word64
50

goldenHeader :: Property
goldenHeader :: Property
goldenHeader =
  Text
-> (Header -> Encoding)
-> (forall s. Decoder s Header)
-> Header
-> FilePath
-> Property
forall a.
(Eq a, Show a, HasCallStack) =>
Text
-> (a -> Encoding)
-> (forall s. Decoder s a)
-> a
-> FilePath
-> Property
goldenTestCBORExplicit
    Text
"Header"
    (EpochSlots -> Header -> Encoding
encCBORHeader EpochSlots
exampleEs)
    (EpochSlots -> Decoder s Header
forall s. EpochSlots -> Decoder s Header
decCBORHeader EpochSlots
exampleEs)
    Header
exampleHeader
    FilePath
"golden/cbor/block/Header"

-- | Round-trip test the backwards compatible header encoding/decoding functions
ts_roundTripHeaderCompat :: TSProperty
ts_roundTripHeaderCompat :: TSProperty
ts_roundTripHeaderCompat =
  TestLimit
-> Gen (WithEpochSlots Header)
-> (WithEpochSlots Header -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS
    TestLimit
300
    ((ProtocolMagicId -> EpochSlots -> Gen (WithEpochSlots Header))
-> Gen (WithEpochSlots Header)
forall a. (ProtocolMagicId -> EpochSlots -> Gen a) -> Gen a
feedPMEpochSlots ((ProtocolMagicId -> EpochSlots -> Gen (WithEpochSlots Header))
 -> Gen (WithEpochSlots Header))
-> (ProtocolMagicId -> EpochSlots -> Gen (WithEpochSlots Header))
-> Gen (WithEpochSlots Header)
forall a b. (a -> b) -> a -> b
$ (ProtocolMagicId -> EpochSlots -> Gen Header)
-> ProtocolMagicId -> EpochSlots -> Gen (WithEpochSlots Header)
forall a.
(ProtocolMagicId -> EpochSlots -> Gen a)
-> ProtocolMagicId -> EpochSlots -> Gen (WithEpochSlots a)
genWithEpochSlots ProtocolMagicId -> EpochSlots -> Gen Header
genHeader)
    WithEpochSlots Header -> PropertyT IO ()
roundTripsHeaderCompat
  where
    roundTripsHeaderCompat :: WithEpochSlots Header -> H.PropertyT IO ()
    roundTripsHeaderCompat :: WithEpochSlots Header -> PropertyT IO ()
roundTripsHeaderCompat esh :: WithEpochSlots Header
esh@(WithEpochSlots EpochSlots
es Header
_) =
      WithEpochSlots Header
-> (WithEpochSlots Header -> ByteString)
-> (ByteString -> Either DecoderError (WithEpochSlots Header))
-> PropertyT IO ()
forall (f :: * -> *) a b (m :: * -> *).
(HasCallStack, Buildable (f a), Eq (f a), Show b, Applicative f,
 MonadTest m) =>
a -> (a -> b) -> (b -> f a) -> m ()
trippingBuildable
        WithEpochSlots Header
esh
        (Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer (Encoding -> ByteString)
-> (WithEpochSlots Header -> Encoding)
-> WithEpochSlots Header
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EpochSlots -> Header -> Encoding
encCBORHeaderToHash EpochSlots
es (Header -> Encoding)
-> (WithEpochSlots Header -> Header)
-> WithEpochSlots Header
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WithEpochSlots Header -> Header
forall a. WithEpochSlots a -> a
unWithEpochSlots)
        ( (Maybe Header -> WithEpochSlots Header)
-> Either DecoderError (Maybe Header)
-> Either DecoderError (WithEpochSlots Header)
forall a b.
(a -> b) -> Either DecoderError a -> Either DecoderError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochSlots -> Header -> WithEpochSlots Header
forall a. EpochSlots -> a -> WithEpochSlots a
WithEpochSlots EpochSlots
es (Header -> WithEpochSlots Header)
-> (Maybe Header -> Header)
-> Maybe Header
-> WithEpochSlots Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe Header -> Header
forall a. HasCallStack => Maybe a -> a
fromJust)
            (Either DecoderError (Maybe Header)
 -> Either DecoderError (WithEpochSlots Header))
-> (ByteString -> Either DecoderError (Maybe Header))
-> ByteString
-> Either DecoderError (WithEpochSlots Header)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version
-> Text
-> (forall s. Decoder s (Maybe Header))
-> ByteString
-> Either DecoderError (Maybe Header)
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer Text
"Header" (EpochSlots -> Decoder s (Maybe Header)
forall s. EpochSlots -> Decoder s (Maybe Header)
decCBORHeaderToHash EpochSlots
es)
        )

--------------------------------------------------------------------------------
-- Block
--------------------------------------------------------------------------------

-- | Round-trip test the backwards compatible block encoding/decoding functions
ts_roundTripBlockCompat :: TSProperty
ts_roundTripBlockCompat :: TSProperty
ts_roundTripBlockCompat =
  TestLimit
-> Gen (WithEpochSlots Block)
-> (WithEpochSlots Block -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS
    TestLimit
300
    ((ProtocolMagicId -> Gen (WithEpochSlots Block))
-> Gen (WithEpochSlots Block)
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen (WithEpochSlots Block)
genBlockWithEpochSlots)
    WithEpochSlots Block -> PropertyT IO ()
roundTripsBlockCompat
  where
    roundTripsBlockCompat :: WithEpochSlots Block -> H.PropertyT IO ()
    roundTripsBlockCompat :: WithEpochSlots Block -> PropertyT IO ()
roundTripsBlockCompat esb :: WithEpochSlots Block
esb@(WithEpochSlots EpochSlots
es Block
_) =
      WithEpochSlots Block
-> (WithEpochSlots Block -> ByteString)
-> (ByteString -> Either DecoderError (WithEpochSlots Block))
-> PropertyT IO ()
forall (f :: * -> *) a b (m :: * -> *).
(HasCallStack, Buildable (f a), Eq (f a), Show b, Applicative f,
 MonadTest m) =>
a -> (a -> b) -> (b -> f a) -> m ()
trippingBuildable
        WithEpochSlots Block
esb
        (Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer (Encoding -> ByteString)
-> (WithEpochSlots Block -> Encoding)
-> WithEpochSlots Block
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EpochSlots -> Block -> Encoding
forall a. EpochSlots -> ABlock a -> Encoding
encCBORABOBBlock EpochSlots
es (Block -> Encoding)
-> (WithEpochSlots Block -> Block)
-> WithEpochSlots Block
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. WithEpochSlots Block -> Block
forall a. WithEpochSlots a -> a
unWithEpochSlots)
        ( (Maybe Block -> WithEpochSlots Block)
-> Either DecoderError (Maybe Block)
-> Either DecoderError (WithEpochSlots Block)
forall a b.
(a -> b) -> Either DecoderError a -> Either DecoderError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EpochSlots -> Block -> WithEpochSlots Block
forall a. EpochSlots -> a -> WithEpochSlots a
WithEpochSlots EpochSlots
es (Block -> WithEpochSlots Block)
-> (Maybe Block -> Block) -> Maybe Block -> WithEpochSlots Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe Block -> Block
forall a. HasCallStack => Maybe a -> a
fromJust)
            (Either DecoderError (Maybe Block)
 -> Either DecoderError (WithEpochSlots Block))
-> (ByteString -> Either DecoderError (Maybe Block))
-> ByteString
-> Either DecoderError (WithEpochSlots Block)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Version
-> Text
-> (forall s. Decoder s (Maybe Block))
-> ByteString
-> Either DecoderError (Maybe Block)
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer Text
"Block" (EpochSlots -> Decoder s (Maybe Block)
forall s. EpochSlots -> Decoder s (Maybe Block)
decCBORABOBBlock EpochSlots
es)
        )

--------------------------------------------------------------------------------
-- BlockSignature
--------------------------------------------------------------------------------

goldenBlockSignature :: Property
goldenBlockSignature :: Property
goldenBlockSignature =
  BlockSignature -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR BlockSignature
exampleBlockSignature FilePath
"golden/cbor/block/BlockSignature"

ts_roundTripBlockSignatureCBOR :: TSProperty
ts_roundTripBlockSignatureCBOR :: TSProperty
ts_roundTripBlockSignatureCBOR =
  TestLimit
-> Gen BlockSignature
-> (BlockSignature -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
300 ((ProtocolMagicId -> EpochSlots -> Gen BlockSignature)
-> Gen BlockSignature
forall a. (ProtocolMagicId -> EpochSlots -> Gen a) -> Gen a
feedPMEpochSlots ProtocolMagicId -> EpochSlots -> Gen BlockSignature
genBlockSignature) BlockSignature -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- BoundaryBlockHeader
--------------------------------------------------------------------------------

goldenDeprecatedBoundaryBlockHeader :: Property
goldenDeprecatedBoundaryBlockHeader :: Property
goldenDeprecatedBoundaryBlockHeader =
  HasCallStack =>
Text -> (forall s. Decoder s ()) -> FilePath -> Property
Text -> (forall s. Decoder s ()) -> FilePath -> Property
deprecatedGoldenDecode
    Text
"BoundaryBlockHeader"
    (Decoder s (ABoundaryHeader ByteSpan) -> Decoder s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Decoder s (ABoundaryHeader ByteSpan)
forall s. Decoder s (ABoundaryHeader ByteSpan)
decCBORABoundaryHeader)
    FilePath
"golden/cbor/block/BoundaryBlockHeader"

ts_roundTripBoundaryBlock :: TSProperty
ts_roundTripBoundaryBlock :: TSProperty
ts_roundTripBoundaryBlock =
  TestLimit
-> Gen (ProtocolMagicId, ABoundaryBlock ())
-> ((ProtocolMagicId, ABoundaryBlock ()) -> PropertyT IO ())
-> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS
    TestLimit
300
    ((ProtocolMagicId -> Gen (ProtocolMagicId, ABoundaryBlock ()))
-> Gen (ProtocolMagicId, ABoundaryBlock ())
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen (ProtocolMagicId, ABoundaryBlock ())
genBVDWithPM)
    (ProtocolMagicId, ABoundaryBlock ()) -> PropertyT IO ()
roundTripsBVD
  where
    -- We ignore the size of the BVD here, since calculating it is annoying.
    roundTripsBVD :: (ProtocolMagicId, ABoundaryBlock ()) -> H.PropertyT IO ()
    roundTripsBVD :: (ProtocolMagicId, ABoundaryBlock ()) -> PropertyT IO ()
roundTripsBVD (ProtocolMagicId
pm, ABoundaryBlock ()
bvd) =
      ABoundaryBlock ()
-> (ABoundaryBlock () -> ByteString)
-> (ByteString -> Either DecoderError (ABoundaryBlock ()))
-> PropertyT IO ()
forall (f :: * -> *) a b (m :: * -> *).
(HasCallStack, Buildable (f a), Eq (f a), Show b, Applicative f,
 MonadTest m) =>
a -> (a -> b) -> (b -> f a) -> m ()
trippingBuildable
        ABoundaryBlock ()
bvd
        (Version -> Encoding -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize Version
byronProtVer (Encoding -> ByteString)
-> (ABoundaryBlock () -> Encoding)
-> ABoundaryBlock ()
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ProtocolMagicId -> ABoundaryBlock () -> Encoding
forall a. ProtocolMagicId -> ABoundaryBlock a -> Encoding
encCBORABoundaryBlock ProtocolMagicId
pm)
        ( (ABoundaryBlock ByteSpan -> ABoundaryBlock ())
-> Either DecoderError (ABoundaryBlock ByteSpan)
-> Either DecoderError (ABoundaryBlock ())
forall a b.
(a -> b) -> Either DecoderError a -> Either DecoderError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ABoundaryBlock () -> ABoundaryBlock ()
forall a. ABoundaryBlock a -> ABoundaryBlock a
dropSize (ABoundaryBlock () -> ABoundaryBlock ())
-> (ABoundaryBlock ByteSpan -> ABoundaryBlock ())
-> ABoundaryBlock ByteSpan
-> ABoundaryBlock ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ByteSpan -> ()) -> ABoundaryBlock ByteSpan -> ABoundaryBlock ()
forall a b. (a -> b) -> ABoundaryBlock a -> ABoundaryBlock b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ByteSpan -> ()
forall a b. a -> b -> a
const ()))
            (Either DecoderError (ABoundaryBlock ByteSpan)
 -> Either DecoderError (ABoundaryBlock ()))
-> (ByteString -> Either DecoderError (ABoundaryBlock ByteSpan))
-> ByteString
-> Either DecoderError (ABoundaryBlock ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version
-> Text
-> (forall s. Decoder s (ABoundaryBlock ByteSpan))
-> ByteString
-> Either DecoderError (ABoundaryBlock ByteSpan)
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
decodeFullDecoder Version
byronProtVer Text
"BoundaryBlock" Decoder s (ABoundaryBlock ByteSpan)
forall s. Decoder s (ABoundaryBlock ByteSpan)
decCBORABoundaryBlock
        )

    genBVDWithPM :: ProtocolMagicId -> H.Gen (ProtocolMagicId, ABoundaryBlock ())
    genBVDWithPM :: ProtocolMagicId -> Gen (ProtocolMagicId, ABoundaryBlock ())
genBVDWithPM ProtocolMagicId
pm = (,) (ProtocolMagicId
 -> ABoundaryBlock () -> (ProtocolMagicId, ABoundaryBlock ()))
-> GenT Identity ProtocolMagicId
-> GenT
     Identity
     (ABoundaryBlock () -> (ProtocolMagicId, ABoundaryBlock ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProtocolMagicId -> GenT Identity ProtocolMagicId
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolMagicId
pm GenT
  Identity
  (ABoundaryBlock () -> (ProtocolMagicId, ABoundaryBlock ()))
-> GenT Identity (ABoundaryBlock ())
-> Gen (ProtocolMagicId, ABoundaryBlock ())
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (ABoundaryBlock ())
genBoundaryBlock

    dropSize :: ABoundaryBlock a -> ABoundaryBlock a
    dropSize :: forall a. ABoundaryBlock a -> ABoundaryBlock a
dropSize ABoundaryBlock a
bvd = ABoundaryBlock a
bvd {boundaryBlockLength = 0}

--------------------------------------------------------------------------------
-- BoundaryBody
--------------------------------------------------------------------------------

goldenDeprecatedBoundaryBody :: Property
goldenDeprecatedBoundaryBody :: Property
goldenDeprecatedBoundaryBody =
  HasCallStack =>
Text -> (forall s. Decoder s ()) -> FilePath -> Property
Text -> (forall s. Decoder s ()) -> FilePath -> Property
deprecatedGoldenDecode
    Text
"BoundaryBody"
    Dropper s
forall s. Decoder s ()
dropBoundaryBody
    FilePath
"golden/cbor/block/BoundaryBody"

--------------------------------------------------------------------------------
-- BoundaryConsensusData
--------------------------------------------------------------------------------

goldenDeprecatedBoundaryConsensusData :: Property
goldenDeprecatedBoundaryConsensusData :: Property
goldenDeprecatedBoundaryConsensusData =
  HasCallStack =>
Text -> (forall s. Decoder s ()) -> FilePath -> Property
Text -> (forall s. Decoder s ()) -> FilePath -> Property
deprecatedGoldenDecode
    Text
"BoundaryConsensusData"
    (Decoder s (Word64, ChainDifficulty) -> Decoder s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Decoder s (Word64, ChainDifficulty)
forall s. Decoder s (Word64, ChainDifficulty)
decCBORBoundaryConsensusData)
    FilePath
"golden/cbor/block/BoundaryConsensusData"

--------------------------------------------------------------------------------
-- HeaderHash
--------------------------------------------------------------------------------

goldenHeaderHash :: Property
goldenHeaderHash :: Property
goldenHeaderHash =
  HeaderHash -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR HeaderHash
exampleHeaderHash FilePath
"golden/cbor/block/HeaderHash"

ts_roundTripHeaderHashCBOR :: TSProperty
ts_roundTripHeaderHashCBOR :: TSProperty
ts_roundTripHeaderHashCBOR =
  TestLimit
-> Gen HeaderHash -> (HeaderHash -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
1000 Gen HeaderHash
genHeaderHash HeaderHash -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- BoundaryProof
--------------------------------------------------------------------------------

goldenDeprecatedBoundaryProof :: Property
goldenDeprecatedBoundaryProof :: Property
goldenDeprecatedBoundaryProof =
  HasCallStack =>
Text -> (forall s. Decoder s ()) -> FilePath -> Property
Text -> (forall s. Decoder s ()) -> FilePath -> Property
deprecatedGoldenDecode
    Text
"BoundaryProof"
    Dropper s
forall s. Decoder s ()
dropBytes
    FilePath
"golden/cbor/block/BoundaryProof"

--------------------------------------------------------------------------------
-- Body
--------------------------------------------------------------------------------

goldenBody :: Property
goldenBody :: Property
goldenBody = Body -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Body
exampleBody FilePath
"golden/cbor/block/Body"

ts_roundTripBodyCBOR :: TSProperty
ts_roundTripBodyCBOR :: TSProperty
ts_roundTripBodyCBOR = TestLimit -> Gen Body -> (Body -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen Body) -> Gen Body
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Body
genBody) Body -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

--------------------------------------------------------------------------------
-- Proof
--------------------------------------------------------------------------------

goldenProof :: Property
goldenProof :: Property
goldenProof = Proof -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR Proof
exampleProof FilePath
"golden/cbor/block/Proof"

ts_roundTripProofCBOR :: TSProperty
ts_roundTripProofCBOR :: TSProperty
ts_roundTripProofCBOR = TestLimit -> Gen Proof -> (Proof -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> Gen Proof) -> Gen Proof
forall a. (ProtocolMagicId -> Gen a) -> Gen a
feedPM ProtocolMagicId -> Gen Proof
genProof) Proof -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Buildable a,
 HasCallStack) =>
a -> m ()
roundTripsCBORBuildable

--------------------------------------------------------------------------------
-- ToSign
--------------------------------------------------------------------------------

goldenToSign :: Property
goldenToSign :: Property
goldenToSign = ToSign -> FilePath -> Property
forall a.
(DecCBOR a, EncCBOR a, Eq a, Show a, HasCallStack) =>
a -> FilePath -> Property
goldenTestCBOR ToSign
exampleToSign FilePath
"golden/cbor/block/ToSign"

ts_roundTripToSignCBOR :: TSProperty
ts_roundTripToSignCBOR :: TSProperty
ts_roundTripToSignCBOR =
  TestLimit
-> Gen ToSign -> (ToSign -> PropertyT IO ()) -> TSProperty
forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS TestLimit
20 ((ProtocolMagicId -> EpochSlots -> Gen ToSign) -> Gen ToSign
forall a. (ProtocolMagicId -> EpochSlots -> Gen a) -> Gen a
feedPMEpochSlots ProtocolMagicId -> EpochSlots -> Gen ToSign
genToSign) ToSign -> PropertyT IO ()
forall a (m :: * -> *).
(DecCBOR a, EncCBOR a, Eq a, MonadTest m, Show a, HasCallStack) =>
a -> m ()
roundTripsCBORShow

--------------------------------------------------------------------------------
-- Example golden datatypes
--------------------------------------------------------------------------------

exampleHeader :: Header
exampleHeader :: Header
exampleHeader =
  ProtocolMagicId
-> HeaderHash
-> ChainDifficulty
-> EpochSlots
-> SlotNumber
-> SigningKey
-> Certificate
-> Body
-> ProtocolVersion
-> SoftwareVersion
-> Header
mkHeaderExplicit
    (Word32 -> ProtocolMagicId
ProtocolMagicId Word32
7)
    HeaderHash
exampleHeaderHash
    ChainDifficulty
exampleChainDifficulty
    EpochSlots
exampleEs
    (EpochSlots -> SlotNumber
exampleSlotNumber EpochSlots
exampleEs)
    SigningKey
delegateSk
    Certificate
certificate
    Body
exampleBody
    ProtocolVersion
Update.exampleProtocolVersion
    SoftwareVersion
Update.exampleSoftwareVersion
  where
    pm :: ProtocolMagicId
pm = Word32 -> ProtocolMagicId
ProtocolMagicId Word32
7
    [SigningKey
delegateSk, SigningKey
issuerSk] = Int -> Int -> [SigningKey]
exampleSigningKeys Int
5 Int
2
    certificate :: Certificate
certificate =
      ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Delegation.signCertificate
        ProtocolMagicId
pm
        (SigningKey -> VerificationKey
toVerification SigningKey
delegateSk)
        (Word64 -> EpochNumber
EpochNumber Word64
5)
        (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
issuerSk)

exampleBlockSignature :: BlockSignature
exampleBlockSignature :: BlockSignature
exampleBlockSignature = Certificate -> Signature ToSign -> BlockSignature
forall a. ACertificate a -> Signature ToSign -> ABlockSignature a
ABlockSignature Certificate
cert Signature ToSign
sig
  where
    cert :: Certificate
cert =
      ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Delegation.signCertificate
        ProtocolMagicId
pm
        (SigningKey -> VerificationKey
toVerification SigningKey
delegateSK)
        (Word64 -> EpochNumber
EpochNumber Word64
5)
        (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
issuerSK)

    sig :: Signature ToSign
sig = ProtocolMagicId
-> SignTag -> SigningKey -> ToSign -> Signature ToSign
forall a.
EncCBOR a =>
ProtocolMagicId -> SignTag -> SigningKey -> a -> Signature a
sign ProtocolMagicId
pm (VerificationKey -> SignTag
SignBlock (SigningKey -> VerificationKey
toVerification SigningKey
issuerSK)) SigningKey
delegateSK ToSign
exampleToSign

    [SigningKey
delegateSK, SigningKey
issuerSK] = Int -> Int -> [SigningKey]
exampleSigningKeys Int
5 Int
2
    pm :: ProtocolMagicId
pm = Word32 -> ProtocolMagicId
ProtocolMagicId Word32
7

exampleProof :: Proof
exampleProof :: Proof
exampleProof =
  TxProof -> SscProof -> Hash Payload -> Proof -> Proof
Proof
    TxProof
exampleTxProof
    SscProof
SscProof
    (Payload -> Hash Payload
forall algo a.
(HashAlgorithm algo, EncCBOR a) =>
a -> AbstractHash algo a
abstractHash Payload
dp)
    Proof
Update.exampleProof
  where
    dp :: Payload
dp = [Certificate] -> Payload
Delegation.unsafePayload (Int -> [Certificate] -> [Certificate]
forall a. Int -> [a] -> [a]
take Int
4 [Certificate]
exampleCertificates)

exampleHeaderHash :: HeaderHash
exampleHeaderHash :: HeaderHash
exampleHeaderHash = Hash Text -> HeaderHash
forall a b. Coercible a b => a -> b
coerce (Hash Text -> HeaderHash) -> Hash Text -> HeaderHash
forall a b. (a -> b) -> a -> b
$ Text -> Hash Text
forall a. EncCBOR a => a -> Hash a
serializeCborHash (Text
"HeaderHash" :: Text)

exampleBody :: Body
exampleBody :: Body
exampleBody = TxPayload -> SscPayload -> Payload -> Payload -> Body
Body TxPayload
exampleTxPayload SscPayload
SscPayload Payload
dp Payload
Update.examplePayload
  where
    dp :: Payload
dp = [Certificate] -> Payload
Delegation.unsafePayload (Int -> [Certificate] -> [Certificate]
forall a. Int -> [a] -> [a]
take Int
4 [Certificate]
exampleCertificates)

exampleToSign :: ToSign
exampleToSign :: ToSign
exampleToSign =
  HeaderHash
-> Proof
-> EpochAndSlotCount
-> ChainDifficulty
-> ProtocolVersion
-> SoftwareVersion
-> ToSign
ToSign
    HeaderHash
exampleHeaderHash
    Proof
exampleProof
    EpochAndSlotCount
exampleEpochAndSlotCount
    ChainDifficulty
exampleChainDifficulty
    ProtocolVersion
Update.exampleProtocolVersion
    SoftwareVersion
Update.exampleSoftwareVersion

-----------------------------------------------------------------------
-- Main test export
-----------------------------------------------------------------------

tests :: TSGroup
tests :: TSGroup
tests = [TSGroup] -> TSGroup
concatTSGroups [Group -> TSGroup
forall a b. a -> b -> a
const $$FilePath
[(PropertyName, Property)]
Property
FilePath -> GroupName
FilePath -> PropertyName
GroupName -> [(PropertyName, Property)] -> Group
goldenHeader :: Property
goldenBlockSignature :: Property
goldenDeprecatedBoundaryBlockHeader :: Property
goldenDeprecatedBoundaryBody :: Property
goldenDeprecatedBoundaryConsensusData :: Property
goldenHeaderHash :: Property
goldenDeprecatedBoundaryProof :: Property
goldenBody :: Property
goldenProof :: Property
goldenToSign :: Property
discoverGolden, $$discoverRoundTripArg]