Generate protocol parameters randomly

Author: Niols

ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/PerasCert/Smoke.hs

@@ -33,6 +33,7 @@ import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
 import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound (objectDiffusionOutboundClientPeer)
 import Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
   ( ListWithUniqueIds (..)
+  , ProtocolConstants
   , WithId
   , getId
   , prop_smoke_object_diffusion
@@ -85,9 +86,9 @@ newCertDB certs = do
     certs
   pure db
 
-prop_smoke :: ListWithUniqueIds (PerasCert TestBlock) PerasRoundNo -> Property
-prop_smoke (ListWithUniqueIds certs) =
-  prop_smoke_object_diffusion certs runOutboundPeer runInboundPeer mkPoolInterfaces
+prop_smoke :: ProtocolConstants -> ListWithUniqueIds (PerasCert TestBlock) PerasRoundNo -> Property
+prop_smoke protocolConstants (ListWithUniqueIds certs) =
+  prop_smoke_object_diffusion protocolConstants certs runOutboundPeer runInboundPeer mkPoolInterfaces
  where
   runOutboundPeer outbound outboundChannel tracer =
     runPeer

ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 -- | 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
@@ -14,6 +15,7 @@ module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
   ( tests
   , WithId (..)
   , ListWithUniqueIds (..)
+  , ProtocolConstants
   , prop_smoke_object_diffusion
   ) where
 
@@ -164,21 +166,30 @@ mkMockPoolInterfaces objects = do
 
 -- Protocol constants
 
-maxFifoSize :: NumObjectsOutstanding
-maxFifoSize = NumObjectsOutstanding 10
-
-maxIdsToReq :: NumObjectIdsReq
-maxIdsToReq = NumObjectIdsReq 3
-
-maxObjectsToReq :: NumObjectsReq
-maxObjectsToReq = NumObjectsReq 2
+newtype ProtocolConstants
+  = ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq)
+  deriving (Show)
+
+instance Arbitrary ProtocolConstants
+  -- REVIEW: not sure about those constraints at all, and don't have the
+  -- brainspace right now to reason about them
+  arbitrary = do
+    maxFifoSize <- choose (5, 20)
+    maxIdsToReq <- choose (3, maxFifoSize)
+    maxObjectsToReq <- choose (2, maxIdsToReq)
+    pure $
+      ProtocolConstants
+        ( NumObjectsOutstanding maxFifoSize,
+          NumObjectIdsReq maxIdsToReq,
+          NumObjectsReq maxObjectsToReq
+        )
 
 nodeToNodeVersion :: NodeToNodeVersion
 nodeToNodeVersion = NodeToNodeV_14
 
-prop_smoke_init_inbound :: ListWithUniqueIds SmokeObject idTy -> Property
-prop_smoke_init_inbound (ListWithUniqueIds objects) =
-  prop_smoke_object_diffusion objects runOutboundPeer runInboundPeer (mkMockPoolInterfaces objects)
+prop_smoke_init_inbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property
+prop_smoke_init_inbound protocolConstants (ListWithUniqueIds objects) =
+  prop_smoke_object_diffusion protocolConstants objects runOutboundPeer runInboundPeer (mkMockPoolInterfaces objects)
  where
   runOutboundPeer outbound outboundChannel tracer =
     runPeer
@@ -196,9 +207,9 @@ prop_smoke_init_inbound (ListWithUniqueIds objects) =
       (objectDiffusionInboundClientPeerPipelined inbound)
       >> pure ()
 
-prop_smoke_init_outbound :: ListWithUniqueIds SmokeObject SmokeObjectId -> Property
-prop_smoke_init_outbound (ListWithUniqueIds objects) =
-  prop_smoke_object_diffusion objects runOutboundPeer runInboundPeer (mkMockPoolInterfaces objects)
+prop_smoke_init_outbound :: ProtocolConstants -> ListWithUniqueIds SmokeObject SmokeObjectId -> Property
+prop_smoke_init_outbound protocolConstants (ListWithUniqueIds objects) =
+  prop_smoke_object_diffusion protocolConstants objects runOutboundPeer runInboundPeer (mkMockPoolInterfaces objects)
  where
   runOutboundPeer outbound outboundChannel tracer =
     runPeer
@@ -226,6 +237,7 @@ prop_smoke_object_diffusion ::
   , NoThunks object
   , Ord ticketNo
   ) =>
+  ProtocolConstants ->
   [object] ->
   ( forall m.
     IOLike m =>
@@ -250,7 +262,10 @@ prop_smoke_object_diffusion ::
       )
   ) ->
   Property
-prop_smoke_object_diffusion objects runOutboundPeer runInboundPeer mkPoolInterfaces =
+prop_smoke_object_diffusion
+  (ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq))
+  objects runOutboundPeer runInboundPeer mkPoolInterfaces
+  =
   let
     simulationResult = runSimStrictShutdown $ do
       let tracer = nullTracer