{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Tests of LeiosFetch's codec: the bounds and CBOR encodings it accepts.
module Test.Consensus.Leios.LeiosFetch.Codec (tests) where

import Cardano.Binary (ToCBOR (..))
import Cardano.Crypto.Hash (Hash (UnsafeHash), castHash, hashToBytes, hashWith)
import Cardano.Ledger.Hashes (HASH)
import qualified Codec.CBOR.Encoding as CBOR
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR
import Data.Bits (shiftL, shiftR, (.|.))
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS
import Data.Containers.ListUtils (nubOrd)
import Data.Functor ((<&>))
import Data.List (inits, sort, tails)
import Data.Maybe (isJust)
import qualified Data.Vector.Strict as V
import Data.Word (Word16, Word32, Word64, Word8)
import Network.TypedProtocol.Codec
  ( ActiveState
  , AnnotatedCodec
  , Annotator (..)
  , CodecF (..)
  , SomeMessage (..)
  , StateToken
  , runDecoder
  )
import Ouroboros.Consensus.Block (SlotNo (..))
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , EndorserBlock
  , EndorserBlockHash
  , LeiosPoint (..)
  , LeiosTx (..)
  , TxHash
  , decodeEndorserBlock
  , decodeLeiosPoint
  , decodeLeiosTx
  , encodeEndorserBlock
  , encodeEndorserBlockSize
  , encodeLeiosPoint
  , encodeLeiosTx
  , endorserBlockHash
  , endorserBlockReferences
  , maxEndorserBlockBytesSize
  , mkEndorserBlock
  )
import Ouroboros.Consensus.MiniProtocol.LeiosFetch.Type
import Ouroboros.Network.Protocol.Limits (ProtocolSizeLimits (..))
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
  ( Gen
  , Property
  , arbitrary
  , choose
  , conjoin
  , counterexample
  , elements
  , forAllShrink
  , ioProperty
  , listOf
  , listOf1
  , oneof
  , shrink
  , shrinkList
  , testProperty
  , vectorOf
  , (===)
  )
import Test.Util.Serialisation.CBOR (definite, definiteMap, indefinite, indefiniteMap)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"codec"
    [ [Char] -> [TestTree] -> TestTree
testGroup
        [Char]
"the codec accepts either CBOR encoding of a list or map"
        [ [Char] -> Assertion -> TestTree
testCase [Char]
"definite message, indefinite txs" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Encoding
txsKey, [Encoding] -> Encoding
indefinite [Encoding]
twoTxs])
              IO (Maybe [LeiosTx]) -> (Maybe [LeiosTx] -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe [LeiosTx] -> Maybe [LeiosTx] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [LeiosTx] -> Maybe [LeiosTx]
forall a. a -> Maybe a
Just [LeiosTx
txA, LeiosTx
txB])
        , [Char] -> Assertion -> TestTree
testCase [Char]
"indefinite message, definite txs" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec ([Encoding] -> Encoding
indefinite [Encoding
txsKey, [Encoding] -> Encoding
definite [Encoding]
twoTxs])
              IO (Maybe [LeiosTx]) -> (Maybe [LeiosTx] -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe [LeiosTx] -> Maybe [LeiosTx] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [LeiosTx] -> Maybe [LeiosTx]
forall a. a -> Maybe a
Just [LeiosTx
txA, LeiosTx
txB])
        , [Char] -> Assertion -> TestTree
testCase [Char]
"indefinite message, indefinite txs" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec ([Encoding] -> Encoding
indefinite [Encoding
txsKey, [Encoding] -> Encoding
indefinite [Encoding]
twoTxs])
              IO (Maybe [LeiosTx]) -> (Maybe [LeiosTx] -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe [LeiosTx] -> Maybe [LeiosTx] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [LeiosTx] -> Maybe [LeiosTx]
forall a. a -> Maybe a
Just [LeiosTx
txA, LeiosTx
txB])
        , [Char] -> Assertion -> TestTree
testCase [Char]
"rejects indefinite txs past the bound" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec
              ([Encoding] -> Encoding
definite [Encoding
txsKey, [Encoding] -> Encoding
indefinite ([Encoding]
twoTxs [Encoding] -> [Encoding] -> [Encoding]
forall a. Semigroup a => a -> a -> a
<> [LeiosTx -> Encoding
encodeLeiosTx LeiosTx
txA])])
              IO (Maybe [LeiosTx]) -> (Maybe [LeiosTx] -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe [LeiosTx] -> Maybe [LeiosTx] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe [LeiosTx]
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"rejects an indefinite message with an extra field" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec ([Encoding] -> Encoding
indefinite [Encoding
txsKey, [Encoding] -> Encoding
definite [Encoding]
twoTxs, Word -> Encoding
CBOR.encodeWord Word
0])
              IO (Maybe [LeiosTx]) -> (Maybe [LeiosTx] -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe [LeiosTx] -> Maybe [LeiosTx] -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe [LeiosTx]
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"an indefinite point" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe LeiosPoint)
decodeMsgLeiosBlockRequestViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
1, (LeiosPoint, Encoding) -> Encoding
forall a b. (a, b) -> b
snd (LeiosPoint, Encoding)
onePoint])
              IO (Maybe LeiosPoint)
-> (Maybe LeiosPoint -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe LeiosPoint -> Maybe LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosPoint -> Maybe LeiosPoint
forall a. a -> Maybe a
Just ((LeiosPoint, Encoding) -> LeiosPoint
forall a b. (a, b) -> a
fst (LeiosPoint, Encoding)
onePoint))
        , [Char] -> Assertion -> TestTree
testCase [Char]
"a definite endorser block" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, (EndorserBlock, Encoding) -> Encoding
forall a b. (a, b) -> b
snd (EndorserBlock, Encoding)
oneRefEb])
              IO (Maybe EndorserBlock)
-> (Maybe EndorserBlock -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe EndorserBlock -> Maybe EndorserBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= EndorserBlock -> Maybe EndorserBlock
forall a. a -> Maybe a
Just ((EndorserBlock, Encoding) -> EndorserBlock
forall a b. (a, b) -> a
fst (EndorserBlock, Encoding)
oneRefEb))
        , [Char] -> Assertion -> TestTree
testCase [Char]
"keeps the bytes of an indefinite endorser block" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
            let eb :: Encoding
eb = [Encoding] -> Encoding
indefiniteMap [ByteString -> Encoding
reference (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
7)]
            decoded <- Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, Encoding
eb])
            fmap (CBOR.toStrictByteString . encodeEndorserBlock) decoded
              @?= Just (CBOR.toStrictByteString eb)
            -- The same reference as 'oneRefEb', but other bytes.
            assertBool "hashes the bytes received" $
              fmap endorserBlockHash decoded /= Just (endorserBlockHash (fst oneRefEb))
        , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty
            [Char]
"slices exactly the bytes of an endorser block out of its MsgLeiosBlock"
            Property
prop_slicesEndorserBlockFromMessage
        , [Char] -> Assertion -> TestTree
testCase [Char]
"rejects an empty endorser block" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, [Encoding] -> Encoding
definiteMap []])
              IO (Maybe EndorserBlock)
-> (Maybe EndorserBlock -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe EndorserBlock -> Maybe EndorserBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe EndorserBlock
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"rejects an endorser block naming a transaction twice" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec
              ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, [Encoding] -> Encoding
definiteMap (Int -> Encoding -> [Encoding]
forall a. Int -> a -> [a]
replicate Int
2 (ByteString -> Encoding
reference (Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
7)))])
              IO (Maybe EndorserBlock)
