{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Consensus.Cardano.Serialisation (tests) where

import qualified Codec.CBOR.Write as CBOR
import qualified Data.ByteString.Lazy as Lazy
import Data.Constraint
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Byron.Ledger
import Ouroboros.Consensus.Byron.Node ()
import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Cardano.Node ()
import Ouroboros.Consensus.HardFork.Combinator.Block
import Ouroboros.Consensus.Shelley.Ledger
import Ouroboros.Consensus.Shelley.Node ()
import Ouroboros.Consensus.Storage.Serialisation
import Ouroboros.Network.Block (Serialised (..))
import Test.Consensus.Byron.Generators (epochSlots)
import qualified Test.Consensus.Cardano.Examples as Cardano.Examples
import Test.Consensus.Cardano.Generators ()
import Test.Tasty
import Test.Tasty.QuickCheck (Property, testProperty, (===))
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Serialisation.Roundtrip

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Cardano"
    [ TestName -> [TestTree] -> TestTree
testGroup TestName
"Examples roundtrip" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
        CodecConfig (CardanoBlock StandardCrypto)
-> Examples (CardanoBlock StandardCrypto) -> [TestTree]
forall blk.
(SerialiseDiskConstraints blk, Eq blk, Show blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk -> Examples blk -> [TestTree]
examplesRoundtrip CodecConfig (CardanoBlock StandardCrypto)
Cardano.Examples.codecConfig Examples (CardanoBlock StandardCrypto)
Cardano.Examples.examples
    , (TestName -> ShouldCheckCBORValidity)
-> CodecConfig (CardanoBlock StandardCrypto)
-> (forall a.
    NestedCtxt_ (CardanoBlock StandardCrypto) Header a
    -> Dict (Eq a, Show a))
-> Maybe CDDLsForNodeToNode
-> TestTree
forall blk.
(SerialiseDiskConstraints blk, SerialiseNodeToNodeConstraints blk,
 SerialiseNodeToClientConstraints blk,
 Show (BlockNodeToNodeVersion blk), StandardHash blk, GetHeader blk,
 Arbitrary' blk, Arbitrary' (Header blk),
 Arbitrary' (HeaderHash blk), Arbitrary' (LedgerState blk EmptyMK),
 Arbitrary' (AnnTip blk),
 Arbitrary' (ChainDepState (BlockProtocol blk)),
 ArbitraryWithVersion (BlockNodeToNodeVersion blk) (Coherent blk),
 ArbitraryWithVersion (BlockNodeToNodeVersion blk) (Header blk),
 ArbitraryWithVersion (BlockNodeToNodeVersion blk) (GenTx blk),
 ArbitraryWithVersion (BlockNodeToNodeVersion blk) (GenTxId blk),
 ArbitraryWithVersion
   (BlockNodeToNodeVersion blk) (SomeSecond (NestedCtxt Header) blk),
 ArbitraryWithVersion (BlockNodeToClientVersion blk) blk,
 ArbitraryWithVersion (BlockNodeToClientVersion blk) (GenTx blk),
 ArbitraryWithVersion
   (BlockNodeToClientVersion blk) (ApplyTxErr blk),
 ArbitraryWithVersion
   (BlockNodeToClientVersion blk) (SomeBlockQuery (BlockQuery blk)),
 ArbitraryWithVersion
   (BlockNodeToClientVersion blk) (SomeResult blk),
 Arbitrary
   (WithVersion (BlockNodeToClientVersion blk) (LedgerConfig blk)),
 ArbitraryWithVersion
   (QueryVersion, BlockNodeToClientVersion blk)
   (SomeSecond Query blk),
 Show (BlockNodeToClientVersion blk),
 BlockSupportsLedgerQuery blk) =>
(TestName -> ShouldCheckCBORValidity)
-> CodecConfig blk
-> (forall a. NestedCtxt_ blk Header a -> Dict (Eq a, Show a))
-> Maybe CDDLsForNodeToNode
-> TestTree
roundtrip_all_skipping
        TestName -> ShouldCheckCBORValidity
forall {a}. (Eq a, IsString a) => a -> ShouldCheckCBORValidity
result
        CodecConfig (CardanoBlock StandardCrypto)
testCodecCfg
        NestedCtxt_ (CardanoBlock StandardCrypto) Header a
-> Dict (Eq a, Show a)
forall a.
NestedCtxt_ (CardanoBlock StandardCrypto) Header a
-> Dict (Eq a, Show a)
dictNestedHdr
        -- We would want to use this instead, but the generated blocks
        -- do not quite validate yet or sometimes they are not
        -- entirely coherent, so for now this is commented out.
        --
        -- It is also the case that some (conway in particular) blocks take a
        -- very long time to validate or consume too much memory.
        --
        -- ( Just $
        --     CDDLsForNodeToNode ("ntnblock.cddl", "serialisedCardanoBlock") ("ntnheader.cddl", "header")
        -- )
        Maybe CDDLsForNodeToNode
forall a. Maybe a
Nothing
    , TestName -> (CardanoBlock StandardCrypto -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"BinaryBlockInfo sanity check" CardanoBlock StandardCrypto -> Property
prop_CardanoBinaryBlockInfo
    ]
 where
  -- See https://github.com/IntersectMBO/cardano-ledger/issues/3800
  result :: a -> ShouldCheckCBORValidity
result a
"roundtrip Result" = ShouldCheckCBORValidity
DoNotCheckCBORValidity
  result a
_ = ShouldCheckCBORValidity
CheckCBORValidity

testCodecCfg :: CardanoCodecConfig StandardCrypto
testCodecCfg :: CodecConfig (CardanoBlock StandardCrypto)
testCodecCfg =
  CodecConfig ByronBlock
-> CodecConfig (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
-> CodecConfig (ShelleyBlock (TPraos StandardCrypto) AllegraEra)
-> CodecConfig (ShelleyBlock (TPraos StandardCrypto) MaryEra)
-> CodecConfig (ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
-> CodecConfig (ShelleyBlock (Praos StandardCrypto) BabbageEra)
-> CodecConfig (ShelleyBlock (Praos StandardCrypto) ConwayEra)
-> CodecConfig (ShelleyBlock (Praos StandardCrypto) DijkstraEra)
-> CodecConfig (CardanoBlock StandardCrypto)
forall c.
CodecConfig ByronBlock
-> CodecConfig (ShelleyBlock (TPraos c) ShelleyEra)
-> CodecConfig (ShelleyBlock (TPraos c) AllegraEra)
-> CodecConfig (ShelleyBlock (TPraos c) MaryEra)
-> CodecConfig (ShelleyBlock (TPraos c) AlonzoEra)
-> CodecConfig (ShelleyBlock (Praos c) BabbageEra)
-> CodecConfig (ShelleyBlock (Praos c) ConwayEra)
-> CodecConfig (ShelleyBlock (Praos c) DijkstraEra)
-> CardanoCodecConfig c
CardanoCodecConfig
    (EpochSlots -> CodecConfig ByronBlock
ByronCodecConfig EpochSlots
epochSlots)
    CodecConfig (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    CodecConfig (ShelleyBlock (TPraos StandardCrypto) AllegraEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    CodecConfig (ShelleyBlock (TPraos StandardCrypto) MaryEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    CodecConfig (ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    CodecConfig (ShelleyBlock (Praos StandardCrypto) BabbageEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    CodecConfig (ShelleyBlock (Praos StandardCrypto) ConwayEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    CodecConfig (ShelleyBlock (Praos StandardCrypto) DijkstraEra)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig

dictNestedHdr ::
  forall a.
  NestedCtxt_ (CardanoBlock StandardCrypto) Header a ->
  Dict (Eq a, Show a)
dictNestedHdr :: forall a.
NestedCtxt_ (CardanoBlock StandardCrypto) Header a
-> Dict (Eq a, Show a)
dictNestedHdr = \case
  NCZ (CtxtByronBoundary{}) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCZ (CtxtByronRegular{}) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (TPraos StandardCrypto) ShelleyEra Header a
CtxtShelley) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (TPraos StandardCrypto) AllegraEra Header a
CtxtShelley)) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCS (NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (TPraos StandardCrypto) MaryEra Header a
CtxtShelley))) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCS (NCS (NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (TPraos StandardCrypto) AlonzoEra Header a
CtxtShelley)))) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCS (NCS (NCS (NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (Praos StandardCrypto) BabbageEra Header a
CtxtShelley))))) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCS (NCS (NCS (NCS (NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (Praos StandardCrypto) ConwayEra Header a
CtxtShelley)))))) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
  NCS (NCS (NCS (NCS (NCS (NCS (NCS (NCZ NestedCtxt_ x Header a
R:NestedCtxt_ShelleyBlockfa
  (Praos StandardCrypto) DijkstraEra Header a
CtxtShelley))))))) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict

{-------------------------------------------------------------------------------
  BinaryBlockInfo
-------------------------------------------------------------------------------}

prop_CardanoBinaryBlockInfo :: CardanoBlock StandardCrypto -> Property
prop_CardanoBinaryBlockInfo :: CardanoBlock StandardCrypto -> Property
prop_CardanoBinaryBlockInfo CardanoBlock StandardCrypto
blk =
  ByteString
encodedNestedHeader ByteString -> ByteString -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString
extractedHeader
 where
  BinaryBlockInfo{Word16
headerOffset :: Word16
headerOffset :: BinaryBlockInfo -> Word16
headerOffset, Word16
headerSize :: Word16
headerSize :: BinaryBlockInfo -> Word16
headerSize} =
    CardanoBlock StandardCrypto -> BinaryBlockInfo
forall blk. HasBinaryBlockInfo blk => blk -> BinaryBlockInfo
getBinaryBlockInfo CardanoBlock StandardCrypto
blk

  extractedHeader :: Lazy.ByteString
  extractedHeader :: ByteString
extractedHeader =
    Int64 -> ByteString -> ByteString
Lazy.take (Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
headerSize) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
      Int64 -> ByteString -> ByteString
Lazy.drop (Word16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
headerOffset) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
        Encoding -> ByteString
