{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -Wno-orphans            #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Test.Ouroboros.Network.Mux (tests) where

import Codec.Serialise (Serialise (..))
import Data.Functor (void)
import Data.Monoid.Synchronisation (FirstToFinish (..))

import Control.Applicative (Alternative)
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.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim
import Control.Tracer

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

import Network.TypedProtocol.Core
import Network.TypedProtocol.Peer.Client (Client)
import Network.TypedProtocol.Peer.Server (Server)

import Ouroboros.Network.Block (Tip (..), decodeTip, encodeTip)
import Ouroboros.Network.Context
import Ouroboros.Network.Mock.Chain (Chain, ChainUpdate, Point)
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ProducerState qualified as CPS
import Ouroboros.Network.Protocol.ChainSync.Client qualified as ChainSync
import Ouroboros.Network.Protocol.ChainSync.Codec qualified as ChainSync
import Ouroboros.Network.Protocol.ChainSync.Examples qualified as ChainSync
import Ouroboros.Network.Protocol.ChainSync.Server qualified as ChainSync
import Ouroboros.Network.Protocol.ChainSync.Type qualified as ChainSync
import Ouroboros.Network.Util.ShowProxy

import Network.Mux qualified as Mx
import Network.Mux.Bearer qualified as Mx
import Network.Mux.Bearer.Queues qualified as Mx
import Ouroboros.Network.Mux as Mx


tests :: TestTree
tests :: TestTree
tests =
    TestName -> [TestTree] -> TestTree
testGroup TestName
"Ouroboros.Network.Mux"
  [ TestName -> (TestBlockChainAndUpdates -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"ChainSync Demo (IO)"  TestBlockChainAndUpdates -> Property
prop_mux_demo_io
  , TestName -> (TestBlockChainAndUpdates -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"ChainSync Demo (Sim)" TestBlockChainAndUpdates -> Property
prop_mux_demo_sim
  ]

activeTracer :: forall m a. (MonadSay m, Show a) => Tracer m a
activeTracer :: forall (m :: * -> *) a. (MonadSay m, Show a) => Tracer m a
activeTracer = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
--activeTracer = showTracing sayTracer

_sayTracer :: MonadSay m => Tracer m String
_sayTracer :: forall (m :: * -> *). MonadSay m => Tracer m TestName
_sayTracer = (TestName -> m ()) -> Tracer m TestName
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer TestName -> m ()
forall (m :: * -> *). MonadSay m => TestName -> m ()
say


testProtocols :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b
              -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b
testProtocols :: forall (appType :: Mode) addr bytes (m :: * -> *) a b.
RunMiniProtocolWithMinimalCtx appType addr bytes m a b
-> OuroborosApplicationWithMinimalCtx appType addr bytes m a b
testProtocols RunMiniProtocolWithMinimalCtx appType addr bytes m a b
chainSync =
    [MiniProtocol
   appType
   (MinimalInitiatorContext addr)
   (ResponderContext addr)
   bytes
   m
   a
   b]
-> OuroborosApplication
     appType
     (MinimalInitiatorContext addr)
     (ResponderContext addr)
     bytes
     m
     a
     b
forall (mode :: Mode) initiatorCtx responderCtx bytes (m :: * -> *)
       a b.
[MiniProtocol mode initiatorCtx responderCtx bytes m a b]
-> OuroborosApplication mode initiatorCtx responderCtx bytes m a b
OuroborosApplication [
      MiniProtocol {
        miniProtocolNum :: MiniProtocolNum
miniProtocolNum    = Word16 -> MiniProtocolNum
MiniProtocolNum Word16
2,
        miniProtocolLimits :: MiniProtocolLimits
miniProtocolLimits = MiniProtocolLimits {
                               maximumIngressQueue :: Int
maximumIngressQueue = Int
0xffff
                             },
        miniProtocolRun :: RunMiniProtocolWithMinimalCtx appType addr bytes m a b
miniProtocolRun    = RunMiniProtocolWithMinimalCtx appType addr bytes m a b
chainSync
      }
    ]


demo :: forall m block.
        ( Alternative (STM m)
        , MonadAsync m
        , MonadDelay m
        , MonadCatch m
        , MonadFork m
        , MonadLabelledSTM m
        , MonadMask m
        , MonadSay m
        , MonadST m
        , MonadSTM m
        , MonadThrow (STM m)
        , MonadTime m
        , MonadTimer m
        , Chain.HasHeader block
        , Serialise (Chain.HeaderHash block)
        , Serialise block
        , Eq block
        , Show block
        , ShowProxy block
        , Eq (Async m ()) )
     => Chain block -> [ChainUpdate block block] -> DiffTime -> m Property
demo :: forall (m :: * -> *) block.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadCatch m,
 MonadFork m, MonadLabelledSTM m, MonadMask m, MonadSay m,
 MonadST m, MonadSTM m, MonadThrow (STM m), MonadTime m,
 MonadTimer m, HasHeader block, Serialise (HeaderHash block),
 Serialise block, Eq block, Show block, ShowProxy block,
 Eq (Async m ())) =>
Chain block -> [ChainUpdate block block] -> DiffTime -> m Property
demo Chain block
chain0 [ChainUpdate block block]
updates DiffTime
delay = do
    client_w <- STM m (StrictTBQueue m ByteString)
-> m (StrictTBQueue m ByteString)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTBQueue m ByteString)
 -> m (StrictTBQueue m ByteString))
