{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}

-- | The node's LeiosFetch codec against the CDDL.
module Test.Consensus.Cardano.LeiosFetch (tests) where

import Cardano.Crypto.Hash (Hash (UnsafeHash))
import Codec.CBOR.Read (DeserialiseFailure)
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString, toStrict)
import qualified Data.ByteString.Short as SBS
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Vector.Strict as V
import Network.TypedProtocol.Codec (AnnotatedCodec, AnyMessage (..), CodecF (..))
import Ouroboros.Consensus.Block (SlotNo (..))
import Ouroboros.Consensus.Leios.Types
  ( EndorserBlock
  , LeiosPoint (..)
  , LeiosTx (..)
  , decodeEndorserBlock
  , decodeLeiosPoint
  , decodeLeiosTx
  , encodeEndorserBlock
  , encodeLeiosPoint
  , encodeLeiosTx
  , maxTxsPerEndorserBlock
  , mkEndorserBlock
  )
import Ouroboros.Consensus.MiniProtocol.LeiosFetch.Type
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Serialisation.CDDL (cddlTest, isCDDLCDisabled)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"LeiosFetch" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
    [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"the node's codec encodes each message as the CDDL specifies" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
        Property
prop_nodeCodecMatchesCDDL
    | Bool -> Bool
not Bool
isCDDLCDisabled
    ]

prop_nodeCodecMatchesCDDL :: Property
prop_nodeCodecMatchesCDDL :: Property
prop_nodeCodecMatchesCDDL =
  Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
    -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
genMessage ((AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  -> Property)
 -> Property)
-> (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
    -> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(AnyMessage Message (LeiosFetch LeiosPoint EndorserBlock LeiosTx) st st'
msg) ->
    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
      result <-
        IO ByteString -> TestName -> Text -> IO (Either TestName ())
cddlTest
          (ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ CodecF
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  DeserialiseFailure
  IO
  (Annotator LazyByteString)
  LazyByteString
-> forall (st :: LeiosFetch LeiosPoint EndorserBlock LeiosTx)
          (st' :: LeiosFetch LeiosPoint EndorserBlock LeiosTx).
   (StateTokenI st, ActiveState st) =>
   Message (LeiosFetch LeiosPoint EndorserBlock LeiosTx) st st'
   -> LazyByteString
forall ps failure (m :: * -> *) (f :: ps -> *) bytes.
CodecF ps failure m f bytes
-> forall (st :: ps) (st' :: ps).
   (StateTokenI st, ActiveState st) =>
   Message ps st st' -> bytes
encode CodecF
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  DeserialiseFailure
  IO
  (Annotator LazyByteString)
  LazyByteString
nodeCodec Message (LeiosFetch LeiosPoint EndorserBlock LeiosTx) st st'
msg)
          TestName
"ntnleiosfetch.cddl"
          (TestName -> Text
T.pack TestName
"leiosFetchMessage")
      pure $ either (`counterexample` False) (const $ property True) result
 where
  nodeCodec ::
    AnnotatedCodec (LeiosFetch LeiosPoint EndorserBlock LeiosTx) DeserialiseFailure IO ByteString
  nodeCodec :: CodecF
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  DeserialiseFailure
  IO
  (Annotator LazyByteString)
  LazyByteString
nodeCodec =
    Int
-> (LeiosPoint -> Encoding)
-> (forall s. Decoder s LeiosPoint)
-> (EndorserBlock -> Encoding)
-> (forall s. Decoder s (LazyByteString -> EndorserBlock))
-> (LeiosTx -> Encoding)
-> (forall s. Decoder s LeiosTx)
-> CodecF
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     DeserialiseFailure
     IO
     (Annotator LazyByteString)
     LazyByteString
forall point eb tx (m :: * -> *).
MonadST m =>
Int
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (eb -> Encoding)
-> (forall s. Decoder s (LazyByteString -> eb))
-> (tx -> Encoding)
-> (forall s. Decoder s tx)
-> AnnotatedCodec
     (LeiosFetch point eb tx) DeserialiseFailure m LazyByteString
codecLeiosFetch
      Int
maxTxsPerEndorserBlock
      LeiosPoint -> Encoding
encodeLeiosPoint
      Decoder s LeiosPoint
forall s. Decoder s LeiosPoint
decodeLeiosPoint
      EndorserBlock -> Encoding
encodeEndorserBlock
      Decoder s (LazyByteString -> EndorserBlock)
forall s. Decoder s (LazyByteString -> EndorserBlock)
decodeEndorserBlock
      LeiosTx -> Encoding
encodeLeiosTx
      Decoder s LeiosTx
forall s. Decoder s LeiosTx
decodeLeiosTx

  genMessage :: Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
genMessage =
    [Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))]
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
 -> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)))
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall a b. (a -> b) -> a -> b
$ Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx) 'StIdle 'StDone
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx) 'StIdle 'StDone
forall point eb tx.
Message (LeiosFetch point eb tx) 'StIdle 'StDone
MsgDone
      , Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'StIdle
  ('StBusy 'StBlock)
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   'StIdle
   ('StBusy 'StBlock)
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> (LeiosPoint
    -> Message
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         'StIdle
         ('StBusy 'StBlock))
