{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -Wno-orphans #-}

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

import Codec.Serialise qualified as S
import Control.Monad (unless, void)
import Control.Monad.ST qualified as ST
import Data.ByteString.Lazy (ByteString)

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Control.Tracer (nullTracer)

import Control.Monad.IOSim (runSimOrThrow)

import Network.TypedProtocol.Codec
import Network.TypedProtocol.Proofs (connect, connectPipelined)

import Ouroboros.Network.Channel
import Ouroboros.Network.Driver

import Ouroboros.Network.Block (BlockNo, Serialised (..), StandardHash,
           Tip (..), decodeTip, encodeTip, pattern BlockPoint,
           pattern GenesisPoint, unwrapCBORinCBOR, wrapCBORinCBOR)
import Ouroboros.Network.Mock.Chain (Chain, Point)
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ConcreteBlock (Block, BlockHeader (..))
import Ouroboros.Network.Mock.ProducerState qualified as ChainProducerState

import Ouroboros.Network.Protocol.ChainSync.Client
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import Ouroboros.Network.Protocol.ChainSync.Codec
import Ouroboros.Network.Protocol.ChainSync.Direct
import Ouroboros.Network.Protocol.ChainSync.DirectPipelined
import Ouroboros.Network.Protocol.ChainSync.Examples (Client)
import Ouroboros.Network.Protocol.ChainSync.Examples qualified as ChainSyncExamples
import Ouroboros.Network.Protocol.ChainSync.ExamplesPipelined qualified as ChainSyncExamples
import Ouroboros.Network.Protocol.ChainSync.Server
import Ouroboros.Network.Protocol.ChainSync.Type
import Test.Data.PipeliningDepth (PipeliningDepth (..))

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

import Test.QuickCheck hiding (Result)
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
"ChainSync"
    [ TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"direct ST" ChainProducerStateForkTest -> Property
propChainSyncDirectST
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"direct IO" ChainProducerStateForkTest -> Property
propChainSyncDirectIO
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect ST" ChainProducerStateForkTest -> Property
propChainSyncConnectST
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connect IO" ChainProducerStateForkTest -> Property
propChainSyncConnectIO
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"directPipelinedMax ST" ChainProducerStateForkTest -> PipeliningDepth -> Bool
propChainSyncPipelinedMaxDirectST
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"directPipelinedMax IO" ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncPipelinedMaxDirectIO
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"directPipelinedMin ST" ChainProducerStateForkTest -> PipeliningDepth -> Bool
propChainSyncPipelinedMinDirectST
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"directPipelinedMin IO" ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncPipelinedMinDirectIO
    , TestName
-> (ChainProducerStateForkTest
    -> [Bool] -> PipeliningDepth -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connectPipelinedMax ST" ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Bool
propChainSyncPipelinedMaxConnectST
    , TestName
-> (ChainProducerStateForkTest
    -> [Bool] -> PipeliningDepth -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connectPipelinedMin ST" ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Bool
propChainSyncPipelinedMinConnectST
    , TestName
-> (ChainProducerStateForkTest
    -> [Bool] -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connectPipelinedMax IO" ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Property
propChainSyncPipelinedMaxConnectIO
    , TestName
-> (ChainProducerStateForkTest
    -> [Bool] -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"connectPipelinedMin IO" ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Property
propChainSyncPipelinedMinConnectIO
    , TestName -> (AnyMessage ChainSync_BlockHeader -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec"            AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_ChainSync
    , TestName -> (AnyMessage ChainSync_BlockHeader -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec 2-splits"   AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_splits2_ChainSync
    , 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 ChainSync_BlockHeader -> Bool) -> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30 AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_splits3_ChainSync
    , TestName -> (AnyMessage ChainSync_BlockHeader -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec cbor"       AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_cbor
    , TestName
-> (AnyMessage ChainSync_BlockHeader -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec valid cbor" AnyMessage ChainSync_BlockHeader -> Property
prop_codec_valid_cbor
    , TestName
-> (AnyMessage ChainSync_Serialised_BlockHeader -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised"            AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_ChainSyncSerialised
    , TestName
-> (AnyMessage ChainSync_Serialised_BlockHeader -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised 2-splits"   AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_splits2_ChainSyncSerialised
    , 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 ChainSync_Serialised_BlockHeader -> Bool)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
30
                                                AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_splits3_ChainSyncSerialised
    , TestName
-> (AnyMessage ChainSync_Serialised_BlockHeader -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised cbor"       AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_cbor_ChainSyncSerialised
    , TestName -> (AnyMessage ChainSync_BlockHeader -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codec/codecSerialised bin compat"  AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_binary_compat_ChainSync_ChainSyncSerialised
    , TestName
-> (AnyMessage ChainSync_Serialised_BlockHeader -> Bool)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"codecSerialised/codec bin compat"  AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_binary_compat_ChainSyncSerialised_ChainSync
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demo ST" ChainProducerStateForkTest -> Property
propChainSyncDemoST
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demo IO" ChainProducerStateForkTest -> Property
propChainSyncDemoIO
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedMax ST"     ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMaxST
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedMax IO"     ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMaxIO
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedMin ST"     ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMinST
    , TestName
-> (ChainProducerStateForkTest -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedMin IO"     ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMinIO
    , TestName
-> (ChainProducerStateForkTest
    -> PipeliningDepth -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedLowHigh ST" ChainProducerStateForkTest
-> PipeliningDepth -> PipeliningDepth -> Property
propChainSyncDemoPipelinedLowHighST
    , TestName
-> (ChainProducerStateForkTest
    -> PipeliningDepth -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedLowHigh IO" ChainProducerStateForkTest
-> PipeliningDepth -> PipeliningDepth -> Property
propChainSyncDemoPipelinedLowHighIO
    , TestName
-> (ChainProducerStateForkTest
    -> PipeliningDepth -> PipeliningDepth -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demoPipelinedMin IO (buffered)"
                                         ChainProducerStateForkTest
-> PipeliningDepth -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMinBufferedIO
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"demo IO" ChainProducerStateForkTest -> Property
propChainSyncDemoIO
    , TestName -> (ChainProducerStateForkTest -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"pipe demo" ChainProducerStateForkTest -> Property
propChainSyncPipe
    ]
  ]

-- | Testing @'Client'@ which stops at a given point.
--
testClient
  :: MonadSTM m
  => StrictTVar m Bool
  -> Point Block
  -> ChainSyncExamples.Client Block (Point Block) blockInfo m ()
testClient :: forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar Point Block
tip =
  ChainSyncExamples.Client {
      rollbackward :: Point Block
-> blockInfo
-> m (Either () (Client Block (Point Block) blockInfo m ()))
ChainSyncExamples.rollbackward = \Point Block
point blockInfo
_ ->
        if Point Block
point Point Block -> Point Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block
tip
          then do
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Bool
doneVar Bool
True
            Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () (Client Block (Point Block) blockInfo m ())
 -> m (Either () (Client Block (Point Block) blockInfo m ())))
-> Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a b. (a -> b) -> a -> b
$ () -> Either () (Client Block (Point Block) blockInfo m ())
forall a b. a -> Either a b
Left ()
          else Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () (Client Block (Point Block) blockInfo m ())
 -> m (Either () (Client Block (Point Block) blockInfo m ())))
-> Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a b. (a -> b) -> a -> b
$ Client Block (Point Block) blockInfo m ()
-> Either () (Client Block (Point Block) blockInfo m ())
forall a b. b -> Either a b
Right (StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar Point Block
tip),
      rollforward :: Block -> m (Either () (Client Block (Point Block) blockInfo m ()))
ChainSyncExamples.rollforward = \Block
block ->
        if Block -> Point Block
forall block. HasHeader block => block -> Point block
Chain.blockPoint Block
block Point Block -> Point Block -> Bool
forall a. Eq a => a -> a -> Bool
== Point Block
tip
          then do
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Bool
doneVar Bool
True
            Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () (Client Block (Point Block) blockInfo m ())
 -> m (Either () (Client Block (Point Block) blockInfo m ())))
-> Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a b. (a -> b) -> a -> b
$ () -> Either () (Client Block (Point Block) blockInfo m ())
forall a b. a -> Either a b
Left ()
          else Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () (Client Block (Point Block) blockInfo m ())
 -> m (Either () (Client Block (Point Block) blockInfo m ())))
-> Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a b. (a -> b) -> a -> b
$ Client Block (Point Block) blockInfo m ()
-> Either () (Client Block (Point Block) blockInfo m ())
forall a b. b -> Either a b
Right (StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar Point Block
tip),
      points :: [Point Block]
-> m (Either () (Client Block (Point Block) blockInfo m ()))
ChainSyncExamples.points = \[Point Block]
_ -> Either () (Client Block (Point Block) blockInfo m ())
-> m (Either () (Client Block (Point Block) blockInfo m ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Client Block (Point Block) blockInfo m ()
-> Either () (Client Block (Point Block) blockInfo m ())
forall a b. b -> Either a b
Right (Client Block (Point Block) blockInfo m ()
 -> Either () (Client Block (Point Block) blockInfo m ()))
-> Client Block (Point Block) blockInfo m ()
-> Either () (Client Block (Point Block) blockInfo m ())
forall a b. (a -> b) -> a -> b
$ StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar Point Block
tip)
    }

-- | An experiment in which the client has a fork of the server chain.  The
-- experiment finishes successfully if the client receives the server's chain.
--
chainSyncForkExperiment
  :: forall m.
     ( MonadST m
     , MonadSTM m
     )
  => (forall a b.
         ChainSyncServer Block (Point Block) (Tip Block) m a
      -> ChainSyncClient Block (Point Block) (Tip Block) m b
      -> m ())
  -> ChainProducerStateForkTest
  -> m Property
chainSyncForkExperiment :: forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClient Block (Point Block) (Tip Block) m b -> m ())
-> ChainProducerStateForkTest -> m Property
chainSyncForkExperiment forall a b.
ChainSyncServer Block (Point Block) (Tip Block) m a
-> ChainSyncClient Block (Point Block) (Tip Block) m b -> m ()
run (ChainProducerStateForkTest ChainProducerState Block
cps Chain Block
chain) = do
  let pchain :: Chain Block
pchain = ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
ChainProducerState.producerChain ChainProducerState Block
cps
  cpsVar   <- STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTVar m (ChainProducerState Block))
 -> m (StrictTVar m (ChainProducerState Block)))
-> STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a b. (a -> b) -> a -> b
$ ChainProducerState Block
-> STM m (StrictTVar m (ChainProducerState Block))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar ChainProducerState Block
cps
  chainVar <- atomically $ newTVar chain
  doneVar  <- atomically $ newTVar False
  let server = Any
-> StrictTVar m (ChainProducerState Block)
-> (Block -> Block)
-> ChainSyncServer Block (Point Block) (Tip Block) m Any
forall blk header (m :: * -> *) a.
(HasHeader blk, MonadSTM m, HeaderHash header ~ HeaderHash blk) =>
a
-> StrictTVar m (ChainProducerState blk)
-> (blk -> header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
ChainSyncExamples.chainSyncServerExample
        (TestName -> Any
forall a. HasCallStack => TestName -> a
error TestName
"chainSyncServerExample: lazy in the result type")
        StrictTVar m (ChainProducerState Block)
cpsVar
        Block -> Block
forall a. a -> a
id
      client = StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m ()
-> ChainSyncClient Block (Point Block) (Tip Block) m ()
forall header block tip (m :: * -> *) a.
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadSTM m) =>
StrictTVar m (Chain header)
-> Client header (Point block) tip m a
-> ChainSyncClient header (Point block) tip m a
ChainSyncExamples.chainSyncClientExample StrictTVar m (Chain Block)
chainVar (StrictTVar m Bool
-> Point Block -> Client Block (Point Block) (Tip Block) m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar (Chain Block -> Point Block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain Block
pchain))
  _ <- run server client

  cchain <- atomically $ readTVar chainVar
  return (pchain === cchain)

propChainSyncDirectST :: ChainProducerStateForkTest -> Property
propChainSyncDirectST :: ChainProducerStateForkTest -> Property
propChainSyncDirectST ChainProducerStateForkTest
cps =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> ChainProducerStateForkTest -> IOSim s Property
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClient Block (Point Block) (Tip Block) m b -> m ())
-> ChainProducerStateForkTest -> m Property
chainSyncForkExperiment ((((ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
  -> IOSim s (a, b))
 -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall a b.
(a -> b)
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> a)
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
   -> IOSim s (a, b))
  -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
  -> IOSim s ())
 -> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
     -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
     -> IOSim s (a, b))
 -> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> ((IOSim s (a, b) -> IOSim s ())
    -> (ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
        -> IOSim s (a, b))
    -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s ())
-> (IOSim s (a, b) -> IOSim s ())
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOSim s (a, b) -> IOSim s ())
-> (ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall a b.
(a -> b)
-> (ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
    -> a)
-> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) IOSim s (a, b) -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct) ChainProducerStateForkTest
cps

propChainSyncDirectIO :: ChainProducerStateForkTest -> Property
propChainSyncDirectIO :: ChainProducerStateForkTest -> Property
propChainSyncDirectIO ChainProducerStateForkTest
cps =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClient Block (Point Block) (Tip Block) IO b -> IO ())
-> ChainProducerStateForkTest -> IO Property
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClient Block (Point Block) (Tip Block) m b -> m ())
-> ChainProducerStateForkTest -> m Property
chainSyncForkExperiment ((((ChainSyncClient Block (Point Block) (Tip Block) IO b
  -> IO (a, b))
 -> ChainSyncClient Block (Point Block) (Tip Block) IO b -> IO ())
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a
    -> ChainSyncClient Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClient Block (Point Block) (Tip Block) IO b
-> IO ()
forall a b.
(a -> b)
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a -> a)
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ChainSyncClient Block (Point Block) (Tip Block) IO b
   -> IO (a, b))
  -> ChainSyncClient Block (Point Block) (Tip Block) IO b -> IO ())
 -> (ChainSyncServer Block (Point Block) (Tip Block) IO a
     -> ChainSyncClient Block (Point Block) (Tip Block) IO b
     -> IO (a, b))
 -> ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClient Block (Point Block) (Tip Block) IO b
 -> IO ())
-> ((IO (a, b) -> IO ())
    -> (ChainSyncClient Block (Point Block) (Tip Block) IO b
        -> IO (a, b))
    -> ChainSyncClient Block (Point Block) (Tip Block) IO b
    -> IO ())
-> (IO (a, b) -> IO ())
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a
    -> ChainSyncClient Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClient Block (Point Block) (Tip Block) IO b
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (a, b) -> IO ())
-> (ChainSyncClient Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncClient Block (Point Block) (Tip Block) IO b
-> IO ()
forall a b.
(a -> b)
-> (ChainSyncClient Block (Point Block) (Tip Block) IO b -> a)
-> ChainSyncClient Block (Point Block) (Tip Block) IO b
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) IO (a, b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClient Block (Point Block) (Tip Block) IO b
-> IO (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClient header point tip m b -> m (a, b)
direct) ChainProducerStateForkTest
cps

propChainSyncConnectST :: ChainProducerStateForkTest -> Property
propChainSyncConnectST :: ChainProducerStateForkTest -> Property
propChainSyncConnectST ChainProducerStateForkTest
cps =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> ChainProducerStateForkTest -> IOSim s Property
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClient Block (Point Block) (Tip Block) m b -> m ())
-> ChainProducerStateForkTest -> m Property
chainSyncForkExperiment
        (\ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
ser ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
cli ->
            IOSim
  s
  (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim
   s
   (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
 -> IOSim s ())
-> IOSim
     s
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IOSim s ()
forall a b. (a -> b) -> a -> b
$ Peer
  (ChainSync Block (Point Block) (Tip Block))
  'AsClient
  'NonPipelined
  'StIdle
  (IOSim s)
  b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     (IOSim s)
     a
-> IOSim
     s
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip 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 (ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     'AsClient
     'NonPipelined
     'StIdle
     (IOSim s)
     b
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClient header point tip m a
-> Client (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncClientPeer ChainSyncClient Block (Point Block) (Tip Block) (IOSim s) b
cli) (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> Server
     (ChainSync Block (Point Block) (Tip Block))
     'NonPipelined
     'StIdle
     (IOSim s)
     a
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
ser)
        ) ChainProducerStateForkTest
cps

propChainSyncConnectIO :: ChainProducerStateForkTest -> Property
propChainSyncConnectIO :: ChainProducerStateForkTest -> Property
propChainSyncConnectIO ChainProducerStateForkTest
cps =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClient Block (Point Block) (Tip Block) IO b -> IO ())
-> ChainProducerStateForkTest -> IO Property
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClient Block (Point Block) (Tip Block) m b -> m ())
-> ChainProducerStateForkTest -> m Property
chainSyncForkExperiment
        (\ChainSyncServer Block (Point Block) (Tip Block) IO a
ser ChainSyncClient Block (Point Block) (Tip Block) IO b
cli ->
            IO
  (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO
   (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
 -> IO ())
-> IO
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IO ()
forall a b. (a -> b) -> a -> b
$  Peer
  (ChainSync Block (Point Block) (Tip Block))
  'AsClient
  'NonPipelined
  'StIdle
  IO
  b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     IO
     a
-> IO
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip 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 (ChainSyncClient Block (Point Block) (Tip Block) IO b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     'AsClient
     'NonPipelined
     'StIdle
     IO
     b
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClient header point tip m a
-> Client (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncClientPeer ChainSyncClient Block (Point Block) (Tip Block) IO b
cli) (ChainSyncServer Block (Point Block) (Tip Block) IO a
-> Server
     (ChainSync Block (Point Block) (Tip Block))
     'NonPipelined
     'StIdle
     IO
     a
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer Block (Point Block) (Tip Block) IO a
ser)
        ) ChainProducerStateForkTest
cps


--
-- Properties of pipelined client
--

-- | An experiment in which the client has a fork of the server chain.  The
-- experiment finishes successfully if the client receives the server's chain.
--
chainSyncPipelinedForkExperiment
  :: forall m.
     ( MonadST m
     , MonadSTM m
     )
  => (forall a b. ChainSyncServer Block (Point Block) (Tip Block) m a
      -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
      -> m ())
  -> (forall a. StrictTVar m (Chain Block)
      -> Client Block (Point Block) (Tip Block) m a
      -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
  -> ChainProducerStateForkTest
  -> m Bool
chainSyncPipelinedForkExperiment :: forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment forall a b.
ChainSyncServer Block (Point Block) (Tip Block) m a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
-> m ()
run forall a.
StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a
mkClient (ChainProducerStateForkTest ChainProducerState Block
cps Chain Block
chain) = do
  let pchain :: Chain Block
pchain = ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
ChainProducerState.producerChain ChainProducerState Block
cps
  cpsVar   <- STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTVar m (ChainProducerState Block))
 -> m (StrictTVar m (ChainProducerState Block)))
-> STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a b. (a -> b) -> a -> b
$ ChainProducerState Block
-> STM m (StrictTVar m (ChainProducerState Block))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar ChainProducerState Block
cps
  chainVar <- atomically $ newTVar chain
  doneVar  <- atomically $ newTVar False
  let server = Any
-> StrictTVar m (ChainProducerState Block)
-> (Block -> Block)
-> ChainSyncServer Block (Point Block) (Tip Block) m Any
forall blk header (m :: * -> *) a.
(HasHeader blk, MonadSTM m, HeaderHash header ~ HeaderHash blk) =>
a
-> StrictTVar m (ChainProducerState blk)
-> (blk -> header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
ChainSyncExamples.chainSyncServerExample
        (TestName -> Any
forall a. HasCallStack => TestName -> a
error TestName
"chainSyncServerExample: lazy in the result type")
        StrictTVar m (ChainProducerState Block)
cpsVar
        Block -> Block
forall a. a -> a
id
      client :: ChainSyncClientPipelined Block (Point Block) (Tip Block) m ()
      client = StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m ()
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m ()
forall a.
StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a
mkClient StrictTVar m (Chain Block)
chainVar (StrictTVar m Bool
-> Point Block -> Client Block (Point Block) (Tip Block) m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar (Chain Block -> Point Block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain Block
pchain))
  _ <- run server client

  cchain <- atomically $ readTVar chainVar
  return (pchain == cchain)

--
-- Pipelined direct tests
--

propChainSyncPipelinedMaxDirectST :: ChainProducerStateForkTest
                                  -> PipeliningDepth
                                  -> Bool
propChainSyncPipelinedMaxDirectST :: ChainProducerStateForkTest -> PipeliningDepth -> Bool
propChainSyncPipelinedMaxDirectST ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
    (forall s. IOSim s Bool) -> Bool
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Bool) -> Bool)
-> (forall s. IOSim s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (forall a.
    StrictTVar (IOSim s) (Chain Block)
    -> Client Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) a)
