-- | The sizes the mempool charges for an endorser block agree with
-- the bytes 'encodeEndorserBlock' writes.
module Test.Consensus.Shelley.EndorserBlock (tests) where

import Cardano.Binary (ToCBOR (..))
import Cardano.Crypto.Hash (Hash (UnsafeHash))
import Cardano.Ledger.Core (TopTx, Tx)
import Cardano.Ledger.Dijkstra (DijkstraEra)
import qualified Codec.CBOR.Encoding as CBOR
import Codec.CBOR.Write (toStrictByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as SBS
import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..))
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , EndorserBlock
  , TxHash
  , encodeEndorserBlock
  , endorserBlockReferences
  , mkEndorserBlock
  , referencesCapacity
  , sizeEndorserBlockReference
  )
import Ouroboros.Consensus.Shelley.Ledger.Forge (ebTxBytes)
import Ouroboros.Consensus.Shelley.Ledger.Mempool (txByteSizeWithOverhead)
import Test.Cardano.Ledger.Dijkstra.Arbitrary ()
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Endorser block"
    [ [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"sizeEndorserBlockReference consistent with encodeEndorserBlock"
        Property
prop_referenceSizeConsistent
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"encodeEndorserBlock framing bounded by what referencesCapacity subtracts"
        Property
prop_ebFramingBounded
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"referencesCapacity floors at zero instead of wrapping"
        Property
prop_referencesCapacityFloorsAtZero
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
        [Char]
"the tx size a forged endorser block records does not exceed the tx size the mempool records"
        -- Few runs: the generator of Dijkstra transactions is slow.
        (Int -> (Tx TopTx DijkstraEra -> Property) -> Property
forall prop. Testable prop => Int -> prop -> Property
withNumTests Int
10 Tx TopTx DijkstraEra -> Property
prop_dijkstraEbTxSizeBounded)
    ]

genTxHash :: Gen TxHash
genTxHash :: Gen TxHash
genTxHash = ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> TxHash)
-> ([Word8] -> ShortByteString) -> [Word8] -> TxHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
SBS.pack ([Word8] -> TxHash) -> Gen [Word8] -> Gen TxHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
32 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary

-- | A tx size with good coverage of CBOR encoding boundaries.
-- Values 0-23 encode in 1 byte, 24-255 in 2 bytes, 256-65535 in 3 bytes.
genTxBytesSize :: Gen BytesSize
genTxBytesSize :: Gen Word32
genTxBytesSize =
  [(Int, Gen Word32)] -> Gen Word32
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
55) -- smallest transaction
    , (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
16384) -- largest transaction
    , (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
255) -- boundary: last 2-byte CBOR uint
    , (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
256) -- boundary: first 3-byte CBOR uint
    , (Int
1, Word32 -> Gen Word32
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
65536) -- first 5-byte CBOR uint
    , (Int
5, (Word32, Word32) -> Gen Word32
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Word32
55, Word32
16384))
    ]

-- | The number of references with good coverage of CBOR encoding boundaries for
-- the map length: 0-23 in 1 byte, 24-255 in 2 bytes, 256 and more in 3 bytes.
genNumReferences :: Gen Int
genNumReferences :: Gen Int
genNumReferences =
  [(Int, Gen Int)] -> Gen Int
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0)
    , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1)
    , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
23)
    , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
24)
    , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
255)
    , (Int
1, Int -> Gen Int
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
256)
    , (Int
3, (Int, Int) -> Gen Int
chooseInt (Int
0, Int
1000))
    ]

