ouroboros-consensus: updated to the new diffusion interface

ouroboros-consensus/ouroboros-consensus.cabal

@@ -125,7 +125,7 @@ library
                        Ouroboros.Consensus.Node
                        Ouroboros.Consensus.Node.DbLock
                        Ouroboros.Consensus.Node.DbMarker
-                       Ouroboros.Consensus.Node.ErrorPolicy
+                       Ouroboros.Consensus.Node.RethrowPolicy
                        Ouroboros.Consensus.Node.Exit
                        Ouroboros.Consensus.NodeId
                        Ouroboros.Consensus.NodeKernel

ouroboros-consensus/src/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -25,9 +25,8 @@ module Ouroboros.Consensus.Network.NodeToNode (
   , ServerApp
   , Apps (..)
   , mkApps
-    -- ** Projections
-  , initiator
-  , responder
+    -- ** 'OuroborosBundle'
+  , initiatorAndResponder
     -- * Re-exports
   , ChainSyncTimeout (..)
   ) where
@@ -39,7 +38,6 @@ import           Control.Monad.Class.MonadTimer (MonadTimer)
 import           Control.Tracer
 import           Data.ByteString.Lazy (ByteString)
 import           Data.Map.Strict (Map)
-import           Data.Void (Void)
 
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment (..))
 import           Ouroboros.Network.Block (Serialised (..), decodePoint,
@@ -583,18 +581,17 @@ mkApps kernel Tracers {..} Codecs {..} genChainSyncTimeout Handlers {..} =
   Projections from 'Apps'
 -------------------------------------------------------------------------------}
 
--- | A projection from 'NetworkApplication' to a client-side
--- 'OuroborosApplication' for the node-to-node protocols.
+-- | A bi-directional network applicaiton.
 --
 -- Implementation note: network currently doesn't enable protocols conditional
 -- on the protocol version, but it eventually may; this is why @_version@ is
 -- currently unused.
-initiator
+initiatorAndResponder
   :: MiniProtocolParameters
   -> NodeToNodeVersion
   -> Apps m (ConnectionId peer) b b b b a
-  -> OuroborosApplication 'InitiatorMode peer b m a Void
-initiator miniProtocolParameters version Apps {..} =
+  -> OuroborosBundle 'InitiatorResponderMode peer b m a a
+initiatorAndResponder miniProtocolParameters version Apps {..} =
     nodeToNodeProtocols
       miniProtocolParameters
       -- TODO: currently consensus is using 'ConnectionId' for its 'peer' type.
@@ -605,36 +602,20 @@ initiator miniProtocolParameters version Apps {..} =
       -- a quadruple uniquely determinaing a connection).
       (\them controlMessageSTM -> NodeToNodeProtocols {
           chainSyncProtocol =
-            (InitiatorProtocolOnly (MuxPeerRaw (aChainSyncClient version controlMessageSTM them))),
+            (InitiatorAndResponderProtocol
+              (MuxPeerRaw (aChainSyncClient version controlMessageSTM them))
+              (MuxPeerRaw (aChainSyncServer version                   them))),
           blockFetchProtocol =
-            (InitiatorProtocolOnly (MuxPeerRaw (aBlockFetchClient version controlMessageSTM them))),
+            (InitiatorAndResponderProtocol
+              (MuxPeerRaw (aBlockFetchClient version controlMessageSTM them))
+              (MuxPeerRaw (aBlockFetchServer version                   them))),
           txSubmissionProtocol =
-            (InitiatorProtocolOnly (MuxPeerRaw (aTxSubmissionClient version controlMessageSTM them))),
+            (InitiatorAndResponderProtocol
+              (MuxPeerRaw (aTxSubmissionClient version controlMessageSTM them))
+              (MuxPeerRaw (aTxSubmissionServer version                   them))),
           keepAliveProtocol =
-            (InitiatorProtocolOnly (MuxPeerRaw (aKeepAliveClient version controlMessageSTM them)))
-        })
-      version
-
--- | A projection from 'NetworkApplication' to a server-side
--- 'OuroborosApplication' for the node-to-node protocols.
---
--- See 'initiatorNetworkApplication' for rationale for the @_version@ arg.
-responder
-  :: MiniProtocolParameters
-  -> NodeToNodeVersion
-  -> Apps m (ConnectionId peer) b b b b a
-  -> OuroborosApplication 'ResponderMode peer b m Void a
-responder miniProtocolParameters version Apps {..} =
-    nodeToNodeProtocols
-      miniProtocolParameters
-      (\them _controlMessageSTM -> NodeToNodeProtocols {
-          chainSyncProtocol =
-            (ResponderProtocolOnly (MuxPeerRaw (aChainSyncServer version them))),
-          blockFetchProtocol =
-            (ResponderProtocolOnly (MuxPeerRaw (aBlockFetchServer version them))),
-          txSubmissionProtocol =
-            (ResponderProtocolOnly (MuxPeerRaw (aTxSubmissionServer version them))),
-          keepAliveProtocol =
-            (ResponderProtocolOnly (MuxPeerRaw (aKeepAliveServer version them)))
+            (InitiatorAndResponderProtocol
+              (MuxPeerRaw (aKeepAliveClient version controlMessageSTM them))
+              (MuxPeerRaw (aKeepAliveServer version                   them)))
         })
       version