-> ChainProducerStateForkTest
-> IOSim s Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        ((((ChainSyncClientPipelined
    Block (Point Block) (Tip Block) (IOSim s) b
  -> IOSim s (a, b))
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall a b.
(a -> b)
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> a)
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
   -> IOSim s (a, b))
  -> ChainSyncClientPipelined
       Block (Point Block) (Tip Block) (IOSim s) b
  -> IOSim s ())
 -> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
     -> ChainSyncClientPipelined
          Block (Point Block) (Tip Block) (IOSim s) b
     -> IOSim s (a, b))
 -> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> ((IOSim s (a, b) -> IOSim s ())
    -> (ChainSyncClientPipelined
          Block (Point Block) (Tip Block) (IOSim s) b
        -> IOSim s (a, b))
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s ())
-> (IOSim s (a, b) -> IOSim s ())
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOSim s (a, b) -> IOSim s ())
-> (ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall a b.
(a -> b)
-> (ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
    -> a)
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) IOSim s (a, b) -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClientPipelined header point tip m b -> m (a, b)
directPipelined)
        (Word16
-> StrictTVar (IOSim s) (Chain Block)
-> Client Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMax (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps

propChainSyncPipelinedMaxDirectIO :: ChainProducerStateForkTest
                                  -> PipeliningDepth
                                  -> Property
propChainSyncPipelinedMaxDirectIO :: ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncPipelinedMaxDirectIO ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> (forall a.
    StrictTVar IO (Chain Block)
    -> Client Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a)
-> ChainProducerStateForkTest
-> IO Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        ((((ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
  -> IO (a, b))
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO ()
forall a b.
(a -> b)
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a -> a)
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
   -> IO (a, b))
  -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
  -> IO ())
 -> (ChainSyncServer Block (Point Block) (Tip Block) IO a
     -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
     -> IO (a, b))
 -> ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> ((IO (a, b) -> IO ())
    -> (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
        -> IO (a, b))
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO ())
-> (IO (a, b) -> IO ())
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (a, b) -> IO ())
-> (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO ()
forall a b.
(a -> b)
-> (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> a)
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) IO (a, b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClientPipelined header point tip m b -> m (a, b)
directPipelined)
        (Word16
-> StrictTVar IO (Chain Block)
-> Client Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMax (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps

propChainSyncPipelinedMinDirectST :: ChainProducerStateForkTest
                                  -> PipeliningDepth
                                  -> Bool
propChainSyncPipelinedMinDirectST :: ChainProducerStateForkTest -> PipeliningDepth -> Bool
propChainSyncPipelinedMinDirectST ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
    (forall s. IOSim s Bool) -> Bool
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Bool) -> Bool)
-> (forall s. IOSim s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (forall a.
    StrictTVar (IOSim s) (Chain Block)
    -> Client Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) a)
-> ChainProducerStateForkTest
-> IOSim s Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        ((((ChainSyncClientPipelined
    Block (Point Block) (Tip Block) (IOSim s) b
  -> IOSim s (a, b))
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall a b.
(a -> b)
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> a)
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
   -> IOSim s (a, b))
  -> ChainSyncClientPipelined
       Block (Point Block) (Tip Block) (IOSim s) b
  -> IOSim s ())
 -> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
     -> ChainSyncClientPipelined
          Block (Point Block) (Tip Block) (IOSim s) b
     -> IOSim s (a, b))
 -> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> ((IOSim s (a, b) -> IOSim s ())
    -> (ChainSyncClientPipelined
          Block (Point Block) (Tip Block) (IOSim s) b
        -> IOSim s (a, b))
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s ())
-> (IOSim s (a, b) -> IOSim s ())
-> (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOSim s (a, b) -> IOSim s ())
-> (ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
    -> IOSim s (a, b))
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s ()
forall a b.
(a -> b)
-> (ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
    -> a)
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) IOSim s (a, b) -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) b
-> IOSim s (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClientPipelined header point tip m b -> m (a, b)
directPipelined)
        (Word16
-> StrictTVar (IOSim s) (Chain Block)
-> Client Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMin (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps

propChainSyncPipelinedMinDirectIO :: ChainProducerStateForkTest
                                  -> PipeliningDepth
                                  -> Property
propChainSyncPipelinedMinDirectIO :: ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncPipelinedMinDirectIO ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> (forall a.
    StrictTVar IO (Chain Block)
    -> Client Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a)
-> ChainProducerStateForkTest
-> IO Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        ((((ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
  -> IO (a, b))
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO ()
forall a b.
(a -> b)
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a -> a)
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
   -> IO (a, b))
  -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
  -> IO ())
 -> (ChainSyncServer Block (Point Block) (Tip Block) IO a
     -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
     -> IO (a, b))
 -> ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> ((IO (a, b) -> IO ())
    -> (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
        -> IO (a, b))
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO ())
-> (IO (a, b) -> IO ())
-> (ChainSyncServer Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (a, b) -> IO ())
-> (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> IO (a, b))
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO ()
forall a b.
(a -> b)
-> (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
    -> a)
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) IO (a, b) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ChainSyncServer Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> IO (a, b)
forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClientPipelined header point tip m b -> m (a, b)
directPipelined)
        (Word16
-> StrictTVar IO (Chain Block)
-> Client Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMin (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps

--
-- Pipelined connect tests
--

propChainSyncPipelinedMaxConnectST :: ChainProducerStateForkTest
                                   -> [Bool]
                                   -> PipeliningDepth
                                   -> Bool
propChainSyncPipelinedMaxConnectST :: ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Bool
propChainSyncPipelinedMaxConnectST ChainProducerStateForkTest
cps [Bool]
choices (PipeliningDepth Int
omax) =
    (forall s. IOSim s Bool) -> Bool
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Bool) -> Bool)
-> (forall s. IOSim s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (forall a.
    StrictTVar (IOSim s) (Chain Block)
    -> Client Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) a)
