{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}

-- | Smoke tests for the object diffusion protocol. This uses a trivial object
-- pool and checks that a few objects can indeed be transferred from the
-- outbound to the inbound peer.
module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
  ( tests
  , prop_smoke_object_diffusion
  , ProtocolConstants
  , genProtocolConstants
  ) where

import Cardano.Network.NodeToNode.Version (NodeToNodeVersion (..))
import Control.Monad.IOSim (runSimStrictShutdown)
import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry)
import Control.Tracer (Tracer, nullTracer, traceWith)
import Data.Data (Typeable)
import Data.Functor.Contravariant (contramap)
import qualified Data.Map.Strict as Map
import Network.TypedProtocol.Channel (Channel, createConnectedChannels)
import Network.TypedProtocol.Codec (AnyMessage)
import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
  ( objectDiffusionInbound
  )
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
  ( ObjectPoolReader (..)
  , ObjectPoolWriter (..)
  )
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound)
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , MonadDelay (..)
  , MonadSTM (..)
  , StrictTVar
  , modifyTVar
  , readTVar
  , uncheckedNewTVarM
  , writeTVar
  )
import Ouroboros.Network.ControlMessage (ControlMessage (..))
import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId)
import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
  ( ObjectDiffusionInboundPipelined
  , objectDiffusionInboundPeerPipelined
  )
import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound
  ( ObjectDiffusionOutbound
  , objectDiffusionOutboundPeer
  )
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
  ( NumObjectIdsReq (..)
  , NumObjectsReq (..)
  , NumObjectsUnacknowledged (..)
  , ObjectDiffusion
  )
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Orphans.IOLike ()
import Test.Util.Peras (ListWithUniqueIds (..), genListWithUniqueIds)

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"ObjectDiffusion.Smoke"
    [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty
        TestName
"ObjectDiffusion smoke test with mock objects"
        Property
prop_smoke
    ]

{-------------------------------------------------------------------------------
  Mock objectPools
-------------------------------------------------------------------------------}

newtype SmokeObjectId = SmokeObjectId Int
  deriving (SmokeObjectId -> SmokeObjectId -> Bool
(SmokeObjectId -> SmokeObjectId -> Bool)
-> (SmokeObjectId -> SmokeObjectId -> Bool) -> Eq SmokeObjectId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SmokeObjectId -> SmokeObjectId -> Bool
== :: SmokeObjectId -> SmokeObjectId -> Bool
$c/= :: SmokeObjectId -> SmokeObjectId -> Bool
/= :: SmokeObjectId -> SmokeObjectId -> Bool
Eq, Eq SmokeObjectId
Eq SmokeObjectId =>
(SmokeObjectId -> SmokeObjectId -> Ordering)
-> (SmokeObjectId -> SmokeObjectId -> Bool)
-> (SmokeObjectId -> SmokeObjectId -> Bool)
-> (SmokeObjectId -> SmokeObjectId -> Bool)
-> (SmokeObjectId -> SmokeObjectId -> Bool)
-> (SmokeObjectId -> SmokeObjectId -> SmokeObjectId)
-> (SmokeObjectId -> SmokeObjectId -> SmokeObjectId)
-> Ord SmokeObjectId
SmokeObjectId -> SmokeObjectId -> Bool
SmokeObjectId -> SmokeObjectId -> Ordering
SmokeObjectId -> SmokeObjectId -> SmokeObjectId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SmokeObjectId -> SmokeObjectId -> Ordering
compare :: SmokeObjectId -> SmokeObjectId -> Ordering
$c< :: SmokeObjectId -> SmokeObjectId -> Bool
< :: SmokeObjectId -> SmokeObjectId -> Bool
$c<= :: SmokeObjectId -> SmokeObjectId -> Bool
<= :: SmokeObjectId -> SmokeObjectId -> Bool
$c> :: SmokeObjectId -> SmokeObjectId -> Bool
> :: SmokeObjectId -> SmokeObjectId -> Bool
$c>= :: SmokeObjectId -> SmokeObjectId -> Bool
>= :: SmokeObjectId -> SmokeObjectId -> Bool
$cmax :: SmokeObjectId -> SmokeObjectId -> SmokeObjectId
max :: SmokeObjectId -> SmokeObjectId -> SmokeObjectId
$cmin :: SmokeObjectId -> SmokeObjectId -> SmokeObjectId
min :: SmokeObjectId -> SmokeObjectId -> SmokeObjectId
Ord, Int -> SmokeObjectId -> ShowS
[SmokeObjectId] -> ShowS
SmokeObjectId -> TestName
(Int -> SmokeObjectId -> ShowS)
-> (SmokeObjectId -> TestName)
-> ([SmokeObjectId] -> ShowS)
-> Show SmokeObjectId
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SmokeObjectId -> ShowS
showsPrec :: Int -> SmokeObjectId -> ShowS
$cshow :: SmokeObjectId -> TestName
show :: SmokeObjectId -> TestName
$cshowList :: [SmokeObjectId] -> ShowS
showList :: [SmokeObjectId] -> ShowS
Show, Context -> SmokeObjectId -> IO (Maybe ThunkInfo)
Proxy SmokeObjectId -> TestName
(Context -> SmokeObjectId -> IO (Maybe ThunkInfo))
-> (Context -> SmokeObjectId -> IO (Maybe ThunkInfo))
-> (Proxy SmokeObjectId -> TestName)
-> NoThunks SmokeObjectId
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> SmokeObjectId -> IO (Maybe ThunkInfo)
noThunks :: Context -> SmokeObjectId -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SmokeObjectId -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SmokeObjectId -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SmokeObjectId -> TestName
showTypeOf :: Proxy SmokeObjectId -> TestName
NoThunks)