-> STM m (StrictTBQueue m ByteString)
-> m (StrictTBQueue m ByteString)
forall a b. (a -> b) -> a -> b
$ Natural -> STM m (StrictTBQueue m ByteString)
forall (m :: * -> *) a.
MonadSTM m =>
Natural -> STM m (StrictTBQueue m a)
newTBQueue Natural
10
    client_r <- atomically $ newTBQueue 10
    let server_w = StrictTBQueue m ByteString
client_r
        server_r = StrictTBQueue m ByteString
client_w
    producerVar <- newTVarIO (CPS.initChainProducerState chain0)
    consumerVar <- newTVarIO chain0
    done <- newEmptyTMVarIO

    let Just expectedChain = Chain.applyChainUpdates updates chain0
        target = Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain block
expectedChain

        consumerApp = RunMiniProtocolWithMinimalCtx
  'InitiatorMode TestName ByteString m () Void
-> OuroborosApplicationWithMinimalCtx
     'InitiatorMode TestName ByteString m () Void
forall (appType :: Mode) addr bytes (m :: * -> *) a b.
RunMiniProtocolWithMinimalCtx appType addr bytes m a b
-> OuroborosApplicationWithMinimalCtx appType addr bytes m a b
testProtocols RunMiniProtocolWithMinimalCtx
  'InitiatorMode TestName ByteString m () Void
chainSyncInitator

        chainSyncInitator =
          MiniProtocolCb (MinimalInitiatorContext TestName) ByteString m ()
-> RunMiniProtocolWithMinimalCtx
     'InitiatorMode TestName ByteString m () Void
forall initiatorCtx bytes (m :: * -> *) a responderCtx.
MiniProtocolCb initiatorCtx bytes m a
-> RunMiniProtocol
     'InitiatorMode initiatorCtx responderCtx bytes m a Void
InitiatorProtocolOnly (MiniProtocolCb (MinimalInitiatorContext TestName) ByteString m ()
 -> RunMiniProtocolWithMinimalCtx
      'InitiatorMode TestName ByteString m () Void)
-> MiniProtocolCb
     (MinimalInitiatorContext TestName) ByteString m ()
-> RunMiniProtocolWithMinimalCtx
     'InitiatorMode TestName ByteString m () Void
forall a b. (a -> b) -> a -> b
$
          (MinimalInitiatorContext TestName
 -> (Tracer
       m (TraceSendRecv (ChainSync block (Point block) (Tip block))),
     Codec
       (ChainSync block (Point block) (Tip block))
       DeserialiseFailure
       m
       ByteString,
     Peer
       (ChainSync block (Point block) (Tip block))
       'AsClient
       'NonPipelined
       'StIdle
       m
       ()))
-> MiniProtocolCb
     (MinimalInitiatorContext TestName) ByteString m ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr 'NonPipelined st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer ((MinimalInitiatorContext TestName
  -> (Tracer
        m (TraceSendRecv (ChainSync block (Point block) (Tip block))),
      Codec
        (ChainSync block (Point block) (Tip block))
        DeserialiseFailure
        m
        ByteString,
      Peer
        (ChainSync block (Point block) (Tip block))
        'AsClient
        'NonPipelined
        'StIdle
        m
        ()))
 -> MiniProtocolCb
      (MinimalInitiatorContext TestName) ByteString m ())