-> ChainProducerStateForkTest
-> IOSim s Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        (\ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
ser ChainSyncClientPipelined
  Block (Point Block) (Tip Block) (IOSim s) b
cli ->
            IOSim
  s
  (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim
   s
   (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
 -> IOSim s ())
-> IOSim
     s
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IOSim s ()
forall a b. (a -> b) -> a -> b
$ [Bool]
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block))
     'AsClient
     'StIdle
     (IOSim s)
     b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     (IOSim s)
     a
-> IOSim
     s
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip 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]
choices
              (ChainSyncClientPipelined
  Block (Point Block) (Tip Block) (IOSim s) b
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block))
     'AsClient
     'StIdle
     (IOSim s)
     b
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClientPipelined header point tip m a
-> ClientPipelined (ChainSync header point tip) 'StIdle m a
chainSyncClientPeerPipelined ChainSyncClientPipelined
  Block (Point Block) (Tip Block) (IOSim s) b
cli)
              (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> Server
     (ChainSync Block (Point Block) (Tip Block))
     'NonPipelined
     'StIdle
     (IOSim s)
     a
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
ser)
        )
        (Word16
-> StrictTVar (IOSim s) (Chain Block)
-> Client Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMax (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps


propChainSyncPipelinedMinConnectST :: ChainProducerStateForkTest
                                   -> [Bool]
                                   -> PipeliningDepth
                                   -> Bool
propChainSyncPipelinedMinConnectST :: ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Bool
propChainSyncPipelinedMinConnectST ChainProducerStateForkTest
cps [Bool]
choices (PipeliningDepth Int
omax) =
    (forall s. IOSim s Bool) -> Bool
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Bool) -> Bool)
-> (forall s. IOSim s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
 -> ChainSyncClientPipelined
      Block (Point Block) (Tip Block) (IOSim s) b
 -> IOSim s ())
-> (forall a.
    StrictTVar (IOSim s) (Chain Block)
    -> Client Block (Point Block) (Tip Block) (IOSim s) a
    -> ChainSyncClientPipelined
         Block (Point Block) (Tip Block) (IOSim s) a)
-> ChainProducerStateForkTest
-> IOSim s Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        (\ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
ser ChainSyncClientPipelined
  Block (Point Block) (Tip Block) (IOSim s) b
cli ->
            IOSim
  s
  (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim
   s
   (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
 -> IOSim s ())
-> IOSim
     s
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IOSim s ()
forall a b. (a -> b) -> a -> b
$ [Bool]
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block))
     'AsClient
     'StIdle
     (IOSim s)
     b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     (IOSim s)
     a
-> IOSim
     s
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip 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]
choices
              (ChainSyncClientPipelined
  Block (Point Block) (Tip Block) (IOSim s) b
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block))
     'AsClient
     'StIdle
     (IOSim s)
     b
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClientPipelined header point tip m a
-> ClientPipelined (ChainSync header point tip) 'StIdle m a
chainSyncClientPeerPipelined ChainSyncClientPipelined
  Block (Point Block) (Tip Block) (IOSim s) b
