Merge pull request #5062 from IntersectMBO/coot/versions

coot/versions
IntersectMBO · Feb 4, 2025 · 1429be7 · 1429be7
2 parents 5433d5a + 52ef0fa
commit 1429be7
Show file tree

Hide file tree

Showing 16 changed files with 138 additions and 63 deletions.
diff --git a/cardano-client/cardano-client.cabal b/cardano-client/cardano-client.cabal
@@ -29,7 +29,7 @@ library
     network-mux ^>=0.6,
     ouroboros-network ^>=0.19,
     ouroboros-network-api ^>=0.12,
-    ouroboros-network-framework ^>=0.15,
+    ouroboros-network-framework ^>=0.15 || ^>=0.16,
     si-timers,
 
   ghc-options:

diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerSharing.hs
@@ -28,7 +28,7 @@ instance Semigroup PeerSharing where
   (<>) :: PeerSharing -> PeerSharing -> PeerSharing
   PeerSharingDisabled <> _                   = PeerSharingDisabled
   _                   <> PeerSharingDisabled = PeerSharingDisabled
-  _                   <> _                   = PeerSharingEnabled
+  PeerSharingEnabled  <> PeerSharingEnabled  = PeerSharingEnabled
 
 -- | The Monoid laws are witnessed by the following denotation function:
 --

diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md
@@ -8,6 +8,12 @@
 
 ### Non-breaking changes
 
+## 0.16.0.0 -- 2025-02-03
+
+### Breaking changes
+
+* `simpleSingletonVersions`: takes a callback which receives negotiated version data.
+
 ## 0.15.0.0 -- 2025-01-02
 
 ### Breaking changes

diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal
@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: ouroboros-network-framework
-version: 0.15.0.0
+version: 0.16.0.0
 synopsis: Ouroboros network framework
 description: Ouroboros network framework.
 license: Apache-2.0

diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Unversioned.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Unversioned.hs
@@ -70,7 +70,10 @@ unversionedProtocol :: app
                     -> Versions UnversionedProtocol
                                 UnversionedProtocolData
                                 app
-unversionedProtocol = simpleSingletonVersions UnversionedProtocol UnversionedProtocolData
+unversionedProtocol app =
+    simpleSingletonVersions UnversionedProtocol
+                            UnversionedProtocolData
+                            (\_ -> app)
 
 
 -- | Alternative for 'UnversionedProtocolData' which contains 'DataFlow'.
@@ -119,8 +122,10 @@ dataFlowProtocol :: DataFlow
                  -> Versions UnversionedProtocol
                              DataFlowProtocolData
                              app
-dataFlowProtocol dataFlow =
-    simpleSingletonVersions UnversionedProtocol (DataFlowProtocolData dataFlow PeerSharingDisabled)
+dataFlowProtocol dataFlow app =
+    simpleSingletonVersions UnversionedProtocol
+                            (DataFlowProtocolData dataFlow PeerSharingDisabled)
+                            (\_ -> app)
 
 -- | 'Handshake' codec used in various tests.
 --

diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Version.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Version.hs
@@ -101,10 +101,13 @@ data VersionMismatch vNum where
 --
 simpleSingletonVersions
   :: vNum
+  -- ^ version number
   -> vData
-  -> r
+  -- ^ proposed version data
+  -> (vData -> r)
+  -- ^ callback which receives negotiated version data
   -> Versions vNum vData r
 simpleSingletonVersions vNum vData r =
   Versions
     $ Map.singleton vNum
-      (Version (\_ -> r) vData)
+      (Version r vData)
diff --git a/ouroboros-network/CHANGELOG.md b/ouroboros-network/CHANGELOG.md
@@ -10,6 +10,18 @@
 
 ### Non-breaking changes
 
+## 0.19.0.2 -- 2025-02-03
+
+### Non-breaking changes
+
+* UnknownMiniProtocol error should not crash the node
+
+## 0.19.0.1 -- 2025-01-15
+
+### Non-breaking changes
+
+- Removed `UnsupportedOperation` from rethrow policy.
+
 ## 0.19.0.0 -- 2025-01-02
 
 ### Breaking changes
@@ -23,7 +35,7 @@
 * Added `diConnStateSupply` record field to `Ouroboros.Network.Diffusion.P2P.Interfaces`.
 * UnknownMiniProtocol error should not crash the node
 
