{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Cardano.Chain.Block.Size (
  tests,
)
where

import Cardano.Chain.Block
import Cardano.Ledger.Binary hiding (label)
import Cardano.Prelude
import qualified Data.ByteString as BS
import Data.String (IsString (..))
import Hedgehog (Gen, LabelName, failure, footnote, label, success)
import Test.Cardano.Chain.Block.Gen
import Test.Cardano.Chain.Common.Gen
import qualified Test.Cardano.Chain.Genesis.Gen as Genesis
import qualified Test.Cardano.Chain.Slotting.Gen as Slotting
import qualified Test.Cardano.Chain.Update.Gen as Update
import qualified Test.Cardano.Crypto.Gen as Crypto
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, eachOfTS)

encodedSizeTest ::
  forall a.
  Show a =>
  (a -> Encoding) ->
  (Proxy a -> Size) ->
  Gen a ->
  TSProperty
encodedSizeTest :: forall a.
Show a =>
(a -> Encoding) -> (Proxy a -> Size) -> Gen a -> TSProperty
encodedSizeTest a -> Encoding
encode Proxy a -> Size
encodedSize Gen a
gen = forall a.
(Show a, HasCallStack) =>
TestLimit -> Gen a -> (a -> PropertyT IO ()) -> TSProperty
eachOfTS
  TestLimit
300
  Gen a
gen
  forall a b. (a -> b) -> a -> b
$ \a
a -> case Size -> Either Size (Range Natural)
szSimplify (Proxy a -> Size
encodedSize (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) of
    Right rng :: Range Natural
rng@Range {Natural
lo :: forall b. Range b -> b
lo :: Natural
lo, Natural
hi :: forall b. Range b -> b
hi :: Natural
hi} ->
      let size :: Natural
          size :: Natural
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer (a -> Encoding
encode a
a))
       in if
            | Natural
size forall a. Ord a => a -> a -> Bool
< Natural
lo -> do
                forall (m :: * -> *). MonadTest m => [Char] -> m ()
footnote forall a b. (a -> b) -> a -> b
$ [Char]
"actual size not greater or equal the minimal size: " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
size forall a. [a] -> [a] -> [a]
++ [Char]
" ≱ " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
lo
                forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
            | Natural
size forall a. Ord a => a -> a -> Bool
> Natural
hi -> do
                forall (m :: * -> *). MonadTest m => [Char] -> m ()
footnote forall a b. (a -> b) -> a -> b
$ [Char]
"actual size not smaller or equal the maximal size: " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
size forall a. [a] -> [a] -> [a]
++ [Char]
" ≰ " forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
hi
                forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
            | Bool
otherwise -> do
                forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
LabelName -> m ()
label (Range Natural -> Natural -> LabelName
classifySize Range Natural
rng Natural
size)
                forall (m :: * -> *). MonadTest m => m ()
success
    Left Size
_ -> do
      forall (m :: * -> *). MonadTest m => [Char] -> m ()
footnote [Char]
"a thunk in size expression"
      forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
  where
    -- we can assume that lo ≤ size ≤ hi
    classifySize :: Range Natural -> Natural -> LabelName
    classifySize :: Range Natural -> Natural -> LabelName
classifySize Range {Natural
lo :: Natural
lo :: forall b. Range b -> b
lo, Natural
hi :: Natural
hi :: forall b. Range b -> b
hi} Natural
size =
      forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$
        [Char]
"lo: "
          forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
lo
          forall a. [a] -> [a] -> [a]
++ [Char]
" hi: "
          forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
hi
          forall a. [a] -> [a] -> [a]
++ [Char]
" size: "
          forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show Natural
s
          forall a. [a] -> [a] -> [a]
++ [Char]
" - "
          forall a. [a] -> [a] -> [a]
++ forall a b. (Show a, ConvertText [Char] b) => a -> b
show (Natural
s forall a. Num a => a -> a -> a
+ Natural
bucket)
      where
        bucket :: Natural
bucket =
          if Natural
hi forall a. Num a => a -> a -> a
- Natural
lo forall a. Ord a => a -> a -> Bool
>= Natural
5
            then (Natural
hi forall a. Num a => a -> a -> a
- Natural
lo) forall a. Integral a => a -> a -> a
`div` Natural
5
            else Natural
1
        s :: Natural
s = Natural
lo forall a. Num a => a -> a -> a
+ Natural
bucket forall a. Num a => a -> a -> a
* ((Natural
size forall a. Num a => a -> a -> a
- Natural
lo) forall a. Integral a => a -> a -> a
`div` Natural
bucket)

encodedSizeTestEncCBOR ::
  forall a.
  (EncCBOR a, Show a) =>
  Gen a ->
  TSProperty
encodedSizeTestEncCBOR :: forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR =
  forall a.