cli)
              (ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
-> Server
     (ChainSync Block (Point Block) (Tip Block))
     'NonPipelined
     'StIdle
     (IOSim s)
     a
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer Block (Point Block) (Tip Block) (IOSim s) a
ser)
        )
        (Word16
-> StrictTVar (IOSim s) (Chain Block)
-> Client Block (Point Block) (Tip Block) (IOSim s) a
-> ChainSyncClientPipelined
     Block (Point Block) (Tip Block) (IOSim s) a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMin (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps

propChainSyncPipelinedMaxConnectIO :: ChainProducerStateForkTest
                                   -> [Bool]
                                   -> PipeliningDepth
                                   -> Property
propChainSyncPipelinedMaxConnectIO :: ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Property
propChainSyncPipelinedMaxConnectIO ChainProducerStateForkTest
cps [Bool]
choices (PipeliningDepth Int
omax) =
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> (forall a.
    StrictTVar IO (Chain Block)
    -> Client Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a)
-> ChainProducerStateForkTest
-> IO Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        (\ChainSyncServer Block (Point Block) (Tip Block) IO a
ser ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
cli ->
            IO
  (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO
   (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
 -> IO ())
-> IO
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ [Bool]
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block)) 'AsClient 'StIdle IO b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     IO
     a
-> IO
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip 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]
choices
              (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block)) 'AsClient 'StIdle IO b
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClientPipelined header point tip m a
-> ClientPipelined (ChainSync header point tip) 'StIdle m a
chainSyncClientPeerPipelined ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
cli)
              (ChainSyncServer Block (Point Block) (Tip Block) IO a
-> Server
     (ChainSync Block (Point Block) (Tip Block))
     'NonPipelined
     'StIdle
     IO
     a
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer Block (Point Block) (Tip Block) IO a
ser)
        )
        (Word16
-> StrictTVar IO (Chain Block)
-> Client Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMax (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps

propChainSyncPipelinedMinConnectIO :: ChainProducerStateForkTest
                                   -> [Bool]
                                   -> PipeliningDepth
                                   -> Property
propChainSyncPipelinedMinConnectIO :: ChainProducerStateForkTest -> [Bool] -> PipeliningDepth -> Property
propChainSyncPipelinedMinConnectIO ChainProducerStateForkTest
cps [Bool]
choices (PipeliningDepth Int
omax) =
    IO Bool -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Bool -> Property) -> IO Bool -> Property
forall a b. (a -> b) -> a -> b
$
      (forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) IO a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
 -> IO ())
-> (forall a.
    StrictTVar IO (Chain Block)
    -> Client Block (Point Block) (Tip Block) IO a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a)
-> ChainProducerStateForkTest
-> IO Bool
forall (m :: * -> *).
(MonadST m, MonadSTM m) =>
(forall a b.
 ChainSyncServer Block (Point Block) (Tip Block) m a
 -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m b
 -> m ())
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Bool
chainSyncPipelinedForkExperiment
        (\ChainSyncServer Block (Point Block) (Tip Block) IO a
ser ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
cli ->
            IO
  (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO
   (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
 -> IO ())
-> IO
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip Block)))
-> IO ()
forall a b. (a -> b) -> a -> b
$ [Bool]
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block)) 'AsClient 'StIdle IO b
-> Peer
     (ChainSync Block (Point Block) (Tip Block))
     (FlipAgency 'AsClient)
     'NonPipelined
     'StIdle
     IO
     a
-> IO
     (b, a, TerminalStates (ChainSync Block (Point Block) (Tip 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]
choices
              (ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
-> PeerPipelined
     (ChainSync Block (Point Block) (Tip Block)) 'AsClient 'StIdle IO b
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClientPipelined header point tip m a
-> ClientPipelined (ChainSync header point tip) 'StIdle m a
chainSyncClientPeerPipelined ChainSyncClientPipelined Block (Point Block) (Tip Block) IO b
cli)
              (ChainSyncServer Block (Point Block) (Tip Block) IO a
-> Server
     (ChainSync Block (Point Block) (Tip Block))
     'NonPipelined
     'StIdle
     IO
     a
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
chainSyncServerPeer ChainSyncServer Block (Point Block) (Tip Block) IO a
ser)
        )
        (Word16
-> StrictTVar IO (Chain Block)
-> Client Block (Point Block) (Tip Block) IO a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) IO a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
ChainSyncExamples.chainSyncClientPipelinedMin (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax))
        ChainProducerStateForkTest
cps


instance (Arbitrary header, Arbitrary point, Arbitrary tip)
      => Arbitrary (AnyMessage (ChainSync header point tip)) where
  arbitrary :: Gen (AnyMessage (ChainSync header point tip))
arbitrary = [Gen (AnyMessage (ChainSync header point tip))]
-> Gen (AnyMessage (ChainSync header point tip))
forall a. [Gen a] -> Gen a
oneof
    [ AnyMessage (ChainSync header point tip)
-> Gen (AnyMessage (ChainSync header point tip))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (ChainSync header point tip)
 -> Gen (AnyMessage (ChainSync header point tip)))
-> AnyMessage (ChainSync header point tip)
-> Gen (AnyMessage (ChainSync header point tip))
forall a b. (a -> b) -> a -> b
$ Message (ChainSync header point tip) 'StIdle ('StNext 'StCanAwait)
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (ChainSync header point tip) 'StIdle ('StNext 'StCanAwait)
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2).
Message (ChainSync header point tip) 'StIdle ('StNext 'StCanAwait)
MsgRequestNext
    , AnyMessage (ChainSync header point tip)
-> Gen (AnyMessage (ChainSync header point tip))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (ChainSync header point tip)
 -> Gen (AnyMessage (ChainSync header point tip)))
-> AnyMessage (ChainSync header point tip)
-> Gen (AnyMessage (ChainSync header point tip))
forall a b. (a -> b) -> a -> b
$ Message
  (ChainSync header point tip)
  ('StNext 'StCanAwait)
  ('StNext 'StMustReply)
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message
  (ChainSync header point tip)
  ('StNext 'StCanAwait)
  ('StNext 'StMustReply)
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2).
Message
  (ChainSync header point tip)
  ('StNext 'StCanAwait)
  ('StNext 'StMustReply)
