{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE KindSignatures    #-}
{-# LANGUAGE ParallelListComp  #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TypeApplications  #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Network.Protocol.BlockFetch.Test (tests) where

import Codec.Serialise qualified as S
import Control.Monad.ST (runST)
import Data.ByteString.Lazy (ByteString)

import Control.Monad.Class.MonadAsync (MonadAsync)
import Control.Monad.Class.MonadST (MonadST)
import Control.Monad.Class.MonadSTM (MonadSTM)
import Control.Monad.Class.MonadThrow (MonadCatch)
import Control.Monad.IOSim (runSimOrThrow)
import Control.Tracer (nullTracer)

import Network.TypedProtocol.Codec
import Network.TypedProtocol.Proofs

import Ouroboros.Network.Channel
import Ouroboros.Network.Driver.Simple (runConnectedPeers)

import Ouroboros.Network.Block (Serialised (..), genesisPoint, unwrapCBORinCBOR,
           wrapCBORinCBOR)

import Ouroboros.Network.Mock.Chain (Chain, Point)
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ConcreteBlock (Block)

import Ouroboros.Network.Protocol.BlockFetch.Client
import Ouroboros.Network.Protocol.BlockFetch.Codec
import Ouroboros.Network.Protocol.BlockFetch.Direct
import Ouroboros.Network.Protocol.BlockFetch.Examples
import Ouroboros.Network.Protocol.BlockFetch.Server
import Ouroboros.Network.Protocol.BlockFetch.Type
import Test.Data.PipeliningDepth (PipeliningDepth (..))

import Test.ChainGenerators (TestChainAndPoints (..))
import Test.Ouroboros.Network.Testing.Utils (prop_codec_cborM,
           prop_codec_valid_cbor_encoding, splits2, splits3)

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)


tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"Ouroboros.Network.Protocol"
    [ TestName -> [TestTree] -> TestTree
testGroup TestName
"BlockFetch"
        [ TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"direct"              TestChainAndPoints -> Bool
prop_direct
        , TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"directPipelined 1"   TestChainAndPoints -> Bool
prop_directPipelined1
        , TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"directPipelined 2"   TestChainAndPoints -> Bool
prop_directPipelined2
        , TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect"             TestChainAndPoints -> Bool
prop_connect
        , TestName -> (TestChainAndPoints -> [Bool] -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 1" TestChainAndPoints -> [Bool] -> Bool
prop_connect_pipelined1
        , TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 2" TestChainAndPoints -> Bool
prop_connect_pipelined2
        , TestName -> (TestChainAndPoints -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 3" TestChainAndPoints -> Bool
prop_connect_pipelined3
        , TestName -> (TestChainAndPoints -> [Bool] -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 4" TestChainAndPoints -> [Bool] -> Bool
prop_connect_pipelined4
        , TestName
-> (TestChainAndPoints -> PipeliningDepth -> [Bool] -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 5" TestChainAndPoints -> PipeliningDepth -> [Bool] -> Bool
prop_connect_pipelined5
        , TestName -> (TestChainAndPoints -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"channel ST"          TestChainAndPoints -> Property
prop_channel_ST
        , TestName -> (TestChainAndPoints -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"channel IO"          TestChainAndPoints -> Property
prop_channel_IO
        , TestName -> (TestChainAndPoints -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"pipe IO"             TestChainAndPoints -> Property
prop_pipe_IO
        , TestName
-> (AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec"               AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_BlockFetch
        , TestName
-> (AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec 2-splits"      AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits2_BlockFetch
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec 3-splits"    (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Int
-> (AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                             AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits3_BlockFetch
        , TestName
-> (AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec cbor"          AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_cbor_BlockFetch
        , TestName
-> (AnyMessageAndAgency (BlockFetch Block (Point Block))
    -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec valid cbor"    AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Property
prop_codec_valid_cbor_BlockFetch

        , TestName
-> (AnyMessageAndAgency
      (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised"                   AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_BlockFetchSerialised
        , TestName
-> (AnyMessageAndAgency
      (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised 2-splits"          AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_splits2_BlockFetchSerialised
        , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised 3-splits"        (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ Int
-> (AnyMessageAndAgency
      (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                                           AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_splits3_BlockFetchSerialised
        , TestName
-> (AnyMessageAndAgency
      (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised cbor"              AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_cbor_BlockFetchSerialised
        , TestName
-> (AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec/codecSerialised bin compat"  AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_binary_compat_BlockFetch_BlockFetchSerialised
        , TestName
-> (AnyMessageAndAgency
      (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised/codec bin compat"  AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_binary_compat_BlockFetchSerialised_BlockFetch
        ]
    ]


--
-- Block fetch client and server used in many subsequent tests.
--

type TestClient m = BlockFetchClient Block (Point Block) m [Block]
type TestServer m = BlockFetchServer Block (Point Block) m ()
type TestClientPipelined m =
       BlockFetchClientPipelined Block (Point Block) m
                                 [Either (ChainRange (Point Block)) [Block]]

testClient :: MonadSTM m => Chain Block -> [Point Block] -> TestClient m
testClient :: forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClient m
testClient Chain Block
chain [Point Block]
points = [ChainRange (Point Block)]
-> BlockFetchClient Block (Point Block) m [Block]
forall block point (m :: * -> *).
MonadSTM m =>
[ChainRange point] -> BlockFetchClient block point m [block]
blockFetchClientMap (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges Chain Block
chain [Point Block]
points)

testServer :: MonadSTM m => Chain Block -> TestServer m
testServer :: forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain = RangeRequests m Block -> BlockFetchServer Block (Point Block) m ()
forall (m :: * -> *) block.
Monad m =>
RangeRequests m block -> BlockFetchServer block (Point block) m ()
blockFetchServer (Chain Block -> RangeRequests m Block
forall (m :: * -> *) block.
(Monad m, HasHeader block) =>
Chain block -> RangeRequests m block
rangeRequestsFromChain Chain Block
chain)

testClientPipelinedMax,
  testClientPipelinedMin
  :: MonadSTM m
  => Chain Block
  -> [Point Block]
  -> TestClientPipelined m

testClientPipelinedLimited
  :: MonadSTM m
  => Int -- pipelining depth
  -> Chain Block
  -> [Point Block]
  -> TestClientPipelined m

testClientPipelinedMax :: forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMax Chain Block
chain [Point Block]
points =
    [ChainRange (Point Block)]
-> BlockFetchClientPipelined
     Block (Point Block) m [Either (ChainRange (Point Block)) [Block]]
forall block point (m :: * -> *).
Monad m =>
[ChainRange point]
-> BlockFetchClientPipelined
     block point m [Either (ChainRange point) [block]]
blockFetchClientPipelinedMax (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges Chain Block
chain [Point Block]
points)

testClientPipelinedMin :: forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMin Chain Block
chain [Point Block]
points =
    [ChainRange (Point Block)]
-> BlockFetchClientPipelined
     Block (Point Block) m [Either (ChainRange (Point Block)) [Block]]
forall block point (m :: * -> *).
Monad m =>
[ChainRange point]
-> BlockFetchClientPipelined
     block point m [Either (ChainRange point) [block]]
blockFetchClientPipelinedMin (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges Chain Block
chain [Point Block]
points)

testClientPipelinedLimited :: forall (m :: * -> *).
MonadSTM m =>
Int -> Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedLimited Int
omax Chain Block
chain [Point Block]
points =
    Int
-> [ChainRange (Point Block)]
-> BlockFetchClientPipelined
     Block (Point Block) m [Either (ChainRange (Point Block)) [Block]]
forall block point (m :: * -> *).
Monad m =>
Int
-> [ChainRange point]
-> BlockFetchClientPipelined
     block point m [Either (ChainRange point) [block]]
blockFetchClientPipelinedLimited Int
omax (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges Chain Block
chain [Point Block]
points)


--
-- Properties going directly, not via Peer.
--

-- | Run a simple block-fetch client and server, without going via the 'Peer'.
--
prop_direct :: TestChainAndPoints -> Bool
prop_direct :: TestChainAndPoints -> Bool
prop_direct (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    (forall s. IOSim s ([Block], ())) -> ([Block], ())
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (BlockFetchClient Block (Point Block) (IOSim s) [Block]
-> BlockFetchServer Block (Point Block) (IOSim s) ()
-> IOSim s ([Block], ())
forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClient block point m a
-> BlockFetchServer block point m b -> m (a, b)
direct (Chain Block
-> [Point Block]
-> BlockFetchClient Block (Point Block) (IOSim s) [Block]
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClient m
testClient Chain Block
chain [Point Block]
points)
                          (Chain Block -> BlockFetchServer Block (Point Block) (IOSim s) ()
forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain))
 ([Block], ()) -> ([Block], ()) -> Bool
forall a. Eq a => a -> a -> Bool
==
    ([Block] -> [Block]
forall a. [a] -> [a]
reverse ([Block] -> [Block])
-> ([[Block]] -> [Block]) -> [[Block]] -> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Block]] -> [Block]) -> [[Block]] -> [Block]
forall a b. (a -> b) -> a -> b
$ Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points, ())


-- | Run a pipelined block-fetch client with a server, without going via 'Peer'.
--
--
--
prop_directPipelined1 :: TestChainAndPoints -> Bool
prop_directPipelined1 :: TestChainAndPoints -> Bool
prop_directPipelined1 (TestChainAndPoints Chain Block
chain [Point Block]
points) =
   case (forall s.
 IOSim s ([Either (ChainRange (Point Block)) [Block]], ()))
-> ([Either (ChainRange (Point Block)) [Block]], ())
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (BlockFetchClientPipelined
  Block
  (Point Block)
  (IOSim s)
  [Either (ChainRange (Point Block)) [Block]]
-> BlockFetchServer Block (Point Block) (IOSim s) ()
-> IOSim s ([Either (ChainRange (Point Block)) [Block]], ())
forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClientPipelined block point m a
-> BlockFetchServer block point m b -> m (a, b)
directPipelined (Chain Block
-> [Point Block]
-> BlockFetchClientPipelined
     Block
     (Point Block)
     (IOSim s)
     [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMax Chain Block
chain [Point Block]
points)
                                       (Chain Block -> BlockFetchServer Block (Point Block) (IOSim s) ()
forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain)) of
     ([Either (ChainRange (Point Block)) [Block]]
res, ()) ->
         [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a. [a] -> [a]
reverse ((Either (ChainRange (Point Block)) [Block]
 -> Either (ChainRange (Point Block)) [Block])
-> [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map (([Block] -> [Block])
-> Either (ChainRange (Point Block)) [Block]
-> Either (ChainRange (Point Block)) [Block]
forall a b.
(a -> b)
-> Either (ChainRange (Point Block)) a
-> Either (ChainRange (Point Block)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Block] -> [Block]
forall a. [a] -> [a]
reverse) [Either (ChainRange (Point Block)) [Block]]
res)
      [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
         (ChainRange (Point Block)
 -> Either (ChainRange (Point Block)) [Block])
-> [ChainRange (Point Block)]
-> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map ChainRange (Point Block)
-> Either (ChainRange (Point Block)) [Block]
forall a b. a -> Either a b
Left  (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points)
      [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a. [a] -> [a] -> [a]
++ ([Block] -> Either (ChainRange (Point Block)) [Block])
-> [[Block]] -> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map [Block] -> Either (ChainRange (Point Block)) [Block]
forall a b. b -> Either a b
Right (Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points)

prop_directPipelined2 :: TestChainAndPoints -> Bool
prop_directPipelined2 :: TestChainAndPoints -> Bool
prop_directPipelined2 (TestChainAndPoints Chain Block
chain [Point Block]
points) =
   case (forall s.
 IOSim s ([Either (ChainRange (Point Block)) [Block]], ()))
-> ([Either (ChainRange (Point Block)) [Block]], ())
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (BlockFetchClientPipelined
  Block
  (Point Block)
  (IOSim s)
  [Either (ChainRange (Point Block)) [Block]]
-> BlockFetchServer Block (Point Block) (IOSim s) ()
-> IOSim s ([Either (ChainRange (Point Block)) [Block]], ())
forall block point (m :: * -> *) a b.
Monad m =>
BlockFetchClientPipelined block point m a
-> BlockFetchServer block point m b -> m (a, b)
directPipelined (Chain Block
-> [Point Block]
-> BlockFetchClientPipelined
     Block
     (Point Block)
     (IOSim s)
     [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMin Chain Block
chain [Point Block]
points)
                                       (Chain Block -> BlockFetchServer Block (Point Block) (IOSim s) ()
forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain)) of
     ([Either (ChainRange (Point Block)) [Block]]
res, ()) ->
         [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a. [a] -> [a]
reverse ((Either (ChainRange (Point Block)) [Block]
 -> Either (ChainRange (Point Block)) [Block])
-> [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map (([Block] -> [Block])
-> Either (ChainRange (Point Block)) [Block]
-> Either (ChainRange (Point Block)) [Block]
forall a b.
(a -> b)
-> Either (ChainRange (Point Block)) a
-> Either (ChainRange (Point Block)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Block] -> [Block]
forall a. [a] -> [a]
reverse) [Either (ChainRange (Point Block)) [Block]]
res)
      [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
         [[Either (ChainRange (Point Block)) [Block]]]
-> [Either (ChainRange (Point Block)) [Block]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ChainRange (Point Block)
-> Either (ChainRange (Point Block)) [Block]
forall a b. a -> Either a b
Left ChainRange (Point Block)
l, [Block] -> Either (ChainRange (Point Block)) [Block]
forall a b. b -> Either a b
Right [Block]
r]
                | ChainRange (Point Block)
l <- Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points
                | [Block]
r <- Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points ]


--
-- Properties going via Peer, but without using a channel
--

-- | Run a simple block-fetch client and server, going via the 'Peer'
-- representation, but without going via a channel.
--
prop_connect :: TestChainAndPoints -> Bool
prop_connect :: TestChainAndPoints -> Bool
prop_connect (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    case (forall s.
 IOSim
   s ([Block], (), TerminalStates (BlockFetch Block (Point Block))))
-> ([Block], (), TerminalStates (BlockFetch Block (Point Block)))
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
           (Peer
  (BlockFetch Block (Point Block))
  'AsClient
  'BFIdle
  (IOSim s)
  [Block]
-> Peer
     (BlockFetch Block (Point Block))
     (FlipAgency 'AsClient)
     'BFIdle
     (IOSim s)
     ()
-> IOSim
     s ([Block], (), TerminalStates (BlockFetch Block (Point Block)))
forall ps (pr :: PeerRole) (st :: ps) (m :: * -> *) a b.
(Monad m, Protocol ps) =>
Peer ps pr st m a
-> Peer ps (FlipAgency pr) st m b -> m (a, b, TerminalStates ps)
connect
             (BlockFetchClient Block (Point Block) (IOSim s) [Block]
-> Peer
     (BlockFetch Block (Point Block))
     'AsClient
     'BFIdle
     (IOSim s)
     [Block]
forall block point (m :: * -> *) a.
Monad m =>
BlockFetchClient block point m a
-> Peer (BlockFetch block point) 'AsClient 'BFIdle m a
blockFetchClientPeer (Chain Block
-> [Point Block]
-> BlockFetchClient Block (Point Block) (IOSim s) [Block]
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClient m
testClient Chain Block
chain [Point Block]
points))
             (BlockFetchServer Block (Point Block) (IOSim s) ()
-> Peer
     (BlockFetch Block (Point Block)) 'AsServer 'BFIdle (IOSim s) ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer (Chain Block -> BlockFetchServer Block (Point Block) (IOSim s) ()
forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain))) of
      ([Block]
bodies, (), TerminalStates NobodyHasAgency st
R:NobodyHasAgencyBlockFetchst (*) (*) Block (Point Block) st
TokDone NobodyHasAgency st
R:NobodyHasAgencyBlockFetchst (*) (*) Block (Point Block) 'BFDone
TokDone) ->
        [Block] -> [Block]
forall a. [a] -> [a]
reverse [Block]
bodies [Block] -> [Block] -> Bool
forall a. Eq a => a -> a -> Bool
== [[Block]] -> [Block]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points)


-- | Run a pipelined block-fetch client against a server, going via the 'Peer'
-- representation, but without going via a channel.
--
connect_pipelined :: MonadSTM m
                  => TestClientPipelined m
                  -> Chain Block
                  -> [Bool]
                  -> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined :: forall (m :: * -> *).
MonadSTM m =>
TestClientPipelined m
-> Chain Block
-> [Bool]
-> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined TestClientPipelined m
client Chain Block
chain [Bool]
cs = do
    (res, _, TerminalStates TokDone TokDone)
      <- [Bool]
-> PeerPipelined
     (BlockFetch Block (Point Block))
     'AsClient
     'BFIdle
     m
     [Either (ChainRange (Point Block)) [Block]]
-> Peer
     (BlockFetch Block (Point Block))
     (FlipAgency 'AsClient)
     'BFIdle
     m
     ()
-> m ([Either (ChainRange (Point Block)) [Block]], (),
      TerminalStates (BlockFetch Block (Point Block)))
forall ps (pr :: PeerRole) (st :: ps) (m :: * -> *) a b.
(Monad m, Protocol ps) =>
[Bool]
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) st m b
-> m (a, b, TerminalStates ps)
connectPipelined [Bool]
cs
           (TestClientPipelined m
-> PeerPipelined
     (BlockFetch Block (Point Block))
     'AsClient
     'BFIdle
     m
     [Either (ChainRange (Point Block)) [Block]]
forall block point (m :: * -> *) a.
Monad m =>
BlockFetchClientPipelined block point m a
-> PeerPipelined (BlockFetch block point) 'AsClient 'BFIdle m a
blockFetchClientPeerPipelined TestClientPipelined m
client)
           (BlockFetchServer Block (Point Block) m ()
-> Peer (BlockFetch Block (Point Block)) 'AsServer 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer (Chain Block -> BlockFetchServer Block (Point Block) m ()
forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain))
    return $ reverse $ map (fmap reverse) res


-- | With a client with maximum pipelining we get all requests followed by
-- all responses.
--
prop_connect_pipelined1 :: TestChainAndPoints -> [Bool] -> Bool
prop_connect_pipelined1 :: TestChainAndPoints -> [Bool] -> Bool
prop_connect_pipelined1 (TestChainAndPoints Chain Block
chain [Point Block]
points) [Bool]
choices =
    (forall s. IOSim s [Either (ChainRange (Point Block)) [Block]])
-> [Either (ChainRange (Point Block)) [Block]]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (TestClientPipelined (IOSim s)
-> Chain Block
-> [Bool]
-> IOSim s [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
TestClientPipelined m
-> Chain Block
-> [Bool]
-> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined (Chain Block -> [Point Block] -> TestClientPipelined (IOSim s)
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMax Chain Block
chain [Point Block]
points) Chain Block
chain [Bool]
choices)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
    (ChainRange (Point Block)
 -> Either (ChainRange (Point Block)) [Block])
-> [ChainRange (Point Block)]
-> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map ChainRange (Point Block)
-> Either (ChainRange (Point Block)) [Block]
forall a b. a -> Either a b
Left  (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a. [a] -> [a] -> [a]
++ ([Block] -> Either (ChainRange (Point Block)) [Block])
-> [[Block]] -> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map [Block] -> Either (ChainRange (Point Block)) [Block]
forall a b. b -> Either a b
Right (Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points)


-- | With a client that collects eagerly and the driver chooses maximum
-- pipelining then we get all requests followed by all responses.
--
prop_connect_pipelined2 :: TestChainAndPoints -> Bool
prop_connect_pipelined2 :: TestChainAndPoints -> Bool
prop_connect_pipelined2 (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    (forall s. IOSim s [Either (ChainRange (Point Block)) [Block]])
-> [Either (ChainRange (Point Block)) [Block]]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (TestClientPipelined (IOSim s)
-> Chain Block
-> [Bool]
-> IOSim s [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
TestClientPipelined m
-> Chain Block
-> [Bool]
-> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined (Chain Block -> [Point Block] -> TestClientPipelined (IOSim s)
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMin Chain Block
chain [Point Block]
points) Chain Block
chain [Bool]
choices)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
    (ChainRange (Point Block)
 -> Either (ChainRange (Point Block)) [Block])
-> [ChainRange (Point Block)]
-> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map ChainRange (Point Block)
-> Either (ChainRange (Point Block)) [Block]
forall a b. a -> Either a b
Left  (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall a. [a] -> [a] -> [a]
++ ([Block] -> Either (ChainRange (Point Block)) [Block])
-> [[Block]] -> [Either (ChainRange (Point Block)) [Block]]
forall a b. (a -> b) -> [a] -> [b]
map [Block] -> Either (ChainRange (Point Block)) [Block]
forall a b. b -> Either a b
Right (Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points)
  where
    choices :: [Bool]
choices = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
True


-- | With a client that collects eagerly and the driver chooses minimum
-- pipelining then we get the interleaving of requests with responses.
--
prop_connect_pipelined3 :: TestChainAndPoints -> Bool
prop_connect_pipelined3 :: TestChainAndPoints -> Bool
prop_connect_pipelined3 (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    (forall s. IOSim s [Either (ChainRange (Point Block)) [Block]])
-> [Either (ChainRange (Point Block)) [Block]]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (TestClientPipelined (IOSim s)
-> Chain Block
-> [Bool]
-> IOSim s [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
TestClientPipelined m
-> Chain Block
-> [Bool]
-> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined (Chain Block -> [Point Block] -> TestClientPipelined (IOSim s)
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMin Chain Block
chain [Point Block]
points) Chain Block
chain [Bool]
choices)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
    [[Either (ChainRange (Point Block)) [Block]]]
-> [Either (ChainRange (Point Block)) [Block]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ChainRange (Point Block)
-> Either (ChainRange (Point Block)) [Block]
forall a b. a -> Either a b
Left ChainRange (Point Block)
l, [Block] -> Either (ChainRange (Point Block)) [Block]
forall a b. b -> Either a b
Right [Block]
r]
           | ChainRange (Point Block)
l <- Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points
           | [Block]
r <- Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points ]
  where
    choices :: [Bool]
choices = Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False


-- | With a client that collects eagerly and the driver chooses arbitrary
-- pipelining then we get complex interleavings given by the reference
-- specification 'pipelineInterleaving'.
--
prop_connect_pipelined4 :: TestChainAndPoints -> [Bool] -> Bool
prop_connect_pipelined4 :: TestChainAndPoints -> [Bool] -> Bool
prop_connect_pipelined4 (TestChainAndPoints Chain Block
chain [Point Block]
points) [Bool]
choices =
    (forall s. IOSim s [Either (ChainRange (Point Block)) [Block]])
-> [Either (ChainRange (Point Block)) [Block]]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (TestClientPipelined (IOSim s)
-> Chain Block
-> [Bool]
-> IOSim s [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
TestClientPipelined m
-> Chain Block
-> [Bool]
-> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined (Chain Block -> [Point Block] -> TestClientPipelined (IOSim s)
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedMin Chain Block
chain [Point Block]
points) Chain Block
chain [Bool]
choices)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
    Int
-> [Bool]
-> [ChainRange (Point Block)]
-> [[Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall req resp.
Int -> [Bool] -> [req] -> [resp] -> [Either req resp]
pipelineInterleaving Int
forall a. Bounded a => a
maxBound [Bool]
choices
                         (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points)
                         (Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points)


-- | With a client that collects eagerly and is willing to send new messages
-- up to a fixed limit of outstanding messages, and the driver chooses
-- arbitrary pipelining then we get complex interleavings given by the
-- reference specification 'pipelineInterleaving', for that limit of
-- outstanding messages.
--
prop_connect_pipelined5 :: TestChainAndPoints -> PipeliningDepth
                        -> [Bool] -> Bool
prop_connect_pipelined5 :: TestChainAndPoints -> PipeliningDepth -> [Bool] -> Bool
prop_connect_pipelined5 (TestChainAndPoints Chain Block
chain [Point Block]
points)
                        (PipeliningDepth Int
omax) [Bool]
choices =
    (forall s. IOSim s [Either (ChainRange (Point Block)) [Block]])
-> [Either (ChainRange (Point Block)) [Block]]
forall a. (forall s. IOSim s a) -> a
runSimOrThrow
      (TestClientPipelined (IOSim s)
-> Chain Block
-> [Bool]
-> IOSim s [Either (ChainRange (Point Block)) [Block]]
forall (m :: * -> *).
MonadSTM m =>
TestClientPipelined m
-> Chain Block
-> [Bool]
-> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined (Int
-> Chain Block -> [Point Block] -> TestClientPipelined (IOSim s)
forall (m :: * -> *).
MonadSTM m =>
Int -> Chain Block -> [Point Block] -> TestClientPipelined m
testClientPipelinedLimited Int
omax Chain Block
chain [Point Block]
points)
                         Chain Block
chain [Bool]
choices)
 [Either (ChainRange (Point Block)) [Block]]
-> [Either (ChainRange (Point Block)) [Block]] -> Bool
forall a. Eq a => a -> a -> Bool
==
    Int
-> [Bool]
-> [ChainRange (Point Block)]
-> [[Block]]
-> [Either (ChainRange (Point Block)) [Block]]
forall req resp.
Int -> [Bool] -> [req] -> [resp] -> [Either req resp]
pipelineInterleaving (Int
omax) [Bool]
choices
                         (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges      Chain Block
chain [Point Block]
points)
                         (Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points)


--
-- Properties using a channel
--

-- | Run a simple block-fetch client and server using connected channels.
--
prop_channel :: (MonadAsync m, MonadCatch m, MonadST m)
             => m (Channel m ByteString, Channel m ByteString)
             -> Chain Block -> [Point Block] -> m Property
prop_channel :: forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Chain Block -> [Point Block] -> m Property
prop_channel m (Channel m ByteString, Channel m ByteString)
createChannels Chain Block
chain [Point Block]
points = do
    (bodies, ()) <-
      m (Channel m ByteString, Channel m ByteString)
-> Tracer m (Role, TraceSendRecv (BlockFetch Block (Point Block)))
-> Codec
     (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
-> Peer
     (BlockFetch Block (Point Block)) 'AsClient 'BFIdle m [Block]
-> Peer
     (BlockFetch Block (Point Block))
     (FlipAgency 'AsClient)
     'BFIdle
     m
     ()
-> m ([Block], ())
forall (m :: * -> *) failure ps bytes (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadCatch m, Show failure,
 forall (st' :: ps). Show (ClientHasAgency st'),
 forall (st' :: ps). Show (ServerHasAgency st'), ShowProxy ps) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr st m a
-> Peer ps (FlipAgency pr) st m b
-> m (a, b)
runConnectedPeers
        m (Channel m ByteString, Channel m ByteString)
createChannels Tracer m (Role, TraceSendRecv (BlockFetch Block (Point Block)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec
        (BlockFetchClient Block (Point Block) m [Block]
-> Peer
     (BlockFetch Block (Point Block)) 'AsClient 'BFIdle m [Block]
forall block point (m :: * -> *) a.
Monad m =>
BlockFetchClient block point m a
-> Peer (BlockFetch block point) 'AsClient 'BFIdle m a
blockFetchClientPeer (Chain Block
-> [Point Block] -> BlockFetchClient Block (Point Block) m [Block]
forall (m :: * -> *).
MonadSTM m =>
Chain Block -> [Point Block] -> TestClient m
testClient Chain Block
chain [Point Block]
points))
        (BlockFetchServer Block (Point Block) m ()
-> Peer (BlockFetch Block (Point Block)) 'AsServer 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Peer (BlockFetch block point) 'AsServer 'BFIdle m a
blockFetchServerPeer (Chain Block -> BlockFetchServer Block (Point Block) m ()
forall (m :: * -> *). MonadSTM m => Chain Block -> TestServer m
testServer Chain Block
chain))
    return $ reverse bodies === concat (receivedBlockBodies chain points)


-- | Run 'prop_channel' in the simulation monad.
--
prop_channel_ST :: TestChainAndPoints -> Property
prop_channel_ST :: TestChainAndPoints -> Property
prop_channel_ST (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow (IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
-> Chain Block -> [Point Block] -> IOSim s Property
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Chain Block -> [Point Block] -> m Property
prop_channel IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Chain Block
chain [Point Block]
points)


-- | Run 'prop_channel' in the IO monad.
--
prop_channel_IO :: TestChainAndPoints -> Property
prop_channel_IO :: TestChainAndPoints -> Property
prop_channel_IO (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> Chain Block -> [Point Block] -> IO Property
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Chain Block -> [Point Block] -> m Property
prop_channel IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels Chain Block
chain [Point Block]
points)


-- | Run 'prop_channel' in the IO monad using local pipes.
--
prop_pipe_IO :: TestChainAndPoints -> Property
prop_pipe_IO :: TestChainAndPoints -> Property
prop_pipe_IO (TestChainAndPoints Chain Block
chain [Point Block]
points) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO (Channel IO ByteString, Channel IO ByteString)
-> Chain Block -> [Point Block] -> IO Property
forall (m :: * -> *).
(MonadAsync m, MonadCatch m, MonadST m) =>
m (Channel m ByteString, Channel m ByteString)
-> Chain Block -> [Point Block] -> m Property
prop_channel IO (Channel IO ByteString, Channel IO ByteString)
createPipeConnectedChannels Chain Block
chain [Point Block]
points)


-- TODO: issue #347: BlockFetch pipelined tests using channels & pipes

--
-- Codec properties
--

codec :: MonadST m
      => Codec (BlockFetch Block (Point Block))
               S.DeserialiseFailure
               m ByteString
codec :: forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec = (Block -> Encoding)
-> (forall s. Decoder s Block)
-> (Point Block -> Encoding)
-> (forall s. Decoder s (Point Block))
-> Codec
     (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
forall block point (m :: * -> *).
MonadST m =>
(block -> Encoding)
-> (forall s. Decoder s block)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> Codec (BlockFetch block point) DeserialiseFailure m ByteString
codecBlockFetch Block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode Decoder s Block
forall s. Decoder s Block
forall a s. Serialise a => Decoder s a
S.decode
                        Point Block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode Decoder s (Point Block)
forall s. Decoder s (Point Block)
forall a s. Serialise a => Decoder s a
S.decode

codecWrapped :: MonadST m
             => Codec (BlockFetch Block (Point Block))
                      S.DeserialiseFailure
                      m ByteString
codecWrapped :: forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codecWrapped =
    (Block -> Encoding)
-> (forall s. Decoder s Block)
-> (Point Block -> Encoding)
-> (forall s. Decoder s (Point Block))
-> Codec
     (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
forall block point (m :: * -> *).
MonadST m =>
(block -> Encoding)
-> (forall s. Decoder s block)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> Codec (BlockFetch block point) DeserialiseFailure m ByteString
codecBlockFetch
      ((Block -> Encoding) -> Block -> Encoding
forall a. (a -> Encoding) -> a -> Encoding
wrapCBORinCBOR Block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode) ((forall s. Decoder s (ByteString -> Block))
-> forall s. Decoder s Block
forall a.
(forall s. Decoder s (ByteString -> a)) -> forall s. Decoder s a
unwrapCBORinCBOR (Block -> ByteString -> Block
forall a b. a -> b -> a
const (Block -> ByteString -> Block)
-> Decoder s Block -> Decoder s (ByteString -> Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Block
forall s. Decoder s Block
forall a s. Serialise a => Decoder s a
S.decode))
      Point Block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode                  Decoder s (Point Block)
forall s. Decoder s (Point Block)
forall a s. Serialise a => Decoder s a
S.decode

codecSerialised :: MonadST m
                => Codec (BlockFetch (Serialised Block) (Point Block))
                         S.DeserialiseFailure
                         m ByteString
codecSerialised :: forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised = (Serialised Block -> Encoding)
-> (forall s. Decoder s (Serialised Block))
-> (Point Block -> Encoding)
-> (forall s. Decoder s (Point Block))
-> Codec
     (BlockFetch (Serialised Block) (Point Block))
     DeserialiseFailure
     m
     ByteString
forall block point (m :: * -> *).
MonadST m =>
(block -> Encoding)
-> (forall s. Decoder s block)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> Codec (BlockFetch block point) DeserialiseFailure m ByteString
codecBlockFetch Serialised Block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode Decoder s (Serialised Block)
forall s. Decoder s (Serialised Block)
forall a s. Serialise a => Decoder s a
S.decode Point Block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode Decoder s (Point Block)
forall s. Decoder s (Point Block)
forall a s. Serialise a => Decoder s a
S.decode


instance Arbitrary point => Arbitrary (ChainRange point) where
  arbitrary :: Gen (ChainRange point)
arbitrary = point -> point -> ChainRange point
forall point. point -> point -> ChainRange point
ChainRange (point -> point -> ChainRange point)
-> Gen point -> Gen (point -> ChainRange point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen point
forall a. Arbitrary a => Gen a
arbitrary Gen (point -> ChainRange point)
-> Gen point -> Gen (ChainRange point)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen point
forall a. Arbitrary a => Gen a
arbitrary
  shrink :: ChainRange point -> [ChainRange point]
shrink (ChainRange point
a point
b) =
    [ point -> point -> ChainRange point
forall point. point -> point -> ChainRange point
ChainRange point
a' point
b
    | point
a' <- point -> [point]
forall a. Arbitrary a => a -> [a]
shrink point
a
    ]
    [ChainRange point] -> [ChainRange point] -> [ChainRange point]
forall a. [a] -> [a] -> [a]
++
    [ point -> point -> ChainRange point
forall point. point -> point -> ChainRange point
ChainRange point
a point
b'
    | point
b' <- point -> [point]
forall a. Arbitrary a => a -> [a]
shrink point
b
    ]

instance (Arbitrary block, Arbitrary point)
      => Arbitrary (AnyMessageAndAgency (BlockFetch block point)) where
  arbitrary :: Gen (AnyMessageAndAgency (BlockFetch block point))
arbitrary = [Gen (AnyMessageAndAgency (BlockFetch block point))]
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a. [Gen a] -> Gen a
oneof
    [ PeerHasAgency 'AsClient 'BFIdle
-> Message (BlockFetch block point) 'BFIdle 'BFBusy
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency (ClientHasAgency 'BFIdle -> PeerHasAgency 'AsClient 'BFIdle
forall {ps} (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. ClientHasAgency 'BFIdle
TokIdle) (Message (BlockFetch block point) 'BFIdle 'BFBusy
 -> AnyMessageAndAgency (BlockFetch block point))
-> (ChainRange point
    -> Message (BlockFetch block point) 'BFIdle 'BFBusy)
-> ChainRange point
-> AnyMessageAndAgency (BlockFetch block point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainRange point
-> Message (BlockFetch block point) 'BFIdle 'BFBusy
forall {k} point1 (block :: k).
ChainRange point1
-> Message (BlockFetch block point1) 'BFIdle 'BFBusy
MsgRequestRange (ChainRange point -> AnyMessageAndAgency (BlockFetch block point))
-> Gen (ChainRange point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ChainRange point)
forall a. Arbitrary a => Gen a
arbitrary
    , AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessageAndAgency (BlockFetch block point)
 -> Gen (AnyMessageAndAgency (BlockFetch block point)))
-> AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ PeerHasAgency 'AsServer 'BFBusy
-> Message (BlockFetch block point) 'BFBusy 'BFStreaming
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency (ServerHasAgency 'BFBusy -> PeerHasAgency 'AsServer 'BFBusy
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. ServerHasAgency 'BFBusy
TokBusy) Message (BlockFetch block point) 'BFBusy 'BFStreaming
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFBusy 'BFStreaming
MsgStartBatch
    , AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessageAndAgency (BlockFetch block point)
 -> Gen (AnyMessageAndAgency (BlockFetch block point)))
-> AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ PeerHasAgency 'AsServer 'BFBusy
-> Message (BlockFetch block point) 'BFBusy 'BFIdle
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency (ServerHasAgency 'BFBusy -> PeerHasAgency 'AsServer 'BFBusy
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. ServerHasAgency 'BFBusy
TokBusy) Message (BlockFetch block point) 'BFBusy 'BFIdle
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFBusy 'BFIdle
MsgNoBlocks
    , PeerHasAgency 'AsServer 'BFStreaming
-> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency (ServerHasAgency 'BFStreaming
-> PeerHasAgency 'AsServer 'BFStreaming
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
ServerHasAgency 'BFStreaming
TokStreaming) (Message (BlockFetch block point) 'BFStreaming 'BFStreaming
 -> AnyMessageAndAgency (BlockFetch block point))
-> (block
    -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming)
-> block
-> AnyMessageAndAgency (BlockFetch block point)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> block -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
forall {k1} block1 (point :: k1).
block1
-> Message (BlockFetch block1 point) 'BFStreaming 'BFStreaming
MsgBlock (block -> AnyMessageAndAgency (BlockFetch block point))
-> Gen block -> Gen (AnyMessageAndAgency (BlockFetch block point))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen block
forall a. Arbitrary a => Gen a
arbitrary
    , AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessageAndAgency (BlockFetch block point)
 -> Gen (AnyMessageAndAgency (BlockFetch block point)))
-> AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ PeerHasAgency 'AsServer 'BFStreaming
-> Message (BlockFetch block point) 'BFStreaming 'BFIdle
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency (ServerHasAgency 'BFStreaming
-> PeerHasAgency 'AsServer 'BFStreaming
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
ServerHasAgency 'BFStreaming
TokStreaming) Message (BlockFetch block point) 'BFStreaming 'BFIdle
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFStreaming 'BFIdle
MsgBatchDone
    , AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessageAndAgency (BlockFetch block point)
 -> Gen (AnyMessageAndAgency (BlockFetch block point)))
-> AnyMessageAndAgency (BlockFetch block point)
-> Gen (AnyMessageAndAgency (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ PeerHasAgency 'AsClient 'BFIdle
-> Message (BlockFetch block point) 'BFIdle 'BFDone
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency (ClientHasAgency 'BFIdle -> PeerHasAgency 'AsClient 'BFIdle
forall {ps} (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. ClientHasAgency 'BFIdle
TokIdle) Message (BlockFetch block point) 'BFIdle 'BFDone
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFIdle 'BFDone
MsgClientDone
    ]

  shrink :: AnyMessageAndAgency (BlockFetch block point)
-> [AnyMessageAndAgency (BlockFetch block point)]
shrink (AnyMessageAndAgency a :: PeerHasAgency pr st
a@(ClientAgency ClientHasAgency st
R:ClientHasAgencyBlockFetchst (*) (*) block point st
TokIdle) (MsgRequestRange ChainRange point1
range)) =
    [ PeerHasAgency pr st
-> Message (BlockFetch block point) st 'BFBusy
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency PeerHasAgency pr st
a (ChainRange point
-> Message (BlockFetch block point) 'BFIdle 'BFBusy
forall {k} point1 (block :: k).
ChainRange point1
-> Message (BlockFetch block point1) 'BFIdle 'BFBusy
MsgRequestRange ChainRange point
ChainRange point1
range')
    | ChainRange point1
range' <- ChainRange point1 -> [ChainRange point1]
forall a. Arbitrary a => a -> [a]
shrink ChainRange point1
range
    ]
  shrink (AnyMessageAndAgency (ServerAgency ServerHasAgency st
R:ServerHasAgencyBlockFetchst (*) (*) block point st
TokBusy) Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgStartBatch) = []
  shrink (AnyMessageAndAgency (ServerAgency ServerHasAgency st
R:ServerHasAgencyBlockFetchst (*) (*) block point st
TokBusy) Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgNoBlocks) = []
  shrink (AnyMessageAndAgency a :: PeerHasAgency pr st
a@(ServerAgency ServerHasAgency st
R:ServerHasAgencyBlockFetchst (*) (*) block point st
TokStreaming) (MsgBlock block1
block)) =
    [ PeerHasAgency pr st
-> Message (BlockFetch block point) st 'BFStreaming
-> AnyMessageAndAgency (BlockFetch block point)
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps).
PeerHasAgency pr st -> Message ps st st' -> AnyMessageAndAgency ps
AnyMessageAndAgency PeerHasAgency pr st
a (block -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
forall {k1} block1 (point :: k1).
block1
-> Message (BlockFetch block1 point) 'BFStreaming 'BFStreaming
MsgBlock block
block1
block')
    | block1
block' <- block1 -> [block1]
forall a. Arbitrary a => a -> [a]
shrink block1
block
    ]
  shrink (AnyMessageAndAgency (ServerAgency ServerHasAgency st
R:ServerHasAgencyBlockFetchst (*) (*) block point st
TokStreaming) Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgBatchDone) = []
  shrink (AnyMessageAndAgency (ClientAgency ClientHasAgency st
R:ClientHasAgencyBlockFetchst (*) (*) block point st
TokIdle) Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgClientDone) = []


instance (Eq block, Eq point) =>
         Eq (AnyMessage (BlockFetch block point)) where
  AnyMessage (MsgRequestRange ChainRange point1
r1) == :: AnyMessage (BlockFetch block point)
-> AnyMessage (BlockFetch block point) -> Bool
== AnyMessage (MsgRequestRange ChainRange point1
r2) = ChainRange point1
r1 ChainRange point1 -> ChainRange point1 -> Bool
forall a. Eq a => a -> a -> Bool
== ChainRange point1
ChainRange point1
r2
  AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgStartBatch        == AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgStartBatch        = Bool
True
  AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgNoBlocks          == AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgNoBlocks          = Bool
True
  AnyMessage (MsgBlock block1
b1)        == AnyMessage (MsgBlock block1
b2)        = block1
b1 block1 -> block1 -> Bool
forall a. Eq a => a -> a -> Bool
== block1
block1
b2
  AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgBatchDone         == AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgBatchDone         = Bool
True
  AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgClientDone        == AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgClientDone        = Bool
True
  AnyMessage (BlockFetch block point)
_                               ==                  AnyMessage (BlockFetch block point)
_              = Bool
False

instance Arbitrary (Serialised Block) where
  arbitrary :: Gen (Serialised Block)
arbitrary = ByteString -> Serialised Block
forall {k} (a :: k). ByteString -> Serialised a
Serialised (ByteString -> Serialised Block)
-> (Block -> ByteString) -> Block -> Serialised Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialise a => a -> ByteString
S.serialise @Block (Block -> Serialised Block) -> Gen Block -> Gen (Serialised Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Block
forall a. Arbitrary a => Gen a
arbitrary

  shrink :: Serialised Block -> [Serialised Block]
shrink (Serialised ByteString
block) =
    ByteString -> Serialised Block
forall {k} (a :: k). ByteString -> Serialised a
Serialised (ByteString -> Serialised Block)
-> (Block -> ByteString) -> Block -> Serialised Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialise a => a -> ByteString
S.serialise @Block (Block -> Serialised Block) -> [Block] -> [Serialised Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Block -> [Block]
forall a. Arbitrary a => a -> [a]
shrink (ByteString -> Block
forall a. Serialise a => ByteString -> a
S.deserialise ByteString
block)

prop_codec_BlockFetch
  :: AnyMessageAndAgency (BlockFetch Block (Point Block))
  -> Bool
prop_codec_BlockFetch :: AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_BlockFetch AnyMessageAndAgency (BlockFetch Block (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
-> AnyMessageAndAgency (BlockFetch Block (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
Codec ps failure m bytes -> AnyMessageAndAgency ps -> m Bool
prop_codecM Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec AnyMessageAndAgency (BlockFetch Block (Point Block))
msg)

prop_codec_splits2_BlockFetch
  :: AnyMessageAndAgency (BlockFetch Block (Point Block))
  -> Bool
prop_codec_splits2_BlockFetch :: AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits2_BlockFetch AnyMessageAndAgency (BlockFetch Block (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((ByteString -> [[ByteString]])
-> Codec
     (BlockFetch Block (Point Block))
     DeserialiseFailure
     (ST s)
     ByteString
-> AnyMessageAndAgency (BlockFetch Block (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessageAndAgency ps -> m Bool
prop_codec_splitsM ByteString -> [[ByteString]]
splits2 Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec AnyMessageAndAgency (BlockFetch Block (Point Block))
msg)

prop_codec_splits3_BlockFetch
  :: AnyMessageAndAgency (BlockFetch Block (Point Block))
  -> Bool
prop_codec_splits3_BlockFetch :: AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits3_BlockFetch AnyMessageAndAgency (BlockFetch Block (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((ByteString -> [[ByteString]])
-> Codec
     (BlockFetch Block (Point Block))
     DeserialiseFailure
     (ST s)
     ByteString
-> AnyMessageAndAgency (BlockFetch Block (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessageAndAgency ps -> m Bool
prop_codec_splitsM ByteString -> [[ByteString]]
splits3 Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec AnyMessageAndAgency (BlockFetch Block (Point Block))
msg)

prop_codec_cbor_BlockFetch
  :: AnyMessageAndAgency (BlockFetch Block (Point Block))
  -> Bool
prop_codec_cbor_BlockFetch :: AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_cbor_BlockFetch AnyMessageAndAgency (BlockFetch Block (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
-> AnyMessageAndAgency (BlockFetch Block (Point Block))
-> ST s Bool
forall ps (m :: * -> *).
(Monad m, Eq (AnyMessage ps)) =>
Codec ps DeserialiseFailure m ByteString
-> AnyMessageAndAgency ps -> m Bool
prop_codec_cborM Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec AnyMessageAndAgency (BlockFetch Block (Point Block))
msg)

prop_codec_valid_cbor_BlockFetch
  :: AnyMessageAndAgency (BlockFetch Block (Point Block))
  -> Property
prop_codec_valid_cbor_BlockFetch :: AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Property
prop_codec_valid_cbor_BlockFetch = Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure IO ByteString
-> AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Property
forall ps.
Codec ps DeserialiseFailure IO ByteString
-> AnyMessageAndAgency ps -> Property
prop_codec_valid_cbor_encoding Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure IO ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codec

prop_codec_BlockFetchSerialised
  :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_BlockFetchSerialised :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_BlockFetchSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
-> AnyMessageAndAgency
     (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
Codec ps failure m bytes -> AnyMessageAndAgency ps -> m Bool
prop_codecM Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg)

prop_codec_splits2_BlockFetchSerialised
  :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_splits2_BlockFetchSerialised :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_splits2_BlockFetchSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((ByteString -> [[ByteString]])
-> Codec
     (BlockFetch (Serialised Block) (Point Block))
     DeserialiseFailure
     (ST s)
     ByteString
-> AnyMessageAndAgency
     (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessageAndAgency ps -> m Bool
prop_codec_splitsM ByteString -> [[ByteString]]
splits2 Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg)

prop_codec_splits3_BlockFetchSerialised
  :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_splits3_BlockFetchSerialised :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_splits3_BlockFetchSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((ByteString -> [[ByteString]])
-> Codec
     (BlockFetch (Serialised Block) (Point Block))
     DeserialiseFailure
     (ST s)
     ByteString
-> AnyMessageAndAgency
     (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessageAndAgency ps -> m Bool
prop_codec_splitsM ByteString -> [[ByteString]]
splits3 Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg)

prop_codec_cbor_BlockFetchSerialised
  :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_cbor_BlockFetchSerialised :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_cbor_BlockFetchSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg =
  (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
-> AnyMessageAndAgency
     (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall ps (m :: * -> *).
(Monad m, Eq (AnyMessage ps)) =>
Codec ps DeserialiseFailure m ByteString
-> AnyMessageAndAgency ps -> m Bool
prop_codec_cborM Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg)


prop_codec_binary_compat_BlockFetch_BlockFetchSerialised
  :: AnyMessageAndAgency (BlockFetch Block (Point Block))
  -> Bool
prop_codec_binary_compat_BlockFetch_BlockFetchSerialised :: AnyMessageAndAgency (BlockFetch Block (Point Block)) -> Bool
prop_codec_binary_compat_BlockFetch_BlockFetchSerialised AnyMessageAndAgency (BlockFetch Block (Point Block))
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
-> Codec
     (BlockFetch (Serialised Block) (Point Block))
     DeserialiseFailure
     (ST s)
     ByteString
-> (forall (pr :: PeerRole)
           (stA :: BlockFetch Block (Point Block)).
    PeerHasAgency pr stA
    -> SamePeerHasAgency
         pr (BlockFetch (Serialised Block) (Point Block)))
-> AnyMessageAndAgency (BlockFetch Block (Point Block))
-> ST s Bool
forall psA psB failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage psA)) =>
Codec psA failure m bytes
-> Codec psB failure m bytes
-> (forall (pr :: PeerRole) (stA :: psA).
    PeerHasAgency pr stA -> SamePeerHasAgency pr psB)
-> AnyMessageAndAgency psA
-> m Bool
prop_codec_binary_compatM Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codecWrapped Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised PeerHasAgency pr stA
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall (pr :: PeerRole) (stA :: BlockFetch Block (Point Block)).
PeerHasAgency pr stA
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
stokEq AnyMessageAndAgency (BlockFetch Block (Point Block))
msg)
  where
    stokEq
      :: forall pr (stA :: BlockFetch Block (Point Block)).
         PeerHasAgency pr stA
      -> SamePeerHasAgency pr (BlockFetch (Serialised Block) (Point Block))
    stokEq :: forall (pr :: PeerRole) (stA :: BlockFetch Block (Point Block)).
PeerHasAgency pr stA
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
stokEq (ClientAgency ClientHasAgency stA
ca) = case ClientHasAgency stA
ca of
      ClientHasAgency stA
R:ClientHasAgencyBlockFetchst (*) (*) Block (Point Block) stA
TokIdle -> PeerHasAgency pr 'BFIdle
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall (pr :: PeerRole) ps (st :: ps).
PeerHasAgency pr st -> SamePeerHasAgency pr ps
SamePeerHasAgency (PeerHasAgency pr 'BFIdle
 -> SamePeerHasAgency
      pr (BlockFetch (Serialised Block) (Point Block)))
-> PeerHasAgency pr 'BFIdle
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall a b. (a -> b) -> a -> b
$ ClientHasAgency 'BFIdle -> PeerHasAgency 'AsClient 'BFIdle
forall {ps} (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. ClientHasAgency 'BFIdle
TokIdle
    stokEq (ServerAgency ServerHasAgency stA
sa) = case ServerHasAgency stA
sa of
      ServerHasAgency stA
R:ServerHasAgencyBlockFetchst (*) (*) Block (Point Block) stA
TokBusy      -> PeerHasAgency pr 'BFBusy
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall (pr :: PeerRole) ps (st :: ps).
PeerHasAgency pr st -> SamePeerHasAgency pr ps
SamePeerHasAgency (PeerHasAgency pr 'BFBusy
 -> SamePeerHasAgency
      pr (BlockFetch (Serialised Block) (Point Block)))
-> PeerHasAgency pr 'BFBusy
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall a b. (a -> b) -> a -> b
$ ServerHasAgency 'BFBusy -> PeerHasAgency 'AsServer 'BFBusy
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. ServerHasAgency 'BFBusy
TokBusy
      ServerHasAgency stA
R:ServerHasAgencyBlockFetchst (*) (*) Block (Point Block) stA
TokStreaming -> PeerHasAgency pr 'BFStreaming
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall (pr :: PeerRole) ps (st :: ps).
PeerHasAgency pr st -> SamePeerHasAgency pr ps
SamePeerHasAgency (PeerHasAgency pr 'BFStreaming
 -> SamePeerHasAgency
      pr (BlockFetch (Serialised Block) (Point Block)))
-> PeerHasAgency pr 'BFStreaming
-> SamePeerHasAgency
     pr (BlockFetch (Serialised Block) (Point Block))
forall a b. (a -> b) -> a -> b
$ ServerHasAgency 'BFStreaming
-> PeerHasAgency 'AsServer 'BFStreaming
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
ServerHasAgency 'BFStreaming
TokStreaming

prop_codec_binary_compat_BlockFetchSerialised_BlockFetch
  :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_binary_compat_BlockFetchSerialised_BlockFetch :: AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
-> Bool
prop_codec_binary_compat_BlockFetchSerialised_BlockFetch AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST (Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
-> Codec
     (BlockFetch Block (Point Block))
     DeserialiseFailure
     (ST s)
     ByteString
-> (forall (pr :: PeerRole)
           (stA :: BlockFetch (Serialised Block) (Point Block)).
    PeerHasAgency pr stA
    -> SamePeerHasAgency pr (BlockFetch Block (Point Block)))
-> AnyMessageAndAgency
     (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall psA psB failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage psA)) =>
Codec psA failure m bytes
-> Codec psB failure m bytes
-> (forall (pr :: PeerRole) (stA :: psA).
    PeerHasAgency pr stA -> SamePeerHasAgency pr psB)
-> AnyMessageAndAgency psA
-> m Bool
prop_codec_binary_compatM Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch (Serialised Block) (Point Block))
  DeserialiseFailure
  m
  ByteString
codecSerialised Codec
  (BlockFetch Block (Point Block))
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *).
MonadST m =>
Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure m ByteString
codecWrapped PeerHasAgency pr stA
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall (pr :: PeerRole)
       (stA :: BlockFetch (Serialised Block) (Point Block)).
PeerHasAgency pr stA
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
stokEq AnyMessageAndAgency (BlockFetch (Serialised Block) (Point Block))
msg)
  where
    stokEq
      :: forall pr (stA :: BlockFetch (Serialised Block) (Point Block)).
         PeerHasAgency pr stA
      -> SamePeerHasAgency pr (BlockFetch Block (Point Block))
    stokEq :: forall (pr :: PeerRole)
       (stA :: BlockFetch (Serialised Block) (Point Block)).
PeerHasAgency pr stA
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
stokEq (ClientAgency ClientHasAgency stA
ca) = case ClientHasAgency stA
ca of
      ClientHasAgency stA
R:ClientHasAgencyBlockFetchst
  (*) (*) (Serialised Block) (Point Block) stA
TokIdle -> PeerHasAgency pr 'BFIdle
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall (pr :: PeerRole) ps (st :: ps).
PeerHasAgency pr st -> SamePeerHasAgency pr ps
SamePeerHasAgency (PeerHasAgency pr 'BFIdle
 -> SamePeerHasAgency pr (BlockFetch Block (Point Block)))
-> PeerHasAgency pr 'BFIdle
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall a b. (a -> b) -> a -> b
$ ClientHasAgency 'BFIdle -> PeerHasAgency 'AsClient 'BFIdle
forall {ps} (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. ClientHasAgency 'BFIdle
TokIdle
    stokEq (ServerAgency ServerHasAgency stA
sa) = case ServerHasAgency stA
sa of
      ServerHasAgency stA
R:ServerHasAgencyBlockFetchst
  (*) (*) (Serialised Block) (Point Block) stA
TokBusy      -> PeerHasAgency pr 'BFBusy
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall (pr :: PeerRole) ps (st :: ps).
PeerHasAgency pr st -> SamePeerHasAgency pr ps
SamePeerHasAgency (PeerHasAgency pr 'BFBusy
 -> SamePeerHasAgency pr (BlockFetch Block (Point Block)))
-> PeerHasAgency pr 'BFBusy
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall a b. (a -> b) -> a -> b
$ ServerHasAgency 'BFBusy -> PeerHasAgency 'AsServer 'BFBusy
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. ServerHasAgency 'BFBusy
TokBusy
      ServerHasAgency stA
R:ServerHasAgencyBlockFetchst
  (*) (*) (Serialised Block) (Point Block) stA
TokStreaming -> PeerHasAgency pr 'BFStreaming
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall (pr :: PeerRole) ps (st :: ps).
PeerHasAgency pr st -> SamePeerHasAgency pr ps
SamePeerHasAgency (PeerHasAgency pr 'BFStreaming
 -> SamePeerHasAgency pr (BlockFetch Block (Point Block)))
-> PeerHasAgency pr 'BFStreaming
-> SamePeerHasAgency pr (BlockFetch Block (Point Block))
forall a b. (a -> b) -> a -> b
$ ServerHasAgency 'BFStreaming
-> PeerHasAgency 'AsServer 'BFStreaming
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
ServerHasAgency 'BFStreaming
TokStreaming

--
-- Auxiliary functions
--

-- | Generate a list of @ChainRange@s from a list of points on a chain.  The
-- the ranges which both ends are on the chain are disjoint.
--
pointsToRanges
  :: Chain.HasHeader block
  => Chain block
  -> [Point block]
  -> [ChainRange (Point block)]
pointsToRanges :: forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges Chain block
chain [Point block]
points =
    [Point block] -> [ChainRange (Point block)]
go ([Point block] -> [Point block]
forall a. [a] -> [a]
reverse [Point block]
points)
  where
    go :: [Point block] -> [ChainRange (Point block)]
go (Point block
x : Point block
y : [Point block]
ys) =
      if Point block
x Point block -> Chain block -> Bool
forall block. HasHeader block => Point block -> Chain block -> Bool
`Chain.pointOnChain` Chain block
chain
         -- otherwise `Chain.successorBlock` will error
        then case Point block -> Chain block -> Maybe block
forall block.
HasHeader block =>
Point block -> Chain block -> Maybe block
Chain.successorBlock Point block
x Chain block
chain of
          Maybe block
Nothing -> Point block -> Point block -> ChainRange (Point block)
forall point. point -> point -> ChainRange point
ChainRange Point block
x Point block
y ChainRange (Point block)
-> [ChainRange (Point block)] -> [ChainRange (Point block)]
forall a. a -> [a] -> [a]
: [Point block] -> [ChainRange (Point block)]
go (Point block
y Point block -> [Point block] -> [Point block]
forall a. a -> [a] -> [a]
: [Point block]
ys)
          Just block
x' -> Point block -> Point block -> ChainRange (Point block)
forall point. point -> point -> ChainRange point
ChainRange (block -> Point block
forall block. HasHeader block => block -> Point block
Chain.blockPoint block
x') Point block
y ChainRange (Point block)
-> [ChainRange (Point block)] -> [ChainRange (Point block)]
forall a. a -> [a] -> [a]
: [Point block] -> [ChainRange (Point block)]
go (Point block
y Point block -> [Point block] -> [Point block]
forall a. a -> [a] -> [a]
: [Point block]
ys)
        else Point block -> Point block -> ChainRange (Point block)
forall point. point -> point -> ChainRange point
ChainRange Point block
x Point block
y ChainRange (Point block)
-> [ChainRange (Point block)] -> [ChainRange (Point block)]
forall a. a -> [a] -> [a]
: [Point block] -> [ChainRange (Point block)]
go (Point block
y Point block -> [Point block] -> [Point block]
forall a. a -> [a] -> [a]
: [Point block]
ys)
    go [Point block
x] = [Point block -> Point block -> ChainRange (Point block)
forall point. point -> point -> ChainRange point
ChainRange Point block
forall {k} (block :: k). Point block
genesisPoint Point block
x]
    go []  = []

-- | Compute list of received block bodies from a chain and points.
-- This is the reference function against which we compare block-fetch
-- protocol.  The @'ponitsToRanges'@ function is used to compute the ranges,
-- and then the results are then read from the chain directly.  Thus this is
-- the prototypical function for the block-fetch protocol.
--
receivedBlockBodies
  :: Chain Block
  -> [Point Block]
  -> [[Block]]
receivedBlockBodies :: Chain Block -> [Point Block] -> [[Block]]
receivedBlockBodies Chain Block
chain [Point Block]
points =
    (ChainRange (Point Block) -> [Block])
-> [ChainRange (Point Block)] -> [[Block]]
forall a b. (a -> b) -> [a] -> [b]
map ChainRange (Point Block) -> [Block]
f (Chain Block -> [Point Block] -> [ChainRange (Point Block)]
forall block.
HasHeader block =>
Chain block -> [Point block] -> [ChainRange (Point block)]
pointsToRanges Chain Block
chain [Point Block]
points)
 where
    f :: ChainRange (Point Block) -> [Block]
f (ChainRange Point Block
from Point Block
to) =
      case Chain Block -> Point Block -> Point Block -> Maybe [Block]
forall block.
HasHeader block =>
Chain block -> Point block -> Point block -> Maybe [block]
Chain.selectBlockRange Chain Block
chain Point Block
from Point Block
to of
        Maybe [Block]
Nothing -> []
        Just [Block]
bs -> [Block]
bs