{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ParallelListComp    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 1" TestChainAndPoints -> [Bool] -> Property
prop_connect_pipelined1
        , TestName -> (TestChainAndPoints -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 2" TestChainAndPoints -> Property
prop_connect_pipelined2
        , TestName -> (TestChainAndPoints -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 3" TestChainAndPoints -> Property
prop_connect_pipelined3
        , TestName -> (TestChainAndPoints -> [Bool] -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 4" TestChainAndPoints -> [Bool] -> Property
prop_connect_pipelined4
        , TestName
-> (TestChainAndPoints -> PipeliningDepth -> [Bool] -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect_pipelined 5" TestChainAndPoints -> PipeliningDepth -> [Bool] -> Property
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
-> (AnyMessage (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec"               AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_BlockFetch
        , TestName
-> (AnyMessage (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec 2-splits"      AnyMessage (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
-> (AnyMessage (BlockFetch Block (Point Block)) -> Bool)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                             AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits3_BlockFetch
        , TestName
-> (AnyMessage (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec cbor"          AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_cbor_BlockFetch
        , TestName
-> (AnyMessage (BlockFetch Block (Point Block)) -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec valid cbor"    AnyMessage (BlockFetch Block (Point Block)) -> Property
prop_codec_valid_cbor_BlockFetch

        , TestName
-> (AnyMessage (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised"                   AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_BlockFetchSerialised
        , TestName
-> (AnyMessage (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised 2-splits"          AnyMessage (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
-> (AnyMessage (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                                           AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_splits3_BlockFetchSerialised
        , TestName
-> (AnyMessage (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised cbor"              AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_cbor_BlockFetchSerialised
        , TestName
-> (AnyMessage (BlockFetch Block (Point Block)) -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec/codecSerialised bin compat"  AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_binary_compat_BlockFetch_BlockFetchSerialised
        , TestName
-> (AnyMessage (BlockFetch (Serialised Block) (Point Block))
    -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised/codec bin compat"  AnyMessage (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
  'NonPipelined
  'BFIdle
  (IOSim s)
  [Block]
-> Peer
     (BlockFetch Block (Point Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'BFIdle
     (IOSim s)
     ()
-> IOSim
     s ([Block], (), TerminalStates (BlockFetch Block (Point Block)))
forall ps (pr :: PeerRole) (initSt :: ps) (m :: * -> *) a b.
(Monad m, SingI pr) =>
Peer ps pr 'NonPipelined initSt m a
-> Peer ps (FlipAgency pr) 'NonPipelined initSt m b
-> m (a, b, TerminalStates ps)
connect
             (BlockFetchClient Block (Point Block) (IOSim s) [Block]
-> Peer
     (BlockFetch Block (Point Block))
     'AsClient
     'NonPipelined
     'BFIdle
     (IOSim s)
     [Block]
forall block point (m :: * -> *) a.
Monad m =>
BlockFetchClient block point m a
-> Client (BlockFetch block point) 'NonPipelined '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) ()
-> Server
     (BlockFetch Block (Point Block)) 'NonPipelined 'BFIdle (IOSim s) ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined '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 SingBlockFetch st
StateToken st
SingBFDone SingBlockFetch 'BFDone
StateToken st
SingBFDone) ->
        [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
                     , MonadFail m
                     )
                  => TestClientPipelined m
                  -> Chain Block
                  -> [Bool]
                  -> m [Either (ChainRange (Point Block)) [Block]]
connect_pipelined :: forall (m :: * -> *).
(MonadSTM m, MonadFail 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 SingBFDone SingBFDone)
      <- [Bool]
-> PeerPipelined
     (BlockFetch Block (Point Block))
     'AsClient
     'BFIdle
     m
     [Either (ChainRange (Point Block)) [Block]]
-> Peer
     (BlockFetch Block (Point Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'BFIdle
     m
     ()
-> m ([Either (ChainRange (Point Block)) [Block]], (),
      TerminalStates (BlockFetch Block (Point Block)))
forall ps (pr :: PeerRole) (st :: ps) (m :: * -> *) a b.
(Monad m, SingI pr) =>
[Bool]
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) 'NonPipelined 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
-> ClientPipelined (BlockFetch block point) 'BFIdle m a
blockFetchClientPeerPipelined TestClientPipelined m
client)
           (BlockFetchServer Block (Point Block) m ()
-> Server
     (BlockFetch Block (Point Block)) 'NonPipelined 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined '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] -> Property
prop_connect_pipelined1 :: TestChainAndPoints -> [Bool] -> Property
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, MonadFail 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]] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
    (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 -> Property
prop_connect_pipelined2 :: TestChainAndPoints -> Property
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, MonadFail 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]] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
    (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 -> Property
prop_connect_pipelined3 :: TestChainAndPoints -> Property
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, MonadFail 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]] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
    [[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] -> Property
prop_connect_pipelined4 :: TestChainAndPoints -> [Bool] -> Property
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, MonadFail 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]] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
    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] -> Property
prop_connect_pipelined5 :: TestChainAndPoints -> PipeliningDepth -> [Bool] -> Property
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, MonadFail 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]] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
===
    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
     'NonPipelined
     'BFIdle
     m
     [Block]
-> Peer
     (BlockFetch Block (Point Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'BFIdle
     m
     ()
-> m ([Block], ())
forall ps (pr :: PeerRole) (st :: ps) failure bytes (m :: * -> *) a
       b.
(MonadAsync m, MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (Role, TraceSendRecv ps)
-> Codec ps failure m bytes
-> Peer ps pr 'NonPipelined st m a
-> Peer ps (FlipAgency pr) 'NonPipelined 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
     'NonPipelined
     'BFIdle
     m
     [Block]
forall block point (m :: * -> *) a.
Monad m =>
BlockFetchClient block point m a
-> Client (BlockFetch block point) 'NonPipelined '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 ()
-> Server
     (BlockFetch Block (Point Block)) 'NonPipelined 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined '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 (AnyMessage (BlockFetch block point)) where
  arbitrary :: Gen (AnyMessage (BlockFetch block point))
arbitrary = [Gen (AnyMessage (BlockFetch block point))]
-> Gen (AnyMessage (BlockFetch block point))
forall a. [Gen a] -> Gen a
oneof
    [ Message (BlockFetch block point) 'BFIdle 'BFBusy
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (BlockFetch block point) 'BFIdle 'BFBusy
 -> AnyMessage (BlockFetch block point))
-> (ChainRange point
    -> Message (BlockFetch block point) 'BFIdle 'BFBusy)
-> ChainRange point
-> AnyMessage (BlockFetch block point)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainRange point
-> Message (BlockFetch block point) 'BFIdle 'BFBusy
forall {k} point1 (block :: k).
ChainRange point1
-> Message (BlockFetch block point1) 'BFIdle 'BFBusy
MsgRequestRange (ChainRange point -> AnyMessage (BlockFetch block point))
-> Gen (ChainRange point)
-> Gen (AnyMessage (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
    , AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (BlockFetch block point)
 -> Gen (AnyMessage (BlockFetch block point)))
-> AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ Message (BlockFetch block point) 'BFBusy 'BFStreaming
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (BlockFetch block point) 'BFBusy 'BFStreaming
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFBusy 'BFStreaming
MsgStartBatch
    , AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (BlockFetch block point)
 -> Gen (AnyMessage (BlockFetch block point)))
-> AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ Message (BlockFetch block point) 'BFBusy 'BFIdle
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (BlockFetch block point) 'BFBusy 'BFIdle
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFBusy 'BFIdle
MsgNoBlocks
    , Message (BlockFetch block point) 'BFStreaming 'BFStreaming
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (BlockFetch block point) 'BFStreaming 'BFStreaming
 -> AnyMessage (BlockFetch block point))
-> (block
    -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming)
-> block
-> AnyMessage (BlockFetch block point)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. block -> Message (BlockFetch block point) 'BFStreaming 'BFStreaming
forall {k1} block1 (point :: k1).
block1
-> Message (BlockFetch block1 point) 'BFStreaming 'BFStreaming
MsgBlock (block -> AnyMessage (BlockFetch block point))
-> Gen block -> Gen (AnyMessage (BlockFetch block point))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen block
forall a. Arbitrary a => Gen a
arbitrary
    , AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (BlockFetch block point)
 -> Gen (AnyMessage (BlockFetch block point)))
-> AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ Message (BlockFetch block point) 'BFStreaming 'BFIdle
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (BlockFetch block point) 'BFStreaming 'BFIdle
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFStreaming 'BFIdle
MsgBatchDone
    , AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (BlockFetch block point)
 -> Gen (AnyMessage (BlockFetch block point)))
-> AnyMessage (BlockFetch block point)
-> Gen (AnyMessage (BlockFetch block point))
forall a b. (a -> b) -> a -> b
$ Message (BlockFetch block point) 'BFIdle 'BFDone
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (BlockFetch block point) 'BFIdle 'BFDone
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFIdle 'BFDone
MsgClientDone
    ]

  shrink :: AnyMessage (BlockFetch block point)
-> [AnyMessage (BlockFetch block point)]
shrink (AnyMessage (MsgRequestRange ChainRange point1
range)) =
    [ Message (BlockFetch block point) 'BFIdle 'BFBusy
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (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 (AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgStartBatch) = []
  shrink (AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgNoBlocks) = []
  shrink (AnyMessage (MsgBlock block1
block)) =
    [ Message (BlockFetch block point) 'BFStreaming 'BFStreaming
-> AnyMessage (BlockFetch block point)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (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 (AnyMessage Message (BlockFetch block point) st st'
R:MessageBlockFetchfromto (*) (*) block point st st'
MsgBatchDone) = []
  shrink (AnyMessage 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
  :: AnyMessage (BlockFetch Block (Point Block))
  -> Bool
prop_codec_BlockFetch :: AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_BlockFetch AnyMessage (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
-> AnyMessage (BlockFetch Block (Point Block)) -> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
Codec ps failure m bytes -> AnyMessage 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 AnyMessage (BlockFetch Block (Point Block))
msg)

prop_codec_splits2_BlockFetch
  :: AnyMessage (BlockFetch Block (Point Block))
  -> Bool
prop_codec_splits2_BlockFetch :: AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits2_BlockFetch AnyMessage (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
-> AnyMessage (BlockFetch Block (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessage 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 AnyMessage (BlockFetch Block (Point Block))
msg)

prop_codec_splits3_BlockFetch
  :: AnyMessage (BlockFetch Block (Point Block))
  -> Bool
prop_codec_splits3_BlockFetch :: AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_splits3_BlockFetch AnyMessage (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
-> AnyMessage (BlockFetch Block (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
(bytes -> [[bytes]])
-> Codec ps failure m bytes -> AnyMessage 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 AnyMessage (BlockFetch Block (Point Block))
msg)

prop_codec_cbor_BlockFetch
  :: AnyMessage (BlockFetch Block (Point Block))
  -> Bool
prop_codec_cbor_BlockFetch :: AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_cbor_BlockFetch AnyMessage (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
-> AnyMessage (BlockFetch Block (Point Block)) -> ST s Bool
forall ps (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure m ByteString -> AnyMessage 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 AnyMessage (BlockFetch Block (Point Block))
msg)

prop_codec_valid_cbor_BlockFetch
  :: AnyMessage (BlockFetch Block (Point Block))
  -> Property
prop_codec_valid_cbor_BlockFetch :: AnyMessage (BlockFetch Block (Point Block)) -> Property
prop_codec_valid_cbor_BlockFetch = Codec
  (BlockFetch Block (Point Block)) DeserialiseFailure IO ByteString
-> AnyMessage (BlockFetch Block (Point Block)) -> Property
forall ps.
Codec ps DeserialiseFailure IO ByteString
-> AnyMessage 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
  :: AnyMessage (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_BlockFetchSerialised :: AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_BlockFetchSerialised AnyMessage (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
-> AnyMessage (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall ps failure (m :: * -> *) bytes.
(Monad m, Eq (AnyMessage ps)) =>
Codec ps failure m bytes -> AnyMessage 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 AnyMessage (BlockFetch (Serialised Block) (Point Block))
msg)

prop_codec_splits2_BlockFetchSerialised
  :: AnyMessage (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_splits2_BlockFetchSerialised :: AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_splits2_BlockFetchSerialised AnyMessage (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
-> AnyMessage (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 -> AnyMessage 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 AnyMessage (BlockFetch (Serialised Block) (Point Block))
msg)

prop_codec_splits3_BlockFetchSerialised
  :: AnyMessage (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_splits3_BlockFetchSerialised :: AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_splits3_BlockFetchSerialised AnyMessage (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
-> AnyMessage (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 -> AnyMessage 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 AnyMessage (BlockFetch (Serialised Block) (Point Block))
msg)

prop_codec_cbor_BlockFetchSerialised
  :: AnyMessage (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_cbor_BlockFetchSerialised :: AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_cbor_BlockFetchSerialised AnyMessage (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
-> AnyMessage (BlockFetch (Serialised Block) (Point Block))
-> ST s Bool
forall ps (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure m ByteString -> AnyMessage 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 AnyMessage (BlockFetch (Serialised Block) (Point Block))
msg)


prop_codec_binary_compat_BlockFetch_BlockFetchSerialised
  :: AnyMessage (BlockFetch Block (Point Block))
  -> Bool
prop_codec_binary_compat_BlockFetch_BlockFetchSerialised :: AnyMessage (BlockFetch Block (Point Block)) -> Bool
prop_codec_binary_compat_BlockFetch_BlockFetchSerialised AnyMessage (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 (stA :: BlockFetch Block (Point Block)).
    ActiveState stA =>
    StateToken stA
    -> SomeState (BlockFetch (Serialised Block) (Point Block)))
-> AnyMessage (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 (stA :: psA).
    ActiveState stA =>
    StateToken stA -> SomeState psB)
-> AnyMessage 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 StateToken stA
-> SomeState (BlockFetch (Serialised Block) (Point Block))
forall (stA :: BlockFetch Block (Point Block)).
ActiveState stA =>
StateToken stA
-> SomeState (BlockFetch (Serialised Block) (Point Block))
stokEq AnyMessage (BlockFetch Block (Point Block))
msg)
  where
    stokEq
      :: forall (stA :: BlockFetch Block (Point Block)).
         ActiveState stA
      => StateToken stA
      -> SomeState (BlockFetch (Serialised Block) (Point Block))
    stokEq :: forall (stA :: BlockFetch Block (Point Block)).
ActiveState stA =>
StateToken stA
-> SomeState (BlockFetch (Serialised Block) (Point Block))
stokEq SingBlockFetch stA
StateToken stA
SingBFIdle      = StateToken 'BFIdle
-> SomeState (BlockFetch (Serialised Block) (Point Block))
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingBlockFetch 'BFIdle
StateToken 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. SingBlockFetch 'BFIdle
SingBFIdle
    stokEq SingBlockFetch stA
StateToken stA
SingBFBusy      = StateToken 'BFBusy
-> SomeState (BlockFetch (Serialised Block) (Point Block))
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingBlockFetch 'BFBusy
StateToken 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. SingBlockFetch 'BFBusy
SingBFBusy
    stokEq SingBlockFetch stA
StateToken stA
SingBFStreaming = StateToken 'BFStreaming
-> SomeState (BlockFetch (Serialised Block) (Point Block))
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingBlockFetch 'BFStreaming
StateToken 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
SingBlockFetch 'BFStreaming
SingBFStreaming
    stokEq a :: StateToken stA
a@SingBlockFetch stA
StateToken stA
SingBFDone    = StateToken 'BFDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken stA
StateToken 'BFDone
a

prop_codec_binary_compat_BlockFetchSerialised_BlockFetch
  :: AnyMessage (BlockFetch (Serialised Block) (Point Block))
  -> Bool
prop_codec_binary_compat_BlockFetchSerialised_BlockFetch :: AnyMessage (BlockFetch (Serialised Block) (Point Block)) -> Bool
prop_codec_binary_compat_BlockFetchSerialised_BlockFetch AnyMessage (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 (stA :: BlockFetch (Serialised Block) (Point Block)).
    ActiveState stA =>
    StateToken stA -> SomeState (BlockFetch Block (Point Block)))
-> AnyMessage (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 (stA :: psA).
    ActiveState stA =>
    StateToken stA -> SomeState psB)
-> AnyMessage 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 StateToken stA -> SomeState (BlockFetch Block (Point Block))
forall (stA :: BlockFetch (Serialised Block) (Point Block)).
ActiveState stA =>
StateToken stA -> SomeState (BlockFetch Block (Point Block))
stokEq AnyMessage (BlockFetch (Serialised Block) (Point Block))
msg)
  where
    stokEq
      :: forall (stA :: BlockFetch (Serialised Block) (Point Block)).
         ActiveState stA
      => StateToken stA
      -> SomeState (BlockFetch Block (Point Block))
    stokEq :: forall (stA :: BlockFetch (Serialised Block) (Point Block)).
ActiveState stA =>
StateToken stA -> SomeState (BlockFetch Block (Point Block))
stokEq SingBlockFetch stA
StateToken stA
SingBFIdle      = StateToken 'BFIdle -> SomeState (BlockFetch Block (Point Block))
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingBlockFetch 'BFIdle
StateToken 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. SingBlockFetch 'BFIdle
SingBFIdle
    stokEq SingBlockFetch stA
StateToken stA
SingBFBusy      = StateToken 'BFBusy -> SomeState (BlockFetch Block (Point Block))
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingBlockFetch 'BFBusy
StateToken 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. SingBlockFetch 'BFBusy
SingBFBusy
    stokEq SingBlockFetch stA
StateToken stA
SingBFStreaming = StateToken 'BFStreaming
-> SomeState (BlockFetch Block (Point Block))
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingBlockFetch 'BFStreaming
StateToken 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
SingBlockFetch 'BFStreaming
SingBFStreaming
    stokEq a :: StateToken stA
a@SingBlockFetch stA
StateToken stA
SingBFDone    = StateToken 'BFDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken stA
StateToken 'BFDone
a

--
-- 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 @'pointsToRanges'@ 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