Added diffusion multinode sim

ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs

@@ -124,12 +124,10 @@ import           Ouroboros.Network.Testing.Data.AbsBearerInfo
 import           Ouroboros.Network.Testing.Utils (genDelayWithPrecision)
 
 import           Test.Ouroboros.Network.ConnectionManager
-                     (verifyAbstractTransition)
+                     (allValidTransitionsNames, validTransitionMap,
+                     verifyAbstractTransition)
 import           Test.Ouroboros.Network.Orphans ()
 import           Test.Simulation.Network.Snocket hiding (tests)
-import           Test.Ouroboros.Network.ConnectionManager
-                   (validTransitionMap,
-                    allValidTransitionsNames)
 
 tests :: TestTree
 tests =

ouroboros-network/ouroboros-network.cabal

@@ -310,6 +310,8 @@ test-suite test
                        Test.Ouroboros.Network.PeerSelection.PeerGraph
                        Test.Ouroboros.Network.NodeToNode.Version
                        Test.Ouroboros.Network.NodeToClient.Version
+                       Test.Ouroboros.Network.Testnet
+                       Test.Ouroboros.Network.Testnet.Simulation.Node
                        Test.Mux
                        Test.Pipe
                        Test.Socket

ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs

@@ -36,8 +36,8 @@ module Ouroboros.Network.Diffusion.P2P
 
 
 import           Control.Exception (IOException)
-import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadAsync (Async, MonadAsync)
+import qualified Control.Monad.Class.MonadAsync as Async
 import           Control.Monad.Class.MonadFork
 import           Control.Monad.Class.MonadSTM.Strict
 import           Control.Monad.Class.MonadThrow

ouroboros-network/test/Main.hs

@@ -28,6 +28,7 @@ import qualified Test.Ouroboros.Network.PeerSelection.Json (tests)
 import qualified Test.Ouroboros.Network.PeerSelection.LocalRootPeers
 import qualified Test.Ouroboros.Network.PeerSelection.MockEnvironment
 import qualified Test.Ouroboros.Network.PeerSelection.RootPeersDNS
+import qualified Test.Ouroboros.Network.Testnet (tests)
 import qualified Test.Ouroboros.Network.TxSubmission (tests)
 import qualified Test.PeerState (tests)
 import qualified Test.Pipe (tests)
@@ -74,6 +75,7 @@ tests =
   , Test.Ouroboros.Network.TxSubmission.tests
   , Test.Ouroboros.Network.NodeToNode.Version.tests
   , Test.Ouroboros.Network.NodeToClient.Version.tests
+  , Test.Ouroboros.Network.Testnet.tests
   , Test.LedgerPeers.tests
   , Test.Ouroboros.Network.Diffusion.Policies.tests
 

ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE UndecidableInstances  #-}
 
 module Test.Ouroboros.Network.Diffusion.Node
   ( -- * run a node
@@ -27,16 +29,19 @@ module Test.Ouroboros.Network.Diffusion.Node
   ) where
 
 import           Control.Monad.Class.MonadAsync
-import           Control.Monad.Class.MonadFork
-import           Control.Monad.Class.MonadST
+                     (MonadAsync (Async, wait, withAsync))
+import           Control.Monad.Class.MonadFork (MonadFork)
+import           Control.Monad.Class.MonadST (MonadST)
 import qualified Control.Monad.Class.MonadSTM as LazySTM
-import           Control.Monad.Class.MonadSTM.Strict
-import           Control.Monad.Class.MonadThrow
-import           Control.Monad.Class.MonadTime
-import           Control.Monad.Class.MonadTimer
+import           Control.Monad.Class.MonadSTM.Strict (MonadLabelledSTM,
+                     MonadSTM (STM, atomically), newTVar)
+import           Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask,
+                     MonadThrow, SomeException)
+import           Control.Monad.Class.MonadTime (DiffTime, MonadTime)
+import           Control.Monad.Class.MonadTimer (MonadTimer)
 import           Control.Tracer (nullTracer)
 
-import           Data.IP (IP)
+import           Data.IP (IP (..))
 import qualified Data.IntPSQ as IntPSQ
 import           Data.Map (Map)
 import           Data.Set (Set)
@@ -65,18 +70,22 @@ import           Ouroboros.Network.PeerSelection.RootPeersDNS
 import           Ouroboros.Network.PeerSelection.Types (PeerAdvertise (..))
 import           Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..))
 import           Ouroboros.Network.Protocol.Handshake.Codec
+                     (VersionDataCodec (..), noTimeLimitsHandshake,
+                     timeLimitsHandshake)
 import           Ouroboros.Network.Protocol.Handshake.Unversioned
+                     (unversionedHandshakeCodec, unversionedProtocolDataCodec)
 import           Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept))