CBOR.toLazyByteString (CodecConfig (CardanoBlock StandardCrypto)
-> CardanoBlock StandardCrypto -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig (CardanoBlock StandardCrypto)
testCodecCfg CardanoBlock StandardCrypto
blk)

  encodedNestedHeader :: Lazy.ByteString
  encodedNestedHeader :: ByteString
encodedNestedHeader = case CodecConfig (CardanoBlock StandardCrypto)
-> DepPair (NestedCtxt Header (CardanoBlock StandardCrypto))
-> GenDepPair
     Serialised (NestedCtxt Header (CardanoBlock StandardCrypto))
forall (f :: MapKind) blk.
EncodeDiskDep f blk =>
CodecConfig blk -> DepPair (f blk) -> GenDepPair Serialised (f blk)
encodeDepPair CodecConfig (CardanoBlock StandardCrypto)
testCodecCfg (Header (CardanoBlock StandardCrypto)
-> DepPair (NestedCtxt Header (CardanoBlock StandardCrypto))
forall (f :: * -> *) blk.
HasNestedContent f blk =>
f blk -> DepPair (NestedCtxt f blk)
unnest (CardanoBlock StandardCrypto -> Header (CardanoBlock StandardCrypto)
forall blk. GetHeader blk => blk -> Header blk
getHeader CardanoBlock StandardCrypto
blk)) of
    GenDepPair NestedCtxt Header (CardanoBlock StandardCrypto) a
_ (Serialised ByteString
bytes) -> ByteString
bytes