newtype SmokeObject = SmokeObject {SmokeObject -> SmokeObjectId
getSmokeObjectId :: SmokeObjectId}
  deriving (SmokeObject -> SmokeObject -> Bool
(SmokeObject -> SmokeObject -> Bool)
-> (SmokeObject -> SmokeObject -> Bool) -> Eq SmokeObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SmokeObject -> SmokeObject -> Bool
== :: SmokeObject -> SmokeObject -> Bool
$c/= :: SmokeObject -> SmokeObject -> Bool
/= :: SmokeObject -> SmokeObject -> Bool
Eq, Eq SmokeObject
Eq SmokeObject =>
(SmokeObject -> SmokeObject -> Ordering)
-> (SmokeObject -> SmokeObject -> Bool)
-> (SmokeObject -> SmokeObject -> Bool)
-> (SmokeObject -> SmokeObject -> Bool)
-> (SmokeObject -> SmokeObject -> Bool)
-> (SmokeObject -> SmokeObject -> SmokeObject)
-> (SmokeObject -> SmokeObject -> SmokeObject)
-> Ord SmokeObject
SmokeObject -> SmokeObject -> Bool
SmokeObject -> SmokeObject -> Ordering
SmokeObject -> SmokeObject -> SmokeObject
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SmokeObject -> SmokeObject -> Ordering
compare :: SmokeObject -> SmokeObject -> Ordering
$c< :: SmokeObject -> SmokeObject -> Bool
< :: SmokeObject -> SmokeObject -> Bool
$c<= :: SmokeObject -> SmokeObject -> Bool
<= :: SmokeObject -> SmokeObject -> Bool
$c> :: SmokeObject -> SmokeObject -> Bool
> :: SmokeObject -> SmokeObject -> Bool
$c>= :: SmokeObject -> SmokeObject -> Bool
>= :: SmokeObject -> SmokeObject -> Bool
$cmax :: SmokeObject -> SmokeObject -> SmokeObject
max :: SmokeObject -> SmokeObject -> SmokeObject
$cmin :: SmokeObject -> SmokeObject -> SmokeObject
min :: SmokeObject -> SmokeObject -> SmokeObject
Ord, Int -> SmokeObject -> ShowS
[SmokeObject] -> ShowS
SmokeObject -> TestName
(Int -> SmokeObject -> ShowS)
-> (SmokeObject -> TestName)
-> ([SmokeObject] -> ShowS)
-> Show SmokeObject
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SmokeObject -> ShowS
showsPrec :: Int -> SmokeObject -> ShowS
$cshow :: SmokeObject -> TestName
show :: SmokeObject -> TestName
$cshowList :: [SmokeObject] -> ShowS
showList :: [SmokeObject] -> ShowS
Show, Context -> SmokeObject -> IO (Maybe ThunkInfo)
Proxy SmokeObject -> TestName
(Context -> SmokeObject -> IO (Maybe ThunkInfo))
-> (Context -> SmokeObject -> IO (Maybe ThunkInfo))
-> (Proxy SmokeObject -> TestName)
-> NoThunks SmokeObject
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> SmokeObject -> IO (Maybe ThunkInfo)
noThunks :: Context -> SmokeObject -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> SmokeObject -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> SmokeObject -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SmokeObject -> TestName
showTypeOf :: Proxy SmokeObject -> TestName
NoThunks)

