{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 qualified Test.Consensus.Cardano.Examples as Cardano.Examples
import           Test.Consensus.Cardano.Generators (epochSlots)
import           Test.Consensus.Cardano.MockCrypto (MockCryptoCompatByron)
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 Crypto)
-> Examples (CardanoBlock Crypto) -> [TestTree]
forall blk.
(SerialiseDiskConstraints blk, Eq blk, Show blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk -> Examples blk -> [TestTree]
examplesRoundtrip CodecConfig (CardanoBlock Crypto)
Cardano.Examples.codecConfig Examples (CardanoBlock Crypto)
Cardano.Examples.examples
    , (TestName -> ShouldCheckCBORValidity)
-> CodecConfig (CardanoBlock MockCryptoCompatByron)
-> (forall a.
    NestedCtxt_ (CardanoBlock MockCryptoCompatByron) Header a
    -> Dict (Eq a, Show a))
-> TestTree
forall blk.
(SerialiseDiskConstraints blk, SerialiseNodeToNodeConstraints blk,
 SerialiseNodeToClientConstraints blk,
 Show (BlockNodeToNodeVersion blk),
 Show (BlockNodeToClientVersion blk), StandardHash blk,
 GetHeader blk, Arbitrary' blk, Arbitrary' (Header blk),
 Arbitrary' (HeaderHash blk), Arbitrary' (LedgerState blk),
 Arbitrary' (AnnTip blk),
 Arbitrary' (ChainDepState (BlockProtocol blk)),
 ArbitraryWithVersion (BlockNodeToNodeVersion blk) 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) (SomeSecond BlockQuery blk),
 ArbitraryWithVersion
   (BlockNodeToClientVersion blk) (SomeResult blk),
 ArbitraryWithVersion
   (QueryVersion, BlockNodeToClientVersion blk)
   (SomeSecond Query blk)) =>
(TestName -> ShouldCheckCBORValidity)
-> CodecConfig blk
-> (forall a. NestedCtxt_ blk Header a -> Dict (Eq a, Show a))
-> TestTree
roundtrip_all_skipping TestName -> ShouldCheckCBORValidity
result CodecConfig (CardanoBlock MockCryptoCompatByron)
testCodecCfg NestedCtxt_ (CardanoBlock MockCryptoCompatByron) Header a
-> Dict (Eq a, Show a)
forall a.
NestedCtxt_ (CardanoBlock MockCryptoCompatByron) Header a
-> Dict (Eq a, Show a)
dictNestedHdr
    , TestName
-> (CardanoBlock MockCryptoCompatByron -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"BinaryBlockInfo sanity check" CardanoBlock MockCryptoCompatByron -> Property
prop_CardanoBinaryBlockInfo
    ]
  where
    -- See https://github.com/IntersectMBO/cardano-ledger/issues/3800
    result :: TestName -> ShouldCheckCBORValidity
result TestName
"roundtrip Result" = ShouldCheckCBORValidity
DoNotCheckCBORValidity
    result TestName
_                  = ShouldCheckCBORValidity
CheckCBORValidity

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

dictNestedHdr ::
     forall a.
     NestedCtxt_ (CardanoBlock MockCryptoCompatByron) Header a
  -> Dict (Eq a, Show a)
dictNestedHdr :: forall a.
NestedCtxt_ (CardanoBlock MockCryptoCompatByron) 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 MockCryptoCompatByron)
  (ShelleyEra MockCryptoCompatByron)
  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 MockCryptoCompatByron)
  (AllegraEra MockCryptoCompatByron)
  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 MockCryptoCompatByron)
  (MaryEra MockCryptoCompatByron)
  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 MockCryptoCompatByron)
  (AlonzoEra MockCryptoCompatByron)
  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 MockCryptoCompatByron)
  (BabbageEra MockCryptoCompatByron)
  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 MockCryptoCompatByron)
  (ConwayEra MockCryptoCompatByron)
  Header
  a
CtxtShelley)))))) -> Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict

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

prop_CardanoBinaryBlockInfo :: CardanoBlock MockCryptoCompatByron -> Property
prop_CardanoBinaryBlockInfo :: CardanoBlock MockCryptoCompatByron -> Property
prop_CardanoBinaryBlockInfo CardanoBlock MockCryptoCompatByron
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 MockCryptoCompatByron -> BinaryBlockInfo
forall blk. HasBinaryBlockInfo blk => blk -> BinaryBlockInfo
getBinaryBlockInfo CardanoBlock MockCryptoCompatByron
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 MockCryptoCompatByron)
-> CardanoBlock MockCryptoCompatByron -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig (CardanoBlock MockCryptoCompatByron)
testCodecCfg CardanoBlock MockCryptoCompatByron
blk)

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