module Test.Consensus.MiniProtocol.ObjectDiffusion.PerasVote.Smoke ( tests ) where import Control.Monad (join) import Control.Tracer (contramap, nullTracer) import qualified Data.Map as Map import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer) import Ouroboros.Consensus.Block.SupportsPeras import Ouroboros.Consensus.BlockchainTime.WallClock.Types ( WithArrivalTime (..) , forgetArrivalTime ) import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.PerasVote import Ouroboros.Consensus.Peras.Context ( PerasEpochContextResolverHandle , mockPerasEpochContextResolverHandle ) import Ouroboros.Consensus.Storage.PerasVoteDB ( AddPerasVoteResult (..) , PerasVoteDB , PerasVoteTicketNo , zeroPerasVoteTicketNo ) import qualified Ouroboros.Consensus.Storage.PerasVoteDB as PerasVoteDB import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.Protocol.ObjectDiffusion.Codec import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound ( objectDiffusionInboundPeerPipelined ) import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundPeer) import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke ( genProtocolConstants , prop_smoke_object_diffusion ) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck (testProperty) import Test.Util.Peras import Test.Util.TestBlock tests :: TestTree tests :: TestTree tests = TestName -> [TestTree] -> TestTree testGroup TestName "ObjectDiffusion.PerasVote.Smoke" [ TestName -> Property -> TestTree forall a. Testable a => TestName -> a -> TestTree testProperty TestName "PerasVoteDiffusion smoke test" Property prop_smoke ] newVoteDB :: ( IOLike m , BlockSupportsPeras blk ) => PerasEpochContextResolverHandle m blk -> [WithArrivalTime (ValidatedPerasVote blk)] -> m (PerasVoteDB m blk) newVoteDB :: forall (m :: * -> *) blk. (IOLike m, BlockSupportsPeras blk) => PerasEpochContextResolverHandle m blk -> [WithArrivalTime (ValidatedPerasVote blk)] -> m (PerasVoteDB m blk) newVoteDB PerasEpochContextResolverHandle m blk resolverHandle [WithArrivalTime (ValidatedPerasVote blk)] votes = do let args :: PerasVoteDbArgs f m blk args = Tracer m (TraceEvent blk) -> PerasVoteDbArgs f m blk forall (f :: * -> *) (m :: * -> *) blk. Tracer m (TraceEvent blk) -> PerasVoteDbArgs f m blk PerasVoteDB.PerasVoteDbArgs Tracer m (TraceEvent blk) forall (m :: * -> *) a. Monad m => Tracer m a nullTracer db <- Complete PerasVoteDbArgs m blk -> PerasEpochContextResolverHandle m blk -> m (PerasVoteDB m blk) forall (m :: * -> *) blk. (IOLike m, BlockSupportsPeras blk) => Complete PerasVoteDbArgs m blk -> PerasEpochContextResolverHandle m blk -> m (PerasVoteDB m blk) PerasVoteDB.createDB Complete PerasVoteDbArgs m blk forall {f :: * -> *} {blk}. PerasVoteDbArgs f m blk args PerasEpochContextResolverHandle m blk resolverHandle mapM_ ( \WithArrivalTime (ValidatedPerasVote blk) vote -> do result <- m (m (AddPerasVoteResult blk)) -> m (AddPerasVoteResult blk) forall (m :: * -> *) a. Monad m => m (m a) -> m a join (m (m (AddPerasVoteResult blk)) -> m (AddPerasVoteResult blk)) -> m (m (AddPerasVoteResult blk)) -> m (AddPerasVoteResult blk) forall a b. (a -> b) -> a -> b $ STM m (m (AddPerasVoteResult blk)) -> m (m (AddPerasVoteResult blk)) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (m (AddPerasVoteResult blk)) -> m (m (AddPerasVoteResult blk))) -> STM m (m (AddPerasVoteResult blk)) -> m (m (AddPerasVoteResult blk)) forall a b. (a -> b) -> a -> b $ PerasVoteDB m blk -> WithArrivalTime (ValidatedPerasVote blk) -> STM m (m (AddPerasVoteResult blk)) forall (m :: * -> *) blk. PerasVoteDB m blk -> WithArrivalTime (ValidatedPerasVote blk) -> STM m (m (AddPerasVoteResult blk)) PerasVoteDB.addVote PerasVoteDB m blk db WithArrivalTime (ValidatedPerasVote blk) vote case result of AddPerasVoteResult blk PerasVoteAlreadyInDB -> IOException -> m () forall e a. Exception e => e -> m a forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a throwIO (TestName -> IOException userError TestName "Expected AddedPerasVote..., but vote was already in DB") AddPerasVoteResult blk AddedPerasVoteButDidntGenerateNewCert -> () -> m () forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure () AddedPerasVoteAndGeneratedNewCert ValidatedPerasCert blk _ -> () -> m () forall a. a -> m a forall (f :: * -> *) a. Applicative f => a -> f a pure () ) votes pure db 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 (PerasEpochContext TestBlock) -> (PerasEpochContext TestBlock -> Property) -> Property forall a prop. (Show a, Testable prop) => Gen a -> (a -> prop) -> Property forAll Gen (PerasEpochContext TestBlock) genMockPerasEpochContext ((PerasEpochContext TestBlock -> Property) -> Property) -> (PerasEpochContext TestBlock -> Property) -> Property forall a b. (a -> b) -> a -> b $ \PerasEpochContext TestBlock epochContext -> Gen (ListWithUniqueIds (WithArrivalTime (ValidatedPerasVote TestBlock))) -> (ListWithUniqueIds (WithArrivalTime (ValidatedPerasVote TestBlock)) -> Property) -> Property forall a prop. (Show a, Testable prop) => Gen a -> (a -> prop) -> Property forAll ((WithArrivalTime (ValidatedPerasVote TestBlock) -> PerasRoundNo) -> Gen (WithArrivalTime (ValidatedPerasVote TestBlock)) -> Gen (ListWithUniqueIds (WithArrivalTime (ValidatedPerasVote TestBlock))) forall idTy a. Ord idTy => (a -> idTy) -> Gen a -> Gen (ListWithUniqueIds a) genListWithUniqueIds WithArrivalTime (ValidatedPerasVote TestBlock) -> PerasRoundNo forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo getPerasVoteRound (Gen (ValidatedPerasVote TestBlock) -> Gen (WithArrivalTime (ValidatedPerasVote TestBlock)) forall a. Gen a -> Gen (WithArrivalTime a) genWithArrivalTime (PerasEpochContext TestBlock -> Gen (ValidatedPerasVote TestBlock) genMockValidatedPerasVote PerasEpochContext TestBlock epochContext))) ((ListWithUniqueIds (WithArrivalTime (ValidatedPerasVote TestBlock)) -> Property) -> Property) -> (ListWithUniqueIds (WithArrivalTime (ValidatedPerasVote TestBlock)) -> Property) -> Property forall a b. (a -> b) -> a -> b $ \(ListWithUniqueIds [WithArrivalTime (ValidatedPerasVote TestBlock)] watValidatedVotes) -> let mkPoolInterfaces :: IOLike m => m ( ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m , ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m , m [PerasVote TestBlock] ) mkPoolInterfaces :: forall (m :: * -> *). IOLike m => m (ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m, ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m, m [PerasVote TestBlock]) mkPoolInterfaces = do epochContextResolverHandle <- PerasEpochContext TestBlock -> m (PerasEpochContextResolverHandle m TestBlock) forall (m :: * -> *) blk. (IOLike m, NoThunks (PerasEpochContext blk)) => PerasEpochContext blk -> m (PerasEpochContextResolverHandle m blk) mockPerasEpochContextResolverHandle PerasEpochContext TestBlock epochContext outboundPool <- newVoteDB epochContextResolverHandle watValidatedVotes inboundPool <- newVoteDB epochContextResolverHandle [] let outboundPoolReader = PerasVoteDB m TestBlock -> ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m forall (m :: * -> *) blk. (IOLike m, IsPerasVote (PerasVote blk) blk) => PerasVoteDB m blk -> ObjectPoolReader PerasVoteId (PerasVote blk) PerasVoteTicketNo m makeTestPerasVotePoolReaderFromVoteDB PerasVoteDB m TestBlock outboundPool inboundPoolWriter = SystemTime m -> PerasVoteDB m TestBlock -> PerasEpochContextResolverHandle m TestBlock -> ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m forall (m :: * -> *) blk. (IOLike m, BlockSupportsPeras blk) => SystemTime m -> PerasVoteDB m blk -> PerasEpochContextResolverHandle m blk -> ObjectPoolWriter PerasVoteId (PerasVote blk) m makeTestPerasVotePoolWriterFromVoteDB SystemTime m forall (m :: * -> *). Applicative m => SystemTime m mockSystemTime PerasVoteDB m TestBlock inboundPool PerasEpochContextResolverHandle m TestBlock epochContextResolverHandle getAllInboundPoolContent = do votesMap <- STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock))) -> m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock))) forall a. HasCallStack => STM m a -> m a forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock))) -> m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock)))) -> STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock))) -> m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock))) forall a b. (a -> b) -> a -> b $ PerasVoteDB m TestBlock -> PerasVoteTicketNo -> STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote TestBlock))) forall (m :: * -> *) blk. PerasVoteDB m blk -> PerasVoteTicketNo -> STM m (Map PerasVoteTicketNo (WithArrivalTime (ValidatedPerasVote blk))) PerasVoteDB.getVotesAfter PerasVoteDB m TestBlock inboundPool PerasVoteTicketNo zeroPerasVoteTicketNo pure $ vpvVote . forgetArrivalTime <$> Map.elems votesMap return (outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) in ProtocolConstants -> [MockPerasVote TestBlock] -> (forall (m :: * -> *). IOLike m => ObjectDiffusionOutbound PerasVoteId (MockPerasVote TestBlock) m () -> Channel m (AnyMessage (ObjectDiffusion PerasVoteId (MockPerasVote TestBlock))) -> Tracer m TestName -> m ()) -> (forall (m :: * -> *). IOLike m => ObjectDiffusionInboundPipelined PerasVoteId (MockPerasVote TestBlock) m () -> Channel m (AnyMessage (ObjectDiffusion PerasVoteId (MockPerasVote TestBlock))) -> Tracer m TestName -> m ()) -> (forall (m :: * -> *). IOLike m => m (ObjectPoolReader PerasVoteId (MockPerasVote TestBlock) PerasVoteTicketNo m, ObjectPoolWriter PerasVoteId (MockPerasVote TestBlock) m, m [MockPerasVote TestBlock])) -> 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 ((WithArrivalTime (ValidatedPerasVote TestBlock) -> MockPerasVote TestBlock) -> [WithArrivalTime (ValidatedPerasVote TestBlock)] -> [MockPerasVote TestBlock] forall a b. (a -> b) -> [a] -> [b] map (ValidatedPerasVote TestBlock -> PerasVote TestBlock ValidatedPerasVote TestBlock -> MockPerasVote TestBlock forall blk. ValidatedPerasVote blk -> PerasVote blk vpvVote (ValidatedPerasVote TestBlock -> MockPerasVote TestBlock) -> (WithArrivalTime (ValidatedPerasVote TestBlock) -> ValidatedPerasVote TestBlock) -> WithArrivalTime (ValidatedPerasVote TestBlock) -> MockPerasVote TestBlock forall b c a. (b -> c) -> (a -> b) -> a -> c . WithArrivalTime (ValidatedPerasVote TestBlock) -> ValidatedPerasVote TestBlock forall a. WithArrivalTime a -> a forgetArrivalTime) [WithArrivalTime (ValidatedPerasVote TestBlock)] watValidatedVotes) ObjectDiffusionOutbound PerasVoteId (MockPerasVote TestBlock) m () -> Channel m (AnyMessage (ObjectDiffusion PerasVoteId (MockPerasVote TestBlock))) -> Tracer m TestName -> m () forall (m :: * -> *). IOLike m => ObjectDiffusionOutbound PerasVoteId (MockPerasVote TestBlock) m () -> Channel m (AnyMessage (ObjectDiffusion PerasVoteId (MockPerasVote TestBlock))) -> 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 PerasVoteId (MockPerasVote TestBlock) m () -> Channel m (AnyMessage (ObjectDiffusion PerasVoteId (MockPerasVote TestBlock))) -> Tracer m TestName -> m () forall (m :: * -> *). IOLike m => ObjectDiffusionInboundPipelined PerasVoteId (MockPerasVote TestBlock) m () -> Channel m (AnyMessage (ObjectDiffusion PerasVoteId (MockPerasVote TestBlock))) -> 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 m (ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m, ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m, m [PerasVote TestBlock]) m (ObjectPoolReader PerasVoteId (MockPerasVote TestBlock) PerasVoteTicketNo m, ObjectPoolWriter PerasVoteId (MockPerasVote TestBlock) m, m [MockPerasVote TestBlock]) forall (m :: * -> *). IOLike m => m (ObjectPoolReader PerasVoteId (PerasVote TestBlock) PerasVoteTicketNo m, ObjectPoolWriter PerasVoteId (PerasVote TestBlock) m, m [PerasVote TestBlock]) forall (m :: * -> *). IOLike m => m (ObjectPoolReader PerasVoteId (MockPerasVote TestBlock) PerasVoteTicketNo m, ObjectPoolWriter PerasVoteId (MockPerasVote TestBlock) m, m [MockPerasVote TestBlock]) mkPoolInterfaces 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 (Client): " TestName -> TestName -> TestName 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 (Server): " TestName -> TestName -> TestName 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 ()