genSmokeObjectId :: Gen SmokeObjectId
genSmokeObjectId :: Gen SmokeObjectId
genSmokeObjectId = Int -> SmokeObjectId
SmokeObjectId (Int -> SmokeObjectId) -> Gen Int -> Gen SmokeObjectId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
forall a. Arbitrary a => Gen a
arbitrary

genSmokeObject :: Gen SmokeObject
genSmokeObject :: Gen SmokeObject
genSmokeObject = SmokeObjectId -> SmokeObject
SmokeObject (SmokeObjectId -> SmokeObject)
-> Gen SmokeObjectId -> Gen SmokeObject
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen SmokeObjectId
genSmokeObjectId

newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject])

newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m)
newObjectPool :: forall (m :: * -> *).
MonadSTM m =>
[SmokeObject] -> m (SmokeObjectPool m)
newObjectPool [SmokeObject]
initialPoolContent = StrictTVar m [SmokeObject] -> SmokeObjectPool m
forall (m :: * -> *).
StrictTVar m [SmokeObject] -> SmokeObjectPool m
SmokeObjectPool (StrictTVar m [SmokeObject] -> SmokeObjectPool m)
-> m (StrictTVar m [SmokeObject]) -> m (SmokeObjectPool m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SmokeObject] -> m (StrictTVar m [SmokeObject])
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM [SmokeObject]
initialPoolContent

makeObjectPoolReader ::
  MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m
makeObjectPoolReader :: forall (m :: * -> *).
MonadSTM m =>
SmokeObjectPool m
-> ObjectPoolReader SmokeObjectId SmokeObject Int m
makeObjectPoolReader (SmokeObjectPool StrictTVar m [SmokeObject]
poolContentTvar) =
  ObjectPoolReader
    { oprObjectId :: SmokeObject -> SmokeObjectId
oprObjectId = SmokeObject -> SmokeObjectId
getSmokeObjectId
    , oprObjectsAfter :: Int -> Word64 -> STM m (Maybe (m (Map Int SmokeObject)))
oprObjectsAfter = \Int
minTicketNo Word64
limit -> do
        poolContent <- StrictTVar m [SmokeObject] -> STM m [SmokeObject]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m [SmokeObject]
poolContentTvar
        let items =
              Int -> [(Int, SmokeObject)] -> [(Int, SmokeObject)]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
limit) ([(Int, SmokeObject)] -> [(Int, SmokeObject)])
-> [(Int, SmokeObject)] -> [(Int, SmokeObject)]
forall a b. (a -> b) -> a -> b
$
                Int -> [(Int, SmokeObject)] -> [(Int, SmokeObject)]
forall a. Int -> [a] -> [a]
drop (Int
minTicketNo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ([(Int, SmokeObject)] -> [(Int, SmokeObject)])
-> [(Int, SmokeObject)] -> [(Int, SmokeObject)]
forall a b. (a -> b) -> a -> b
$
                  [Int] -> [SmokeObject] -> [(Int, SmokeObject)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int) ..] [SmokeObject]
poolContent
        if null items
          then pure Nothing
          else pure $ Just $ pure $ Map.fromList items
    , oprZeroTicketNo :: Int
oprZeroTicketNo = -Int
1 :: Int -- objectPoolObjectIdsAfter uses strict comparison, and first ticketNo is 0.
    }

makeObjectPoolWriter ::
  MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
makeObjectPoolWriter :: forall (m :: * -> *).
MonadSTM m =>
SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
makeObjectPoolWriter (SmokeObjectPool StrictTVar m [SmokeObject]
poolContentTvar) =
  ObjectPoolWriter
    { opwObjectId :: SmokeObject -> SmokeObjectId
opwObjectId = SmokeObject -> SmokeObjectId
getSmokeObjectId
    , opwAddObjects :: [SmokeObject] -> m ()
opwAddObjects = \[SmokeObject]
objects -> 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 [SmokeObject]
-> ([SmokeObject] -> [SmokeObject]) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m [SmokeObject]
poolContentTvar ([SmokeObject] -> [SmokeObject] -> [SmokeObject]
forall a. [a] -> [a] -> [a]
++ [SmokeObject]
objects)
        () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , opwHasObject :: STM m (SmokeObjectId -> Bool)
opwHasObject = do
        poolContent <- StrictTVar m [SmokeObject] -> STM m [SmokeObject]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m [SmokeObject]
poolContentTvar
        pure $ \SmokeObjectId
objectId -> (SmokeObject -> Bool) -> [SmokeObject] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\SmokeObject
obj -> SmokeObject -> SmokeObjectId
getSmokeObjectId SmokeObject
obj SmokeObjectId -> SmokeObjectId -> Bool
forall a. Eq a => a -> a -> Bool
== SmokeObjectId
objectId) [SmokeObject]
poolContent
    }