-> LeiosPoint
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosPoint
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'StIdle
     ('StBusy 'StBlock)
forall point eb tx.
point
-> Message (LeiosFetch point eb tx) 'StIdle ('StBusy 'StBlock)
MsgLeiosBlockRequest (LeiosPoint
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> Gen LeiosPoint
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosPoint
genPoint
      , Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  ('StBusy 'StBlock)
  'StIdle
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   ('StBusy 'StBlock)
   'StIdle
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> (EndorserBlock
    -> Message
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         ('StBusy 'StBlock)
         'StIdle)
-> EndorserBlock
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EndorserBlock
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     ('StBusy 'StBlock)
     'StIdle
forall eb point tx.
eb -> Message (LeiosFetch point eb tx) ('StBusy 'StBlock) 'StIdle
MsgLeiosBlock (EndorserBlock
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> Gen EndorserBlock
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen EndorserBlock
genEb
      , (Message
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   'StIdle
   ('StBusy 'StBlockTxs)
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> Gen
     (Message
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'StIdle
        ('StBusy 'StBlockTxs))
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  'StIdle
  ('StBusy 'StBlockTxs)
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Gen
   (Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'StIdle
      ('StBusy 'StBlockTxs))
 -> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)))
-> Gen
     (Message
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'StIdle
        ('StBusy 'StBlockTxs))
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall a b. (a -> b) -> a -> b
$ LeiosPoint
-> TxBitmaps
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     'StIdle
     ('StBusy 'StBlockTxs)
forall point eb tx.
point
-> TxBitmaps
-> Message (LeiosFetch point eb tx) 'StIdle ('StBusy 'StBlockTxs)
MsgLeiosBlockTxsRequest (LeiosPoint
 -> TxBitmaps
 -> Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      'StIdle
      ('StBusy 'StBlockTxs))
-> Gen LeiosPoint
-> Gen
     (TxBitmaps
      -> Message
           (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
           'StIdle
           ('StBusy 'StBlockTxs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosPoint
genPoint Gen
  (TxBitmaps
   -> Message
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'StIdle
        ('StBusy 'StBlockTxs))
-> Gen TxBitmaps
-> Gen
     (Message
        (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
        'StIdle
        ('StBusy 'StBlockTxs))
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen TxBitmaps
genBitmaps
      , Message
  (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
  ('StBusy 'StBlockTxs)
  'StIdle
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message
   (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
   ('StBusy 'StBlockTxs)
   'StIdle
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> ([LeiosTx]
    -> Message
         (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
         ('StBusy 'StBlockTxs)
         'StIdle)
-> [LeiosTx]
-> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector LeiosTx
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     ('StBusy 'StBlockTxs)
     'StIdle
forall tx point eb.
Vector tx
-> Message (LeiosFetch point eb tx) ('StBusy 'StBlockTxs) 'StIdle
MsgLeiosBlockTxs (Vector LeiosTx
 -> Message
      (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
      ('StBusy 'StBlockTxs)
      'StIdle)
-> ([LeiosTx] -> Vector LeiosTx)
-> [LeiosTx]
-> Message
     (LeiosFetch LeiosPoint EndorserBlock LeiosTx)
     ('StBusy 'StBlockTxs)
     'StIdle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LeiosTx] -> Vector LeiosTx
forall a. [a] -> Vector a
V.fromList ([LeiosTx]
 -> AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
-> Gen [LeiosTx]
-> Gen (AnyMessage (LeiosFetch LeiosPoint EndorserBlock LeiosTx))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen LeiosTx -> Gen [LeiosTx]
forall a. Gen a -> Gen [a]
listOf Gen LeiosTx
genTx
      ]

  genPoint :: Gen LeiosPoint
genPoint = SlotNo -> EndorserBlockHash -> LeiosPoint
MkLeiosPoint (SlotNo -> EndorserBlockHash -> LeiosPoint)
-> Gen SlotNo -> Gen (EndorserBlockHash -> LeiosPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary) Gen (EndorserBlockHash -> LeiosPoint)
-> Gen EndorserBlockHash -> Gen LeiosPoint
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen EndorserBlockHash
forall {a}. Gen (Hash HASH a)
genHash

  -- strictly ascending indices, each with a non-zero bitmap, as the decoder
  -- requires
  genBitmaps :: Gen TxBitmaps
genBitmaps = do
    indices <- Set Word16 -> [Word16]
forall a. Set a -> [a]
Set.toAscList (Set Word16 -> [Word16])
-> ([Word16] -> Set Word16) -> [Word16] -> [Word16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word16] -> Set Word16
forall a. Ord a => [a] -> Set a
Set.fromList ([Word16] -> [Word16]) -> Gen [Word16] -> Gen [Word16]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Word16]
forall a. Arbitrary a => Gen a
arbitrary
    traverse (\Word16
i -> (,) Word16
i (Word64 -> (Word16, Word64))
-> (Positive Word64 -> Word64)
-> Positive Word64
-> (Word16, Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Word64 -> Word64
forall a. Positive a -> a
getPositive (Positive Word64 -> (Word16, Word64))
-> Gen (Positive Word64) -> Gen (Word16, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Word64)
forall a. Arbitrary a => Gen a
arbitrary) indices

  genEb :: Gen EndorserBlock
genEb = [(TxHash, BytesSize)] -> EndorserBlock
mkEndorserBlock ([(TxHash, BytesSize)] -> EndorserBlock)
-> Gen [(TxHash, BytesSize)] -> Gen EndorserBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (TxHash, BytesSize) -> Gen [(TxHash, BytesSize)]
forall a. Gen a -> Gen [a]
listOf1 ((,) (TxHash -> BytesSize -> (TxHash, BytesSize))
-> Gen TxHash -> Gen (BytesSize -> (TxHash, BytesSize))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxHash
forall {a}. Gen (Hash HASH a)
genHash Gen (BytesSize -> (TxHash, BytesSize))
-> Gen BytesSize -> Gen (TxHash, BytesSize)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen BytesSize
forall a. Arbitrary a => Gen a
arbitrary)

  genTx :: Gen LeiosTx
genTx = ByteString -> LeiosTx
MkLeiosTx (ByteString -> LeiosTx)
-> ([Word8] -> ByteString) -> [Word8] -> LeiosTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack ([Word8] -> LeiosTx) -> Gen [Word8] -> Gen LeiosTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Word8]
forall a. Arbitrary a => Gen a
arbitrary

  genHash :: Gen (Hash HASH a)
genHash = ShortByteString -> Hash HASH a
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (ShortByteString -> Hash HASH a)
-> ([Word8] -> ShortByteString) -> [Word8] -> Hash HASH a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
SBS.pack ([Word8] -> Hash HASH a) -> Gen [Word8] -> Gen (Hash HASH a)
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