-### Non-Breaking changes
+### Non-breaking changes
 
 * Added the `mapTraceFetchClientState` function
 

diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs
@@ -248,7 +248,7 @@ clientChainSync sockPaths maxSlotNo = withIOManager $ \iocp ->
         (simpleSingletonVersions
            UnversionedProtocol
            UnversionedProtocolData
-           app)
+           (\_ -> app))
         Nothing
         (localAddressFromPath sockPath)
 
@@ -288,7 +288,7 @@ serverChainSync sockAddr slotLength seed = withIOManager $ \iocp -> do
       (simpleSingletonVersions
         UnversionedProtocol
         UnversionedProtocolData
-        (SomeResponderApplication (app prng)))
+        (\_ -> SomeResponderApplication (app prng)))
       nullErrorPolicies
       $ \_ serverAsync ->
         wait serverAsync   -- block until async exception
@@ -497,7 +497,7 @@ clientBlockFetch sockAddrs maxSlotNo = withIOManager $ \iocp -> do
                           (simpleSingletonVersions
                             UnversionedProtocol
                             UnversionedProtocolData
-                            app)
+                            (\_ -> app))
                           Nothing
                           (localAddressFromPath sockAddr)
                     | sockAddr <- sockAddrs ]
@@ -564,7 +564,7 @@ serverBlockFetch sockAddr slotLength seed = withIOManager $ \iocp -> do
       (simpleSingletonVersions
         UnversionedProtocol
         UnversionedProtocolData
-        (SomeResponderApplication (app prng)))
+        (\_ -> SomeResponderApplication (app prng)))
       nullErrorPolicies
       $ \_ serverAsync ->
         wait serverAsync   -- block until async exception

diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Socket.hs
@@ -176,7 +176,7 @@ demo chain0 updates = withIOManager $ \iocp -> do
           diffusionMode = InitiatorAndResponderDiffusionMode,
           peerSharing = PeerSharingDisabled,
           query = False })
-        (SomeResponderApplication responderApp))
+        (\_ -> SomeResponderApplication responderApp))
       nullErrorPolicies
       $ \realProducerAddress _ -> do
       withAsync
@@ -198,7 +198,7 @@ demo chain0 updates = withIOManager $ \iocp -> do
               diffusionMode = InitiatorOnlyDiffusionMode,
               peerSharing = PeerSharingDisabled,
               query = False })
-            initiatorApp)
+            (\_ -> initiatorApp))
           (Just consumerAddress)
           realProducerAddress)
         $ \ _connAsync -> do

diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal
@@ -1,6 +1,6 @@
 cabal-version: 3.0
 name: ouroboros-network
-version: 0.19.0.0
+version: 0.19.0.2
 synopsis: A networking layer for the Ouroboros blockchain protocol
 description: A networking layer for the Ouroboros blockchain protocol.
 license: Apache-2.0
@@ -165,7 +165,7 @@ library
     network-mux,
     nothunks,
     ouroboros-network-api ^>=0.12,
-    ouroboros-network-framework ^>=0.15,
+    ouroboros-network-framework ^>=0.16,
     ouroboros-network-protocols ^>=0.13,
     psqueues >=0.2.3 && <0.3,
     random,

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs
@@ -44,6 +44,7 @@ import GHC.IO.Exception as GHC (IOErrorType (..), IOException (..))
 import System.Random (mkStdGen)
 
 import Network.DNS.Types qualified as DNS
+import Network.Mux.Trace qualified as Mx
 
 import Ouroboros.Network.BlockFetch (PraosFetchMode (..),
            TraceFetchClientState (..))
@@ -226,6 +227,7 @@ tests =
     , testGroup "Peer Sharing"
       [ testProperty "share a peer"
                      unit_peer_sharing
+      , testProperty "don't peershare the unwilling" (testWithIOSim prop_no_peershare_unwilling 100000)
       ]
     , testGroup "Churn"
       [ testProperty "no timeouts"
@@ -4328,6 +4330,32 @@ unit_local_root_diffusion_mode diffusionMode =
           )
         ]
 