-> (Maybe EndorserBlock -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe EndorserBlock -> Maybe EndorserBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe EndorserBlock
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"a definite bitmaps map" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe (LeiosPoint, TxBitmaps))
decodeMsgLeiosBlockTxsRequestViaLeiosFetchCodec
              ([Encoding] -> Encoding
definite [Encoding
txsRequestKey, Encoding
somePoint, [Encoding] -> Encoding
definiteMap [Encoding
bitmap0]])
              IO (Maybe (LeiosPoint, TxBitmaps))
-> (Maybe (LeiosPoint, TxBitmaps) -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe (LeiosPoint, TxBitmaps)
-> Maybe (LeiosPoint, TxBitmaps) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (LeiosPoint, TxBitmaps) -> Maybe (LeiosPoint, TxBitmaps)
forall a. a -> Maybe a
Just ((LeiosPoint, Encoding) -> LeiosPoint
forall a b. (a, b) -> a
fst (LeiosPoint, Encoding)
onePoint, [(Word16
0, Word64
1)]))
        , [Char] -> Assertion -> TestTree
testCase [Char]
"an indefinite bitmaps map" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe (LeiosPoint, TxBitmaps))
decodeMsgLeiosBlockTxsRequestViaLeiosFetchCodec
              ([Encoding] -> Encoding
definite [Encoding
txsRequestKey, Encoding
somePoint, [Encoding] -> Encoding
indefiniteMap [Encoding
bitmap0]])
              IO (Maybe (LeiosPoint, TxBitmaps))
-> (Maybe (LeiosPoint, TxBitmaps) -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe (LeiosPoint, TxBitmaps)
-> Maybe (LeiosPoint, TxBitmaps) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (LeiosPoint, TxBitmaps) -> Maybe (LeiosPoint, TxBitmaps)
forall a. a -> Maybe a
Just ((LeiosPoint, Encoding) -> LeiosPoint
forall a b. (a, b) -> a
fst (LeiosPoint, Encoding)
onePoint, [(Word16
0, Word64
1)]))
        , [Char] -> Assertion -> TestTree
testCase [Char]
"rejects indefinite bitmaps past the bound" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe (LeiosPoint, TxBitmaps))
decodeMsgLeiosBlockTxsRequestViaLeiosFetchCodec
              ([Encoding] -> Encoding
definite [Encoding
txsRequestKey, Encoding
somePoint, [Encoding] -> Encoding
indefiniteMap [Encoding
bitmap0, Encoding
bitmap1]])
              IO (Maybe (LeiosPoint, TxBitmaps))
-> (Maybe (LeiosPoint, TxBitmaps) -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe (LeiosPoint, TxBitmaps)
-> Maybe (LeiosPoint, TxBitmaps) -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe (LeiosPoint, TxBitmaps)
forall a. Maybe a
Nothing)
        ]
    , [Char] -> [TestTree] -> TestTree
testGroup
        [Char]
"the codec refuses a hash that is not 32 bytes"
        [ [Char] -> Assertion -> TestTree
testCase [Char]
"a tx hash of 31 bytes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, Int -> Encoding
ebReferencing Int
31])
              IO (Maybe EndorserBlock)
-> (Maybe EndorserBlock -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe EndorserBlock -> Maybe EndorserBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe EndorserBlock
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"a tx hash of 33 bytes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, Int -> Encoding
ebReferencing Int
33])
              IO (Maybe EndorserBlock)
-> (Maybe EndorserBlock -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe EndorserBlock -> Maybe EndorserBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe EndorserBlock
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"an endorser block hash of 31 bytes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe LeiosPoint)
decodeMsgLeiosBlockRequestViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
1, Int -> Encoding
pointOf Int
31])
              IO (Maybe LeiosPoint)
-> (Maybe LeiosPoint -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe LeiosPoint -> Maybe LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe LeiosPoint
forall a. Maybe a
Nothing)
        , [Char] -> Assertion -> TestTree
testCase [Char]
"an endorser block hash of 33 bytes" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
            Encoding -> IO (Maybe LeiosPoint)
decodeMsgLeiosBlockRequestViaLeiosFetchCodec ([Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
1, Int -> Encoding
pointOf Int
33])
              IO (Maybe LeiosPoint)
-> (Maybe LeiosPoint -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe LeiosPoint -> Maybe LeiosPoint -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe LeiosPoint
forall a. Maybe a
Nothing)
        ]
    , [Char] -> [TestTree] -> TestTree
testGroup
        [Char]
"the byte limit admits a MsgLeiosBlock of the largest endorser block"
        [ [Char] -> Assertion -> TestTree
testCase [Char]
"a definite message" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ([Encoding] -> Encoding) -> Assertion
fitsByteLimit [Encoding] -> Encoding
definite
        , [Char] -> Assertion -> TestTree
testCase [Char]
"an indefinite message" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ ([Encoding] -> Encoding) -> Assertion
fitsByteLimit [Encoding] -> Encoding
indefinite
        ]
    , [Char] -> Assertion -> TestTree
testCase [Char]
"the codec rejects an endorser block larger than maxEndorserBlockBytesSize" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        let eb :: Encoding
eb = EndorserBlock -> Encoding
encodeEndorserBlock (Int -> EndorserBlock
endorserBlockOfSize (Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            msg :: Encoding
msg = [Encoding] -> Encoding
definite [Word -> Encoding
CBOR.encodeWord Word
2, Encoding
eb]
        ByteString -> Int
BS.length (Encoding -> ByteString
CBOR.toStrictByteString Encoding
eb) Int -> Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int
maxSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        -- Its message fits the byte limit, so only the codec can reject it.
        Encoding -> Assertion
assertFitsByteLimit Encoding
msg
        Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec Encoding
msg IO (Maybe EndorserBlock)
-> (Maybe EndorserBlock -> Assertion) -> Assertion
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe EndorserBlock -> Maybe EndorserBlock -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Maybe EndorserBlock
forall a. Maybe a
Nothing)
    ]

-- | The codec accepts a 'MsgLeiosBlock' of an endorser block of
-- 'maxEndorserBlockBytesSize' in this list encoding, and the message fits
-- 'byteLimitsLeiosFetch'.
fitsByteLimit :: ([CBOR.Encoding] -> CBOR.Encoding) -> Assertion
fitsByteLimit :: ([Encoding] -> Encoding) -> Assertion
fitsByteLimit [Encoding] -> Encoding
list = do
  ByteString -> Int
BS.length (Encoding -> ByteString
CBOR.toStrictByteString Encoding
eb) Int -> Int -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Int
maxSize
  decoded <- Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec Encoding
msg
  assertBool "the codec rejects the message" (isJust decoded)
  assertFitsByteLimit msg
 where
  eb :: Encoding
eb = EndorserBlock -> Encoding
encodeEndorserBlock (Int -> EndorserBlock
endorserBlockOfSize Int
maxSize)
  msg :: Encoding
msg = [Encoding] -> Encoding
list [Word -> Encoding
CBOR.encodeWord Word
2, Encoding
eb]

assertFitsByteLimit :: CBOR.Encoding -> Assertion
assertFitsByteLimit :: Encoding -> Assertion
assertFitsByteLimit Encoding
msg =
  HasCallStack => [Char] -> Bool -> Assertion
[Char] -> Bool -> Assertion
assertBool
    (Word -> [Char]
forall a. Show a => a -> [Char]
show Word
size [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" bytes exceed the limit of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Word -> [Char]
forall a. Show a => a -> [Char]
show Word
msgLeiosBlockByteLimit)
    (Word
size Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
msgLeiosBlockByteLimit)
 where
  size :: Word
size = Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
BSL.length (Encoding -> ByteString
CBOR.toLazyByteString Encoding
msg))

msgLeiosBlockByteLimit :: Word
msgLeiosBlockByteLimit :: Word
msgLeiosBlockByteLimit = ProtocolSizeLimits
  (LeiosFetch (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)) ByteString