-> (MinimalInitiatorContext TestName
    -> (Tracer
          m (TraceSendRecv (ChainSync block (Point block) (Tip block))),
        Codec
          (ChainSync block (Point block) (Tip block))
          DeserialiseFailure
          m
          ByteString,
        Peer
          (ChainSync block (Point block) (Tip block))
          'AsClient
          'NonPipelined
          'StIdle
          m
          ()))
-> MiniProtocolCb
     (MinimalInitiatorContext TestName) ByteString m ()
forall a b. (a -> b) -> a -> b
$ \MinimalInitiatorContext TestName
_ctx ->
            ( Tracer
  m (TraceSendRecv (ChainSync block (Point block) (Tip block)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            , (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
ChainSync.codecChainSync
                 block -> Encoding
forall a. Serialise a => a -> Encoding
encode             Decoder s block
forall s. Decoder s block
forall a s. Serialise a => Decoder s a
decode
                 Point block -> Encoding
forall a. Serialise a => a -> Encoding
encode             Decoder s (Point block)
forall s. Decoder s (Point block)
forall a s. Serialise a => Decoder s a
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
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
decode)
            , Peer
  (ChainSync block (Point block) (Tip block))
  'AsClient
  'NonPipelined
  'StIdle
  m
  ()
consumerPeer
            )

        consumerPeer :: Client (ChainSync.ChainSync block (Point block) (Tip block))
                               'NonPipelined ChainSync.StIdle m ()
        consumerPeer = ChainSyncClient block (Point block) (Tip block) m ()
-> Peer
     (ChainSync block (Point block) (Tip block))
     'AsClient
     'NonPipelined
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncClient header point tip m a
-> Client (ChainSync header point tip) 'NonPipelined 'StIdle m a
ChainSync.chainSyncClientPeer
                          (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
ChainSync.chainSyncClientExample StrictTVar m (Chain block)
consumerVar
                          (StrictTMVar m Bool
-> Point block
-> StrictTVar m (Chain block)
-> Client block (Point block) (Tip block) m ()
consumerClient StrictTMVar m Bool
done Point block
target StrictTVar m (Chain block)
consumerVar))

        producerApp = RunMiniProtocolWithMinimalCtx
  'ResponderMode TestName ByteString m Void ()
-> OuroborosApplicationWithMinimalCtx
     'ResponderMode TestName ByteString m Void ()
forall (appType :: Mode) addr bytes (m :: * -> *) a b.
RunMiniProtocolWithMinimalCtx appType addr bytes m a b
-> OuroborosApplicationWithMinimalCtx appType addr bytes m a b
testProtocols RunMiniProtocolWithMinimalCtx
  'ResponderMode TestName ByteString m Void ()
chainSyncResponder

        chainSyncResponder =
          MiniProtocolCb (ResponderContext TestName) ByteString m ()
-> RunMiniProtocolWithMinimalCtx
     'ResponderMode TestName ByteString m Void ()
forall responderCtx bytes (m :: * -> *) b initiatorCtx.
MiniProtocolCb responderCtx bytes m b
-> RunMiniProtocol
     'ResponderMode initiatorCtx responderCtx bytes m Void b
ResponderProtocolOnly (MiniProtocolCb (ResponderContext TestName) ByteString m ()
 -> RunMiniProtocolWithMinimalCtx
      'ResponderMode TestName ByteString m Void ())
-> MiniProtocolCb (ResponderContext TestName) ByteString m ()
-> RunMiniProtocolWithMinimalCtx
     'ResponderMode TestName ByteString m Void ()
forall a b. (a -> b) -> a -> b
$ (ResponderContext TestName
 -> (Tracer
       m (TraceSendRecv (ChainSync block (Point block) (Tip block))),
     Codec
       (ChainSync block (Point block) (Tip block))
       DeserialiseFailure
       m
       ByteString,
     Peer
       (ChainSync block (Point block) (Tip block))
       'AsServer
       'NonPipelined
       'StIdle
       m
       ()))
-> MiniProtocolCb (ResponderContext TestName) ByteString m ()
forall (pr :: PeerRole) ps (st :: ps) failure bytes ctx
       (m :: * -> *) a.
(MonadThrow m, ShowProxy ps,
 forall (st' :: ps) stok. (stok ~ StateToken st') => Show stok,
 Show failure) =>
(ctx
 -> (Tracer m (TraceSendRecv ps), Codec ps failure m bytes,
     Peer ps pr 'NonPipelined st m a))
-> MiniProtocolCb ctx bytes m a
mkMiniProtocolCbFromPeer ((ResponderContext TestName
  -> (Tracer
        m (TraceSendRecv (ChainSync block (Point block) (Tip block))),
      Codec
        (ChainSync block (Point block) (Tip block))
        DeserialiseFailure
        m
        ByteString,
      Peer
        (ChainSync block (Point block) (Tip block))
        'AsServer
        'NonPipelined
        'StIdle
        m
        ()))
 -> MiniProtocolCb (ResponderContext TestName) ByteString m ())
-> (ResponderContext TestName
    -> (Tracer
          m (TraceSendRecv (ChainSync block (Point block) (Tip block))),
        Codec
          (ChainSync block (Point block) (Tip block))
          DeserialiseFailure
          m
          ByteString,
        Peer
          (ChainSync block (Point block) (Tip block))
          'AsServer
          'NonPipelined
          'StIdle
          m
          ()))
-> MiniProtocolCb (ResponderContext TestName) ByteString m ()
forall a b. (a -> b) -> a -> b
$ \ResponderContext TestName
_ctx ->
            ( Tracer
  m (TraceSendRecv (ChainSync block (Point block) (Tip block)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
            , (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
ChainSync.codecChainSync
                 block -> Encoding
forall a. Serialise a => a -> Encoding
encode             Decoder s block
forall s. Decoder s block
forall a s. Serialise a => Decoder s a
decode
                 Point block -> Encoding
forall a. Serialise a => a -> Encoding
encode             Decoder s (Point block)
forall s. Decoder s (Point block)
forall a s. Serialise a => Decoder s a
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
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
decode)
            , Peer
  (ChainSync block (Point block) (Tip block))
  'AsServer
  'NonPipelined
  'StIdle
  m
  ()
producerPeer
            )

        producerPeer :: Server (ChainSync.ChainSync block (Point block) (Tip block))
                               'NonPipelined ChainSync.StIdle m ()
        producerPeer = ChainSyncServer block (Point block) (Tip block) m ()
-> Peer
     (ChainSync block (Point block) (Tip block))
     'AsServer
     'NonPipelined
     'StIdle
     m
     ()
forall header point tip (m :: * -> *) a.
Monad m =>
ChainSyncServer header point tip m a
-> Server (ChainSync header point tip) 'NonPipelined 'StIdle m a
ChainSync.chainSyncServerPeer (()
-> StrictTVar m (ChainProducerState block)
-> (block -> block)
-> ChainSyncServer block (Point block) (Tip block) m ()
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
ChainSync.chainSyncServerExample () StrictTVar m (ChainProducerState block)
producerVar block -> block
forall a. a -> a
id)

    clientBearer <- Mx.getBearer Mx.makeQueueChannelBearer
                      (-1)
                      activeTracer
                      Mx.QueueChannel { Mx.writeQueue = client_w,
                                        Mx.readQueue = client_r
                                      }
    serverBearer <- Mx.getBearer Mx.makeQueueChannelBearer
                       (-1)
                       activeTracer
                       Mx.QueueChannel { Mx.writeQueue = server_w,
                                         Mx.readQueue = server_r
                                       }

    clientAsync <- async $ do
      clientMux <- Mx.new (toMiniProtocolInfos consumerApp)
      let initCtx = ConnectionId TestName -> MinimalInitiatorContext TestName
forall addr. ConnectionId addr -> MinimalInitiatorContext addr
MinimalInitiatorContext (TestName -> TestName -> ConnectionId TestName
forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestName
"consumer" TestName
"producer")
      resOps <- sequence
        [ Mx.runMiniProtocol
            clientMux
            miniProtocolNum
            miniProtocolDir
            Mx.StartEagerly
            (\ByteChannel m
a -> do
              r <- ByteChannel m -> m ()
action ByteChannel m
a
              return (r, Nothing)
            )
        | MiniProtocol{miniProtocolNum, miniProtocolRun}
            <- getOuroborosApplication consumerApp
        , (miniProtocolDir, action) <-
            case miniProtocolRun of
              InitiatorProtocolOnly MiniProtocolCb (MinimalInitiatorContext TestName) ByteString m ()
initiator ->
                [(MiniProtocolDirection 'InitiatorMode
Mx.InitiatorDirectionOnly, m ((), Maybe ByteString) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ((), Maybe ByteString) -> m ())
-> (ByteChannel m -> m ((), Maybe ByteString))
-> ByteChannel m
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MiniProtocolCb (MinimalInitiatorContext TestName) ByteString m ()
-> MinimalInitiatorContext TestName
-> ByteChannel m
-> m ((), Maybe ByteString)
forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMiniProtocolCb MiniProtocolCb (MinimalInitiatorContext TestName) ByteString m ()
initiator MinimalInitiatorContext TestName
initCtx)]
        ]
      withAsync (Mx.run nullTracer clientMux clientBearer) $ \Async m ()
aid -> do
        _ <- STM m (Either SomeException ()) -> m (Either SomeException ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either SomeException ()) -> m (Either SomeException ()))
-> STM m (Either SomeException ()) -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ FirstToFinish (STM m) (Either SomeException ())
-> STM m (Either SomeException ())
forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish (FirstToFinish (STM m) (Either SomeException ())
 -> STM m (Either SomeException ()))
-> FirstToFinish (STM m) (Either SomeException ())
-> STM m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (STM m (Either SomeException ())
 -> FirstToFinish (STM m) (Either SomeException ()))
-> [STM m (Either SomeException ())]
-> FirstToFinish (STM m) (Either SomeException ())
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap STM m (Either SomeException ())
-> FirstToFinish (STM m) (Either SomeException ())
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish [STM m (Either SomeException ())]
resOps
        Mx.stop clientMux
        wait aid

    serverAsync <- async $ do
      serverMux <- Mx.new (toMiniProtocolInfos producerApp)
      let respCtx = ConnectionId TestName -> ResponderContext TestName
forall addr. ConnectionId addr -> ResponderContext addr
ResponderContext (TestName -> TestName -> ConnectionId TestName
forall addr. addr -> addr -> ConnectionId addr
ConnectionId TestName
"producer" TestName
"consumer")
      resOps <- sequence
        [ Mx.runMiniProtocol
            serverMux
            miniProtocolNum
            miniProtocolDir
            Mx.StartEagerly
            (\ByteChannel m
a -> do
              r <- ByteChannel m -> m ()
action ByteChannel m
a
              return (r, Nothing)
            )
        | MiniProtocol{miniProtocolNum, miniProtocolRun}
            <- getOuroborosApplication producerApp
        , (miniProtocolDir, action) <-
            case miniProtocolRun of
              ResponderProtocolOnly MiniProtocolCb (ResponderContext TestName) ByteString m ()
responder ->
                [(MiniProtocolDirection 'ResponderMode
Mx.ResponderDirectionOnly, m ((), Maybe ByteString) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ((), Maybe ByteString) -> m ())
-> (ByteChannel m -> m ((), Maybe ByteString))
-> ByteChannel m
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MiniProtocolCb (ResponderContext TestName) ByteString m ()
-> ResponderContext TestName
-> ByteChannel m
-> m ((), Maybe ByteString)
forall ctx bytes (m :: * -> *) a.
MiniProtocolCb ctx bytes m a
-> ctx -> Channel m bytes -> m (a, Maybe bytes)
runMiniProtocolCb MiniProtocolCb (ResponderContext TestName) ByteString m ()
responder ResponderContext TestName
respCtx)]
        ]
      withAsync (Mx.run nullTracer serverMux serverBearer) $ \Async m ()
aid -> do
        _ <- STM m (Either SomeException ()) -> m (Either SomeException ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either SomeException ()) -> m (Either SomeException ()))
-> STM m (Either SomeException ()) -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ FirstToFinish (STM m) (Either SomeException ())
-> STM m (Either SomeException ())
forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish (FirstToFinish (STM m) (Either SomeException ())
 -> STM m (Either SomeException ()))
-> FirstToFinish (STM m) (Either SomeException ())
-> STM m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ (STM m (Either SomeException ())
 -> FirstToFinish (STM m) (Either SomeException ()))
-> [STM m (Either SomeException ())]
-> FirstToFinish (STM m) (Either SomeException ())
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap STM m (Either SomeException ())
-> FirstToFinish (STM m) (Either SomeException ())
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish [STM m (Either SomeException ())]
resOps
        Mx.stop serverMux
        wait aid

    updateAid <- async $ sequence_
        [ do
            threadDelay delay -- X milliseconds, just to provide interest
            atomically $ do
              p <- readTVar producerVar
              let Just p' = CPS.applyChainUpdate update p
              writeTVar producerVar p'
        | update <- updates
        ]

    wait updateAid
    _ <- waitBoth clientAsync serverAsync
    -- TODO: use new mechanism to collect mini-protocol result:
    ret <- atomically $ takeTMVar done
    return $ property ret

  where
    checkTip :: Point block -> StrictTVar m (Chain block) -> m Bool
checkTip Point block
target StrictTVar m (Chain block)
consumerVar = STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
      chain <- StrictTVar m (Chain block) -> STM m (Chain block)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain block)
consumerVar
      return (Chain.headPoint chain == target)

    -- A simple chain-sync client which runs until it recieves an update to
    -- a given point (either as a roll forward or as a roll backward).
    consumerClient :: StrictTMVar m Bool
                   -> Point block
                   -> StrictTVar m (Chain block)
                   -> ChainSync.Client block (Point block) (Tip block) m ()
    consumerClient :: StrictTMVar m Bool
-> Point block
-> StrictTVar m (Chain block)
-> Client block (Point block) (Tip block) m ()
consumerClient StrictTMVar m Bool
done Point block
target StrictTVar m (Chain block)
chain =
      ChainSync.Client
        { rollforward :: block
-> m (Either () (Client block (Point block) (Tip block) m ()))
ChainSync.rollforward = \block
_ -> Point block -> StrictTVar m (Chain block) -> m Bool
forall {m :: * -> *} {block}.
(MonadSTM m, HasHeader block) =>
Point block -> StrictTVar m (Chain block) -> m Bool
checkTip Point block
target StrictTVar m (Chain block)
chain m Bool
-> (Bool
    -> m (Either () (Client block (Point block) (Tip block) m ())))
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b 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
$ StrictTMVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m Bool
done Bool
True
                    Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () (Client block (Point block) (Tip block) m ())
 -> m (Either () (Client block (Point block) (Tip block) m ())))
-> Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. (a -> b) -> a -> b
$ () -> Either () (Client block (Point block) (Tip block) m ())
forall a b. a -> Either a b
Left ()
                 else
                    Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () (Client block (Point block) (Tip block) m ())
 -> m (Either () (Client block (Point block) (Tip block) m ())))
-> Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. (a -> b) -> a -> b
$ Client block (Point block) (Tip block) m ()
-> Either () (Client block (Point block) (Tip block) m ())
forall a b. b -> Either a b
Right (Client block (Point block) (Tip block) m ()
 -> Either () (Client block (Point block) (Tip block) m ()))
-> Client block (Point block) (Tip block) m ()
-> Either () (Client block (Point block) (Tip block) m ())
forall a b. (a -> b) -> a -> b
$ StrictTMVar m Bool
-> Point block
-> StrictTVar m (Chain block)
-> Client block (Point block) (Tip block) m ()
consumerClient StrictTMVar m Bool
done Point block
target StrictTVar m (Chain block)
chain
        , rollbackward :: Point block
-> Tip block
-> m (Either () (Client block (Point block) (Tip block) m ()))
ChainSync.rollbackward = \Point block
_ Tip block
_ -> Point block -> StrictTVar m (Chain block) -> m Bool
forall {m :: * -> *} {block}.
(MonadSTM m, HasHeader block) =>
Point block -> StrictTVar m (Chain block) -> m Bool
checkTip Point block
target StrictTVar m (Chain block)
chain m Bool
-> (Bool
    -> m (Either () (Client block (Point block) (Tip block) m ())))
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b 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
$ StrictTMVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m Bool
done Bool
True
                    Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () (Client block (Point block) (Tip block) m ())
 -> m (Either () (Client block (Point block) (Tip block) m ())))
-> Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. (a -> b) -> a -> b
$ () -> Either () (Client block (Point block) (Tip block) m ())
forall a b. a -> Either a b
Left ()
                 else
                    Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () (Client block (Point block) (Tip block) m ())
 -> m (Either () (Client block (Point block) (Tip block) m ())))
-> Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. (a -> b) -> a -> b
$ Client block (Point block) (Tip block) m ()
-> Either () (Client block (Point block) (Tip block) m ())
forall a b. b -> Either a b
Right (Client block (Point block) (Tip block) m ()
 -> Either () (Client block (Point block) (Tip block) m ()))
-> Client block (Point block) (Tip block) m ()
-> Either () (Client block (Point block) (Tip block) m ())
forall a b. (a -> b) -> a -> b
$ StrictTMVar m Bool
-> Point block
-> StrictTVar m (Chain block)
-> Client block (Point block) (Tip block) m ()
consumerClient StrictTMVar m Bool
done Point block
target StrictTVar m (Chain block)
chain
        , points :: [Point block]
-> m (Either () (Client block (Point block) (Tip block) m ()))
ChainSync.points = \[Point block]
_ -> Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either () (Client block (Point block) (Tip block) m ())
 -> m (Either () (Client block (Point block) (Tip block) m ())))
-> Either () (Client block (Point block) (Tip block) m ())
-> m (Either () (Client block (Point block) (Tip block) m ()))
forall a b. (a -> b) -> a -> b
$ Client block (Point block) (Tip block) m ()
-> Either () (Client block (Point block) (Tip block) m ())
forall a b. b -> Either a b
Right (Client block (Point block) (Tip block) m ()
 -> Either () (Client block (Point block) (Tip block) m ()))