+prop_no_peershare_unwilling:: SimTrace Void
+                           -> Int
+                           -> Property
+prop_no_peershare_unwilling ioSimTrace traceNumber =
+  let events = Trace.toList
+             . fmap (\(WithTime t (WithName _ b)) -> (t, b))
+             . withTimeNameTraceEvents
+                @DiffusionTestTrace
+                @NtNAddr
+             . Trace.take traceNumber
+             $ ioSimTrace
+  in  counterexample (List.intercalate "\n" $ map show events)
+    $ foldMap
+        (\case
+          (_, DiffusionInboundGovernorTrace (IG.TrMuxErrored _ err)) ->
+            case fromException err of
+              -- Technically we fail on more than the peersharing protocol.
+              -- Which is fine.
+              Just (Mx.UnknownMiniProtocol num) -> All
+                                                 $ counterexample (show num) False
+              Just _                            -> All True
+              Nothing                           -> All True
+          _                                     -> All True
+          )
+          events
+
 -- Utils
 --
 

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs
@@ -80,6 +80,7 @@ import Ouroboros.Network.ConsensusMode
 import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P
 import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..),
            ProtocolTimeLimits (..))
+import Ouroboros.Network.Handshake.Acceptable (Acceptable (acceptableVersion))
 import Ouroboros.Network.InboundGovernor qualified as IG
 import Ouroboros.Network.Mux (MiniProtocolLimits (..))
 import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
@@ -96,7 +97,6 @@ import Ouroboros.Network.Protocol.BlockFetch.Codec (byteLimitsBlockFetch,
            timeLimitsBlockFetch)
 import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..),
            byteLimitsChainSync, timeLimitsChainSync)
-import Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept))
 import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive,
            timeLimitsKeepAlive)
 import Ouroboros.Network.Protocol.Limits (shortWait, smallByteLimit)
@@ -1092,9 +1092,7 @@ diffusionSimulation
           readLocalRootPeers  = readTVar lrpVar
           readPublicRootPeers = return publicRoots
           readUseLedgerPeers  = return (UseLedgerPeers (After 0))
-
-          acceptVersion = \_ v -> Accept v
-
+          acceptVersion = acceptableVersion
           defaultMiniProtocolsLimit :: MiniProtocolLimits
           defaultMiniProtocolsLimit =
             MiniProtocolLimits { maximumIngressQueue = 64000 }

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/Kernel.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/Kernel.hs
@@ -61,6 +61,7 @@ import Ouroboros.Network.AnchoredFragment (Anchor (..))
 import Ouroboros.Network.Block (HasFullHeader, SlotNo)
 import Ouroboros.Network.Block qualified as Block
 import Ouroboros.Network.BlockFetch
+import Ouroboros.Network.Handshake.Acceptable (Accept (..), Acceptable (..))
 import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
 import Ouroboros.Network.Protocol.Handshake.Unversioned
 import Ouroboros.Network.Snocket (TestAddress (..))
@@ -141,6 +142,23 @@ data NtNVersionData = NtNVersionData
   , ntnPeerSharing   :: PeerSharing
   }
   deriving Show
+
+instance Acceptable NtNVersionData where
+  acceptableVersion
+    NtNVersionData {
+        ntnDiffusionMode,
+        ntnPeerSharing
+      }
+    NtNVersionData {
+        ntnDiffusionMode = ntnDiffusionMode',
+        ntnPeerSharing   = ntnPeerSharing'
+      }
+    =
+    Accept $ NtNVersionData {
+        ntnDiffusionMode = ntnDiffusionMode `min` ntnDiffusionMode',
+        ntnPeerSharing   = ntnPeerSharing <> ntnPeerSharing'
+      }
+
 type NtCAddr        = TestAddress Int
 type NtCVersion     = UnversionedProtocol
 type NtCVersionData = UnversionedProtocolData

diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs
@@ -265,25 +265,26 @@ applications debugTracer nodeKernel
       { Diff.daApplicationInitiatorMode =
           simpleSingletonVersions UnversionedProtocol
                                   (NtNVersionData InitiatorOnlyDiffusionMode aaOwnPeerSharing)
-                                  initiatorApp
+                                  (\NtNVersionData {ntnPeerSharing} -> initiatorApp ntnPeerSharing)
       , Diff.daApplicationInitiatorResponderMode =
           simpleSingletonVersions UnversionedProtocol
                                   (NtNVersionData aaDiffusionMode aaOwnPeerSharing)
-                                  initiatorAndResponderApp
+                                  (\NtNVersionData {ntnPeerSharing} -> initiatorAndResponderApp ntnPeerSharing)
       , Diff.daLocalResponderApplication =
           simpleSingletonVersions UnversionedProtocol
                                   UnversionedProtocolData
-                                  localResponderApp
+                                  (\_ -> localResponderApp)
       , Diff.daLedgerPeersCtx =
           aaLedgerPeersConsensusInterface
       , Diff.daUpdateOutboundConnectionsState =
           aaUpdateOutboundConnectionsState
       }
   where
     initiatorApp
-      :: OuroborosBundleWithExpandedCtx Mx.InitiatorMode NtNAddr ByteString m () Void
+      :: PSTypes.PeerSharing
+      -> OuroborosBundleWithExpandedCtx Mx.InitiatorMode NtNAddr ByteString m () Void
     -- initiator mode will never run a peer sharing responder side
-    initiatorApp = fmap f <$> initiatorAndResponderApp
+    initiatorApp peerSharing = fmap f <$> initiatorAndResponderApp peerSharing
       where
         f :: MiniProtocolWithExpandedCtx Mx.InitiatorResponderMode NtNAddr ByteString m () ()
           -> MiniProtocolWithExpandedCtx Mx.InitiatorMode          NtNAddr ByteString m () Void
@@ -300,8 +301,9 @@ applications debugTracer nodeKernel
                        }
 
     initiatorAndResponderApp
-      :: OuroborosBundleWithExpandedCtx Mx.InitiatorResponderMode NtNAddr ByteString m () ()
-    initiatorAndResponderApp = TemperatureBundle
+      :: PSTypes.PeerSharing
+      -> OuroborosBundleWithExpandedCtx Mx.InitiatorResponderMode NtNAddr ByteString m () ()
+    initiatorAndResponderApp peerSharing = TemperatureBundle
       { withHot = WithHot
           [ MiniProtocol
               { miniProtocolNum    = chainSyncMiniProtocolNum
@@ -334,7 +336,7 @@ applications debugTracer nodeKernel
               }
           ]
       , withEstablished = WithEstablished $
-          [ MiniProtocol
+            MiniProtocol
               { miniProtocolNum    = keepAliveMiniProtocolNum
               , miniProtocolStart  = StartOnDemandAny
               , miniProtocolLimits = keepAliveLimits limits
@@ -343,18 +345,20 @@ applications debugTracer nodeKernel
                     keepAliveInitiator
                     keepAliveResponder
               }
-          ] ++ if aaOwnPeerSharing /= PSTypes.PeerSharingDisabled
-                  then [ MiniProtocol
-                          { miniProtocolNum    = peerSharingMiniProtocolNum
-                          , miniProtocolStart  = StartOnDemand
-                          , miniProtocolLimits = peerSharingLimits limits
-                          , miniProtocolRun    =
-                              InitiatorAndResponderProtocol
-                                peerSharingInitiator
-                                (peerSharingResponder (nkPeerSharingAPI nodeKernel))
-                          }
-                       ]
-                  else []
+          : case peerSharing of
+              PSTypes.PeerSharingEnabled ->
+                [ MiniProtocol
+                    { miniProtocolNum    = peerSharingMiniProtocolNum
+                    , miniProtocolStart  = StartOnDemand
+                    , miniProtocolLimits = peerSharingLimits limits
+                    , miniProtocolRun    =
+                        InitiatorAndResponderProtocol
+                          peerSharingInitiator
+                          (peerSharingResponder (nkPeerSharingAPI nodeKernel))
+                    }
+                ]
+              PSTypes.PeerSharingDisabled ->
+                []
       }
 
     localResponderApp

diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs
@@ -164,8 +164,9 @@ data NodeToClientProtocols appType ntcAddr bytes m a b = NodeToClientProtocols {
 nodeToClientProtocols
   :: NodeToClientProtocols appType addr bytes m a b
   -> NodeToClientVersion
+  -> NodeToClientVersionData
   -> OuroborosApplicationWithMinimalCtx appType addr bytes m a b
-nodeToClientProtocols protocols _version =
+nodeToClientProtocols protocols _version _versionData =
     OuroborosApplication $
       case protocols of
         NodeToClientProtocols {