MsgAwaitReply

    , Message (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle
 -> AnyMessage (ChainSync header point tip))
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
-> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (header
-> tip
-> Message
     (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle
forall {k1} header1 tip1 (point :: k1) (any :: StNextKind).
header1
-> tip1
-> Message (ChainSync header1 point tip1) ('StNext any) 'StIdle
MsgRollForward (header
 -> tip
 -> Message
      (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
-> Gen header
-> Gen
     (tip
      -> Message
           (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen header
forall a. Arbitrary a => Gen a
arbitrary
                            Gen
  (tip
   -> Message
        (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
-> Gen tip
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen tip
forall a. Arbitrary a => Gen a
arbitrary
              :: Gen (Message (ChainSync header point tip) (StNext StCanAwait) StIdle))

    , Message (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message
   (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle
 -> AnyMessage (ChainSync header point tip))
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
-> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (header
-> tip
-> Message
     (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle
forall {k1} header1 tip1 (point :: k1) (any :: StNextKind).
header1
-> tip1
-> Message (ChainSync header1 point tip1) ('StNext any) 'StIdle
MsgRollForward (header
 -> tip
 -> Message
      (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
-> Gen header
-> Gen
     (tip
      -> Message
           (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen header
forall a. Arbitrary a => Gen a
arbitrary
                            Gen
  (tip
   -> Message
        (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
-> Gen tip
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen tip
forall a. Arbitrary a => Gen a
arbitrary
              :: Gen (Message (ChainSync header point tip) (StNext StMustReply) StIdle))

    , Message (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle
 -> AnyMessage (ChainSync header point tip))
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
-> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (point
-> tip
-> Message
     (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle
forall {k} point1 tip1 (header :: k) (any :: StNextKind).
point1
-> tip1
-> Message (ChainSync header point1 tip1) ('StNext any) 'StIdle
MsgRollBackward (point
 -> tip
 -> Message
      (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
-> Gen point
-> Gen
     (tip
      -> Message
           (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen point
forall a. Arbitrary a => Gen a
arbitrary
                             Gen
  (tip
   -> Message
        (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
-> Gen tip
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StCanAwait) 'StIdle)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen tip
forall a. Arbitrary a => Gen a
arbitrary
              :: Gen (Message (ChainSync header point tip) (StNext StCanAwait) StIdle))

    , Message (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message
   (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle
 -> AnyMessage (ChainSync header point tip))
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
-> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (point
-> tip
-> Message
     (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle
forall {k} point1 tip1 (header :: k) (any :: StNextKind).
point1
-> tip1
-> Message (ChainSync header point1 tip1) ('StNext any) 'StIdle
MsgRollBackward (point
 -> tip
 -> Message
      (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
-> Gen point
-> Gen
     (tip
      -> Message
           (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen point
forall a. Arbitrary a => Gen a
arbitrary
                             Gen
  (tip
   -> Message
        (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
-> Gen tip
-> Gen
     (Message
        (ChainSync header point tip) ('StNext 'StMustReply) 'StIdle)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen tip
forall a. Arbitrary a => Gen a
arbitrary
              :: Gen (Message (ChainSync header point tip) (StNext StMustReply) StIdle))

    , Message (ChainSync header point tip) 'StIdle 'StIntersect
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (Message (ChainSync header point tip) 'StIdle 'StIntersect
 -> AnyMessage (ChainSync header point tip))
-> ([point]
    -> Message (ChainSync header point tip) 'StIdle 'StIntersect)
-> [point]
-> AnyMessage (ChainSync header point tip)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [point]
-> Message (ChainSync header point tip) 'StIdle 'StIntersect
forall {k} {k2} point1 (header :: k) (tip :: k2).
[point1]
-> Message (ChainSync header point1 tip) 'StIdle 'StIntersect
MsgFindIntersect
        ([point] -> AnyMessage (ChainSync header point tip))
-> Gen [point] -> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen point -> Gen [point]
forall a. Gen a -> Gen [a]
listOf Gen point
forall a. Arbitrary a => Gen a
arbitrary

    , Message (ChainSync header point tip) 'StIntersect 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (ChainSync header point tip) 'StIntersect 'StIdle
 -> AnyMessage (ChainSync header point tip))
-> Gen (Message (ChainSync header point tip) 'StIntersect 'StIdle)
-> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (point
-> tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle
forall {k} point1 tip1 (header :: k).
point1
-> tip1
-> Message (ChainSync header point1 tip1) 'StIntersect 'StIdle
MsgIntersectFound (point
 -> tip
 -> Message (ChainSync header point tip) 'StIntersect 'StIdle)
-> Gen point
-> Gen
     (tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen point
forall a. Arbitrary a => Gen a
arbitrary
                               Gen
  (tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle)
-> Gen tip
-> Gen (Message (ChainSync header point tip) 'StIntersect 'StIdle)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen tip
forall a. Arbitrary a => Gen a
arbitrary)

    , Message (ChainSync header point tip) 'StIntersect 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage
        (Message (ChainSync header point tip) 'StIntersect 'StIdle
 -> AnyMessage (ChainSync header point tip))
-> Gen (Message (ChainSync header point tip) 'StIntersect 'StIdle)
-> Gen (AnyMessage (ChainSync header point tip))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle
forall {k} {k1} tip1 (header :: k) (point :: k1).
tip1 -> Message (ChainSync header point tip1) 'StIntersect 'StIdle
MsgIntersectNotFound (tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle)
-> Gen tip
-> Gen (Message (ChainSync header point tip) 'StIntersect 'StIdle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen tip
forall a. Arbitrary a => Gen a
arbitrary)

    , AnyMessage (ChainSync header point tip)
-> Gen (AnyMessage (ChainSync header point tip))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyMessage (ChainSync header point tip)
 -> Gen (AnyMessage (ChainSync header point tip)))
-> AnyMessage (ChainSync header point tip)
-> Gen (AnyMessage (ChainSync header point tip))
forall a b. (a -> b) -> a -> b
$ Message (ChainSync header point tip) 'StIdle 'StDone
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (ChainSync header point tip) 'StIdle 'StDone
forall {k} {k1} {k2} (header :: k) (point :: k1) (tip :: k2).
Message (ChainSync header point tip) 'StIdle 'StDone
MsgDone
    ]

  shrink :: AnyMessage (ChainSync header point tip)
-> [AnyMessage (ChainSync header point tip)]
shrink (AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgRequestNext) = []
  shrink (AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgAwaitReply) = []
  -- shrink (AnyMessage (MsgRollForward header tip)) = []
  shrink (AnyMessage (MsgRollForward header1
header  tip1
tip :: Message (ChainSync header point tip) st st')) =
    -- NOTE: if `mkMsg` is inlined GHC-9.6.2 complains that there are multiple
    -- incoherent instances in the scope to resolve `StateTokenI`.
    let mkMsg :: header -> tip -> Message (ChainSync header point tip) st st'
        mkMsg :: header -> tip -> Message (ChainSync header point tip) st st'
mkMsg = header -> tip -> Message (ChainSync header point tip) st st'
header
-> tip
-> Message (ChainSync header point tip) ('StNext any) 'StIdle
forall {k1} header1 tip1 (point :: k1) (any :: StNextKind).
header1
-> tip1
-> Message (ChainSync header1 point tip1) ('StNext any) 'StIdle
MsgRollForward
    in
        [ Message (ChainSync header point tip) st st'
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (header -> tip -> Message (ChainSync header point tip) st st'
mkMsg header
header1
header' tip
tip1
tip)
        | header1
header' <- header1 -> [header1]
forall a. Arbitrary a => a -> [a]
shrink header1
header
        ]
     [AnyMessage (ChainSync header point tip)]
-> [AnyMessage (ChainSync header point tip)]
-> [AnyMessage (ChainSync header point tip)]
forall a. [a] -> [a] -> [a]
++ [ Message (ChainSync header point tip) st st'
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (header -> tip -> Message (ChainSync header point tip) st st'
mkMsg header
header1
header tip
tip1
tip')
        | tip1
tip' <- tip1 -> [tip1]
forall a. Arbitrary a => a -> [a]
shrink tip1
tip
        ]
  shrink (AnyMessage (MsgRollBackward point1
header tip1
tip :: Message (ChainSync header point tip) st st')) =
    -- NOTE: if `mkMsg` is inlined GHC-9.6.2 complains that there are multiple
    -- incoherent instances in the scope to resolve `StateTokenI`.
    let mkMsg :: point -> tip -> Message (ChainSync header point tip) st st'
        mkMsg :: point -> tip -> Message (ChainSync header point tip) st st'
mkMsg = point -> tip -> Message (ChainSync header point tip) st st'
point
-> tip
-> Message (ChainSync header point tip) ('StNext any) 'StIdle
forall {k} point1 tip1 (header :: k) (any :: StNextKind).
point1
-> tip1
-> Message (ChainSync header point1 tip1) ('StNext any) 'StIdle
MsgRollBackward
    in
       [ Message (ChainSync header point tip) st st'
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (point -> tip -> Message (ChainSync header point tip) st st'
mkMsg point
point1
header' tip
tip1
tip)
       | point1
header' <- point1 -> [point1]
forall a. Arbitrary a => a -> [a]
shrink point1
header
       ]
    [AnyMessage (ChainSync header point tip)]
-> [AnyMessage (ChainSync header point tip)]
-> [AnyMessage (ChainSync header point tip)]
forall a. [a] -> [a] -> [a]
++ [ Message (ChainSync header point tip) st st'
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (point -> tip -> Message (ChainSync header point tip) st st'
mkMsg point
point1
header tip
tip1
tip')
       | tip1
tip' <- tip1 -> [tip1]
forall a. Arbitrary a => a -> [a]
shrink tip1
tip
       ]
  shrink (AnyMessage (MsgFindIntersect [point1]
points)) =
       [ Message (ChainSync header point tip) 'StIdle 'StIntersect
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage ([point]
-> Message (ChainSync header point tip) 'StIdle 'StIntersect
forall {k} {k2} point1 (header :: k) (tip :: k2).
[point1]
-> Message (ChainSync header point1 tip) 'StIdle 'StIntersect
MsgFindIntersect [point]
[point1]
points')
       | [point1]
points' <- [point1] -> [[point1]]
forall a. Arbitrary a => a -> [a]
shrink [point1]
points
       ]
  shrink (AnyMessage (MsgIntersectFound point1
point tip1
tip)) =
       [ Message (ChainSync header point tip) 'StIntersect 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (point
-> tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle
forall {k} point1 tip1 (header :: k).
point1
-> tip1
-> Message (ChainSync header point1 tip1) 'StIntersect 'StIdle
MsgIntersectFound point
point1
point' tip
tip1
tip)
       | point1
point' <- point1 -> [point1]
forall a. Arbitrary a => a -> [a]
shrink point1
point
       ]
    [AnyMessage (ChainSync header point tip)]
-> [AnyMessage (ChainSync header point tip)]
-> [AnyMessage (ChainSync header point tip)]
forall a. [a] -> [a] -> [a]
++ [ Message (ChainSync header point tip) 'StIntersect 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (point
-> tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle
forall {k} point1 tip1 (header :: k).
point1
-> tip1
-> Message (ChainSync header point1 tip1) 'StIntersect 'StIdle
MsgIntersectFound point
point1
point tip
tip1
tip')
       | tip1
tip' <- tip1 -> [tip1]
forall a. Arbitrary a => a -> [a]
shrink tip1
tip
       ]
  shrink (AnyMessage (MsgIntersectNotFound tip1
tip)) =
       [ Message (ChainSync header point tip) 'StIntersect 'StIdle
-> AnyMessage (ChainSync header point tip)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage (tip -> Message (ChainSync header point tip) 'StIntersect 'StIdle
forall {k} {k1} tip1 (header :: k) (point :: k1).
tip1 -> Message (ChainSync header point tip1) 'StIntersect 'StIdle
MsgIntersectNotFound tip
tip1
tip')
       | tip1
tip' <- tip1 -> [tip1]
forall a. Arbitrary a => a -> [a]
shrink tip1
tip
       ]
  shrink (AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgDone) = []


-- type aliases to keep sizes down
type ChainSync_BlockHeader =
     ChainSync BlockHeader (Point BlockHeader) (Tip BlockHeader)

type ChainSync_Serialised_BlockHeader =
     ChainSync (Serialised BlockHeader) (Point BlockHeader) (Tip BlockHeader)

instance Arbitrary (Tip BlockHeader) where
  arbitrary :: Gen (Tip BlockHeader)
arbitrary = Point BlockHeader -> BlockNo -> Tip BlockHeader
f (Point BlockHeader -> BlockNo -> Tip BlockHeader)
-> Gen (Point BlockHeader) -> Gen (BlockNo -> Tip BlockHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Point BlockHeader)
forall a. Arbitrary a => Gen a
arbitrary Gen (BlockNo -> Tip BlockHeader)
-> Gen BlockNo -> Gen (Tip BlockHeader)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen BlockNo
forall a. Arbitrary a => Gen a
arbitrary
    where
      f :: Point BlockHeader ->  BlockNo -> Tip BlockHeader
      f :: Point BlockHeader -> BlockNo -> Tip BlockHeader
f Point BlockHeader
GenesisPoint BlockNo
_     = Tip BlockHeader
forall {k} (b :: k). Tip b
TipGenesis
      f (BlockPoint SlotNo
s HeaderHash BlockHeader
h) BlockNo
b = SlotNo -> HeaderHash BlockHeader -> BlockNo -> Tip BlockHeader
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
s HeaderHash BlockHeader
h BlockNo
b

  shrink :: Tip BlockHeader -> [Tip BlockHeader]
shrink Tip BlockHeader
TipGenesis = []
  shrink (Tip SlotNo
slotNo HeaderHash BlockHeader
hash BlockNo
blockNo) =
       [ SlotNo -> HeaderHash BlockHeader -> BlockNo -> Tip BlockHeader
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
slotNo' HeaderHash BlockHeader
hash BlockNo
blockNo
       | SlotNo
slotNo' <- SlotNo -> [SlotNo]
forall a. Arbitrary a => a -> [a]
shrink SlotNo
slotNo
       ]
    [Tip BlockHeader] -> [Tip BlockHeader] -> [Tip BlockHeader]
forall a. [a] -> [a] -> [a]
++ [ SlotNo -> HeaderHash BlockHeader -> BlockNo -> Tip BlockHeader
forall {k} (b :: k). SlotNo -> HeaderHash b -> BlockNo -> Tip b
Tip SlotNo
slotNo HeaderHash BlockHeader
hash BlockNo
blockNo'
       | BlockNo
blockNo' <- BlockNo -> [BlockNo]
forall a. Arbitrary a => a -> [a]
shrink BlockNo
blockNo
       ]

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

instance ( StandardHash header
         , Eq header
         , Eq point
         , Eq tip
         ) => Eq (AnyMessage (ChainSync header point tip)) where
  AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgRequestNext              == :: AnyMessage (ChainSync header point tip)
-> AnyMessage (ChainSync header point tip) -> Bool
== AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgRequestNext              = Bool
True
  AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgAwaitReply               == AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgAwaitReply               = Bool
True
  AnyMessage (MsgRollForward header1
h1 tip1
tip1)    == AnyMessage (MsgRollForward header1
h2 tip1
tip2)    = header1
h1 header1 -> header1 -> Bool
forall a. Eq a => a -> a -> Bool
== header1
header1
h2 Bool -> Bool -> Bool
&& tip1
tip1 tip1 -> tip1 -> Bool
forall a. Eq a => a -> a -> Bool
== tip1
tip1
tip2
  AnyMessage (MsgRollBackward point1
p1 tip1
tip1)   == AnyMessage (MsgRollBackward point1
p2 tip1
tip2)   = point1
p1 point1 -> point1 -> Bool
forall a. Eq a => a -> a -> Bool
== point1
point1
p2 Bool -> Bool -> Bool
&& tip1
tip1 tip1 -> tip1 -> Bool
forall a. Eq a => a -> a -> Bool
== tip1
tip1
tip2
  AnyMessage (MsgFindIntersect [point1]
ps1)      == AnyMessage (MsgFindIntersect [point1]
ps2)      = [point1]
ps1 [point1] -> [point1] -> Bool
forall a. Eq a => a -> a -> Bool
== [point1]
[point1]
ps2
  AnyMessage (MsgIntersectFound point1
p1 tip1
tip1) == AnyMessage (MsgIntersectFound point1
p2 tip1
tip2) = point1
p1 point1 -> point1 -> Bool
forall a. Eq a => a -> a -> Bool
== point1
point1
p2 Bool -> Bool -> Bool
&& tip1
tip1 tip1 -> tip1 -> Bool
forall a. Eq a => a -> a -> Bool
== tip1
tip1
tip2
  AnyMessage (MsgIntersectNotFound tip1
tip1) == AnyMessage (MsgIntersectNotFound tip1
tip2) = tip1
tip1 tip1 -> tip1 -> Bool
forall a. Eq a => a -> a -> Bool
== tip1
tip1
tip2
  AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgDone                     == AnyMessage Message (ChainSync header point tip) st st'
R:MessageChainSyncfromto (*) (*) (*) header point tip st st'
MsgDone                     = Bool
True
  AnyMessage (ChainSync header point tip)
_                                      == AnyMessage (ChainSync header point tip)
_                                      = Bool
False

codec :: ( MonadST m
         , S.Serialise block
         , S.Serialise (Chain.HeaderHash block)
         )
      => Codec (ChainSync block (Point block) (Tip block))
               S.DeserialiseFailure
               m ByteString
codec :: forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codec = (block -> Encoding)
-> (forall s. Decoder s block)
-> (Point block -> Encoding)
-> (forall s. Decoder s (Point block))
-> (Tip block -> Encoding)
-> (forall s. Decoder s (Tip block))
-> Codec
     (ChainSync block (Point block) (Tip block))
     DeserialiseFailure
     m
     ByteString
forall header point tip (m :: * -> *).
MonadST m =>
(header -> Encoding)
-> (forall s. Decoder s header)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (tip -> Encoding)
-> (forall s. Decoder s tip)
-> Codec
     (ChainSync header point tip) DeserialiseFailure m ByteString
codecChainSync 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
                       ((HeaderHash block -> Encoding) -> Tip block -> Encoding
forall {k} (blk :: k).
(HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip HeaderHash block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode) ((forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Tip block)
forall {k} (blk :: k).
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip Decoder s (HeaderHash block)
forall s. Decoder s (HeaderHash block)
forall a s. Serialise a => Decoder s a
S.decode)

codecWrapped :: ( MonadST m
                , S.Serialise block
                , S.Serialise (Chain.HeaderHash block)
                )
             => Codec (ChainSync block (Point block) (Tip block))
                      S.DeserialiseFailure
                      m ByteString
codecWrapped :: forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecWrapped =
    (block -> Encoding)
-> (forall s. Decoder s block)
-> (Point block -> Encoding)
-> (forall s. Decoder s (Point block))
-> (Tip block -> Encoding)
-> (forall s. Decoder s (Tip block))
-> Codec
     (ChainSync block (Point block) (Tip block))
     DeserialiseFailure
     m
     ByteString
forall header point tip (m :: * -> *).
MonadST m =>
(header -> Encoding)
-> (forall s. Decoder s header)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (tip -> Encoding)
-> (forall s. Decoder s tip)
-> Codec
     (ChainSync header point tip) DeserialiseFailure m ByteString
codecChainSync ((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
                   ((HeaderHash block -> Encoding) -> Tip block -> Encoding
forall {k} (blk :: k).
(HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip HeaderHash block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode)      ((forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Tip block)
forall {k} (blk :: k).
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip Decoder s (HeaderHash block)
forall s. Decoder s (HeaderHash block)
forall a s. Serialise a => Decoder s a
S.decode)

prop_codec_ChainSync
  :: AnyMessage ChainSync_BlockHeader
  -> Bool
prop_codec_ChainSync :: AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_ChainSync AnyMessage ChainSync_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
-> AnyMessage ChainSync_BlockHeader -> 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 ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codec AnyMessage ChainSync_BlockHeader
msg

prop_codec_splits2_ChainSync
  :: AnyMessage ChainSync_BlockHeader
  -> Bool
prop_codec_splits2_ChainSync :: AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_splits2_ChainSync AnyMessage ChainSync_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ (ByteString -> [[ByteString]])
-> Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
-> AnyMessage ChainSync_BlockHeader
-> 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 ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codec
      AnyMessage ChainSync_BlockHeader
msg

prop_codec_splits3_ChainSync
  :: AnyMessage ChainSync_BlockHeader
  -> Bool
prop_codec_splits3_ChainSync :: AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_splits3_ChainSync AnyMessage ChainSync_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ (ByteString -> [[ByteString]])
-> Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
-> AnyMessage ChainSync_BlockHeader
-> 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 ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codec
      AnyMessage ChainSync_BlockHeader
msg

prop_codec_cbor
  :: AnyMessage ChainSync_BlockHeader
  -> Bool
prop_codec_cbor :: AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_cbor AnyMessage ChainSync_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST (Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
-> AnyMessage ChainSync_BlockHeader -> ST s Bool
forall ps (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure m ByteString -> AnyMessage ps -> m Bool
prop_codec_cborM Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codec AnyMessage ChainSync_BlockHeader
msg)

prop_codec_valid_cbor
  :: AnyMessage ChainSync_BlockHeader
  -> Property
prop_codec_valid_cbor :: AnyMessage ChainSync_BlockHeader -> Property
prop_codec_valid_cbor = Codec ChainSync_BlockHeader DeserialiseFailure IO ByteString
-> AnyMessage ChainSync_BlockHeader -> Property
forall ps.
Codec ps DeserialiseFailure IO ByteString
-> AnyMessage ps -> Property
prop_codec_valid_cbor_encoding Codec ChainSync_BlockHeader DeserialiseFailure IO ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codec

codecSerialised
  :: ( MonadST m
     , S.Serialise (Chain.HeaderHash block)
     )
  => Codec (ChainSync (Serialised block) (Point block) (Tip block))
           S.DeserialiseFailure
           m ByteString
codecSerialised :: forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised = (Serialised block -> Encoding)
-> (forall s. Decoder s (Serialised block))
-> (Point block -> Encoding)
-> (forall s. Decoder s (Point block))
-> (Tip block -> Encoding)
-> (forall s. Decoder s (Tip block))
-> Codec
     (ChainSync (Serialised block) (Point block) (Tip block))
     DeserialiseFailure
     m
     ByteString
forall header point tip (m :: * -> *).
MonadST m =>
(header -> Encoding)
-> (forall s. Decoder s header)
-> (point -> Encoding)
-> (forall s. Decoder s point)
-> (tip -> Encoding)
-> (forall s. Decoder s tip)
-> Codec
     (ChainSync header point tip) DeserialiseFailure m ByteString
codecChainSync
    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
    ((HeaderHash block -> Encoding) -> Tip block -> Encoding
forall {k} (blk :: k).
(HeaderHash blk -> Encoding) -> Tip blk -> Encoding
encodeTip HeaderHash block -> Encoding
forall a. Serialise a => a -> Encoding
S.encode) ((forall s. Decoder s (HeaderHash block))
-> forall s. Decoder s (Tip block)
forall {k} (blk :: k).
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (Tip blk)
decodeTip Decoder s (HeaderHash block)
forall s. Decoder s (HeaderHash block)
forall a s. Serialise a => Decoder s a
S.decode)

prop_codec_ChainSyncSerialised
  :: AnyMessage ChainSync_Serialised_BlockHeader
  -> Bool
prop_codec_ChainSyncSerialised :: AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_ChainSyncSerialised AnyMessage ChainSync_Serialised_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ Codec
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
-> AnyMessage ChainSync_Serialised_BlockHeader -> 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
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised AnyMessage ChainSync_Serialised_BlockHeader
msg

prop_codec_splits2_ChainSyncSerialised
  :: AnyMessage ChainSync_Serialised_BlockHeader
  -> Bool
prop_codec_splits2_ChainSyncSerialised :: AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_splits2_ChainSyncSerialised AnyMessage ChainSync_Serialised_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ (ByteString -> [[ByteString]])
-> Codec
     ChainSync_Serialised_BlockHeader
     DeserialiseFailure
     (ST s)
     ByteString
-> AnyMessage ChainSync_Serialised_BlockHeader
-> 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
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised
      AnyMessage ChainSync_Serialised_BlockHeader
msg

prop_codec_splits3_ChainSyncSerialised
  :: AnyMessage ChainSync_Serialised_BlockHeader
  -> Bool
prop_codec_splits3_ChainSyncSerialised :: AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_splits3_ChainSyncSerialised AnyMessage ChainSync_Serialised_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ (ByteString -> [[ByteString]])
-> Codec
     ChainSync_Serialised_BlockHeader
     DeserialiseFailure
     (ST s)
     ByteString
-> AnyMessage ChainSync_Serialised_BlockHeader
-> 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
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised
      AnyMessage ChainSync_Serialised_BlockHeader
msg

prop_codec_cbor_ChainSyncSerialised
  :: AnyMessage ChainSync_Serialised_BlockHeader
  -> Bool
prop_codec_cbor_ChainSyncSerialised :: AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_cbor_ChainSyncSerialised AnyMessage ChainSync_Serialised_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST (Codec
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
-> AnyMessage ChainSync_Serialised_BlockHeader -> ST s Bool
forall ps (m :: * -> *).
Monad m =>
Codec ps DeserialiseFailure m ByteString -> AnyMessage ps -> m Bool
prop_codec_cborM Codec
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised AnyMessage ChainSync_Serialised_BlockHeader
msg)

prop_codec_binary_compat_ChainSync_ChainSyncSerialised
  :: AnyMessage ChainSync_BlockHeader
  -> Bool
prop_codec_binary_compat_ChainSync_ChainSyncSerialised :: AnyMessage ChainSync_BlockHeader -> Bool
prop_codec_binary_compat_ChainSync_ChainSyncSerialised AnyMessage ChainSync_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST (Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
-> Codec
     ChainSync_Serialised_BlockHeader
     DeserialiseFailure
     (ST s)
     ByteString
-> (forall (stA :: ChainSync_BlockHeader).
    ActiveState stA =>
    StateToken stA -> SomeState ChainSync_Serialised_BlockHeader)
-> AnyMessage ChainSync_BlockHeader
-> 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 ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecWrapped Codec
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised StateToken stA -> SomeState ChainSync_Serialised_BlockHeader
forall (stA :: ChainSync_BlockHeader).
ActiveState stA =>
StateToken stA -> SomeState ChainSync_Serialised_BlockHeader
stokEq AnyMessage ChainSync_BlockHeader
msg)
  where
    stokEq
      :: forall (stA :: ChainSync_BlockHeader).
         ActiveState stA
      => StateToken stA
      -> SomeState ChainSync_Serialised_BlockHeader
    stokEq :: forall (stA :: ChainSync_BlockHeader).
ActiveState stA =>
StateToken stA -> SomeState ChainSync_Serialised_BlockHeader
stokEq SingChainSync stA
StateToken stA
SingIdle =
      StateToken 'StIdle -> SomeState ChainSync_Serialised_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingChainSync 'StIdle
StateToken 'StIdle
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}.
SingChainSync 'StIdle
SingIdle
    stokEq (SingNext SingNextKind k4
SingCanAwait) =
      StateToken ('StNext 'StCanAwait)
-> SomeState ChainSync_Serialised_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState (SingNextKind 'StCanAwait -> SingChainSync ('StNext 'StCanAwait)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}
       (k4 :: StNextKind).
SingNextKind k4 -> SingChainSync ('StNext k4)
SingNext SingNextKind 'StCanAwait
SingCanAwait)
    stokEq (SingNext SingNextKind k4
SingMustReply) =
      StateToken ('StNext 'StMustReply)
-> SomeState ChainSync_Serialised_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState (SingNextKind 'StMustReply -> SingChainSync ('StNext 'StMustReply)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}
       (k4 :: StNextKind).
SingNextKind k4 -> SingChainSync ('StNext k4)
SingNext SingNextKind 'StMustReply
SingMustReply)
    stokEq SingChainSync stA
StateToken stA
SingIntersect =
      StateToken 'StIntersect
-> SomeState ChainSync_Serialised_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingChainSync 'StIntersect
StateToken 'StIntersect
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}.
SingChainSync 'StIntersect
SingIntersect
    stokEq a :: StateToken stA
a@SingChainSync stA
StateToken stA
SingDone = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken stA
StateToken 'StDone
a

prop_codec_binary_compat_ChainSyncSerialised_ChainSync
  :: AnyMessage ChainSync_Serialised_BlockHeader
  -> Bool
prop_codec_binary_compat_ChainSyncSerialised_ChainSync :: AnyMessage ChainSync_Serialised_BlockHeader -> Bool
prop_codec_binary_compat_ChainSyncSerialised_ChainSync AnyMessage ChainSync_Serialised_BlockHeader
msg =
    (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
ST.runST (Codec
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
-> Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
-> (forall (stA :: ChainSync_Serialised_BlockHeader).
    ActiveState stA =>
    StateToken stA -> SomeState ChainSync_BlockHeader)
-> AnyMessage ChainSync_Serialised_BlockHeader
-> 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
  ChainSync_Serialised_BlockHeader
  DeserialiseFailure
  (ST s)
  ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise (HeaderHash block)) =>
Codec
  (ChainSync (Serialised block) (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecSerialised Codec ChainSync_BlockHeader DeserialiseFailure (ST s) ByteString
forall (m :: * -> *) block.
(MonadST m, Serialise block, Serialise (HeaderHash block)) =>
Codec
  (ChainSync block (Point block) (Tip block))
  DeserialiseFailure
  m
  ByteString
codecWrapped StateToken stA -> SomeState ChainSync_BlockHeader
forall (stA :: ChainSync_Serialised_BlockHeader).
ActiveState stA =>
StateToken stA -> SomeState ChainSync_BlockHeader
stokEq AnyMessage ChainSync_Serialised_BlockHeader
msg)
  where
    stokEq
      :: forall (stA :: ChainSync_Serialised_BlockHeader).
         ActiveState stA
      => StateToken stA
      -> SomeState ChainSync_BlockHeader
    stokEq :: forall (stA :: ChainSync_Serialised_BlockHeader).
ActiveState stA =>
StateToken stA -> SomeState ChainSync_BlockHeader
stokEq SingChainSync stA
StateToken stA
SingIdle =
      StateToken 'StIdle -> SomeState ChainSync_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingChainSync 'StIdle
StateToken 'StIdle
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}.
SingChainSync 'StIdle
SingIdle
    stokEq (SingNext SingNextKind k4
SingCanAwait) =
      StateToken ('StNext 'StCanAwait) -> SomeState ChainSync_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState (SingNextKind 'StCanAwait -> SingChainSync ('StNext 'StCanAwait)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}
       (k4 :: StNextKind).
SingNextKind k4 -> SingChainSync ('StNext k4)
SingNext SingNextKind 'StCanAwait
SingCanAwait)
    stokEq (SingNext SingNextKind k4
SingMustReply) =
      StateToken ('StNext 'StMustReply)
-> SomeState ChainSync_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState (SingNextKind 'StMustReply -> SingChainSync ('StNext 'StMustReply)
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}
       (k4 :: StNextKind).
SingNextKind k4 -> SingChainSync ('StNext k4)
SingNext SingNextKind 'StMustReply
SingMustReply)
    stokEq SingChainSync stA
StateToken stA
SingIntersect =
      StateToken 'StIntersect -> SomeState ChainSync_BlockHeader
forall ps (st :: ps).
ActiveState st =>
StateToken st -> SomeState ps
SomeState SingChainSync 'StIntersect
StateToken 'StIntersect
forall {k} {k1} {k2} {header :: k} {point :: k1} {tip :: k2}.
SingChainSync 'StIntersect
SingIntersect
    stokEq a :: StateToken stA
a@SingChainSync stA
StateToken stA
SingDone = StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken stA
StateToken 'StDone
a

chainSyncDemo
  :: forall m.
     ( MonadST m
     , MonadSTM m
     , MonadFork m
     , MonadThrow m
     )
  => Channel m ByteString
  -> Channel m ByteString
  -> ChainProducerStateForkTest
  -> m Property
chainSyncDemo :: forall (m :: * -> *).
(MonadST m, MonadSTM m, MonadFork m, MonadThrow m) =>
Channel m ByteString
-> Channel m ByteString -> ChainProducerStateForkTest -> m Property
chainSyncDemo Channel m ByteString
clientChan Channel m ByteString
serverChan (ChainProducerStateForkTest ChainProducerState Block
cps Chain Block
chain) = do
  let pchain :: Chain Block
pchain = ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
ChainProducerState.producerChain ChainProducerState Block
cps
  cpsVar   <- STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTVar m (ChainProducerState Block))
 -> m (StrictTVar m (ChainProducerState Block)))
-> STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a b. (a -> b) -> a -> b
$ ChainProducerState Block
-> STM m (StrictTVar m (ChainProducerState Block))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar ChainProducerState Block
cps
  chainVar <- atomically $ newTVar chain
  doneVar  <- atomically $ newTVar False

  let server :: ChainSyncServer Block (Point Block) (Tip Block) m a
      server = a
-> StrictTVar m (ChainProducerState Block)
-> (Block -> Block)
-> ChainSyncServer Block (Point Block) (Tip Block) m a
forall blk header (m :: * -> *) a.
(HasHeader blk, MonadSTM m, HeaderHash header ~ HeaderHash blk) =>
a
-> StrictTVar m (ChainProducerState blk)
-> (blk -> header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
ChainSyncExamples.chainSyncServerExample
        (TestName -> a
forall a. HasCallStack => TestName -> a
error TestName
"chainSyncServerExample: lazy in the result type")
        StrictTVar m (ChainProducerState Block)
cpsVar
        Block -> Block
forall a. a -> a
id

      client :: ChainSyncClient Block (Point Block) (Tip Block) m ()
      client = StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m ()
-> ChainSyncClient Block (Point Block) (Tip Block) m ()
forall header block tip (m :: * -> *) a.
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadSTM m) =>
StrictTVar m (Chain header)
-> Client header (Point block) tip m a
-> ChainSyncClient header (Point block) tip m a
ChainSyncExamples.chainSyncClientExample StrictTVar m (Chain Block)
chainVar (StrictTVar m Bool
-> Point Block -> Client Block (Point Block) (Tip Block) m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar (Chain Block -> Point Block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain Block
pchain))

  void $ forkIO (void $ runPeer nullTracer codec serverChan (chainSyncServerPeer server))
  void $ forkIO (void $ runPeer nullTracer codec clientChan (chainSyncClientPeer client))

  atomically $ do
    done <- readTVar doneVar
    unless done retry

  cchain <- atomically $ readTVar chainVar
  return (pchain === cchain)

propChainSyncDemoST
  :: ChainProducerStateForkTest
  -> Property
propChainSyncDemoST :: ChainProducerStateForkTest -> Property
propChainSyncDemoST ChainProducerStateForkTest
cps =
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- IOSim
  s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
    chainSyncDemo clientChan serverChan cps

propChainSyncDemoIO
  :: ChainProducerStateForkTest
  -> Property
propChainSyncDemoIO :: ChainProducerStateForkTest -> Property
propChainSyncDemoIO ChainProducerStateForkTest
cps =
  IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a. MonadSTM m => m (Channel m a, Channel m a)
createConnectedChannels
    chainSyncDemo clientChan serverChan cps

propChainSyncPipe
  :: ChainProducerStateForkTest
  -> Property
propChainSyncPipe :: ChainProducerStateForkTest -> Property
propChainSyncPipe ChainProducerStateForkTest
cps =
  IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- IO (Channel IO ByteString, Channel IO ByteString)
createPipeConnectedChannels
    chainSyncDemo clientChan serverChan cps

--
-- Pipelined demo
--

chainSyncDemoPipelined
  :: forall m.
     ( MonadST    m
     , MonadSTM   m
     , MonadFork  m
     , MonadAsync m
     , MonadThrow m
     , MonadSay   m
     )
  => Channel m ByteString
  -> Channel m ByteString
  -> (forall a. StrictTVar m (Chain Block)
      -> Client                   Block (Point Block) (Tip Block) m a
      -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
  -> ChainProducerStateForkTest
  -> m Property
chainSyncDemoPipelined :: forall (m :: * -> *).
(MonadST m, MonadSTM m, MonadFork m, MonadAsync m, MonadThrow m,
 MonadSay m) =>
Channel m ByteString
-> Channel m ByteString
-> (forall a.
    StrictTVar m (Chain Block)
    -> Client Block (Point Block) (Tip Block) m a
    -> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a)
-> ChainProducerStateForkTest
-> m Property
chainSyncDemoPipelined Channel m ByteString
clientChan Channel m ByteString
serverChan forall a.
StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a
mkClient (ChainProducerStateForkTest ChainProducerState Block
cps Chain Block
chain) = do
  let pchain :: Chain Block
pchain = ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
ChainProducerState.producerChain ChainProducerState Block
cps
  cpsVar   <- STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTVar m (ChainProducerState Block))
 -> m (StrictTVar m (ChainProducerState Block)))
-> STM m (StrictTVar m (ChainProducerState Block))
-> m (StrictTVar m (ChainProducerState Block))
forall a b. (a -> b) -> a -> b
$ ChainProducerState Block
-> STM m (StrictTVar m (ChainProducerState Block))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar ChainProducerState Block
cps
  chainVar <- atomically $ newTVar chain
  doneVar  <- atomically $ newTVar False

  let server :: ChainSyncServer Block (Point Block) (Tip Block) m a
      server = a
-> StrictTVar m (ChainProducerState Block)
-> (Block -> Block)
-> ChainSyncServer Block (Point Block) (Tip Block) m a
forall blk header (m :: * -> *) a.
(HasHeader blk, MonadSTM m, HeaderHash header ~ HeaderHash blk) =>
a
-> StrictTVar m (ChainProducerState blk)
-> (blk -> header)
-> ChainSyncServer header (Point blk) (Tip blk) m a
ChainSyncExamples.chainSyncServerExample
        (TestName -> a
forall a. HasCallStack => TestName -> a
error TestName
"chainSyncServerExample: lazy in the result type")
        StrictTVar m (ChainProducerState Block)
cpsVar
        Block -> Block
forall a. a -> a
id

      client :: ChainSyncClientPipelined Block (Point Block) (Tip Block) m ()
      client = StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m ()
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m ()
forall a.
StrictTVar m (Chain Block)
-> Client Block (Point Block) (Tip Block) m a
-> ChainSyncClientPipelined Block (Point Block) (Tip Block) m a
mkClient StrictTVar m (Chain Block)
chainVar (StrictTVar m Bool
-> Point Block -> Client Block (Point Block) (Tip Block) m ()
forall (m :: * -> *) blockInfo.
MonadSTM m =>
StrictTVar m Bool
-> Point Block -> Client Block (Point Block) blockInfo m ()
testClient StrictTVar m Bool
doneVar (Chain Block -> Point Block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain Block
pchain))

  void $ forkIO (void $ runPeer nullTracer codec serverChan (chainSyncServerPeer server))
  void $ forkIO (void $ runPipelinedPeer nullTracer codec clientChan (chainSyncClientPeerPipelined client))

  atomically $ do
    done <- readTVar doneVar
    unless done retry

  cchain <- atomically $ readTVar chainVar
  return (pchain === cchain)

propChainSyncDemoPipelinedMaxST
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedMaxST :: ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMaxST ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
  Int
omax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- Natural
-> IOSim
     s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (Channel m a, Channel m a)
createPipelineTestChannels (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax)
    chainSyncDemoPipelined
      clientChan serverChan
      (ChainSyncExamples.chainSyncClientPipelinedMax (fromIntegral omax))
      cps

propChainSyncDemoPipelinedMaxIO
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedMaxIO :: ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMaxIO ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
  Int
omax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
  IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- Natural -> IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (Channel m a, Channel m a)
createPipelineTestChannels (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax)
    chainSyncDemoPipelined
      clientChan serverChan
      (ChainSyncExamples.chainSyncClientPipelinedMax (fromIntegral omax))
      cps

propChainSyncDemoPipelinedMinST
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedMinST :: ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMinST ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
  Int
omax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
  (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- Natural
-> IOSim
     s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (Channel m a, Channel m a)
createPipelineTestChannels (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax)
    chainSyncDemoPipelined
      clientChan serverChan
      (ChainSyncExamples.chainSyncClientPipelinedMin (fromIntegral omax))
      cps

propChainSyncDemoPipelinedMinIO
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedMinIO :: ChainProducerStateForkTest -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMinIO ChainProducerStateForkTest
cps (PipeliningDepth Int
omax) =
  Int
omax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
  IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
    (clientChan, serverChan) <- Natural -> IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (Channel m a, Channel m a)
createPipelineTestChannels (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omax)
    chainSyncDemoPipelined
      clientChan serverChan
      (ChainSyncExamples.chainSyncClientPipelinedMin (fromIntegral omax))
      cps

propChainSyncDemoPipelinedLowHighST
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedLowHighST :: ChainProducerStateForkTest
-> PipeliningDepth -> PipeliningDepth -> Property
propChainSyncDemoPipelinedLowHighST ChainProducerStateForkTest
cps (PipeliningDepth Int
x) (PipeliningDepth Int
y) =
    Word16
highMark Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ do
      (clientChan, serverChan) <- Natural
-> IOSim
     s (Channel (IOSim s) ByteString, Channel (IOSim s) ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (Channel m a, Channel m a)
createPipelineTestChannels (Word16 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
highMark)
      chainSyncDemoPipelined
        clientChan serverChan
        (ChainSyncExamples.chainSyncClientPipelinedLowHigh lowMark highMark)
        cps
  where
    lowMark :: Word16
lowMark = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x Int
y
    highMark :: Word16
highMark = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
x Int
y

propChainSyncDemoPipelinedLowHighIO
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedLowHighIO :: ChainProducerStateForkTest
-> PipeliningDepth -> PipeliningDepth -> Property
propChainSyncDemoPipelinedLowHighIO ChainProducerStateForkTest
cps (PipeliningDepth Int
x) (PipeliningDepth Int
y) =
    Word16
highMark Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
      (clientChan, serverChan) <- Natural -> IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> m (Channel m a, Channel m a)
createPipelineTestChannels (Word16 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
highMark)
      chainSyncDemoPipelined
        clientChan serverChan
        (ChainSyncExamples.chainSyncClientPipelinedLowHigh lowMark highMark)
        cps
  where
    lowMark :: Word16
lowMark = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x Int
y
    highMark :: Word16
highMark = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
x Int
y

propChainSyncDemoPipelinedMinBufferedIO
  :: ChainProducerStateForkTest
  -> PipeliningDepth
  -> PipeliningDepth
  -> Property
propChainSyncDemoPipelinedMinBufferedIO :: ChainProducerStateForkTest
-> PipeliningDepth -> PipeliningDepth -> Property
propChainSyncDemoPipelinedMinBufferedIO ChainProducerStateForkTest
cps (PipeliningDepth Int
n) (PipeliningDepth Int
m) =
    Int
omin Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
      (clientChan, serverChan) <- Natural -> IO (Channel IO ByteString, Channel IO ByteString)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
Natural -> m (Channel m a, Channel m a)
createConnectedBufferedChannels (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
omin)
      chainSyncDemoPipelined
        clientChan serverChan
        (ChainSyncExamples.chainSyncClientPipelinedMin (fromIntegral omax))
        cps
  where
    omin :: Int
omin = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
m
    omax :: Int
omax = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
m