Show a =>
(a -> Encoding) -> (Proxy a -> Size) -> Gen a -> TSProperty
encodedSizeTest forall a. EncCBOR a => a -> Encoding
encCBOR forall a. EncCBOR a => Proxy a -> Size
szGreedy

ts_prop_sizeProtocolMagicId :: TSProperty
ts_prop_sizeProtocolMagicId :: TSProperty
ts_prop_sizeProtocolMagicId =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen ProtocolMagicId
Crypto.genProtocolMagicId

ts_prop_sizeEpochAndSlotCount :: TSProperty
ts_prop_sizeEpochAndSlotCount :: TSProperty
ts_prop_sizeEpochAndSlotCount =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR (Gen EpochSlots
Slotting.genEpochSlots forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= EpochSlots -> GenT Identity EpochAndSlotCount
Slotting.genEpochAndSlotCount)

ts_prop_sizeChainDifficulty :: TSProperty
ts_prop_sizeChainDifficulty :: TSProperty
ts_prop_sizeChainDifficulty = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen ChainDifficulty
genChainDifficulty

ts_prop_sizeHeaderHash :: TSProperty
ts_prop_sizeHeaderHash :: TSProperty
ts_prop_sizeHeaderHash = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen HeaderHash
genHeaderHash

ts_prop_sizeSlotNumber :: TSProperty
ts_prop_sizeSlotNumber :: TSProperty
ts_prop_sizeSlotNumber = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen SlotNumber
Slotting.genSlotNumber

ts_prop_sizeProtocolVersion :: TSProperty
ts_prop_sizeProtocolVersion :: TSProperty
ts_prop_sizeProtocolVersion = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen ProtocolVersion
Update.genProtocolVersion

ts_prop_sizeApplicationName :: TSProperty
ts_prop_sizeApplicationName :: TSProperty
ts_prop_sizeApplicationName = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen ApplicationName
Update.genApplicationName

ts_prop_sizeSoftwareVersion :: TSProperty
ts_prop_sizeSoftwareVersion :: TSProperty
ts_prop_sizeSoftwareVersion = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen SoftwareVersion
Update.genSoftwareVersion

ts_prop_sizeProof :: TSProperty
ts_prop_sizeProof :: TSProperty
ts_prop_sizeProof = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR (Gen ProtocolMagicId
Crypto.genProtocolMagicId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProtocolMagicId -> GenT Identity Proof
genProof)

ts_prop_sizeVerificationKey :: TSProperty
ts_prop_sizeVerificationKey :: TSProperty
ts_prop_sizeVerificationKey = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen VerificationKey
Crypto.genVerificationKey

ts_prop_sizeToSign :: TSProperty
ts_prop_sizeToSign :: TSProperty
ts_prop_sizeToSign =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR forall a b. (a -> b) -> a -> b
$
    ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ProtocolMagicId
Crypto.genProtocolMagicId forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpochSlots
Slotting.genEpochSlots)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ProtocolMagicId -> EpochSlots -> GenT Identity ToSign
genToSign

ts_prop_sizeBlockVersions :: TSProperty
ts_prop_sizeBlockVersions :: TSProperty
ts_prop_sizeBlockVersions =
  forall a.
Show a =>
(a -> Encoding) -> (Proxy a -> Size) -> Gen a -> TSProperty
encodedSizeTest
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ProtocolVersion -> SoftwareVersion -> Encoding
encCBORBlockVersions)
    (forall a b c. (Proxy a -> Proxy b -> c) -> Proxy (a, b) -> c
uncurryP Proxy ProtocolVersion -> Proxy SoftwareVersion -> Size
encCBORBlockVersionsSize)
    ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ProtocolVersion
Update.genProtocolVersion forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SoftwareVersion
Update.genSoftwareVersion)

ts_prop_sizeEpochNumber :: TSProperty
ts_prop_sizeEpochNumber :: TSProperty
ts_prop_sizeEpochNumber =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen EpochNumber
Slotting.genEpochNumber

-- | test @Signature EpochNumber@ which is a part of 'ACertificate'
ts_prop_sizeEpochNumberSignature :: TSProperty
ts_prop_sizeEpochNumberSignature :: TSProperty
ts_prop_sizeEpochNumberSignature =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR forall a b. (a -> b) -> a -> b
$
    Gen ProtocolMagicId
Crypto.genProtocolMagicId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a.
EncCBOR a =>
ProtocolMagicId -> Gen a -> Gen (Signature a)
Crypto.genSignature Gen EpochSlots
Slotting.genEpochSlots

ts_prop_sizeToSignSignature :: TSProperty
ts_prop_sizeToSignSignature :: TSProperty
ts_prop_sizeToSignSignature =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR forall a b. (a -> b) -> a -> b
$
    do
      ProtocolMagicId