-> forall (st :: LeiosFetch (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)).
   ActiveState st =>
   StateToken st -> Word
forall ps bytes.
ProtocolSizeLimits ps bytes
-> forall (st :: ps). ActiveState st => StateToken st -> Word
sizeLimitForState ((ByteString -> Word)
-> ProtocolSizeLimits
     (LeiosFetch (ZonkAny 0) (ZonkAny 1) (ZonkAny 2)) ByteString
forall bytes point eb tx.
(bytes -> Word)
-> ProtocolSizeLimits (LeiosFetch point eb tx) bytes
byteLimitsLeiosFetch (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length)) SingLeiosFetch ('StBusy 'StBlock)
StateToken ('StBusy 'StBlock)
forall {point} {eb} {tx}. SingLeiosFetch ('StBusy 'StBlock)
SingBlock

maxSize :: Int
maxSize :: Int
maxSize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
maxEndorserBlockBytesSize

-- | An endorser block whose encoding takes this many bytes, for sizes near
-- 'maxSize': after a 3-byte map header, each reference takes 35 bytes, or 36
-- for a size of 100.
endorserBlockOfSize :: Int -> EndorserBlock
endorserBlockOfSize :: Int -> EndorserBlock
endorserBlockOfSize Int
size =
  [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock [(Int -> TxHash
distinctTxHash Int
i, if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
spare then Word32
100 else Word32
1) | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]]
 where
  (Int
n, Int
spare) = (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
35

-- | A tx hash for each 'Int' from 0 to @2^32 - 1@.
distinctTxHash :: Int -> TxHash
distinctTxHash :: Int -> TxHash
distinctTxHash Int
i = ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> TxHash) -> ShortByteString -> TxHash
forall a b. (a -> b) -> a -> b
$ [Word8] -> ShortByteString
SBS.pack ([Word8] -> ShortByteString) -> [Word8] -> ShortByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> [Word8]
forall a. Int -> a -> [a]
replicate Int
28 Word8
0 [Word8] -> [Word8] -> [Word8]
forall a. Semigroup a => a -> a -> a
<> [Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
s) | Int
s <- [Int
24, Int
16, Int
8, Int
0]]

-- | The codec slices exactly the endorser block's bytes out of a
-- 'MsgLeiosBlock', no matter how the message's
-- @[2, { + (bytes .size 32) => (uint .size 4) }]@ is encoded. That slicing is
-- the codec's own work, whereas decoding the references is the ledger's. So the
-- decoded endorser block names those references, and keeps, sizes and hashes
-- exactly the bytes of the map.
--
-- The encodings vary whether the list and the map are definite or indefinite,
-- whether each hash is definite or in chunks, and the width of every head.
--
-- TODO Maybe upstream some of this test and/or reuse some upstream components.
-- It's good to be self-contained, focused, and exhaustive, but that's in
-- tension with reusing the relevant tools.
prop_slicesEndorserBlockFromMessage :: Property
prop_slicesEndorserBlockFromMessage :: Property
prop_slicesEndorserBlockFromMessage =
  Gen MsgRecipe
