{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-orphans #-}

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

import           Cardano.Chain.Block (ABlockOrBoundary (..))
import qualified Cardano.Chain.Block as CC.Block
import qualified Cardano.Chain.Update as CC.Update
import           Codec.CBOR.Write (toLazyByteString)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Constraint
import           Ouroboros.Consensus.Byron.Ledger hiding (byronProtocolVersion,
                     byronSoftwareVersion)
import           Ouroboros.Consensus.Byron.Node
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Node.Serialisation ()
import           Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..))
import qualified Test.Cardano.Chain.Genesis.Dummy as CC
import           Test.Consensus.Byron.Generators
import           Test.QuickCheck hiding (Result)
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.Corruption
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Serialisation.Roundtrip

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Byron"
    [ CodecConfig ByronBlock
-> (forall a.
    NestedCtxt_ ByronBlock 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)) =>
CodecConfig blk
-> (forall a. NestedCtxt_ blk Header a -> Dict (Eq a, Show a))
-> TestTree
roundtrip_all CodecConfig ByronBlock
testCodecCfg NestedCtxt_ ByronBlock Header a -> Dict (Eq a, Show a)
forall a. NestedCtxt_ ByronBlock Header a -> Dict (Eq a, Show a)
dictNestedHdr

    , TestName -> (ByronBlock -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"BinaryBlockInfo sanity check" ByronBlock -> Property
prop_byronBinaryBlockInfo

    , TestName -> [TestTree] -> TestTree
testGroup TestName
"Integrity"
        [ TestName -> (RegularBlock -> Corruption -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"detect corruption in RegularBlock" RegularBlock -> Corruption -> Property
prop_detectCorruption_RegularBlock
        ]
    ]
  where
    dictNestedHdr :: forall a. NestedCtxt_ ByronBlock Header a -> Dict (Eq a, Show a)
    dictNestedHdr :: forall a. NestedCtxt_ ByronBlock Header a -> Dict (Eq a, Show a)
dictNestedHdr (CtxtByronBoundary SizeInBytes
_) = Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict
    dictNestedHdr (CtxtByronRegular  SizeInBytes
_) = Dict (Eq a, Show a)
forall (a :: Constraint). a => Dict a
Dict

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

prop_byronBinaryBlockInfo :: ByronBlock -> Property
prop_byronBinaryBlockInfo :: ByronBlock -> Property
prop_byronBinaryBlockInfo ByronBlock
blk =
    ByteString
headerAnnotation 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 } =
      ByronBlock -> BinaryBlockInfo
byronBinaryBlockInfo ByronBlock
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
toLazyByteString (ByronBlock -> Encoding
encodeByronBlock ByronBlock
blk)

    headerAnnotation :: Lazy.ByteString
    headerAnnotation :: ByteString
headerAnnotation = ByteString -> ByteString
Lazy.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ case ByronBlock -> ABlockOrBoundary ByteString
byronBlockRaw ByronBlock
blk of
      ABOBBoundary ABoundaryBlock ByteString
b -> RawBoundaryHeader -> ByteString
forall a. ABoundaryHeader a -> a
CC.Block.boundaryHeaderAnnotation (RawBoundaryHeader -> ByteString)
-> RawBoundaryHeader -> ByteString
forall a b. (a -> b) -> a -> b
$ ABoundaryBlock ByteString -> RawBoundaryHeader
forall a. ABoundaryBlock a -> ABoundaryHeader a
CC.Block.boundaryHeader ABoundaryBlock ByteString
b
      ABOBBlock    ABlock ByteString
b -> AHeader ByteString -> ByteString
forall a. AHeader a -> a
CC.Block.headerAnnotation         (AHeader ByteString -> ByteString)
-> AHeader ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> AHeader ByteString
forall a. ABlock a -> AHeader a
CC.Block.blockHeader    ABlock ByteString
b

{-------------------------------------------------------------------------------
  Integrity
-------------------------------------------------------------------------------}

-- | Test that we can detect random bitflips in blocks.
--
-- We cannot do this for EBBs, as they are not signed nor have a hash, so we
-- only test with regular blocks.
prop_detectCorruption_RegularBlock :: RegularBlock -> Corruption -> Property
prop_detectCorruption_RegularBlock :: RegularBlock -> Corruption -> Property
prop_detectCorruption_RegularBlock (RegularBlock ByronBlock
blk) =
    (ByronBlock -> Encoding)
-> (forall s. Decoder s (ByteString -> ByronBlock))
-> (ByronBlock -> Bool)
-> ByronBlock
-> Corruption
-> Property
forall a.
Show a =>
(a -> Encoding)
-> (forall s. Decoder s (ByteString -> a))
-> (a -> Bool)
-> a
-> Corruption
-> Property
detectCorruption
      ByronBlock -> Encoding
encodeByronBlock
      (EpochSlots -> Decoder s (ByteString -> ByronBlock)
forall s. EpochSlots -> Decoder s (ByteString -> ByronBlock)
decodeByronBlock EpochSlots
epochSlots)
      (BlockConfig ByronBlock -> ByronBlock -> Bool
verifyBlockIntegrity (TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig ByronBlock
testCfg))
      ByronBlock
blk

-- | Matches the values used for the generators.
testCfg :: TopLevelConfig ByronBlock
testCfg :: TopLevelConfig ByronBlock
testCfg = ProtocolInfo ByronBlock -> TopLevelConfig ByronBlock
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig ProtocolInfo ByronBlock
protocolInfo
  where
    protocolInfo :: ProtocolInfo ByronBlock
    protocolInfo :: ProtocolInfo ByronBlock
protocolInfo =
      ProtocolParamsByron -> ProtocolInfo ByronBlock
protocolInfoByron (ProtocolParamsByron -> ProtocolInfo ByronBlock)
-> ProtocolParamsByron -> ProtocolInfo ByronBlock
forall a b. (a -> b) -> a -> b
$ ProtocolParamsByron {
          $sel:byronGenesis:ProtocolParamsByron :: Config
byronGenesis                = Config
CC.dummyConfig
        , $sel:byronPbftSignatureThreshold:ProtocolParamsByron :: Maybe PBftSignatureThreshold
byronPbftSignatureThreshold = PBftSignatureThreshold -> Maybe PBftSignatureThreshold
forall a. a -> Maybe a
Just (Double -> PBftSignatureThreshold
PBftSignatureThreshold Double
0.5)
        , $sel:byronProtocolVersion:ProtocolParamsByron :: ProtocolVersion
byronProtocolVersion        = Word16 -> Word16 -> Word8 -> ProtocolVersion
CC.Update.ProtocolVersion Word16
1 Word16
0 Word8
0
        , $sel:byronSoftwareVersion:ProtocolParamsByron :: SoftwareVersion
byronSoftwareVersion        = ApplicationName -> NumSoftwareVersion -> SoftwareVersion
CC.Update.SoftwareVersion (Text -> ApplicationName
CC.Update.ApplicationName Text
"Cardano Test") NumSoftwareVersion
2
        , $sel:byronLeaderCredentials:ProtocolParamsByron :: Maybe ByronLeaderCredentials
byronLeaderCredentials      = Maybe ByronLeaderCredentials
forall a. Maybe a
Nothing
        }

-- | Matches the values used for the generators.
testCodecCfg :: CodecConfig ByronBlock
testCodecCfg :: CodecConfig ByronBlock
testCodecCfg = TopLevelConfig ByronBlock -> CodecConfig ByronBlock
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig ByronBlock
testCfg