-import           Ouroboros.Network.RethrowPolicy
+import           Ouroboros.Network.RethrowPolicy (ErrorCommand (ShutdownNode),
+                     ioErrorRethrowPolicy, mkRethrowPolicy,
+                     muxErrorRethrowPolicy)
 import           Ouroboros.Network.Server.RateLimiting
                      (AcceptedConnectionsLimit (..))
 import           Ouroboros.Network.Snocket (FileDescriptor (..), Snocket,
                      TestAddress (..))
 
 import           Ouroboros.Network.Testing.ConcreteBlock (Block)
-import qualified Ouroboros.Network.Testing.Data.Script as Script
-
-import           Simulation.Network.Snocket
+import           Ouroboros.Network.Testing.Data.Script (Script (..))
+import           Simulation.Network.Snocket (AddressType (IPv4Address), FD)
 
 import qualified Test.Ouroboros.Network.Diffusion.Node.MiniProtocols as Node
 import           Test.Ouroboros.Network.Diffusion.Node.NodeKernel (NtCAddr,
@@ -91,7 +100,7 @@ data Interfaces m = Interfaces
     { iNtnSnocket        :: Snocket m (NtNFD m) NtNAddr
     , iAcceptVersion     :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData
     , iNtnDomainResolver :: LookupReqs -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr))
-    , iNtcSnocket        :: Snocket m (NtCFD m) (NtCAddr)
+    , iNtcSnocket        :: Snocket m (NtCFD m) NtCAddr
     , iRng               :: StdGen
     , iDomainMap         :: Map Domain [IP]
     , iLedgerPeersConsensusInterface
@@ -102,8 +111,7 @@ type NtNFD m = FD m NtNAddr
 type NtCFD m = FD m NtCAddr
 
 data Arguments m = Arguments
-    { aIPv4Address          :: NtNAddr
-    , aIPv6Address          :: NtNAddr
+    { aIPAddress            :: NtNAddr
     , aAcceptedLimits       :: AcceptedConnectionsLimit
     , aDiffusionMode        :: DiffusionMode
     , aKeepAliveInterval    :: DiffTime
@@ -115,16 +123,16 @@ data Arguments m = Arguments
     , aReadUseLedgerAfter   :: STM m UseLedgerAfter
     , aProtocolIdleTimeout  :: DiffTime
     , aTimeWaitTimeout      :: DiffTime
-    , aDNSTimeoutScript     :: Script.Script DNSTimeout
-    , aDNSLookupDelayScript :: Script.Script DNSLookupDelay
+    , aDNSTimeoutScript     :: Script DNSTimeout
+    , aDNSLookupDelayScript :: Script DNSLookupDelay
     }
 
 -- The 'mockDNSActions' is not using \/ specifying 'resolverException', thus we
 -- set it to 'SomeException'.
 --
 type ResolverException = SomeException
 
-run :: forall s resolver m.
+run :: forall resolver m.
        ( MonadAsync       m
        , MonadEvaluate    m
        , MonadFork        m
@@ -140,7 +148,7 @@ run :: forall s resolver m.
        , forall a. Semigroup a => Semigroup (m a)
        , Eq (Async m Void)
        )
-    => Node.BlockGeneratorArgs Block s
+    => Node.BlockGeneratorArgs Block StdGen
     -> Node.LimitsAndTimeouts Block
     -> Interfaces m
     -> Arguments m
@@ -187,10 +195,10 @@ run blockGeneratorArgs limits ni na =
               , Diff.P2P.diNtcGetFileDescriptor  = \_ -> pure (FileDescriptor (-1))
               , Diff.P2P.diRng                   = diffStgGen
               , Diff.P2P.diInstallSigUSR1Handler = \_ -> pure ()
-              , Diff.P2P.diDnsActions            = (const (mockDNSActions
+              , Diff.P2P.diDnsActions            = const (mockDNSActions
                                                      (iDomainMap ni)
                                                      dnsTimeoutScriptVar
-                                                     dnsLookupDelayScriptVar))
+                                                     dnsLookupDelayScriptVar)
               }
 
             tracersExtra :: Diff.P2P.TracersExtra NtNAddr NtNVersion NtNVersionData
@@ -243,8 +251,8 @@ run blockGeneratorArgs limits ni na =
 
     args :: Diff.Arguments (NtNFD m) NtNAddr (NtCFD m) NtCAddr
     args = Diff.Arguments