mkMockPoolInterfaces ::
  MonadSTM m =>
  [SmokeObject] ->
  m
    ( ObjectPoolReader SmokeObjectId SmokeObject Int m
    , ObjectPoolWriter SmokeObjectId SmokeObject m
    , m [SmokeObject]
    )
mkMockPoolInterfaces :: forall (m :: * -> *).
MonadSTM m =>
[SmokeObject]
-> m (ObjectPoolReader SmokeObjectId SmokeObject Int m,
      ObjectPoolWriter SmokeObjectId SmokeObject m, m [SmokeObject])
mkMockPoolInterfaces [SmokeObject]
objects = do
  outboundPool <- [SmokeObject] -> m (SmokeObjectPool m)
forall (m :: * -> *).
MonadSTM m =>
[SmokeObject] -> m (SmokeObjectPool m)
newObjectPool [SmokeObject]
objects
  inboundPool@(SmokeObjectPool tvar) <- newObjectPool []

  let outboundPoolReader = SmokeObjectPool m
-> ObjectPoolReader SmokeObjectId SmokeObject Int m
forall (m :: * -> *).
MonadSTM m =>
SmokeObjectPool m
-> ObjectPoolReader SmokeObjectId SmokeObject Int m
makeObjectPoolReader SmokeObjectPool m
outboundPool
      inboundPoolWriter = SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
forall (m :: * -> *).
MonadSTM m =>
SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
makeObjectPoolWriter SmokeObjectPool m
inboundPool

  return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar)

{-------------------------------------------------------------------------------
  Protocol constants
-------------------------------------------------------------------------------}

newtype ProtocolConstants
  = ProtocolConstants (NumObjectsUnacknowledged, NumObjectIdsReq, NumObjectsReq)
  deriving Int -> ProtocolConstants -> ShowS
[ProtocolConstants] -> ShowS
ProtocolConstants -> TestName
(Int -> ProtocolConstants -> ShowS)
-> (ProtocolConstants -> TestName)
-> ([ProtocolConstants] -> ShowS)
-> Show ProtocolConstants
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProtocolConstants -> ShowS
showsPrec :: Int -> ProtocolConstants -> ShowS
$cshow :: ProtocolConstants -> TestName
show :: ProtocolConstants -> TestName
$cshowList :: [ProtocolConstants] -> ShowS
showList :: [ProtocolConstants] -> ShowS
Show

genProtocolConstants :: Gen ProtocolConstants
genProtocolConstants :: Gen ProtocolConstants
genProtocolConstants = do
  maxFifoSize <- (Word16, Word16) -> Gen Word16
forall a. Random a => (a, a) -> Gen a
choose (Word16
5, Word16
20)
  maxIdsToReq <- choose (3, maxFifoSize)
  maxObjectsToReq <- choose (2, maxIdsToReq)
  pure $
    ProtocolConstants
      ( NumObjectsUnacknowledged maxFifoSize
      , NumObjectIdsReq maxIdsToReq
      , NumObjectsReq maxObjectsToReq
      )

nodeToNodeVersion :: NodeToNodeVersion
nodeToNodeVersion :: NodeToNodeVersion
nodeToNodeVersion = NodeToNodeVersion
NodeToNodeV_14

{-------------------------------------------------------------------------------
  Main properties
-------------------------------------------------------------------------------}

prop_smoke :: Property
prop_smoke :: Property
prop_smoke =
  Gen ProtocolConstants