-> (MsgRecipe -> [MsgRecipe])
-> (MsgRecipe -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen MsgRecipe
genMsgRecipe MsgRecipe -> [MsgRecipe]
shrinkMsgRecipe ((MsgRecipe -> Property) -> Property)
-> (MsgRecipe -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \recipe :: MsgRecipe
recipe@(MsgRecipe Framing
_ ArgBytes
_ EbBytesRecipe
ebRecipe) -> IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    let bytes :: ByteString
bytes = EbBytesRecipe -> ByteString
ebRecipeBytes EbBytesRecipe
ebRecipe
    decoded <- Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec (ByteString -> Encoding
CBOR.encodePreEncoded (MsgRecipe -> ByteString
msgRecipeBytes MsgRecipe
recipe))
    pure $ case decoded of
      Maybe EndorserBlock
Nothing -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"the codec rejects the message" Bool
False
      Just EndorserBlock
eb ->
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
          [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"references" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ EndorserBlock -> [(TxHash, Word32)]
endorserBlockReferences EndorserBlock
eb [(TxHash, Word32)] -> [(TxHash, Word32)] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== EbBytesRecipe -> [(TxHash, Word32)]
ebRecipeReferences EbBytesRecipe
ebRecipe
          , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"bytes" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Encoding -> ByteString
CBOR.toStrictByteString (EndorserBlock -> Encoding
encodeEndorserBlock EndorserBlock
eb) ByteString -> ByteString -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString
bytes
          , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"size" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ EndorserBlock -> Word32
encodeEndorserBlockSize EndorserBlock
eb 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
bytes)
          , [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"hash" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ EndorserBlock -> Hash HASH EraIndependentEbReferences
endorserBlockHash EndorserBlock
eb Hash HASH EraIndependentEbReferences
-> Hash HASH EraIndependentEbReferences -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Hash HASH ByteString -> Hash HASH EraIndependentEbReferences
forall h a b. Hash h a -> Hash h b
castHash (forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
hashWith @HASH ByteString -> ByteString
forall a. a -> a
id ByteString
bytes)
          ]

-- | An encoding of a 'MsgLeiosBlock': the list around it, the width of the head
-- of its first item, @2@, and its endorser block.
data MsgRecipe = MsgRecipe Framing ArgBytes EbBytesRecipe
  deriving Int -> MsgRecipe -> [Char] -> [Char]
[MsgRecipe] -> [Char] -> [Char]
MsgRecipe -> [Char]
(Int -> MsgRecipe -> [Char] -> [Char])
-> (MsgRecipe -> [Char])
-> ([MsgRecipe] -> [Char] -> [Char])
-> Show MsgRecipe
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> MsgRecipe -> [Char] -> [Char]
showsPrec :: Int -> MsgRecipe -> [Char] -> [Char]
$cshow :: MsgRecipe -> [Char]
show :: MsgRecipe -> [Char]
$cshowList :: [MsgRecipe] -> [Char] -> [Char]
showList :: [MsgRecipe] -> [Char] -> [Char]
Show

-- | An encoding of an endorser block's references.
data EbBytesRecipe = EbBytesRecipe Framing [RefRecipe]
  deriving Int -> EbBytesRecipe -> [Char] -> [Char]
[EbBytesRecipe] -> [Char] -> [Char]
EbBytesRecipe -> [Char]
(Int -> EbBytesRecipe -> [Char] -> [Char])
-> (EbBytesRecipe -> [Char])
-> ([EbBytesRecipe] -> [Char] -> [Char])
-> Show EbBytesRecipe
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> EbBytesRecipe -> [Char] -> [Char]
showsPrec :: Int -> EbBytesRecipe -> [Char] -> [Char]
$cshow :: EbBytesRecipe -> [Char]
show :: EbBytesRecipe -> [Char]
$cshowList :: [EbBytesRecipe] -> [Char] -> [Char]
showList :: [EbBytesRecipe] -> [Char] -> [Char]
Show

-- | A list or map: definite, its head of at least this width, or indefinite.
data Framing = Definite ArgBytes | Indefinite
  deriving Int -> Framing -> [Char] -> [Char]
[Framing] -> [Char] -> [Char]
Framing -> [Char]
(Int -> Framing -> [Char] -> [Char])
-> (Framing -> [Char])
-> ([Framing] -> [Char] -> [Char])
-> Show Framing
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Framing -> [Char] -> [Char]
showsPrec :: Int -> Framing -> [Char] -> [Char]
$cshow :: Framing -> [Char]
show :: Framing -> [Char]
$cshowList :: [Framing] -> [Char] -> [Char]
showList :: [Framing] -> [Char] -> [Char]
Show

-- | A reference: its tx hash with the framing of that byte string, and its tx
-- size with the width of that head.
data RefRecipe = RefRecipe (TxHash, BytesFraming) (BytesSize, ArgBytes)
  deriving Int -> RefRecipe -> [Char] -> [Char]
[RefRecipe] -> [Char] -> [Char]
RefRecipe -> [Char]
(Int -> RefRecipe -> [Char] -> [Char])
-> (RefRecipe -> [Char])
-> ([RefRecipe] -> [Char] -> [Char])
-> Show RefRecipe
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> RefRecipe -> [Char] -> [Char]
showsPrec :: Int -> RefRecipe -> [Char] -> [Char]
$cshow :: RefRecipe -> [Char]
show :: RefRecipe -> [Char]
$cshowList :: [RefRecipe] -> [Char] -> [Char]
showList :: [RefRecipe] -> [Char] -> [Char]
Show

-- | A byte string: definite, its head of at least this width, or indefinite,
-- in chunks of these lengths, each with its head of at least this width.
--
-- TODO Dijkstra's decoders accept indefinite-length byte strings, but that
-- support will be revoked before Dijkstra ships. This test will then fail on
-- 'Chunks', and we deliberately leave it to whoever integrates that ledger
-- change to remove 'Chunks' and its branches from this recipe.
data BytesFraming = DefiniteBytes ArgBytes | Chunks [(Word16, ArgBytes)]
  deriving Int -> BytesFraming -> [Char] -> [Char]
[BytesFraming] -> [Char] -> [Char]
BytesFraming -> [Char]
(Int -> BytesFraming -> [Char] -> [Char])
-> (BytesFraming -> [Char])
-> ([BytesFraming] -> [Char] -> [Char])
-> Show BytesFraming
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> BytesFraming -> [Char] -> [Char]
showsPrec :: Int -> BytesFraming -> [Char] -> [Char]
$cshow :: BytesFraming -> [Char]
show :: BytesFraming -> [Char]
$cshowList :: [BytesFraming] -> [Char] -> [Char]
showList :: [BytesFraming] -> [Char] -> [Char]
Show

-- | The fewest bytes a CBOR head spends on its argument after its first byte.
-- It spends more if the argument needs them.
data ArgBytes = Arg0 | Arg1 | Arg2 | Arg4 | Arg8
  deriving (Int -> ArgBytes -> [Char] -> [Char]
[ArgBytes] -> [Char] -> [Char]
ArgBytes -> [Char]
(Int -> ArgBytes -> [Char] -> [Char])
-> (ArgBytes -> [Char])
-> ([ArgBytes] -> [Char] -> [Char])
-> Show ArgBytes
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ArgBytes -> [Char] -> [Char]
showsPrec :: Int -> ArgBytes -> [Char] -> [Char]
$cshow :: ArgBytes -> [Char]
show :: ArgBytes -> [Char]
$cshowList :: [ArgBytes] -> [Char] -> [Char]
showList :: [ArgBytes] -> [Char] -> [Char]
Show, ArgBytes -> ArgBytes -> Bool
(ArgBytes -> ArgBytes -> Bool)
-> (ArgBytes -> ArgBytes -> Bool) -> Eq ArgBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArgBytes -> ArgBytes -> Bool
== :: ArgBytes -> ArgBytes -> Bool
$c/= :: ArgBytes -> ArgBytes -> Bool
/= :: ArgBytes -> ArgBytes -> Bool
Eq, Eq ArgBytes
Eq ArgBytes =>
(ArgBytes -> ArgBytes -> Ordering)
-> (ArgBytes -> ArgBytes -> Bool)
-> (ArgBytes -> ArgBytes -> Bool)
-> (ArgBytes -> ArgBytes -> Bool)
-> (ArgBytes -> ArgBytes -> Bool)
-> (ArgBytes -> ArgBytes -> ArgBytes)
-> (ArgBytes -> ArgBytes -> ArgBytes)
-> Ord ArgBytes
ArgBytes -> ArgBytes -> Bool
ArgBytes -> ArgBytes -> Ordering
ArgBytes -> ArgBytes -> ArgBytes
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ArgBytes -> ArgBytes -> Ordering
compare :: ArgBytes -> ArgBytes -> Ordering
$c< :: ArgBytes -> ArgBytes -> Bool
< :: ArgBytes -> ArgBytes -> Bool
$c<= :: ArgBytes -> ArgBytes -> Bool
<= :: ArgBytes -> ArgBytes -> Bool
$c> :: ArgBytes -> ArgBytes -> Bool
> :: ArgBytes -> ArgBytes -> Bool
$c>= :: ArgBytes -> ArgBytes -> Bool
>= :: ArgBytes -> ArgBytes -> Bool
$cmax :: ArgBytes -> ArgBytes -> ArgBytes
max :: ArgBytes -> ArgBytes -> ArgBytes
$cmin :: ArgBytes -> ArgBytes -> ArgBytes
min :: ArgBytes -> ArgBytes -> ArgBytes
Ord, Int -> ArgBytes
ArgBytes -> Int
ArgBytes -> [ArgBytes]
ArgBytes -> ArgBytes
ArgBytes -> ArgBytes -> [ArgBytes]
ArgBytes -> ArgBytes -> ArgBytes -> [ArgBytes]
(ArgBytes -> ArgBytes)
-> (ArgBytes -> ArgBytes)
-> (Int -> ArgBytes)
-> (ArgBytes -> Int)
-> (ArgBytes -> [ArgBytes])
-> (ArgBytes -> ArgBytes -> [ArgBytes])
-> (ArgBytes -> ArgBytes -> [ArgBytes])
-> (ArgBytes -> ArgBytes -> ArgBytes -> [ArgBytes])
-> Enum ArgBytes
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ArgBytes -> ArgBytes
succ :: ArgBytes -> ArgBytes
$cpred :: ArgBytes -> ArgBytes
pred :: ArgBytes -> ArgBytes
$ctoEnum :: Int -> ArgBytes
toEnum :: Int -> ArgBytes
$cfromEnum :: ArgBytes -> Int
fromEnum :: ArgBytes -> Int
$cenumFrom :: ArgBytes -> [ArgBytes]
enumFrom :: ArgBytes -> [ArgBytes]
$cenumFromThen :: ArgBytes -> ArgBytes -> [ArgBytes]
enumFromThen :: ArgBytes -> ArgBytes -> [ArgBytes]
$cenumFromTo :: ArgBytes -> ArgBytes -> [ArgBytes]
enumFromTo :: ArgBytes -> ArgBytes -> [ArgBytes]
$cenumFromThenTo :: ArgBytes -> ArgBytes -> ArgBytes -> [ArgBytes]
enumFromThenTo :: ArgBytes -> ArgBytes -> ArgBytes -> [ArgBytes]
Enum, ArgBytes
ArgBytes -> ArgBytes -> Bounded ArgBytes
forall a. a -> a -> Bounded a
$cminBound :: ArgBytes
minBound :: ArgBytes
$cmaxBound :: ArgBytes
maxBound :: ArgBytes
Bounded)

genMsgRecipe :: Gen MsgRecipe
genMsgRecipe :: Gen MsgRecipe
genMsgRecipe = Framing -> ArgBytes -> EbBytesRecipe -> MsgRecipe
MsgRecipe (Framing -> ArgBytes -> EbBytesRecipe -> MsgRecipe)
-> Gen Framing -> Gen (ArgBytes -> EbBytesRecipe -> MsgRecipe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Framing
genFraming Gen (ArgBytes -> EbBytesRecipe -> MsgRecipe)
-> Gen ArgBytes -> Gen (EbBytesRecipe -> MsgRecipe)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ArgBytes
genArgBytes Gen (EbBytesRecipe -> MsgRecipe)
-> Gen EbBytesRecipe -> Gen MsgRecipe
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EbBytesRecipe
genEbBytesRecipe
 where
  genEbBytesRecipe :: Gen EbBytesRecipe
genEbBytesRecipe = do
    hashes <- [[Word8]] -> [[Word8]]
forall a. Ord a => [a] -> [a]
nubOrd ([[Word8]] -> [[Word8]]) -> Gen [[Word8]] -> Gen [[Word8]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Word8] -> Gen [[Word8]]
forall a. Gen a -> Gen [a]
listOf1 (Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
32 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary)
    EbBytesRecipe <$> genFraming <*> traverse genRef hashes

  genRef :: [Word8] -> Gen RefRecipe
genRef [Word8]
hash =
    (TxHash, BytesFraming) -> (Word32, ArgBytes) -> RefRecipe
RefRecipe
      ((TxHash, BytesFraming) -> (Word32, ArgBytes) -> RefRecipe)
-> Gen (TxHash, BytesFraming)
-> Gen ((Word32, ArgBytes) -> RefRecipe)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((,) (ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash ([Word8] -> ShortByteString
SBS.pack [Word8]
hash)) (BytesFraming -> (TxHash, BytesFraming))
-> Gen BytesFraming -> Gen (TxHash, BytesFraming)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen BytesFraming
genBytesFraming)
      Gen ((Word32, ArgBytes) -> RefRecipe)
-> Gen (Word32, ArgBytes) -> Gen RefRecipe
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((,) (Word32 -> ArgBytes -> (Word32, ArgBytes))
-> Gen Word32 -> Gen (ArgBytes -> (Word32, ArgBytes))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
genTxSize Gen (ArgBytes -> (Word32, ArgBytes))
-> Gen ArgBytes -> Gen (Word32, ArgBytes)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ArgBytes
genArgBytes)

  genTxSize :: Gen Word32
  genTxSize :: Gen Word32
genTxSize = [Gen Word32] -> Gen Word32
forall a. HasCallStack => [Gen a] -> Gen a
oneof [(Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
0, Word32
23), (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
24, Word32
255), (Word32, Word32) -> Gen Word32
forall a. Random a => (a, a) -> Gen a
choose (Word32
256, Word32
65535), Gen Word32
forall a. Arbitrary a => Gen a
arbitrary]

  genFraming :: Gen Framing
genFraming = [Gen Framing] -> Gen Framing
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ArgBytes -> Framing
Definite (ArgBytes -> Framing) -> Gen ArgBytes -> Gen Framing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArgBytes
genArgBytes, Framing -> Gen Framing
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Framing
Indefinite]

  genBytesFraming :: Gen BytesFraming
genBytesFraming = [Gen BytesFraming] -> Gen BytesFraming
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ArgBytes -> BytesFraming
DefiniteBytes (ArgBytes -> BytesFraming) -> Gen ArgBytes -> Gen BytesFraming
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArgBytes
genArgBytes, [(Word16, ArgBytes)] -> BytesFraming
Chunks ([(Word16, ArgBytes)] -> BytesFraming)
-> Gen [(Word16, ArgBytes)] -> Gen BytesFraming
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [(Word16, ArgBytes)]
genChunks]

  -- The 32 bytes of a hash, cut at some points along them. Cuts may coincide
  -- or fall at either end, leaving empty chunks.
  genChunks :: Gen [(Word16, ArgBytes)]
genChunks = do
    cuts <- [Word16] -> [Word16]
forall a. Ord a => [a] -> [a]
sort ([Word16] -> [Word16]) -> Gen [Word16] -> Gen [Word16]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word16 -> Gen [Word16]
forall a. Gen a -> Gen [a]
listOf ((Word16, Word16) -> Gen Word16
forall a. Random a => (a, a) -> Gen a
choose (Word16
0, Word16
32))
    traverse (\Word16
len -> (,) Word16
len (ArgBytes -> (Word16, ArgBytes))
-> Gen ArgBytes -> Gen (Word16, ArgBytes)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ArgBytes
genArgBytes) $ zipWith (-) (cuts <> [32]) (0 : cuts)

  genArgBytes :: Gen ArgBytes
genArgBytes = [ArgBytes] -> Gen ArgBytes
forall a. HasCallStack => [a] -> Gen a
elements [ArgBytes
forall a. Bounded a => a
minBound .. ArgBytes
forall a. Bounded a => a
maxBound]

-- | Drop references, but keep one, since the codec rejects an empty map; shrink
-- each tx size; narrow each head; make the list, the map or a hash definite;
-- and join adjacent chunks. The hashes stay as they are, so they stay
-- distinct.
shrinkMsgRecipe :: MsgRecipe -> [MsgRecipe]
shrinkMsgRecipe :: MsgRecipe -> [MsgRecipe]
shrinkMsgRecipe (MsgRecipe Framing
framing ArgBytes
width EbBytesRecipe
eb) =
  [Framing -> ArgBytes -> EbBytesRecipe -> MsgRecipe
MsgRecipe Framing
framing' ArgBytes
width EbBytesRecipe
eb | Framing
framing' <- Framing -> [Framing]
shrinkFraming Framing
framing]
    [MsgRecipe] -> [MsgRecipe] -> [MsgRecipe]
forall a. Semigroup a => a -> a -> a
<> [Framing -> ArgBytes -> EbBytesRecipe -> MsgRecipe
MsgRecipe Framing
framing ArgBytes
width' EbBytesRecipe
eb | ArgBytes
width' <- ArgBytes -> [ArgBytes]
forall {p}. (Ord p, Bounded p, Enum p) => p -> [p]
shrinkArgBytes ArgBytes
width]
    [MsgRecipe] -> [MsgRecipe] -> [MsgRecipe]
forall a. Semigroup a => a -> a -> a
<> [Framing -> ArgBytes -> EbBytesRecipe -> MsgRecipe
MsgRecipe Framing
framing ArgBytes
width EbBytesRecipe
eb' | EbBytesRecipe
eb' <- EbBytesRecipe -> [EbBytesRecipe]
shrinkEb EbBytesRecipe
eb]
 where
  shrinkEb :: EbBytesRecipe -> [EbBytesRecipe]
shrinkEb (EbBytesRecipe Framing
ebFraming [RefRecipe]
refs) =
    [Framing -> [RefRecipe] -> EbBytesRecipe
EbBytesRecipe Framing
ebFraming' [RefRecipe]
refs | Framing
ebFraming' <- Framing -> [Framing]
shrinkFraming Framing
ebFraming]
      [EbBytesRecipe] -> [EbBytesRecipe] -> [EbBytesRecipe]
forall a. Semigroup a => a -> a -> a
<> [Framing -> [RefRecipe] -> EbBytesRecipe
EbBytesRecipe Framing
ebFraming [RefRecipe]
refs' | [RefRecipe]
refs' <- (RefRecipe -> [RefRecipe]) -> [RefRecipe] -> [[RefRecipe]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList RefRecipe -> [RefRecipe]
shrinkRef [RefRecipe]
refs, Bool -> Bool
not ([RefRecipe] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RefRecipe]
refs')]

  shrinkRef :: RefRecipe -> [RefRecipe]
shrinkRef (RefRecipe (TxHash
hash, BytesFraming
hashFraming) (Word32
size, ArgBytes
sizeWidth)) =
    [(TxHash, BytesFraming) -> (Word32, ArgBytes) -> RefRecipe
RefRecipe (TxHash
hash, BytesFraming
hashFraming') (Word32
size, ArgBytes
sizeWidth) | BytesFraming
hashFraming' <- BytesFraming -> [BytesFraming]
shrinkBytesFraming BytesFraming
hashFraming]
      [RefRecipe] -> [RefRecipe] -> [RefRecipe]
forall a. Semigroup a => a -> a -> a
<> [(TxHash, BytesFraming) -> (Word32, ArgBytes) -> RefRecipe
RefRecipe (TxHash
hash, BytesFraming
hashFraming) (Word32
size', ArgBytes
sizeWidth) | Word32
size' <- Word32 -> [Word32]
forall a. Arbitrary a => a -> [a]
shrink Word32
size]
      [RefRecipe] -> [RefRecipe] -> [RefRecipe]
forall a. Semigroup a => a -> a -> a
<> [(TxHash, BytesFraming) -> (Word32, ArgBytes) -> RefRecipe
RefRecipe (TxHash
hash, BytesFraming
hashFraming) (Word32
size, ArgBytes
sizeWidth') | ArgBytes
sizeWidth' <- ArgBytes -> [ArgBytes]
forall {p}. (Ord p, Bounded p, Enum p) => p -> [p]
shrinkArgBytes ArgBytes
sizeWidth]

  shrinkFraming :: Framing -> [Framing]
shrinkFraming = \case
    Framing
Indefinite -> [ArgBytes -> Framing
Definite ArgBytes
forall a. Bounded a => a
minBound]
    Definite ArgBytes
w -> ArgBytes -> Framing
Definite (ArgBytes -> Framing) -> [ArgBytes] -> [Framing]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgBytes -> [ArgBytes]
forall {p}. (Ord p, Bounded p, Enum p) => p -> [p]
shrinkArgBytes ArgBytes
w

  -- A definite byte string can only narrow its head. Chunks can become the
  -- definite byte string with the narrowest head, join two neighbours into one
  -- chunk with the narrower of their heads, or narrow one chunk's head.
  shrinkBytesFraming :: BytesFraming -> [BytesFraming]
shrinkBytesFraming = \case
    DefiniteBytes ArgBytes
w -> ArgBytes -> BytesFraming
DefiniteBytes (ArgBytes -> BytesFraming) -> [ArgBytes] -> [BytesFraming]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgBytes -> [ArgBytes]
forall {p}. (Ord p, Bounded p, Enum p) => p -> [p]
shrinkArgBytes ArgBytes
w
    Chunks [(Word16, ArgBytes)]
chunks ->
      ArgBytes -> BytesFraming
DefiniteBytes ArgBytes
forall a. Bounded a => a
minBound
        BytesFraming -> [BytesFraming] -> [BytesFraming]
forall a. a -> [a] -> [a]
: [ [(Word16, ArgBytes)] -> BytesFraming
Chunks ([(Word16, ArgBytes)]
pre [(Word16, ArgBytes)]
-> [(Word16, ArgBytes)] -> [(Word16, ArgBytes)]
forall a. Semigroup a => a -> a -> a
<> [(Word16
len1 Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
len2, ArgBytes -> ArgBytes -> ArgBytes
forall a. Ord a => a -> a -> a
min ArgBytes
w1 ArgBytes
w2)] [(Word16, ArgBytes)]
-> [(Word16, ArgBytes)] -> [(Word16, ArgBytes)]
forall a. Semigroup a => a -> a -> a
<> [(Word16, ArgBytes)]
post)
          | ([(Word16, ArgBytes)]
pre, (Word16
len1, ArgBytes
w1) : (Word16
len2, ArgBytes
w2) : [(Word16, ArgBytes)]
post) <- [(Word16, ArgBytes)]
-> [([(Word16, ArgBytes)], [(Word16, ArgBytes)])]
forall {a}. [a] -> [([a], [a])]
splits [(Word16, ArgBytes)]
chunks
          ]
          [BytesFraming] -> [BytesFraming] -> [BytesFraming]
forall a. Semigroup a => a -> a -> a
<> [ [(Word16, ArgBytes)] -> BytesFraming
Chunks ([(Word16, ArgBytes)]
pre [(Word16, ArgBytes)]
-> [(Word16, ArgBytes)] -> [(Word16, ArgBytes)]
forall a. Semigroup a => a -> a -> a
<> [(Word16
len, ArgBytes
w')] [(Word16, ArgBytes)]
-> [(Word16, ArgBytes)] -> [(Word16, ArgBytes)]
forall a. Semigroup a => a -> a -> a
<> [(Word16, ArgBytes)]
post)
             | ([(Word16, ArgBytes)]
pre, (Word16
len, ArgBytes
w) : [(Word16, ArgBytes)]
post) <- [(Word16, ArgBytes)]
-> [([(Word16, ArgBytes)], [(Word16, ArgBytes)])]
forall {a}. [a] -> [([a], [a])]
splits [(Word16, ArgBytes)]
chunks
             , ArgBytes
w' <- ArgBytes -> [ArgBytes]
forall {p}. (Ord p, Bounded p, Enum p) => p -> [p]
shrinkArgBytes ArgBytes
w
             ]

  -- Every way to cut the list in two.
  splits :: [a] -> [([a], [a])]
splits [a]
xs = [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs)

  shrinkArgBytes :: p -> [p]
shrinkArgBytes p
w = (p -> Bool) -> [p] -> [p]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (p -> p -> Bool
forall a. Ord a => a -> a -> Bool
< p
w) [p
forall a. Bounded a => a
minBound .. p
w]

msgRecipeBytes :: MsgRecipe -> BS.ByteString
msgRecipeBytes :: MsgRecipe -> ByteString
msgRecipeBytes (MsgRecipe Framing
framing ArgBytes
width EbBytesRecipe
eb) =
  Word8 -> Framing -> Int -> ByteString -> ByteString
framedBytes Word8
4 Framing
framing Int
2 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
0 ArgBytes
width Word64
2 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> EbBytesRecipe -> ByteString
ebRecipeBytes EbBytesRecipe
eb

ebRecipeBytes :: EbBytesRecipe -> BS.ByteString
ebRecipeBytes :: EbBytesRecipe -> ByteString
ebRecipeBytes (EbBytesRecipe Framing
framing [RefRecipe]
refs) =
  Word8 -> Framing -> Int -> ByteString -> ByteString
framedBytes Word8
5 Framing
framing ([RefRecipe] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RefRecipe]
refs) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (RefRecipe -> ByteString) -> [RefRecipe] -> ByteString
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap RefRecipe -> ByteString
refBytes [RefRecipe]
refs
 where
  refBytes :: RefRecipe -> ByteString
refBytes (RefRecipe (TxHash
hash, BytesFraming
hashFraming) (Word32
size, ArgBytes
sizeWidth)) =
    BytesFraming -> ByteString -> ByteString
hashBytes BytesFraming
hashFraming (TxHash -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes TxHash
hash) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
0 ArgBytes
sizeWidth (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
size)

  hashBytes :: BytesFraming -> ByteString -> ByteString
hashBytes BytesFraming
hashFraming ByteString
bytes = case BytesFraming
hashFraming of
    DefiniteBytes ArgBytes
w -> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
2 ArgBytes
w (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bytes)) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
bytes
    Chunks [(Word16, ArgBytes)]
chunks -> Word8 -> ByteString
BS.singleton Word8
0x5f ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [(Word16, ArgBytes)] -> ByteString
forall {a}.
Integral a =>
ByteString -> [(a, ArgBytes)] -> ByteString
chunksBytes ByteString
bytes [(Word16, ArgBytes)]
chunks ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
0xff

  chunksBytes :: ByteString -> [(a, ArgBytes)] -> ByteString
chunksBytes ByteString
bytes = \case
    [] -> ByteString
BS.empty
    (a
len, ArgBytes
w) : [(a, ArgBytes)]
chunks ->
      let (ByteString
chunk, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len) ByteString
bytes
       in Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
2 ArgBytes
w (a -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
chunk ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [(a, ArgBytes)] -> ByteString
chunksBytes ByteString
rest [(a, ArgBytes)]
chunks

ebRecipeReferences :: EbBytesRecipe -> [(TxHash, BytesSize)]
ebRecipeReferences :: EbBytesRecipe -> [(TxHash, Word32)]
ebRecipeReferences (EbBytesRecipe Framing
_ [RefRecipe]
refs) = [(TxHash
hash, Word32
size) | RefRecipe (TxHash
hash, BytesFraming
_) (Word32
size, ArgBytes
_) <- [RefRecipe]
refs]

-- | A list or map of this major type and number of entries, around the bytes of
-- those entries.
framedBytes :: Word8 -> Framing -> Int -> BS.ByteString -> BS.ByteString
framedBytes :: Word8 -> Framing -> Int -> ByteString -> ByteString
framedBytes Word8
major Framing
framing Int
n ByteString
entries = case Framing
framing of
  Definite ArgBytes
width -> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
major ArgBytes
width (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
entries
  Framing
Indefinite -> Word8 -> ByteString
BS.singleton (Word8
major Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
5 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
31) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
entries ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
0xff

-- | A CBOR head of this major type and argument.
headBytes :: Word8 -> ArgBytes -> Word64 -> BS.ByteString
headBytes :: Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
major ArgBytes
width Word64
n = case ArgBytes
width of
  ArgBytes
Arg0
    | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
24 -> Word8 -> ByteString
BS.singleton (Word8
major Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
5 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
    | Bool
otherwise -> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
major ArgBytes
Arg1 Word64
n
  ArgBytes
Arg1
    | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x100 -> Word8 -> Int -> ByteString
argumentIn Word8
24 Int
1
    | Bool
otherwise -> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
major ArgBytes
Arg2 Word64
n
  ArgBytes
Arg2
    | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x10000 -> Word8 -> Int -> ByteString
argumentIn Word8
25 Int
2
    | Bool
otherwise -> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
major ArgBytes
Arg4 Word64
n
  ArgBytes
Arg4
    | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x100000000 -> Word8 -> Int -> ByteString
argumentIn Word8
26 Int
4
    | Bool
otherwise -> Word8 -> ArgBytes -> Word64 -> ByteString
headBytes Word8
major ArgBytes
Arg8 Word64
n
  ArgBytes
Arg8 -> Word8 -> Int -> ByteString
argumentIn Word8
27 Int
8
 where
  argumentIn :: Word8 -> Int -> ByteString
argumentIn Word8
info Int
len =
    [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$
      (Word8
major Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
5 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
info) Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
n Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)) | Int
i <- [Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 .. Int
0]]

-- | Decode a message with a codec that admits at most two txs.
decodeViaLeiosFetchCodec ::
  forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
  ActiveState st =>
  StateToken st ->
  CBOR.Encoding ->
  IO (Maybe (SomeMessage st))
decodeViaLeiosFetchCodec :: forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
ActiveState st =>
StateToken st -> Encoding -> IO (Maybe (SomeMessage st))
decodeViaLeiosFetchCodec StateToken st
stok Encoding
enc = do
  step <- CodecF
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  DeserialiseFailure
  IO
  (Annotator ByteString)
  ByteString
-> forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
   ActiveState st =>
   StateToken st
   -> IO
        (DecodeStep
           ByteString DeserialiseFailure IO (Annotator ByteString st))
forall ps failure (m :: * -> *) (f :: ps -> *) bytes.
CodecF ps failure m f bytes
-> forall (st :: ps).
   ActiveState st =>
   StateToken st -> m (DecodeStep bytes failure m (f st))
decode CodecF
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  DeserialiseFailure
  IO
  (Annotator ByteString)
  ByteString
codec StateToken st
stok
  either (const Nothing) (Just . (`runAnnotator` bytes)) <$> runDecoder [bytes] step
 where
  bytes :: ByteString
bytes = Encoding -> ByteString
CBOR.toLazyByteString Encoding
enc

  codec ::
    AnnotatedCodec (LeiosFetch LeiosPoint EndorserBlock LeiosTx) CBOR.DeserialiseFailure IO ByteString
  codec :: CodecF
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  DeserialiseFailure
  IO
  (Annotator ByteString)
  ByteString
codec =
    Int
-> (LeiosPoint -> Encoding)
-> (forall s. Decoder s LeiosPoint)
-> (EndorserBlock -> Encoding)
-> (forall s. Decoder s (ByteString -> EndorserBlock))
-> (LeiosTx -> Encoding)
-> (forall s. Decoder s LeiosTx)
-> CodecF
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     DeserialiseFailure
     IO
     (Annotator ByteString)
     ByteString
forall point eb tx (m :: * -> *).
MonadST m =>
Int
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (eb -> Encoding)
-> (forall s. Decoder s (ByteString -> eb))
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> AnnotatedCodec
     (LeiosFetch point eb tx) DeserialiseFailure m ByteString
codecLeiosFetch
      Int
2
      LeiosPoint -> Encoding
encodeLeiosPoint
      Decoder s LeiosPoint
forall s. Decoder s LeiosPoint
decodeLeiosPoint
      EndorserBlock -> Encoding
encodeEndorserBlock
      Decoder s (ByteString -> EndorserBlock)
forall s. Decoder s (ByteString -> EndorserBlock)
decodeEndorserBlock
      LeiosTx -> Encoding
encodeLeiosTx
      Decoder s LeiosTx
forall s. Decoder s LeiosTx
decodeLeiosTx

decodeMsgLeiosBlockTxsViaLeiosFetchCodec :: CBOR.Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec :: Encoding -> IO (Maybe [LeiosTx])
decodeMsgLeiosBlockTxsViaLeiosFetchCodec Encoding
enc =
  StateToken ('StBusy 'StBlockTxs)
-> Encoding -> IO (Maybe (SomeMessage ('StBusy 'StBlockTxs)))
forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
ActiveState st =>
StateToken st -> Encoding -> IO (Maybe (SomeMessage st))
decodeViaLeiosFetchCodec SingLeiosFetch ('StBusy 'StBlockTxs)
StateToken ('StBusy 'StBlockTxs)
forall {point} {eb} {tx}. SingLeiosFetch ('StBusy 'StBlockTxs)
SingBlockTxs Encoding
enc
    IO (Maybe (SomeMessage ('StBusy 'StBlockTxs)))
-> (Maybe (SomeMessage ('StBusy 'StBlockTxs)) -> Maybe [LeiosTx])
-> IO (Maybe [LeiosTx])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SomeMessage ('StBusy 'StBlockTxs) -> [LeiosTx])
-> Maybe (SomeMessage ('StBusy 'StBlockTxs)) -> Maybe [LeiosTx]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\case SomeMessage (MsgLeiosBlockTxs Vector LeiosTx
txs) -> Vector LeiosTx -> [LeiosTx]
forall a. Vector a -> [a]
V.toList Vector LeiosTx
txs)

decodeMsgLeiosBlockViaLeiosFetchCodec :: CBOR.Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec :: Encoding -> IO (Maybe EndorserBlock)
decodeMsgLeiosBlockViaLeiosFetchCodec Encoding
enc =
  StateToken ('StBusy 'StBlock)
-> Encoding -> IO (Maybe (SomeMessage ('StBusy 'StBlock)))
forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
ActiveState st =>
StateToken st -> Encoding -> IO (Maybe (SomeMessage st))
decodeViaLeiosFetchCodec SingLeiosFetch ('StBusy 'StBlock)
StateToken ('StBusy 'StBlock)
forall {point} {eb} {tx}. SingLeiosFetch ('StBusy 'StBlock)
SingBlock Encoding
enc
    IO (Maybe (SomeMessage ('StBusy 'StBlock)))
-> (Maybe (SomeMessage ('StBusy 'StBlock)) -> Maybe EndorserBlock)
-> IO (Maybe EndorserBlock)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (SomeMessage ('StBusy 'StBlock) -> EndorserBlock)
-> Maybe (SomeMessage ('StBusy 'StBlock)) -> Maybe EndorserBlock
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\case SomeMessage (MsgLeiosBlock EndorserBlock
eb) -> EndorserBlock
eb)

-- | Decode a 'MsgLeiosBlockTxsRequest'. The codec's bound of two txs admits one
-- bitmap entry.
decodeMsgLeiosBlockTxsRequestViaLeiosFetchCodec ::
  CBOR.Encoding -> IO (Maybe (LeiosPoint, TxBitmaps))
decodeMsgLeiosBlockTxsRequestViaLeiosFetchCodec :: Encoding -> IO (Maybe (LeiosPoint, TxBitmaps))
decodeMsgLeiosBlockTxsRequestViaLeiosFetchCodec Encoding
enc =
  StateToken 'StIdle -> Encoding -> IO (Maybe (SomeMessage 'StIdle))
forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
ActiveState st =>
StateToken st -> Encoding -> IO (Maybe (SomeMessage st))
decodeViaLeiosFetchCodec SingLeiosFetch 'StIdle
StateToken 'StIdle
forall {point} {eb} {tx}. SingLeiosFetch 'StIdle
SingIdle Encoding
enc IO (Maybe (SomeMessage 'StIdle))
-> (Maybe (SomeMessage 'StIdle) -> Maybe (LeiosPoint, TxBitmaps))
-> IO (Maybe (LeiosPoint, TxBitmaps))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just (SomeMessage (MsgLeiosBlockTxsRequest LeiosPoint
p TxBitmaps
bitmaps)) -> (LeiosPoint, TxBitmaps) -> Maybe (LeiosPoint, TxBitmaps)
forall a. a -> Maybe a
Just (LeiosPoint
p, TxBitmaps
bitmaps)
    Maybe (SomeMessage 'StIdle)
_ -> Maybe (LeiosPoint, TxBitmaps)
forall a. Maybe a
Nothing

decodeMsgLeiosBlockRequestViaLeiosFetchCodec :: CBOR.Encoding -> IO (Maybe LeiosPoint)
decodeMsgLeiosBlockRequestViaLeiosFetchCodec :: Encoding -> IO (Maybe LeiosPoint)
decodeMsgLeiosBlockRequestViaLeiosFetchCodec Encoding
enc =
  StateToken 'StIdle -> Encoding -> IO (Maybe (SomeMessage 'StIdle))
forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
ActiveState st =>
StateToken st -> Encoding -> IO (Maybe (SomeMessage st))
decodeViaLeiosFetchCodec SingLeiosFetch 'StIdle
StateToken 'StIdle
forall {point} {eb} {tx}. SingLeiosFetch 'StIdle
SingIdle Encoding
enc IO (Maybe (SomeMessage 'StIdle))
-> (Maybe (SomeMessage 'StIdle) -> Maybe LeiosPoint)
-> IO (Maybe LeiosPoint)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just (SomeMessage (MsgLeiosBlockRequest LeiosPoint
p)) -> LeiosPoint -> Maybe LeiosPoint
forall a. a -> Maybe a
Just LeiosPoint
p
    Maybe (SomeMessage 'StIdle)
_ -> Maybe LeiosPoint
forall a. Maybe a
Nothing

txsRequestKey :: CBOR.Encoding
txsRequestKey :: Encoding
txsRequestKey = Word -> Encoding
CBOR.encodeWord Word
3

-- | 'onePoint', encoded as the codec writes it.
somePoint :: CBOR.Encoding
somePoint :: Encoding
somePoint = LeiosPoint -> Encoding
encodeLeiosPoint ((LeiosPoint, Encoding) -> LeiosPoint
forall a b. (a, b) -> a
fst (LeiosPoint, Encoding)
onePoint)

-- | Bitmap entries naming the last tx of the first and of the second run of 64.
bitmap0, bitmap1 :: CBOR.Encoding
bitmap0 :: Encoding
bitmap0 = Word16 -> Encoding
CBOR.encodeWord16 Word16
0 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
CBOR.encodeWord64 Word64
1
bitmap1 :: Encoding
bitmap1 = Word16 -> Encoding
CBOR.encodeWord16 Word16
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
CBOR.encodeWord64 Word64
1

txsKey :: CBOR.Encoding
txsKey :: Encoding
txsKey = Word -> Encoding
CBOR.encodeWord Word
4

twoTxs :: [CBOR.Encoding]
twoTxs :: [Encoding]
twoTxs = (LeiosTx -> Encoding) -> [LeiosTx] -> [Encoding]
forall a b. (a -> b) -> [a] -> [b]
map LeiosTx -> Encoding
encodeLeiosTx [LeiosTx
txA, LeiosTx
txB]

txA, txB :: LeiosTx
txA :: LeiosTx
txA = ByteString -> LeiosTx
MkLeiosTx (ByteString -> LeiosTx) -> ByteString -> LeiosTx
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack [Word8
1]
txB :: LeiosTx
txB = ByteString -> LeiosTx
MkLeiosTx (ByteString -> LeiosTx) -> ByteString -> LeiosTx
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack [Word8
2, Word8
2]

-- | An endorser block of one reference, and its encoding.
oneRefEb :: (EndorserBlock, CBOR.Encoding)
oneRefEb :: (EndorserBlock, Encoding)
oneRefEb =
  ( [(TxHash, Word32)] -> EndorserBlock
mkEndorserBlock [(ShortByteString -> TxHash
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ByteString -> ShortByteString
SBS.toShort ByteString
hash), Word32
100)]
  , [Encoding] -> Encoding
definiteMap [ByteString -> Encoding
reference ByteString
hash]
  )
 where
  hash :: ByteString
hash = Int -> Word8 -> ByteString
BS.replicate Int
32 Word8
7

-- | An endorser block referencing one tx by a hash of this many bytes.
ebReferencing :: Int -> CBOR.Encoding
ebReferencing :: Int -> Encoding
ebReferencing Int
n = [Encoding] -> Encoding
definiteMap [ByteString -> Encoding
reference (Int -> Word8 -> ByteString
BS.replicate Int
n Word8
7)]

-- | A reference to a tx of 100 bytes by these hash bytes.
reference :: BS.ByteString -> CBOR.Encoding
reference :: ByteString -> Encoding
reference ByteString
hash = ByteString -> Encoding
CBOR.encodeBytes ByteString
hash Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 Word32
100

-- | A point with an endorser block hash of this many bytes.
pointOf :: Int -> CBOR.Encoding
pointOf :: Int -> Encoding
pointOf Int
n = [Encoding] -> Encoding
indefinite [Word64 -> Encoding
CBOR.encodeWord64 Word64
1, ByteString -> Encoding
CBOR.encodeBytes (Int -> Word8 -> ByteString
BS.replicate Int
n Word8
1)]

-- | A point, and its encoding as an indefinite-length list.
onePoint :: (LeiosPoint, CBOR.Encoding)
onePoint :: (LeiosPoint, Encoding)
onePoint =
  ( SlotNo -> Hash HASH EraIndependentEbReferences -> LeiosPoint
MkLeiosPoint (Word64 -> SlotNo
SlotNo Word64
1) Hash HASH EraIndependentEbReferences
hash
  , [Encoding] -> Encoding
indefinite [Word64 -> Encoding
CBOR.encodeWord64 Word64
1, Hash HASH EraIndependentEbReferences -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Hash HASH EraIndependentEbReferences
hash]
  )
 where
  hash :: EndorserBlockHash
  hash :: Hash HASH EraIndependentEbReferences
hash = ShortByteString -> Hash HASH EraIndependentEbReferences
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
1)