-      { Diff.daIPv4Address   = Just . Right . aIPv4Address $ na
-      , Diff.daIPv6Address   = Just . Right . aIPv6Address $ na
+      { Diff.daIPv4Address   = Right <$> (ntnToIPv4 . aIPAddress) na
+      , Diff.daIPv6Address   = Right <$> (ntnToIPv6 . aIPAddress) na
       , Diff.daLocalAddress  = Nothing
       , Diff.daAcceptedConnectionsLimit
                              = aAcceptedLimits na
@@ -270,3 +278,13 @@ run blockGeneratorArgs limits ni na =
       , Node.aaKeepAliveInterval        = aKeepAliveInterval na
       , Node.aaPingPongInterval         = aPingPongInterval na
       }
+
+--- Utils
+
+ntnToIPv4 :: NtNAddr -> Maybe NtNAddr
+ntnToIPv4 ntnAddr@(TestAddress (Node.IPAddr (IPv4 _) _)) = Just ntnAddr
+ntnToIPv4 (TestAddress _)                                = Nothing
+
+ntnToIPv6 :: NtNAddr -> Maybe NtNAddr
+ntnToIPv6 ntnAddr@(TestAddress (Node.IPAddr (IPv6 _) _)) = Just ntnAddr
+ntnToIPv6 (TestAddress _)                                = Nothing

ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs

@@ -25,7 +25,7 @@ module Test.Ouroboros.Network.Diffusion.Node.NodeKernel
   , NodeKernelError (..)
   ) where
 
-import           Control.Monad (when)
+import           Control.Monad (replicateM, when)
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadSTM.Strict
 import           Control.Monad.Class.MonadThrow
@@ -63,6 +63,9 @@ import qualified Ouroboros.Network.Testing.ConcreteBlock as ConcreteBlock
 import           Simulation.Network.Snocket (AddressType (..),
                      GlobalAddressScheme (..))
 
+import           Data.IP (IP (..), toIPv4, toIPv6)
+import           Test.QuickCheck (Arbitrary (..), choose, chooseInt, oneof)
+
 
 -- | Node-to-node address type.
 --
@@ -72,6 +75,18 @@ data NtNAddr_
   | IPAddr IP.IP PortNumber
   deriving (Eq, Ord)
 
+instance Arbitrary NtNAddr_ where
+  arbitrary = do
+    -- TODO: Move this IP generator to ouroboros-network-testing
+    a <- oneof [ IPv6 . toIPv6 <$> replicateM 8 (choose (0,0xffff))
+               , IPv4 . toIPv4 <$> replicateM 4 (choose (0,255))
+               ]
+    oneof
+      [ EphemeralIPv4Addr <$> (fromInteger <$> arbitrary)
+      , EphemeralIPv6Addr <$> (fromInteger <$> arbitrary)
+      , IPAddr a          <$> (read . show <$> chooseInt (0, 9999))
+      ]
+
 instance Show NtNAddr_ where
     show (EphemeralIPv4Addr n) = "ephemeral:" ++ show n
     show (EphemeralIPv6Addr n) = "ephemeral6:" ++ show n

ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE RankNTypes #-}
+module Test.Ouroboros.Network.Testnet (tests) where
+
+import           Control.Monad.IOSim
+
+import           Data.List (intercalate)
+import           Data.Void (Void)
+
+import           Ouroboros.Network.Testing.Data.AbsBearerInfo
+                     (AbsBearerInfo (..), attenuation, delay, toSduSize)
+import           Simulation.Network.Snocket (BearerInfo (..))
+
+import           Test.Ouroboros.Network.Testnet.Simulation.Node
+                     (DiffusionScript, diffusion_simulation)
+
+import           Test.QuickCheck (Property, counterexample)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck (testProperty)
+
+tests :: TestTree
+tests =
+  testGroup "Ouroboros.Network.Testnet"
+  [ testGroup "multinodeSim"
+    [ testProperty "test"
+                   test
+    ]
+  ]
+
+test :: AbsBearerInfo
+     -> DiffusionScript
+     -> Property
+test defaultBearerInfo dmnScript =
+    let trace = traceEvents
+              $ runSimTrace sim
+     in counterexample (intercalate "\n"
+                       $ map show
+                       $ take 1000 trace)
+                       True
+  where
+    sim :: forall s . IOSim s Void
+    sim = diffusion_simulation (toBearerInfo defaultBearerInfo) dmnScript
+
+toBearerInfo :: AbsBearerInfo -> BearerInfo
+toBearerInfo abi =
+    BearerInfo {
+        biConnectionDelay      = delay (abiConnectionDelay abi),
+        biInboundAttenuation   = attenuation (abiInboundAttenuation abi),
+        biOutboundAttenuation  = attenuation (abiOutboundAttenuation abi),
+        biInboundWriteFailure  = abiInboundWriteFailure abi,
+        biOutboundWriteFailure = abiOutboundWriteFailure abi,
+        biAcceptFailures       = Nothing, -- TODO
+        biSDUSize              = toSduSize (abiSDUSize abi)
+      }
+
+
+