-> (ProtocolConstants -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ProtocolConstants
genProtocolConstants ((ProtocolConstants -> Property) -> Property)
-> (ProtocolConstants -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ProtocolConstants
protocolConstants ->
    Gen (ListWithUniqueIds SmokeObject)
-> (ListWithUniqueIds SmokeObject -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ((SmokeObject -> SmokeObjectId)
-> Gen SmokeObject -> Gen (ListWithUniqueIds SmokeObject)
forall idTy a.
Ord idTy =>
(a -> idTy) -> Gen a -> Gen (ListWithUniqueIds a)
genListWithUniqueIds SmokeObject -> SmokeObjectId
getSmokeObjectId Gen SmokeObject
genSmokeObject) ((ListWithUniqueIds SmokeObject -> Property) -> Property)
-> (ListWithUniqueIds SmokeObject -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
      \(ListWithUniqueIds [SmokeObject]
objects) ->
        ProtocolConstants
-> [SmokeObject]
-> (forall (m :: * -> *).
    IOLike m =>
    ObjectDiffusionOutbound SmokeObjectId SmokeObject m ()
    -> Channel
         m (AnyMessage (ObjectDiffusion SmokeObjectId SmokeObject))
    -> Tracer m TestName
    -> m ())
-> (forall (m :: * -> *).
    IOLike m =>
    ObjectDiffusionInboundPipelined SmokeObjectId SmokeObject m ()
    -> Channel
         m (AnyMessage (ObjectDiffusion SmokeObjectId SmokeObject))
    -> Tracer m TestName
    -> m ())
-> (forall (m :: * -> *).
    IOLike m =>
    m (ObjectPoolReader SmokeObjectId SmokeObject Int m,
       ObjectPoolWriter SmokeObjectId SmokeObject m, m [SmokeObject]))
-> Property
forall object objectId ticketNo.
(Eq object, Show object, Ord objectId, Typeable objectId,
 Typeable object, NoThunks objectId, Show objectId,
 NoThunks object) =>
ProtocolConstants
-> [object]
-> (forall (m :: * -> *).
    IOLike m =>
    ObjectDiffusionOutbound objectId object m ()
    -> Channel m (AnyMessage (ObjectDiffusion objectId object))
    -> Tracer m TestName
    -> m ())
-> (forall (m :: * -> *).
    IOLike m =>
    ObjectDiffusionInboundPipelined objectId object m ()
    -> Channel m (AnyMessage (ObjectDiffusion objectId object))
    -> Tracer m TestName
    -> m ())
-> (forall (m :: * -> *).
    IOLike m =>
    m (ObjectPoolReader objectId object ticketNo m,
       ObjectPoolWriter objectId object m, m [object]))
-> Property
prop_smoke_object_diffusion
          ProtocolConstants
protocolConstants
          [SmokeObject]
objects
          ObjectDiffusionOutbound SmokeObjectId SmokeObject m ()
-> Channel
     m (AnyMessage (ObjectDiffusion SmokeObjectId SmokeObject))
-> Tracer m TestName
-> m ()
forall (m :: * -> *).
IOLike m =>
ObjectDiffusionOutbound SmokeObjectId SmokeObject m ()
-> Channel
     m (AnyMessage (ObjectDiffusion SmokeObjectId SmokeObject))
-> Tracer m TestName
-> m ()
forall {m :: * -> *} {a} {objectId} {object}.
(MonadEvaluate m, MonadThrow m, NFData a, Show objectId,
 Show object) =>
ObjectDiffusionOutbound objectId object m a
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Tracer m TestName
-> m ()
runOutboundPeer
          ObjectDiffusionInboundPipelined SmokeObjectId SmokeObject m ()
-> Channel
     m (AnyMessage (ObjectDiffusion SmokeObjectId SmokeObject))
-> Tracer m TestName
-> m ()
forall (m :: * -> *).
IOLike m =>
ObjectDiffusionInboundPipelined SmokeObjectId SmokeObject m ()
-> Channel
     m (AnyMessage (ObjectDiffusion SmokeObjectId SmokeObject))
-> Tracer m TestName
-> m ()
forall {m :: * -> *} {a} {objectId} {object}.
(MonadAsync m, MonadEvaluate m, MonadThrow m, NFData a,
 Show objectId, Show object) =>
ObjectDiffusionInboundPipelined objectId object m a
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Tracer m TestName
-> m ()
runInboundPeer
          ([SmokeObject]
-> m (ObjectPoolReader SmokeObjectId SmokeObject Int m,
      ObjectPoolWriter SmokeObjectId SmokeObject m, m [SmokeObject])
forall (m :: * -> *).
MonadSTM m =>
[SmokeObject]
-> m (ObjectPoolReader SmokeObjectId SmokeObject Int m,
      ObjectPoolWriter SmokeObjectId SmokeObject m, m [SmokeObject])
mkMockPoolInterfaces [SmokeObject]
objects)
 where
  runOutboundPeer :: ObjectDiffusionOutbound objectId object m a
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Tracer m TestName
-> m ()
runOutboundPeer ObjectDiffusionOutbound objectId object m a
outbound Channel m (AnyMessage (ObjectDiffusion objectId object))
outboundChannel Tracer m TestName
tracer =
    Tracer m (TraceSendRecv (ObjectDiffusion objectId object))
-> Codec
     (ObjectDiffusion objectId object)
     CodecFailure
     m
     (AnyMessage (ObjectDiffusion objectId object))
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StInit
     m
     a
-> m (a, Maybe (AnyMessage (ObjectDiffusion objectId object)))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadEvaluate m, MonadThrow m, Exception failure, NFData failure,
 NFData a) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> Peer ps pr 'NonPipelined st m a
-> m (a, Maybe bytes)
runPeer
      ((\TraceSendRecv (ObjectDiffusion objectId object)
x -> TestName
"Outbound (Server): " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TraceSendRecv (ObjectDiffusion objectId object) -> TestName
forall a. Show a => a -> TestName
show TraceSendRecv (ObjectDiffusion objectId object)
x) (TraceSendRecv (ObjectDiffusion objectId object) -> TestName)
-> Tracer m TestName
-> Tracer m (TraceSendRecv (ObjectDiffusion objectId object))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m TestName
tracer)
      Codec
  (ObjectDiffusion objectId object)
  CodecFailure
  m
  (AnyMessage (ObjectDiffusion objectId object))
forall objectId object (m :: * -> *).
Monad m =>
Codec
  (ObjectDiffusion objectId object)
  CodecFailure
  m
  (AnyMessage (ObjectDiffusion objectId object))
codecObjectDiffusionId
      Channel m (AnyMessage (ObjectDiffusion objectId object))
outboundChannel
      (ObjectDiffusionOutbound objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StInit
     m
     a
forall objectId object (m :: * -> *) a.
Monad m =>
ObjectDiffusionOutbound objectId object m a
-> Peer
     (ObjectDiffusion objectId object)
     'AsServer
     'NonPipelined
     'StInit
     m
     a
objectDiffusionOutboundPeer ObjectDiffusionOutbound objectId object m a
outbound)
      m (a, Maybe (AnyMessage (ObjectDiffusion objectId object)))
-> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  runInboundPeer :: ObjectDiffusionInboundPipelined objectId object m a
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Tracer m TestName
-> m ()
runInboundPeer ObjectDiffusionInboundPipelined objectId object m a
inbound Channel m (AnyMessage (ObjectDiffusion objectId object))
inboundChannel Tracer m TestName
tracer =
    Tracer m (TraceSendRecv (ObjectDiffusion objectId object))
-> Codec
     (ObjectDiffusion objectId object)
     CodecFailure
     m
     (AnyMessage (ObjectDiffusion objectId object))
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> PeerPipelined
     (ObjectDiffusion objectId object) 'AsClient 'StInit m a
-> m (a, Maybe (AnyMessage (ObjectDiffusion objectId object)))
forall ps (st :: ps) (pr :: PeerRole) failure bytes (m :: * -> *)
       a.
(MonadAsync m, MonadEvaluate m, MonadThrow m, Exception failure,
 NFData failure, NFData a) =>
Tracer m (TraceSendRecv ps)
-> Codec ps failure m bytes
-> Channel m bytes
-> PeerPipelined ps pr st m a
-> m (a, Maybe bytes)
runPipelinedPeer
      ((\TraceSendRecv (ObjectDiffusion objectId object)
x -> TestName
"Inbound (Client): " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TraceSendRecv (ObjectDiffusion objectId object) -> TestName
forall a. Show a => a -> TestName
show TraceSendRecv (ObjectDiffusion objectId object)
x) (TraceSendRecv (ObjectDiffusion objectId object) -> TestName)
-> Tracer m TestName
-> Tracer m (TraceSendRecv (ObjectDiffusion objectId object))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m TestName
tracer)
      Codec
  (ObjectDiffusion objectId object)
  CodecFailure
  m
  (AnyMessage (ObjectDiffusion objectId object))
forall objectId object (m :: * -> *).
Monad m =>
Codec
  (ObjectDiffusion objectId object)
  CodecFailure
  m
  (AnyMessage (ObjectDiffusion objectId object))
codecObjectDiffusionId
      Channel m (AnyMessage (ObjectDiffusion objectId object))
inboundChannel
      (ObjectDiffusionInboundPipelined objectId object m a
-> PeerPipelined
     (ObjectDiffusion objectId object) 'AsClient 'StInit m a
forall objectId object (m :: * -> *) a.
Functor m =>
ObjectDiffusionInboundPipelined objectId object m a
-> PeerPipelined
     (ObjectDiffusion objectId object) 'AsClient 'StInit m a
objectDiffusionInboundPeerPipelined ObjectDiffusionInboundPipelined objectId object m a
inbound)
      m (a, Maybe (AnyMessage (ObjectDiffusion objectId object)))
-> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion
prop_smoke_object_diffusion ::
  ( Eq object
  , Show object
  , Ord objectId
  , Typeable objectId
  , Typeable object
  , NoThunks objectId
  , Show objectId
  , NoThunks object
  ) =>
  ProtocolConstants ->
  [object] ->
  ( forall m.
    IOLike m =>
    ObjectDiffusionOutbound objectId object m () ->
    Channel m (AnyMessage (ObjectDiffusion objectId object)) ->
    (Tracer m String) ->
    m ()
  ) ->
  ( forall m.
    IOLike m =>
    ObjectDiffusionInboundPipelined objectId object m () ->
    (Channel m (AnyMessage (ObjectDiffusion objectId object))) ->
    (Tracer m String) ->
    m ()
  ) ->
  ( forall m.
    IOLike m =>
    m
      ( ObjectPoolReader objectId object ticketNo m
      , ObjectPoolWriter objectId object m
      , m [object]
      )
  ) ->
  Property
prop_smoke_object_diffusion :: forall object objectId ticketNo.
(Eq object, Show object, Ord objectId, Typeable objectId,
 Typeable object, NoThunks objectId, Show objectId,
 NoThunks object) =>
ProtocolConstants
-> [object]
-> (forall (m :: * -> *).
    IOLike m =>
    ObjectDiffusionOutbound objectId object m ()
    -> Channel m (AnyMessage (ObjectDiffusion objectId object))
    -> Tracer m TestName
    -> m ())
-> (forall (m :: * -> *).
    IOLike m =>
    ObjectDiffusionInboundPipelined objectId object m ()
    -> Channel m (AnyMessage (ObjectDiffusion objectId object))
    -> Tracer m TestName
    -> m ())
-> (forall (m :: * -> *).
    IOLike m =>
    m (ObjectPoolReader objectId object ticketNo m,
       ObjectPoolWriter objectId object m, m [object]))
-> Property
prop_smoke_object_diffusion
  (ProtocolConstants (NumObjectsUnacknowledged
maxFifoSize, NumObjectIdsReq
maxIdsToReq, NumObjectsReq
maxObjectsToReq))
  [object]
objects
  forall (m :: * -> *).
IOLike m =>
ObjectDiffusionOutbound objectId object m ()
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Tracer m TestName
-> m ()
runOutboundPeer
  forall (m :: * -> *).
IOLike m =>
ObjectDiffusionInboundPipelined objectId object m ()
-> Channel m (AnyMessage (ObjectDiffusion objectId object))
-> Tracer m TestName
-> m ()
runInboundPeer
  forall (m :: * -> *).
IOLike m =>
m (ObjectPoolReader objectId object ticketNo m,
   ObjectPoolWriter objectId object m, m [object])
mkPoolInterfaces =
    let
      simulationResult :: Either Failure [object]
simulationResult = (forall s. IOSim s [object]) -> Either Failure [object]
forall a. (forall s. IOSim s a) -> Either Failure a
runSimStrictShutdown ((forall s. IOSim s [object]) -> Either Failure [object])
-> (forall s. IOSim s [object]) -> Either Failure [object]
forall a b. (a -> b) -> a -> b
$ do
        let tracer :: Tracer (IOSim s) a
tracer = Tracer (IOSim s) a
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer

        Tracer (IOSim s) TestName -> TestName -> IOSim s ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer (IOSim s) TestName
forall {a}. Tracer (IOSim s) a
tracer TestName
"========== [ Starting ObjectDiffusion smoke test ] =========="
        Tracer (IOSim s) TestName -> TestName -> IOSim s ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer (IOSim s) TestName
forall {a}. Tracer (IOSim s) a
tracer ([object] -> TestName
forall a. Show a => a -> TestName
show [object]
objects)

        (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- IOSim
  s
  (ObjectPoolReader objectId object ticketNo (IOSim s),
   ObjectPoolWriter objectId object (IOSim s), IOSim s [object])
forall (m :: * -> *).
IOLike m =>
m (ObjectPoolReader objectId object ticketNo m,
   ObjectPoolWriter objectId object m, m [object])
mkPoolInterfaces
        controlMessage <- uncheckedNewTVarM Continue

        let
          inbound =
            Tracer (IOSim s) (TraceObjectDiffusionInbound objectId object)
-> (NumObjectsUnacknowledged, NumObjectIdsReq, NumObjectsReq)
-> ObjectPoolWriter objectId object (IOSim s)
-> NodeToNodeVersion
-> ControlMessageSTM (IOSim s)
-> ObjectDiffusionInboundPipelined objectId object (IOSim s) ()
forall objectId object (m :: * -> *).
(Ord objectId, Show objectId, Typeable objectId, Typeable object,
 NoThunks objectId, NoThunks object, MonadSTM m, MonadThrow m) =>
Tracer m (TraceObjectDiffusionInbound objectId object)
-> (NumObjectsUnacknowledged, NumObjectIdsReq, NumObjectsReq)
-> ObjectPoolWriter objectId object m
-> NodeToNodeVersion
-> ControlMessageSTM m
-> ObjectDiffusionInboundPipelined objectId object m ()
objectDiffusionInbound
              Tracer (IOSim s) (TraceObjectDiffusionInbound objectId object)
forall {a}. Tracer (IOSim s) a
tracer
              ( NumObjectsUnacknowledged
maxFifoSize
              , NumObjectIdsReq
maxIdsToReq
              , NumObjectsReq
maxObjectsToReq
              )
              ObjectPoolWriter objectId object (IOSim s)
inboundPoolWriter
              NodeToNodeVersion
nodeToNodeVersion
              (StrictTVar (IOSim s) ControlMessage -> ControlMessageSTM (IOSim s)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar (IOSim s) ControlMessage
controlMessage)

          outbound =
            Tracer (IOSim s) (TraceObjectDiffusionOutbound objectId object)
-> NumObjectsUnacknowledged
-> ObjectPoolReader objectId object ticketNo (IOSim s)
-> NodeToNodeVersion
-> ObjectDiffusionOutbound objectId object (IOSim s) ()
forall objectId object ticketNo (m :: * -> *).
(Ord objectId, MonadSTM m, MonadThrow m) =>
Tracer m (TraceObjectDiffusionOutbound objectId object)
-> NumObjectsUnacknowledged
-> ObjectPoolReader objectId object ticketNo m
-> NodeToNodeVersion
-> ObjectDiffusionOutbound objectId object m ()
objectDiffusionOutbound
              Tracer (IOSim s) (TraceObjectDiffusionOutbound objectId object)
forall {a}. Tracer (IOSim s) a
tracer
              NumObjectsUnacknowledged
maxFifoSize
              ObjectPoolReader objectId object ticketNo (IOSim s)
outboundPoolReader
              NodeToNodeVersion
nodeToNodeVersion

        withRegistry $ \ResourceRegistry (IOSim s)
reg -> do
          (outboundChannel, inboundChannel) <- IOSim
  s
  (Channel (IOSim s) (AnyMessage (ObjectDiffusion objectId object)),
   Channel (IOSim s) (AnyMessage (ObjectDiffusion objectId object)))
forall (m :: * -> *) a.
(MonadLabelledSTM m, MonadTraceSTM m, Show a) =>
m (Channel m a, Channel m a)
createConnectedChannels
          outboundThread <-
            forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $
              runOutboundPeer outbound outboundChannel tracer
          inboundThread <-
            forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $
              runInboundPeer inbound inboundChannel tracer
          controlMessageThread <- forkLinkedThread reg "ObjectDiffusion Control thread" $ do
            threadDelay 1000 -- give a head start to the other threads
            atomically $ writeTVar controlMessage Terminate
            threadDelay 1000 -- wait for the other threads to finish

          -- 'outboundThread' and 'inputThread' will run indefinitely, at least
          -- until we send the 'Terminate' control message through the
          -- 'controlMessageThread'.
          -- \* If 'inputThread' supports graceful termination, it will react to
          -- the 'Terminate' message in a timely manner, send 'MsgDone' to the
          -- 'outboundThread', and both threads should terminate shortly after
          -- (before the expiration of the second 'threadDelay' in
          -- 'controlMessageThread').
          -- \* If 'inputThread' does not support graceful termination (which is
          -- the case in the initial Peras implementation), it will probably be
          -- stuck waiting for a response to a blocking `ReqIds` request when no
          -- new data is available on the 'outboundThread' side. So the
          -- 'Terminate' message will have no effect, and 'controlMessageThread'
          -- will actually be the first thread to finish (with the expiration of
          -- the second 'threadDelay') after which we will finish the test by
          -- comparing received data.
          -- But this isn't really an issue, because the 'inputThread' blocks on
          -- `ReqIds` only when it is caught-up, i.e. when all possible data has
          -- already been transferred from the 'outboundThread'. So even without
          -- graceful termination, the test should still work as intended.
          waitAnyThread [outboundThread, inboundThread, controlMessageThread]

        traceWith tracer "========== [ ObjectDiffusion smoke test finished ] =========="
        poolContent <- getAllInboundPoolContent

        traceWith tracer "inboundPoolContent:"
        traceWith tracer (show poolContent)
        traceWith tracer "========== ======================================= =========="
        pure poolContent
     in
      case Either Failure [object]
simulationResult of
        Right [object]
inboundPoolContent -> [object]
inboundPoolContent [object] -> [object] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [object]
objects
        Left Failure
msg -> TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Failure -> TestName
forall a. Show a => a -> TestName
show Failure
msg) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False