pm <- Gen ProtocolMagicId
Crypto.genProtocolMagicId
      EpochSlots
es <- Gen EpochSlots
Slotting.genEpochSlots
      forall a.
EncCBOR a =>
ProtocolMagicId -> Gen a -> Gen (Signature a)
Crypto.genSignature ProtocolMagicId
pm (ProtocolMagicId -> EpochSlots -> GenT Identity ToSign
genToSign ProtocolMagicId
pm EpochSlots
es)

ts_prop_sizeBlockSignature :: TSProperty
ts_prop_sizeBlockSignature :: TSProperty
ts_prop_sizeBlockSignature =
  forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR forall a b. (a -> b) -> a -> b
$
    ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ProtocolMagicId
Crypto.genProtocolMagicId forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpochSlots
Slotting.genEpochSlots)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ProtocolMagicId -> EpochSlots -> GenT Identity BlockSignature
genBlockSignature

--
-- Header
--

ts_prop_sizeHeader :: TSProperty
ts_prop_sizeHeader :: TSProperty
ts_prop_sizeHeader =
  forall a.
Show a =>
(a -> Encoding) -> (Proxy a -> Size) -> Gen a -> TSProperty
encodedSizeTest
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry EpochSlots -> Header -> Encoding
encCBORHeader)
    (forall a b c. (Proxy a -> Proxy b -> c) -> Proxy (a, b) -> c
uncurryP forall a. Proxy EpochSlots -> Proxy (AHeader a) -> Size
encCBORHeaderSize)
    forall a b. (a -> b) -> a -> b
$ do
      ProtocolMagicId
protocolMagicId <- Gen ProtocolMagicId
Crypto.genProtocolMagicId
      EpochSlots
epochSlots <- Gen EpochSlots
Slotting.genEpochSlots
      Header
header <- ProtocolMagicId -> EpochSlots -> Gen Header
genHeader ProtocolMagicId
protocolMagicId EpochSlots
epochSlots
      forall (m :: * -> *) a. Monad m => a -> m a
return (EpochSlots
epochSlots, Header
header)

--
-- ABoundaryHeader
--

ts_prop_sizeGenesisHash :: TSProperty
ts_prop_sizeGenesisHash :: TSProperty
ts_prop_sizeGenesisHash = forall a. (EncCBOR a, Show a) => Gen a -> TSProperty
encodedSizeTestEncCBOR Gen GenesisHash
Genesis.genGenesisHash

ts_prop_sizeABoundaryHeader :: TSProperty
ts_prop_sizeABoundaryHeader :: TSProperty
ts_prop_sizeABoundaryHeader =
  forall a.
Show a =>
(a -> Encoding) -> (Proxy a -> Size) -> Gen a -> TSProperty
encodedSizeTest
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. ProtocolMagicId -> ABoundaryHeader a -> Encoding
encCBORABoundaryHeader)
    (forall a b c. (Proxy a -> Proxy b -> c) -> Proxy (a, b) -> c
uncurryP forall a.
Proxy ProtocolMagicId -> Proxy (ABoundaryHeader a) -> Size
encCBORABoundaryHeaderSize)
    ( (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ProtocolMagicId
Crypto.genProtocolMagicId
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (ABoundaryHeader ())
genBoundaryHeader
    )

--
-- ABlockOrBoundaryHdr
--

ts_prop_sizeABlockOrBoundaryHdr :: TSProperty
ts_prop_sizeABlockOrBoundaryHdr :: TSProperty
ts_prop_sizeABlockOrBoundaryHdr =
  forall a.
Show a =>
(a -> Encoding) -> (Proxy a -> Size) -> Gen a -> TSProperty
encodedSizeTest
    ABlockOrBoundaryHdr ByteString -> Encoding
encCBORABlockOrBoundaryHdr
    forall a. Proxy (ABlockOrBoundaryHdr a) -> Size
encCBORABlockOrBoundaryHdrSize
    forall a b. (a -> b) -> a -> b
$ ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ProtocolMagicId
Crypto.genProtocolMagicId forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EpochSlots
Slotting.genEpochSlots)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ProtocolMagicId
-> EpochSlots -> GenT Identity (ABlockOrBoundaryHdr ByteString)
genABlockOrBoundaryHdr

--
-- Utils
--

uncurryP :: (Proxy a -> Proxy b -> c) -> Proxy (a, b) -> c
uncurryP :: forall a b c. (Proxy a -> Proxy b -> c) -> Proxy (a, b) -> c
uncurryP Proxy a -> Proxy b -> c
f Proxy (a, b)
p = Proxy a -> Proxy b -> c
f (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (a, b)
p) (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (a, b)
p)

--
-- Tests
--

tests :: TSGroup
tests :: TSGroup
tests = $$discoverPropArg