-> Client block (Point block) (Tip block) m ()
-> Either () (Client block (Point block) (Tip block) m ())
forall a b. (a -> b) -> a -> b
$ StrictTMVar m Bool
-> Point block
-> StrictTVar m (Chain block)
-> Client block (Point block) (Tip block) m ()
consumerClient StrictTMVar m Bool
done Point block
target StrictTVar m (Chain block)
chain
        }

prop_mux_demo_io :: TestBlockChainAndUpdates -> Property
prop_mux_demo_io :: TestBlockChainAndUpdates -> Property
prop_mux_demo_io (TestBlockChainAndUpdates Chain Block
chain [ChainUpdate Block Block]
updates) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ Chain Block -> [ChainUpdate Block Block] -> DiffTime -> IO Property
forall (m :: * -> *) block.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadCatch m,
 MonadFork m, MonadLabelledSTM m, MonadMask m, MonadSay m,
 MonadST m, MonadSTM m, MonadThrow (STM m), MonadTime m,
 MonadTimer m, HasHeader block, Serialise (HeaderHash block),
 Serialise block, Eq block, Show block, ShowProxy block,
 Eq (Async m ())) =>
Chain block -> [ChainUpdate block block] -> DiffTime -> m Property
demo Chain Block
chain [ChainUpdate Block Block]
updates DiffTime
10e-4