ouroboros-consensus/src/Ouroboros/Consensus/Node.hs

@@ -23,8 +23,6 @@ module Ouroboros.Consensus.Node
   , NodeKernel (..)
   , MaxTxCapacityOverride (..)
   , MempoolCapacityBytesOverride (..)
-  , IPSubscriptionTarget (..)
-  , DnsSubscriptionTarget (..)
   , ConnectionId (..)
   , RemoteConnectionId
     -- * Internal helpers
@@ -41,6 +39,7 @@ import           Data.ByteString.Lazy (ByteString)
 import           Data.Functor.Identity (Identity)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Void (Void)
 import           System.Random (newStdGen, randomIO, randomRIO)
 
 import           Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..))
@@ -66,10 +65,10 @@ import qualified Ouroboros.Consensus.Network.NodeToClient as NTC
 import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
 import           Ouroboros.Consensus.Node.DbLock
 import           Ouroboros.Consensus.Node.DbMarker
-import           Ouroboros.Consensus.Node.ErrorPolicy
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Recovery
+import           Ouroboros.Consensus.Node.RethrowPolicy
 import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.Node.Tracers
 import           Ouroboros.Consensus.NodeKernel
@@ -152,7 +151,7 @@ data RunNodeArgs blk = RunNodeArgs {
 -- network layer.
 --
 -- This function runs forever unless an exception is thrown.
-run :: forall blk. RunNode blk => RunNodeArgs blk -> IO ()
+run :: forall blk. RunNode blk => RunNodeArgs blk -> IO Void
 run runargs@RunNodeArgs{..} =
 
     withDBChecks runargs $ \lastShutDownWasClean ->
@@ -301,22 +300,14 @@ run runargs@RunNodeArgs{..} =
       -> DiffusionApplications
     mkDiffusionApplications miniProtocolParams ntnApps ntcApps =
       DiffusionApplications {
-          daResponderApplication = combineVersions [
-              simpleSingletonVersions
-                version
-                nodeToNodeVersionData
-                (nodeToNodeDictVersion version)
-                (NTN.responder miniProtocolParams version $ ntnApps blockVersion)
-            | (version, blockVersion) <- Map.toList rnNodeToNodeVersions
-            ]
-        , daInitiatorApplication = combineVersions [
-              simpleSingletonVersions
-                version
-                nodeToNodeVersionData
-                (nodeToNodeDictVersion version)
-                (NTN.initiator miniProtocolParams version $ ntnApps blockVersion)
-            | (version, blockVersion) <- Map.toList rnNodeToNodeVersions
-            ]
+            daApplication = combineVersions
+             [ simpleSingletonVersions
+                 version
+                 nodeToNodeVersionData
+                 (nodeToNodeDictVersion version)
+                 (NTN.initiatorAndResponder miniProtocolParams version $ ntnApps blockVersion)
+             | (version, blockVersion) <- Map.toList rnNodeToNodeVersions
+             ]
         , daLocalResponderApplication = combineVersions [
               simpleSingletonVersions
                 version
@@ -325,7 +316,9 @@ run runargs@RunNodeArgs{..} =
                 (NTC.responder version $ ntcApps blockVersion)
             | (version, blockVersion) <- Map.toList rnNodeToClientVersions
             ]
-        , daErrorPolicies = consensusErrorPolicy
+        , daMiniProtocolParameters = miniProtocolParams
+        , daRethrowPolicy = consensusRethrowPolicy
+        , daLocalRethrowPolicy = mempty
         }
 
 -- | Check the DB marker, lock the DB and look for the clean shutdown marker.