genEndorserBlock :: Int -> Gen EndorserBlock
genEndorserBlock :: Int -> Gen EndorserBlock
genEndorserBlock Int
numTxs =
  [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock ([(TxHash, Word32)] -> EndorserBlock)
-> Gen [(TxHash, Word32)] -> Gen EndorserBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (TxHash, Word32) -> Gen [(TxHash, Word32)]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
numTxs ((,) (TxHash -> Word32 -> (TxHash, Word32))
-> Gen TxHash -> Gen (Word32 -> (TxHash, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxHash
genTxHash Gen (Word32 -> (TxHash, Word32))
-> Gen Word32 -> Gen (TxHash, Word32)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
genTxBytesSize)

-- | The per-reference charge 'sizeEndorserBlockReference', which the mempool charges a
-- transaction for its reference, agrees with the bytes 'encodeEndorserBlock' writes
-- for that reference.
prop_referenceSizeConsistent :: Property
prop_referenceSizeConsistent :: Property
prop_referenceSizeConsistent =
  Gen (TxHash, Word32) -> ((TxHash, Word32) -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ((,) (TxHash -> Word32 -> (TxHash, Word32))
-> Gen TxHash -> Gen (Word32 -> (TxHash, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxHash
genTxHash Gen (Word32 -> (TxHash, Word32))
-> Gen Word32 -> Gen (TxHash, Word32)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Word32
genTxBytesSize) (((TxHash, Word32) -> Property) -> Property)
-> ((TxHash, Word32) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \(TxHash
txHash, Word32
txSize) ->
    let encoded :: ByteString
encoded = Encoding -> ByteString
toStrictByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ TxHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR TxHash
txHash Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 Word32
txSize
        ByteSize32 Word32
estimatedSize = ByteSize32 -> ByteSize32
sizeEndorserBlockReference (Word32 -> ByteSize32
ByteSize32 Word32
txSize)
     in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
          ([Char]
"reference: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (TxHash, Word32) -> [Char]
forall a. Show a => a -> [Char]
show (TxHash
txHash, Word32
txSize))
          (Word32
estimatedSize Word32 -> Word32 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
encoded))

-- | Whatever 'encodeEndorserBlock' writes around the references stays within
-- 'maxFraming'.
prop_ebFramingBounded :: Property
prop_ebFramingBounded :: Property
prop_ebFramingBounded =
  Gen EndorserBlock -> (EndorserBlock -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (Gen Int
genNumReferences Gen Int -> (Int -> Gen EndorserBlock) -> Gen EndorserBlock
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Gen EndorserBlock
genEndorserBlock) ((EndorserBlock -> Property) -> Property)
-> (EndorserBlock -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \EndorserBlock
eb ->
    let actualSize :: Word32
actualSize = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length (Encoding -> ByteString
toStrictByteString (EndorserBlock -> Encoding
encodeEndorserBlock EndorserBlock
eb))
        itemsSize :: Word32
itemsSize =
          [Word32] -> Word32
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
            [ ByteSize32 -> Word32
unByteSize32 (ByteSize32 -> ByteSize32
sizeEndorserBlockReference (Word32 -> ByteSize32
ByteSize32 Word32
txSize))
            | (TxHash
_txHash, Word32
txSize) <- EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb
            ]
        framing :: Word32
framing = Word32
actualSize Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
itemsSize
     in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
          ([Char]
"references: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([(TxHash, Word32)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb)) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", framing: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
framing)
          (Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Word32
actualSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word32
itemsSize Bool -> Bool -> Bool
&& Word32
framing Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
maxFraming)

-- | The framing 'referencesCapacity' subtracts from a parameter. That amount is
-- monotonic in the parameter, so 'maxBound' gives the most.
maxFraming :: BytesSize
maxFraming :: Word32
maxFraming = Word32
capacity Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32 -> Word32
referencesCapacity Word32
capacity
 where
  capacity :: Word32
capacity = Word32
forall a. Bounded a => a
maxBound

-- | A @maxEndorserBlockReferencesSize@ at or below the framing yields a zero
-- references capacity, so nothing fits. It never wraps around to \"no limit\",
-- which 'Data.Word.Word32' subtraction would do for a parameter of 0.
prop_referencesCapacityFloorsAtZero :: Property
prop_referencesCapacityFloorsAtZero :: Property
prop_referencesCapacityFloorsAtZero =
  Gen Word32 -> (Word32 -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Word32
genParamLimit ((Word32 -> Property) -> Property)
-> (Word32 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Word32
paramLimit ->
    let capacity :: Word32
capacity = Word32 -> Word32
referencesCapacity Word32
paramLimit
     in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"capacity: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
capacity) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
            [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"capacity must never exceed the parameter (wrap-around)" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
                  Word32
capacity Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
paramLimit
            , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"a parameter within the framing must yield zero capacity" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                Word32
paramLimit Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
maxFraming Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||. Word32
capacity Word32 -> Word32 -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Word32
0
            ]
 where
  -- Weighted towards the boundary a plain subtraction wraps on.
  genParamLimit :: Gen Word32
genParamLimit =
    [(Int, Gen Word32)] -> Gen Word32
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
4, (Word32, Word32) -> Gen Word32
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Word32
0, Word32
maxFraming))
      , (Int
1, (Word32, Word32) -> Gen Word32
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Word32
maxFraming Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
1, Word32
forall a. Bounded a => a
maxBound))
      ]

-- | The length of the 'ebTxBytes' of a Dijkstra transaction never exceeds
-- its 'txByteSizeWithOverhead', which 'txEbMeasureDijkstra' reserves for the
-- reference.
--
-- The ledger computes 'sizeTxF' from one encoding and 'serialize'' uses
-- another, so a ledger change can make the two disagree.
prop_dijkstraEbTxSizeBounded :: Tx TopTx DijkstraEra -> Property
prop_dijkstraEbTxSizeBounded :: Tx TopTx DijkstraEra -> Property
prop_dijkstraEbTxSizeBounded Tx TopTx DijkstraEra
tx =
  [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"EB tx size: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ebTxSize [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", mempool tx size: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
mempoolTxSize) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
    Int
ebTxSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mempoolTxSize
 where
  ebTxSize :: Int
ebTxSize = ByteString -> Int
BS.length (Tx TopTx DijkstraEra -> ByteString
forall era. EraTx era => Tx TopTx era -> ByteString
ebTxBytes Tx TopTx DijkstraEra
tx)
  mempoolTxSize :: Int
mempoolTxSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tx TopTx DijkstraEra -> Word32
forall era. EraTx era => Tx TopTx era -> Word32
txByteSizeWithOverhead Tx TopTx DijkstraEra
tx)