prop_mux_demo_sim :: TestBlockChainAndUpdates -> Property
prop_mux_demo_sim :: TestBlockChainAndUpdates -> Property
prop_mux_demo_sim (TestBlockChainAndUpdates Chain Block
chain [ChainUpdate Block Block]
updates) =
    case (forall s. IOSim s Property) -> Either Failure Property
forall a. (forall s. IOSim s a) -> Either Failure a
runSimStrictShutdown ((forall s. IOSim s Property) -> Either Failure Property)
-> (forall s. IOSim s Property) -> Either Failure Property
forall a b. (a -> b) -> a -> b
$ Chain Block
-> [ChainUpdate Block Block] -> DiffTime -> IOSim s Property
forall (m :: * -> *) block.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadCatch m,
 MonadFork m, MonadLabelledSTM m, MonadMask m, MonadSay m,
 MonadST m, MonadSTM m, MonadThrow (STM m), MonadTime m,
 MonadTimer m, HasHeader block, Serialise (HeaderHash block),
 Serialise block, Eq block, Show block, ShowProxy block,
 Eq (Async m ())) =>
Chain block -> [ChainUpdate block block] -> DiffTime -> m Property
demo Chain Block
chain [ChainUpdate Block Block]
updates DiffTime
10e-3 of
         Left  Failure
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property  Bool
False
         Right Property
r -> Property
r