From 27c8fac10be0caa2b38811f646c18bd571c1bd03 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 10:00:56 +0100 Subject: [PATCH 01/33] Win32-network: export ByteString operations from System.Win32.Async --- Win32-network/src/System/Win32/Async.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Win32-network/src/System/Win32/Async.hs b/Win32-network/src/System/Win32/Async.hs index 7aac1c3ae60..43d3be6d572 100644 --- a/Win32-network/src/System/Win32/Async.hs +++ b/Win32-network/src/System/Win32/Async.hs @@ -3,9 +3,11 @@ module System.Win32.Async , module System.Win32.Async.ErrCode , module System.Win32.Async.IOManager , module System.Win32.Async.Socket + , module System.Win32.Async.Socket.ByteString ) where import System.Win32.Async.IOManager import System.Win32.Async.File import System.Win32.Async.ErrCode import System.Win32.Async.Socket +import System.Win32.Async.Socket.ByteString From f7d7c6aff53db6f731fef50ad8e69e94b76c1f03 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 15:56:57 +0100 Subject: [PATCH 02/33] Fix a bug in `System.Win32.Async.connect` Error handler was attached to `putTMVar` instead of the `Network.Socketconnect` call. --- Win32-network/src/System/Win32/Async/Socket.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Win32-network/src/System/Win32/Async/Socket.hs b/Win32-network/src/System/Win32/Async/Socket.hs index 1e7b547de77..aefb06e65fc 100644 --- a/Win32-network/src/System/Win32/Async/Socket.hs +++ b/Win32-network/src/System/Win32/Async/Socket.hs @@ -51,7 +51,7 @@ connect :: Socket -> SockAddr -> IO () connect sock addr = do v <- newEmptyMVar _ <- mask_ $ forkIOWithUnmask $ \unmask -> - unmask (Socket.connect sock addr) >> putMVar v Nothing + unmask (Socket.connect sock addr >> putMVar v Nothing) `catch` (\(e :: IOException) -> putMVar v (Just e)) r <- takeMVar v case r of From ada1a7298b1a04fbdf972c2fbd31f147df548d69 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 10:40:43 +0100 Subject: [PATCH 03/33] network-mux: named pipe bearer namedPipeAsBearer - create a mux bearer from a named pipe --- network-mux/network-mux.cabal | 7 ++ .../src/Network/Mux/Bearer/NamedPipe.hs | 85 +++++++++++++++++++ 2 files changed, 92 insertions(+) create mode 100644 network-mux/src/Network/Mux/Bearer/NamedPipe.hs diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 556423c0fcd..8bd7a15a554 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -39,6 +39,10 @@ library vector, time >=1.6 && <1.10 + if os(windows) + build-depends: Win32 >= 2.5.4.1 && <2.9, + Win32-network >=0.1 && <0.2 + ghc-options: -Wall -Wno-unticked-promoted-constructors if flag(asserts) @@ -60,6 +64,9 @@ library Network.Mux.DeltaQ.TraceStatsSupport Network.Mux.DeltaQ.TraceTransformer Network.Mux.DeltaQ.TraceTypes + if os(windows) + exposed-modules: + Network.Mux.Bearer.NamedPipe default-language: Haskell2010 test-suite test-network-mux diff --git a/network-mux/src/Network/Mux/Bearer/NamedPipe.hs b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs new file mode 100644 index 00000000000..33033eea3d6 --- /dev/null +++ b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Mux.Bearer.NamedPipe + ( namedPipeAsBearer ) where + +import Control.Monad (when) +import qualified Data.ByteString.Lazy as BL +import Data.Int (Int64) +import Data.Foldable (traverse_) + +import GHC.Stack + +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTimer +import Control.Tracer + +import qualified Network.Mux as Mx +import Network.Mux.Types (MuxBearer) +import qualified Network.Mux.Types as Mx +import Network.Mux.Trace (MuxTrace) +import qualified Network.Mux.Trace as Mx +import qualified Network.Mux.Time as Mx +import qualified Network.Mux.Codec as Mx + +import System.Win32 (HANDLE) +import qualified System.Win32.Async as Win32.Async + + +-- | Named pipe bearer. The 'HANDLE' must be associated with IO completion port +-- using 'System.Win32.Async.associateWithIOCompletionPort'. +-- +namedPipeAsBearer :: Tracer IO MuxTrace + -> HANDLE + -> MuxBearer IO +namedPipeAsBearer tracer h = + Mx.MuxBearer { + Mx.read = readNamedPipe, + Mx.write = writeNamedPipe, + Mx.sduSize = 24576 + } + where + readNamedPipe :: HasCallStack => IO (Mx.MuxSDU, Time) + readNamedPipe = do + traceWith tracer Mx.MuxTraceRecvHeaderStart + hbuf <- recvLen' True 8 [] + case Mx.decodeMuxSDU hbuf of + Left e -> throwM e + Right header -> do + traceWith tracer $ Mx.MuxTraceRecvHeaderEnd header + traceWith tracer $ Mx.MuxTraceRecvPayloadStart (fromIntegral $ Mx.msLength header) + blob <- recvLen' False (fromIntegral $ Mx.msLength header) [] + ts <- getMonotonicTime + traceWith tracer (Mx.MuxTraceRecvDeltaQObservation header ts) + traceWith tracer $ Mx.MuxTraceRecvPayloadEnd blob + return (header {Mx.msBlob = blob}, ts) + + recvLen' :: Bool -> Int64 -> [BL.ByteString] -> IO BL.ByteString + recvLen' _ 0 bufs = return (BL.concat $ reverse bufs) + recvLen' waitingOnNextHeader l bufs = do + traceWith tracer $ Mx.MuxTraceRecvStart $ fromIntegral l + buf <- BL.fromStrict <$> Win32.Async.readHandle h (fromIntegral l) + `catch` Mx.handleIOException "readHandle errored" + if BL.null buf + then do + when waitingOnNextHeader + $ threadDelay 1 + throwM $ Mx.MuxError Mx.MuxBearerClosed (show h ++ + " closed when reading data, waiting on next header " ++ + show waitingOnNextHeader) callStack + else do + traceWith tracer (Mx.MuxTraceRecvEnd buf) + recvLen' False (l - fromIntegral (BL.length buf)) (buf : bufs) + + writeNamedPipe :: Mx.MuxSDU -> IO Time + writeNamedPipe sdu = do + ts <- getMonotonicTime + let ts32 = Mx.timestampMicrosecondsLow32Bits ts + sdu' = sdu { Mx.msTimestamp = Mx.RemoteClockModel ts32 } + buf = Mx.encodeMuxSDU sdu' + traceWith tracer $ Mx.MuxTraceSendStart sdu' + traverse_ (Win32.Async.writeHandle h) (BL.toChunks buf) + `catch` Mx.handleIOException "writeHandle errored" + traceWith tracer Mx.MuxTraceSendEnd + return ts From 3f0263214bcb92602c6f04f7bbdd86c4a5a55a32 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 10:56:19 +0100 Subject: [PATCH 04/33] network-mux: use System.Win32.Async in the socket bearer --- network-mux/network-mux.cabal | 4 ++++ network-mux/src/Network/Mux/Bearer/Socket.hs | 19 +++++++++++++++++++ 2 files changed, 23 insertions(+) diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 8bd7a15a554..6872c16726c 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -111,6 +111,10 @@ test-suite test-network-mux tasty-hunit, time + if os(windows) + build-depends: Win32 >= 2.5.4.1 && <2.9, + Win32-network >=0.1 && <0.2 + ghc-options: -Wall -Wno-unticked-promoted-constructors -fno-ignore-asserts diff --git a/network-mux/src/Network/Mux/Bearer/Socket.hs b/network-mux/src/Network/Mux/Bearer/Socket.hs index b402cfddadf..f11d4cdb54a 100644 --- a/network-mux/src/Network/Mux/Bearer/Socket.hs +++ b/network-mux/src/Network/Mux/Bearer/Socket.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,7 +18,12 @@ import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer import qualified Network.Socket as Socket +#if !defined(mingw32_HOST_OS) import qualified Network.Socket.ByteString.Lazy as Socket (recv, sendAll) +#else +import Data.Foldable (traverse_) +import qualified System.Win32.Async as Win32.Async +#endif import qualified Network.Mux as Mx import Network.Mux.Types (MuxBearer) @@ -30,6 +36,10 @@ import qualified Network.Mux.Time as Mx -- | -- Create @'MuxBearer'@ from a socket. -- +-- On Windows 'System.Win32.Async` operations are used to read and write. This +-- means that the socket must be associated with the I/O completion port with +-- 'System.Win32.Async.associateWithIOCompletionPort'. +-- -- Note: 'IOException's thrown by 'sendAll' and 'recv' are wrapped in -- 'MuxError'. -- @@ -63,7 +73,11 @@ socketAsMuxBearer tracer sd = recvLen' _ 0 bufs = return (BL.concat $ reverse bufs) recvLen' waitingOnNxtHeader l bufs = do traceWith tracer $ Mx.MuxTraceRecvStart $ fromIntegral l +#if defined(mingw32_HOST_OS) + buf <- BL.fromStrict <$> Win32.Async.recv sd (fromIntegral l) +#else buf <- Socket.recv sd l +#endif `catch` Mx.handleIOException "recv errored" if BL.null buf then do @@ -87,7 +101,12 @@ socketAsMuxBearer tracer sd = sdu' = sdu { Mx.msTimestamp = Mx.RemoteClockModel ts32 } buf = Mx.encodeMuxSDU sdu' traceWith tracer $ Mx.MuxTraceSendStart sdu' +#if defined(mingw32_HOST_OS) + -- TODO: issue #1430: vectored I/O on Windows + traverse_ (Win32.Async.sendAll sd) (BL.toChunks buf) +#else Socket.sendAll sd buf +#endif `catch` Mx.handleIOException "sendAll errored" traceWith tracer $ Mx.MuxTraceSendEnd return ts From 53d43e0675693b6e3560586fec63ecc7405573fb Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 11:09:14 +0100 Subject: [PATCH 05/33] network-mux: pipeAsMuxBearer using named pipes on Windows 'PipeChannel' is introduced to abstract read / write pipe operations. --- network-mux/src/Network/Mux/Bearer/Pipe.hs | 92 ++++++++++++++++------ 1 file changed, 66 insertions(+), 26 deletions(-) diff --git a/network-mux/src/Network/Mux/Bearer/Pipe.hs b/network-mux/src/Network/Mux/Bearer/Pipe.hs index 45ae2945f51..113c604c122 100644 --- a/network-mux/src/Network/Mux/Bearer/Pipe.hs +++ b/network-mux/src/Network/Mux/Bearer/Pipe.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-} @@ -5,7 +6,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.Mux.Bearer.Pipe ( - pipeAsMuxBearer + PipeChannel (..) + , pipeChannelFromHandles +#if defined(mingw32_HOST_OS) + , pipeChannelFromNamedPipe +#endif + , pipeAsMuxBearer , runMuxWithPipes ) where @@ -16,6 +22,13 @@ import qualified Data.ByteString.Lazy as BL import GHC.Stack import System.IO (Handle, hFlush) +#if defined(mingw32_HOST_OS) +import Data.Foldable (traverse_) + +import qualified System.Win32.Types as Win32 (HANDLE) +import qualified System.Win32.Async as Win32.Async +#endif + import qualified Network.Mux as Mx import Network.Mux.Types (MuxBearer) import qualified Network.Mux.Types as Mx @@ -24,44 +37,75 @@ import qualified Network.Mux.Codec as Mx import qualified Network.Mux.Time as Mx +-- | Abstraction over various types of handles. We provide two instances: +-- +-- * based on 'Handle': os independepnt, but will not work well on Windows, +-- * based on 'Win32.HANDLE': Windows specific. +-- +data PipeChannel = PipeChannel { + readHandle :: Int -> IO BL.ByteString, + writeHandle :: BL.ByteString -> IO () + } + +pipeChannelFromHandles :: Handle + -- ^ read handle + -> Handle + -- ^ write handle + -> PipeChannel +pipeChannelFromHandles r w = PipeChannel { + readHandle = BL.hGet r, + writeHandle = \a -> BL.hPut w a >> hFlush w + } + +#if defined(mingw32_HOST_OS) +-- | Create a 'PipeChannel' from a named pipe. This allows to emulate +-- anonymous pipes using named pipes on Windows. +-- +pipeChannelFromNamedPipe :: Win32.HANDLE + -> PipeChannel +pipeChannelFromNamedPipe h = PipeChannel { + readHandle = fmap BL.fromStrict . Win32.Async.readHandle h, + writeHandle = traverse_ (Win32.Async.writeHandle h) . BL.toChunks + } +#endif + pipeAsMuxBearer :: Tracer IO Mx.MuxTrace - -> Handle -- ^ read handle - -> Handle -- ^ write handle + -> PipeChannel -> MuxBearer IO -pipeAsMuxBearer tracer pcRead pcWrite = do +pipeAsMuxBearer tracer channel = Mx.MuxBearer { - Mx.read = readPipe, - Mx.write = writePipe, - Mx.sduSize = 32768 - } + Mx.read = readPipe, + Mx.write = writePipe, + Mx.sduSize = 32768 + } where readPipe :: HasCallStack => IO (Mx.MuxSDU, Time) readPipe = do traceWith tracer $ Mx.MuxTraceRecvHeaderStart - hbuf <- recvLen' pcRead 8 [] + hbuf <- recvLen' 8 [] case Mx.decodeMuxSDU hbuf of Left e -> throwM e Right header -> do traceWith tracer $ Mx.MuxTraceRecvHeaderEnd header traceWith tracer $ Mx.MuxTraceRecvPayloadStart (fromIntegral $ Mx.msLength header) - blob <- recvLen' pcRead (fromIntegral $ Mx.msLength header) [] + blob <- recvLen' (fromIntegral $ Mx.msLength header) [] ts <- getMonotonicTime traceWith tracer (Mx.MuxTraceRecvDeltaQObservation header ts) traceWith tracer $ Mx.MuxTraceRecvPayloadEnd blob return (header {Mx.msBlob = blob}, ts) - recvLen' :: Handle -> Int -> [BL.ByteString] -> IO BL.ByteString - recvLen' _ 0 bufs = return $ BL.concat $ reverse bufs - recvLen' pd l bufs = do + recvLen' :: Int -> [BL.ByteString] -> IO BL.ByteString + recvLen' 0 bufs = return $ BL.concat $ reverse bufs + recvLen' l bufs = do traceWith tracer $ Mx.MuxTraceRecvStart l - buf <- BL.hGet pd l - `catch` Mx.handleIOException "hGet errored" + buf <- readHandle channel l + `catch` Mx.handleIOException "readHandle errored" if BL.null buf then throwM $ Mx.MuxError Mx.MuxBearerClosed "Pipe closed when reading data" callStack else do traceWith tracer $ Mx.MuxTraceRecvEnd buf - recvLen' pd (l - fromIntegral (BL.length buf)) (buf : bufs) + recvLen' (l - fromIntegral (BL.length buf)) (buf : bufs) writePipe :: Mx.MuxSDU -> IO Time writePipe sdu = do @@ -70,20 +114,16 @@ pipeAsMuxBearer tracer pcRead pcWrite = do sdu' = sdu { Mx.msTimestamp = Mx.RemoteClockModel ts32 } buf = Mx.encodeMuxSDU sdu' traceWith tracer $ Mx.MuxTraceSendStart sdu' - BL.hPut pcWrite buf - `catch` Mx.handleIOException "hPut errored" - hFlush pcWrite + writeHandle channel buf + `catch` Mx.handleIOException "writeHandle errored" traceWith tracer $ Mx.MuxTraceSendEnd return ts runMuxWithPipes - :: Tracer IO (Mx.WithMuxBearer String Mx.MuxTrace) + :: Tracer IO Mx.MuxTrace -> Mx.MuxApplication appType IO a b - -> Handle -- ^ read handle - -> Handle -- ^ write handle + -> PipeChannel -> IO () -runMuxWithPipes tracer app pcRead pcWrite = do - let muxTracer = Mx.WithMuxBearer "Pipe" `contramap` tracer - bearer = pipeAsMuxBearer muxTracer pcRead pcWrite +runMuxWithPipes muxTracer app channel = do + let bearer = pipeAsMuxBearer muxTracer channel Mx.muxStart muxTracer app bearer - From f9bb986dc493dd3d3aa1b52d5aaf25f8a7f03e61 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 11:49:02 +0100 Subject: [PATCH 06/33] ouroboros-network: pipe tests on windows Run pipe tests on windows using `pipeChannelFromNamedPipe` This patch makes test-network buildable again and enables pipes tests on Windows. --- ouroboros-network/ouroboros-network.cabal | 4 + ouroboros-network/test/Test/Pipe.hs | 172 ++++++++++++++-------- 2 files changed, 111 insertions(+), 65 deletions(-) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 92f9e67e2eb..5aa54f35acc 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -277,6 +277,10 @@ test-suite test-network ouroboros-network, ouroboros-protocol-tests + if os(windows) + build-depends: Win32-network <0.2.0.0, + Win32 >= 2.5.4.1 && <2.9 + ghc-options: -Wall -Wno-unticked-promoted-constructors -fno-ignore-asserts diff --git a/ouroboros-network/test/Test/Pipe.hs b/ouroboros-network/test/Test/Pipe.hs index 66b8a5b423c..f170779bfef 100644 --- a/ouroboros-network/test/Test/Pipe.hs +++ b/ouroboros-network/test/Test/Pipe.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,6 +9,7 @@ module Test.Pipe (tests) where import Codec.Serialise (Serialise (..)) +import Control.Exception import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork @@ -16,8 +18,6 @@ import Control.Monad.Class.MonadTimer import qualified Data.ByteString.Lazy as BL import Data.Int import Data.Void (Void) -import System.Info (os) -import System.Process (createPipe) import Test.ChainGenerators (TestBlockChainAndUpdates (..)) import Test.QuickCheck import Test.Tasty (TestTree, testGroup) @@ -28,6 +28,17 @@ import Control.Tracer import qualified Network.Mux.Bearer.Pipe as Mx import Ouroboros.Network.Mux +#if defined(mingw32_HOST_OS) +import Data.Bits ((.|.)) + +import qualified System.Win32.NamedPipes as Win32.NamedPipes +import qualified System.Win32.Async as Win32.Async +import qualified System.Win32 as Win32 +#else +import System.Process (createPipe) +import System.IO (hClose) +#endif + import Ouroboros.Network.Block (decodeTip, encodeTip) import Ouroboros.Network.MockChain.Chain (Chain, ChainUpdate, Point) import qualified Ouroboros.Network.MockChain.Chain as Chain @@ -46,21 +57,9 @@ activeTracer = nullTracer -- tests :: TestTree -tests = - {- - - Anonymous pipe test cases fails for an unknown reason - - when compiled without "-threaded" on Windows. The Socket test - - suite deadlocks when compiled with "-threaded" on windows due to - - https://gitlab.haskell.org/ghc/ghc/issues/14503. - - - - We require working sockets not anoynymous pipes on Windows so - - this test group is disabled for now. - -} - if os == "mingw32" - then testGroup "Pipe" [] - else testGroup "Pipe" - [ testProperty "pipe sync demo" prop_pipe_demo - ] +tests = testGroup "Pipe" + [ testProperty "pipe sync demo" (withMaxSuccess 32 prop_pipe_demo) + ] -- -- Properties @@ -88,56 +87,99 @@ instance MiniProtocolLimits DemoProtocols where -- over a pipe with full message serialisation, framing etc. -- demo :: forall block . - (Chain.HasHeader block, Serialise (Chain.HeaderHash block), Serialise block, Eq block ) + (Chain.HasHeader block, Serialise (Chain.HeaderHash block), Serialise block, Eq block, Show block ) => Chain block -> [ChainUpdate block block] -> IO Bool demo chain0 updates = do - - (hndRead1, hndWrite1) <- createPipe - (hndRead2, hndWrite2) <- createPipe - - producerVar <- atomically $ newTVar (CPS.initChainProducerState chain0) - consumerVar <- atomically $ newTVar chain0 - done <- atomically newEmptyTMVar - - let Just expectedChain = Chain.applyChainUpdates updates chain0 - target = Chain.headPoint expectedChain - - consumerApp :: OuroborosApplication InitiatorApp String DemoProtocols IO BL.ByteString () Void - consumerApp = simpleInitiatorApplication $ - \ChainSync -> - MuxPeer nullTracer - (ChainSync.codecChainSync encode decode - encode decode - (encodeTip encode) (decodeTip decode)) - (ChainSync.chainSyncClientPeer - (ChainSync.chainSyncClientExample consumerVar - (consumerClient done target consumerVar))) - - server :: ChainSyncServer block (Tip block) IO () - server = ChainSync.chainSyncServerExample () producerVar - - producerApp ::OuroborosApplication ResponderApp String DemoProtocols IO BL.ByteString Void () - producerApp = simpleResponderApplication $ - \ChainSync -> - MuxPeer nullTracer - (ChainSync.codecChainSync encode decode - encode decode - (encodeTip encode) (decodeTip decode)) - (ChainSync.chainSyncServerPeer server) - - _ <- async $ Mx.runMuxWithPipes activeTracer (toApplication producerApp "producer") hndRead1 hndWrite2 - _ <- async $ Mx.runMuxWithPipes activeTracer (toApplication consumerApp "consumer") hndRead2 hndWrite1 - - void $ fork $ sequence_ - [ do threadDelay 10e-4 -- 1 milliseconds, just to provide interest - atomically $ do - p <- readTVar producerVar - let Just p' = CPS.applyChainUpdate update p - writeTVar producerVar p' - | update <- updates - ] - - atomically $ takeTMVar done +-- instrumentation of pipes is system dependet; on Windows we use NamedPipes +-- and async IO using I/O completion ports, on other systems we default to +-- posix anonymous pipes. +#if defined(mingw32_HOST_OS) + -- using named pipe + Win32.Async.withIOManager $ \iocp -> + let pipeName = "\\\\.\\pipe\\demo-pipe" in + bracket + ((,) <$> Win32.NamedPipes.createNamedPipe + -- TODO: clean exports of `Win32.NamedPipes`: + -- 'fFILE_FLAG_OVERLAPPED' should be re-exported. + pipeName + (Win32.NamedPipes.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED) + (Win32.NamedPipes.pIPE_TYPE_BYTE .|. Win32.NamedPipes.pIPE_READMODE_BYTE) + Win32.NamedPipes.pIPE_UNLIMITED_INSTANCES + maxBound + maxBound + 0 + Nothing + <*> Win32.NamedPipes.createFile + pipeName + (Win32.gENERIC_READ .|. Win32.gENERIC_WRITE) + (Win32.fILE_SHARE_NONE) + Nothing + Win32.oPEN_EXISTING + Win32.fILE_FLAG_OVERLAPPED + Nothing) + (\(namedPipe, file) -> Win32.closeHandle namedPipe >> Win32.closeHandle file) + $ \ (namedPipe, file) -> do + Win32.Async.associateWithIOCompletionPort (Left namedPipe) iocp + Win32.Async.connectNamedPipe namedPipe + Win32.Async.associateWithIOCompletionPort (Left file) iocp + let chan1 = Mx.pipeChannelFromNamedPipe namedPipe + chan2 = Mx.pipeChannelFromNamedPipe file +#else + -- using posix pipes + bracket + ((,) <$> createPipe <*> createPipe) + (\((a, b), (x, y)) -> do + hClose a + hClose b + hClose x + hClose y) + $ \((hndRead1, hndWrite1), (hndRead2, hndWrite2)) -> do + let chan1 = Mx.pipeChannelFromHandles hndRead1 hndWrite2 + chan2 = Mx.pipeChannelFromHandles hndRead2 hndWrite1 +#endif + producerVar <- atomically $ newTVar (CPS.initChainProducerState chain0) + consumerVar <- atomically $ newTVar chain0 + done <- atomically newEmptyTMVar + + let Just expectedChain = Chain.applyChainUpdates updates chain0 + target = Chain.headPoint expectedChain + + consumerApp :: OuroborosApplication InitiatorApp String DemoProtocols IO BL.ByteString () Void + consumerApp = simpleInitiatorApplication $ + \ChainSync -> + MuxPeer nullTracer + (ChainSync.codecChainSync encode decode + encode decode + (encodeTip encode) (decodeTip decode)) + (ChainSync.chainSyncClientPeer + (ChainSync.chainSyncClientExample consumerVar + (consumerClient done target consumerVar))) + + server :: ChainSyncServer block (Tip block) IO () + server = ChainSync.chainSyncServerExample () producerVar + + producerApp ::OuroborosApplication ResponderApp String DemoProtocols IO BL.ByteString Void () + producerApp = simpleResponderApplication $ + \ChainSync -> + MuxPeer nullTracer + (ChainSync.codecChainSync encode decode + encode decode + (encodeTip encode) (decodeTip decode)) + (ChainSync.chainSyncServerPeer server) + + _ <- async $ Mx.runMuxWithPipes activeTracer (toApplication producerApp "producer") chan1 + _ <- async $ Mx.runMuxWithPipes activeTracer (toApplication consumerApp "consumer") chan2 + + void $ fork $ sequence_ + [ do threadDelay 10e-4 -- 1 milliseconds, just to provide interest + atomically $ do + p <- readTVar producerVar + let Just p' = CPS.applyChainUpdate update p + writeTVar producerVar p' + | update <- updates + ] + + atomically $ takeTMVar done where checkTip target consumerVar = atomically $ do From 9784797b15b5d3bd9571ced43418b70046df05b7 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 23 Jan 2020 18:31:18 +0100 Subject: [PATCH 07/33] mux-demo application over named pipes This is a Windows only echo server / and client which is using named pipes. In the future we could extend it to also use unix sockets. --- network-mux/demo/mux-demo.hs | 154 ++++++++++++++++++++++++++++++++++ network-mux/network-mux.cabal | 24 +++++- 2 files changed, 177 insertions(+), 1 deletion(-) create mode 100644 network-mux/demo/mux-demo.hs diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs new file mode 100644 index 00000000000..af931c2c930 --- /dev/null +++ b/network-mux/demo/mux-demo.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | Demo application which for now is only using mux over named pipes on +-- Windows. +-- +-- TODO: extend it to use unix sockets. +-- +module Main (main) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (finally) +import Control.Tracer (Tracer (..), nullTracer, showTracing) +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC +import Data.Void + +import qualified Network.Mux.Types as Mx +import qualified Network.Mux.Bearer.Pipe as Mx + +import Test.Mux.ReqResp + +import System.Win32 +import System.Win32.NamedPipes +import qualified System.Win32.Async as Win32.Async + +import System.IO +import System.Exit +import System.Environment + +main :: IO () +main = do + args <- getArgs + case args of + ["server"] -> echoServer + ["client", n, msg] -> client (read n) msg + _ -> usage + +usage :: IO () +usage = do + hPutStr stderr $ "usage: mux-demo server\n" + ++" mux-demo client (n :: Int) (msg :: String)" + exitFailure + +pipeName :: String +pipeName = "\\\\.\\pipe\\mux-demo" + +putStrLn_ :: String -> IO () +putStrLn_ = BSC.putStrLn . BSC.pack + +debugTracer :: Show a => Tracer IO a +debugTracer = showTracing (Tracer putStrLn_) + +-- +-- Protocols +-- + +defaultProtocolLimits :: Mx.MiniProtocolLimits +defaultProtocolLimits = + Mx.MiniProtocolLimits { + Mx.maximumMessageSize = 3_000_000, + Mx.maximumIngressQueue = 3_000_000 + } + +-- +-- server: accept loop, server loop +-- + + +-- | Server accept loop. +-- +echoServer :: IO () +echoServer = Win32.Async.withIOManager $ \iocp -> do + hpipe <- createNamedPipe pipeName + (pIPE_ACCESS_DUPLEX .|. fILE_FLAG_OVERLAPPED) + (pIPE_TYPE_BYTE .|. pIPE_READMODE_BYTE) + pIPE_UNLIMITED_INSTANCES + 1024 + 1024 + 0 + Nothing + Win32.Async.associateWithIOCompletionPort (Left hpipe) iocp + Win32.Async.connectNamedPipe hpipe + _ <- forkIO $ do + serverLoop hpipe + `finally` closeHandle hpipe + threadDelay 1 + echoServer + + +serverLoop :: HANDLE + -> IO () +serverLoop h = do + let pipeChannel = Mx.pipeChannelFromNamedPipe h + Mx.runMuxWithPipes + nullTracer + app + pipeChannel + where + app :: Mx.MuxApplication 'Mx.ResponderApp IO Void () + app = Mx.MuxApplication + [ Mx.MuxMiniProtocol { + Mx.miniProtocolNum = Mx.MiniProtocolNum 2, + Mx.miniProtocolLimits = defaultProtocolLimits, + Mx.miniProtocolRun = Mx.ResponderProtocolOnly + $ \channel -> runServer debugTracer channel serverApp + } + ] + + serverApp :: ReqRespServer ByteString ByteString IO () + serverApp = ReqRespServer { + recvMsgReq = \req -> pure (req, serverApp), + recvMsgDone = pure () + } + + +-- +-- client +-- + + +client :: Int -> String -> IO () +client n msg = Win32.Async.withIOManager $ \iocp -> do + hpipe <- createFile pipeName + (gENERIC_READ .|. gENERIC_WRITE) + fILE_SHARE_NONE + Nothing + oPEN_EXISTING + fILE_FLAG_OVERLAPPED + Nothing + Win32.Async.associateWithIOCompletionPort (Left hpipe) iocp + let pipeChannel = Mx.pipeChannelFromNamedPipe hpipe + Mx.runMuxWithPipes + nullTracer + app + pipeChannel + where + app :: Mx.MuxApplication 'Mx.InitiatorApp IO () Void + app = Mx.MuxApplication + [ Mx.MuxMiniProtocol { + Mx.miniProtocolNum = Mx.MiniProtocolNum 2, + Mx.miniProtocolLimits = defaultProtocolLimits, + Mx.miniProtocolRun = Mx.InitiatorProtocolOnly + $ \channel -> runClient debugTracer channel (clientApp n (BSC.pack msg)) + } + ] + + clientApp :: Int -> ByteString -> ReqRespClient ByteString ByteString IO () + clientApp 0 _ = SendMsgDone (pure ()) + clientApp m rawmsg = SendMsgReq rawmsg + (pure . clientApp (pred m)) -- send back request + diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 6872c16726c..0af71114620 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -114,9 +114,31 @@ test-suite test-network-mux if os(windows) build-depends: Win32 >= 2.5.4.1 && <2.9, Win32-network >=0.1 && <0.2 - ghc-options: -Wall -Wno-unticked-promoted-constructors -fno-ignore-asserts + -threaded if flag(ipv6) cpp-options: -DOUROBOROS_NETWORK_IPV6 + +executable mux-demo + if !os(windows) + buildable: False + hs-source-dirs: demo, test + main-is: mux-demo.hs + other-modules: Test.Mux.ReqResp + build-depends: base, + network-mux, + io-sim-classes, + io-sim, + contra-tracer, + + binary, + bytestring, + cborg, + serialise, + Win32, + Win32-network + default-language: Haskell2010 + ghc-options: -Wall + -threaded From 5a7d54dca42e30ba2d5405ed2b77456a8a81726d Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 18 Oct 2019 12:33:27 +0100 Subject: [PATCH 08/33] runMuxWithQueues: let it be polymorphic over peerid --- network-mux/src/Network/Mux/Bearer/Queues.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/network-mux/src/Network/Mux/Bearer/Queues.hs b/network-mux/src/Network/Mux/Bearer/Queues.hs index 658aaf6a84c..8aa6c5cb2a9 100644 --- a/network-mux/src/Network/Mux/Bearer/Queues.hs +++ b/network-mux/src/Network/Mux/Bearer/Queues.hs @@ -86,16 +86,15 @@ runMuxWithQueues , MonadTimer m , Eq (Async m ()) ) - => Tracer m (Mx.WithMuxBearer String Mx.MuxTrace) + => Tracer m Mx.MuxTrace -> Mx.MuxApplication appType m a b -> TBQueue m BL.ByteString -> TBQueue m BL.ByteString -> Word16 -> Maybe (TBQueue m (Mx.MiniProtocolNum, Mx.MiniProtocolMode, Time)) -> m (Maybe SomeException) -runMuxWithQueues tracer app wq rq mtu trace = do - let muxTracer = Mx.WithMuxBearer "Queue" `contramap` tracer - bearer = queuesAsMuxBearer muxTracer wq rq mtu trace +runMuxWithQueues muxTracer app wq rq mtu trace = do + let bearer = queuesAsMuxBearer muxTracer wq rq mtu trace res_e <- try $ Mx.muxStart muxTracer app bearer case res_e of Left e -> return (Just e) From 5baaf0f46b631767bb3cdb7213d095a3e7bb291b Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 23 Jan 2020 18:32:49 +0100 Subject: [PATCH 09/33] Extended mux tests Added tests which run the multiplexer using: - queues - pipes (posix) - named pipes (windows) --- network-mux/test/Test/Mux.hs | 226 +++++++++++++++++++++++++++++------ 1 file changed, 192 insertions(+), 34 deletions(-) diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 2a78e4bfecc..03e181b2c21 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -19,7 +20,6 @@ import Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (..)) import Control.Monad -import Control.Tracer import qualified Data.Binary.Put as Bin import Data.Bits import qualified Data.ByteString.Lazy as BL @@ -28,9 +28,10 @@ import Data.List (dropWhileEnd) import Data.Int import Data.Tuple (swap) import Data.Word +import Data.Void (Void) import Test.QuickCheck import Test.QuickCheck.Gen -import Test.Tasty (TestTree, testGroup) +import Test.Tasty import Test.Tasty.QuickCheck (testProperty) import Text.Printf import qualified System.Random.SplitMix as SM @@ -43,7 +44,16 @@ import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer import Control.Monad.IOSim (runSimStrictShutdown) -import Control.Tracer (nullTracer) +import Control.Tracer (Tracer (..), contramap, nullTracer, showTracing) + +#if defined(mingw32_HOST_OS) +import qualified System.Win32.NamedPipes as Win32.NamedPipes +import qualified System.Win32.File as Win32.File +import qualified System.Win32.Async as Win32.Async +#else +import System.IO (hClose) +import System.Process (createPipe) +#endif import Test.Mux.ReqResp @@ -52,18 +62,22 @@ import qualified Network.Mux.Codec as Mx import qualified Network.Mux.Channel as Mx import qualified Network.Mux.Types as Mx import qualified Network.Mux.Bearer.Queues as Mx +import qualified Network.Mux.Bearer.Pipe as Mx tests :: TestTree tests = testGroup "Mux" - [ testProperty "mux send receive" prop_mux_snd_recv - , testProperty "2 miniprotocols" prop_mux_2_minis - , testProperty "starvation" prop_mux_starvation - , testProperty "demuxing (Sim)" prop_demux_sdu_sim - , testProperty "demuxing (IO)" prop_demux_sdu_io + [ testProperty "mux send receive" prop_mux_snd_recv + , testProperty "1 miniprotocol Queue" (withMaxSuccess 50 prop_mux_1_mini_Queue) + , testProperty "2 miniprotocols Queue" (withMaxSuccess 50 prop_mux_2_minis_Queue) + , testProperty "1 miniprotocol Pipe" (withMaxSuccess 50 prop_mux_1_mini_Pipe) + , testProperty "2 miniprotocols Pipe" (withMaxSuccess 50 prop_mux_2_minis_Pipe) + , testProperty "starvation" prop_mux_starvation + , testProperty "demuxing (Sim)" prop_demux_sdu_sim + , testProperty "demuxing (IO)" prop_demux_sdu_io , testGroup "Generators" - [ testProperty "genByteString" prop_arbitrary_genByteString - , testProperty "genLargeByteString" prop_arbitrary_genLargeByteString + [ testProperty "genByteString" prop_arbitrary_genByteString + , testProperty "genLargeByteString" prop_arbitrary_genLargeByteString ] ] @@ -416,21 +430,162 @@ waitOnAllClients clientVar clientTot = do c <- readTVar clientVar unless (c == clientTot) retry --- | Verify that it is possible to run two miniprotocols over the same bearer. --- Makes sure that messages are delivered to the correct miniprotocol in order. -- -prop_mux_2_minis :: DummyTrace - -> DummyTrace - -> Property -prop_mux_2_minis msgTrace0 msgTrace1 = ioProperty $ do - let sduLen = 14000 +-- Running with queues and pipes +-- + +-- Run applications continuation +type RunMuxApplications a + = Mx.MuxApplication Mx.InitiatorApp IO () Void + -> Mx.MuxApplication Mx.ResponderApp IO Void () + -> ((Maybe SomeException, Maybe SomeException) -> IO a) + -> IO a + +runWithQueues :: RunMuxApplications a +runWithQueues initApp respApp k = do + let sduLen = 14000 client_w <- atomically $ newTBQueue 10 client_r <- atomically $ newTBQueue 10 - endMpsVar <- atomically $ newTVar 4 -- Two initiators and two responders. - let server_w = client_r server_r = client_w + respAsync <- async $ do + Mx.runMuxWithQueues + (Mx.WithMuxBearer "server" `contramap` nullTracer) + respApp server_w server_r sduLen Nothing + initAsync <- async $ do + Mx.runMuxWithQueues + (Mx.WithMuxBearer "client" `contramap` nullTracer) + initApp client_w client_r sduLen Nothing + + waitBoth respAsync initAsync + >>= k + + +runWithPipe :: RunMuxApplications a +runWithPipe initApp respApp k = +#if defined(mingw32_HOST_OS) + Win32.Async.withIOManager $ \iocp -> do + let pipeName = "\\\\.\\pipe\\mux-test-pipe" + bracket + (Win32.NamedPipes.createNamedPipe + pipeName + (Win32.NamedPipes.pIPE_ACCESS_DUPLEX .|. Win32.File.fILE_FLAG_OVERLAPPED) + (Win32.NamedPipes.pIPE_TYPE_BYTE .|. Win32.NamedPipes.pIPE_READMODE_BYTE) + Win32.NamedPipes.pIPE_UNLIMITED_INSTANCES + 512 + 512 + 0 + Nothing) + Win32.File.closeHandle + $ \hSrv -> do + bracket (Win32.File.createFile + pipeName + (Win32.File.gENERIC_READ .|. Win32.File.gENERIC_WRITE) + Win32.File.fILE_SHARE_NONE + Nothing + Win32.File.oPEN_EXISTING + Win32.File.fILE_FLAG_OVERLAPPED + Nothing) + Win32.File.closeHandle + $ \hCli -> do + Win32.Async.associateWithIOCompletionPort (Left hSrv) iocp + Win32.Async.associateWithIOCompletionPort (Left hCli) iocp + initAsync <- async $ do + let clientChannel = Mx.pipeChannelFromNamedPipe hCli + res <- try $ Mx.runMuxWithPipes + (Mx.WithMuxBearer "client" `contramap` showTracing nullTracer) + initApp clientChannel + pure $ either Just (const Nothing) res + + respAsync <- async $ do + Win32.Async.connectNamedPipe hSrv + let serverChannel = Mx.pipeChannelFromNamedPipe hSrv + res <- try $ Mx.runMuxWithPipes + (Mx.WithMuxBearer "server"`contramap` showTracing nullTracer) + respApp serverChannel + pure $ either Just (const Nothing) res + + waitBoth respAsync initAsync + >>= k +#else + bracket + ((,) <$> createPipe <*> createPipe) + (\((rCli, wCli), (rSrv, wSrv)) -> do + hClose rCli + hClose wCli + hClose rSrv + hClose wSrv) + $ \ ((rCli, wCli), (rSrv, wSrv)) -> do + initAsync <- async $ do + let clientChannel = Mx.pipeChannelFromHandles rCli wSrv + res <- try $ + Mx.runMuxWithPipes + (Mx.WithMuxBearer "client" `contramap` showTracing nullTracer) + initApp clientChannel + pure $ either Just (const Nothing) res + respAsync <- async $ do + let serverChannel = Mx.pipeChannelFromHandles rSrv wCli + res <- try $ + Mx.runMuxWithPipes + (Mx.WithMuxBearer "server"`contramap` showTracing nullTracer) + respApp serverChannel + pure $ either Just (const Nothing) res + + waitBoth respAsync initAsync + >>= k +#endif + +-- | Verify that it is possible to run two miniprotocols over the same bearer. +-- Makes sure that messages are delivered to the correct miniprotocol in order. +-- +test_mux_1_mini :: RunMuxApplications Bool + -> DummyTrace + -> IO Bool +test_mux_1_mini run msgTrace = do + + endMpsVar <- atomically $ newTVar 2 + + (verify, client_mp, server_mp) <- + setupMiniReqRsp (return ()) endMpsVar msgTrace + + let clientApp = Mx.MuxApplication + [ Mx.MuxMiniProtocol { + Mx.miniProtocolNum = Mx.MiniProtocolNum 2, + Mx.miniProtocolLimits = defaultMiniProtocolLimits, + Mx.miniProtocolRun = Mx.InitiatorProtocolOnly client_mp + } + ] + serverApp = Mx.MuxApplication + [ Mx.MuxMiniProtocol { + Mx.miniProtocolNum = Mx.MiniProtocolNum 2, + Mx.miniProtocolLimits = defaultMiniProtocolLimits, + Mx.miniProtocolRun = Mx.ResponderProtocolOnly server_mp + } + ] + + run clientApp serverApp + $ \r -> case r of + (Just _, _) -> return False + (_, Just _) -> return False + _ -> verify + +prop_mux_1_mini_Queue :: DummyTrace -> Property +prop_mux_1_mini_Queue = ioProperty . test_mux_1_mini runWithQueues + +prop_mux_1_mini_Pipe :: DummyTrace -> Property +prop_mux_1_mini_Pipe = ioProperty . test_mux_1_mini runWithPipe + +-- | Verify that it is possible to run two miniprotocols over the same bearer. +-- Makes sure that messages are delivered to the correct miniprotocol in order. +-- +test_mux_2_minis + :: RunMuxApplications Bool + -> DummyTrace + -> DummyTrace + -> IO Bool +test_mux_2_minis run msgTrace0 msgTrace1 = do + endMpsVar <- atomically $ newTVar 4 -- Two initiators and two responders. (verify_0, client_mp0, server_mp0) <- setupMiniReqRsp (return ()) endMpsVar msgTrace0 @@ -463,23 +618,26 @@ prop_mux_2_minis msgTrace0 msgTrace1 = ioProperty $ do } ] - clientAsync <- async $ Mx.runMuxWithQueues - (contramap (Mx.WithMuxBearer "client") activeTracer) - clientApp client_w client_r sduLen Nothing - serverAsync <- async $ Mx.runMuxWithQueues - (contramap (Mx.WithMuxBearer "server") activeTracer) - serverApp server_w server_r sduLen Nothing + run clientApp serverApp + $ \r -> case r of + (Just _, _) -> return False + (_, Just _) -> return False + _ -> do + res0 <- verify_0 + res1 <- verify_1 + return $ res0 && res1 - r <- waitBoth clientAsync serverAsync - case r of - (Just _, _) -> return $ property False - (_, Just _) -> return $ property False - _ -> do - res0 <- verify_0 - res1 <- verify_1 +prop_mux_2_minis_Queue :: DummyTrace + -> DummyTrace + -> Property +prop_mux_2_minis_Queue a b = ioProperty $ test_mux_2_minis runWithQueues a b + +prop_mux_2_minis_Pipe :: DummyTrace + -> DummyTrace + -> Property +prop_mux_2_minis_Pipe a b = ioProperty $ test_mux_2_minis runWithPipe a b - return $ property $ res0 .&&. res1 -- | Attempt to verify that capacity is diveded fairly between two active -- miniprotocols. Two initiators send a request over two different @@ -759,7 +917,7 @@ prop_demux_sdu a = do blob = toLazyByteString $ Mx.encodeControlMsg msg pkt = Mx.MuxSDU (Mx.RemoteClockModel 0) Mx.Muxcontrol Mx.ModeInitiator (fromIntegral $ BL.length blob) blob - atomically $ writeTBQueue q $ Mx.encodeMuxSDU (pkt :: Mx.MuxSDU TestProtocols1) + atomically $ writeTBQueue q $ Mx.encodeMuxSDU (pkt :: Mx.MuxSDU) return () -} setup _ _ = return () From ec269f0940f5578c13cc0f68cedbdc7d9ae305bf Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 12:26:32 +0100 Subject: [PATCH 10/33] ouroboros-network: IOManager A shim layer for Windows async IO and GHC System.IO. On *nix GHC runtime system runs io manager thread, this patch does the same on Windows, but explicitly. On *nix the `withIOManager` is no-op what is reflected by its type. --- ouroboros-network/ouroboros-network.cabal | 5 ++ .../src/Ouroboros/Network/IOManager.hs | 49 +++++++++++++++++++ 2 files changed, 54 insertions(+) create mode 100644 ouroboros-network/src/Ouroboros/Network/IOManager.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 5aa54f35acc..8e49fb21ebb 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -55,6 +55,7 @@ library Ouroboros.Network.ChainFragment Ouroboros.Network.Channel Ouroboros.Network.DeltaQ + Ouroboros.Network.IOManager Ouroboros.Network.Magic Ouroboros.Network.ErrorPolicy Ouroboros.Network.Mux @@ -162,6 +163,10 @@ library stm >=2.4 && <2.6, time >=1.6 && <1.10 + if os(windows) + build-depends: Win32-network <0.2.0.0, + Win32 >= 2.5.4.1 && <2.9 + ghc-options: -Wall -Wno-unticked-promoted-constructors if flag(asserts) diff --git a/ouroboros-network/src/Ouroboros/Network/IOManager.hs b/ouroboros-network/src/Ouroboros/Network/IOManager.hs new file mode 100644 index 00000000000..b740d9c429c --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/IOManager.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | A shim layer for `Win32-network`'s `IOManager` +-- +module Ouroboros.Network.IOManager + ( WithIOManager + , AssociateWithIOCP (..) + , withIOManager + ) where + + +#if defined(mingw32_HOST_OS) +import System.Win32.Types (HANDLE) +import qualified System.Win32.Async.IOManager as Win32.Async +import Network.Socket (Socket) +#endif + +-- | On Windows 'AssociateWithIOCP' holds +-- `System.Win32.Async.IOManager.associateWithIOCompletionPort'; +-- on other platforms 'AssociateWithIOCP' can run over any type, and thus is +-- guaranteed to be no-op. +-- +#if defined(mingw32_HOST_OS) +newtype AssociateWithIOCP = AssociateWithIOCP { + associateWithIOCP :: Either HANDLE Socket -> IO () + } +#else +newtype AssociateWithIOCP = AssociateWithIOCP { + associateWithIOCP :: forall hole. hole -> IO () + } +#endif + + +type WithIOManager = forall a. (AssociateWithIOCP -> IO a) -> IO a + + +-- | 'withIOManger' must be called only once at the top level. We wrap the +-- 'associateWithIOCompletionPort' in a newtype wrapper since it will be +-- carried arround through the application. +-- +withIOManager :: WithIOManager +#if defined(mingw32_HOST_OS) +withIOManager = \f -> + Win32.Async.withIOManager $ + \iocp -> f (AssociateWithIOCP $ \fd -> Win32.Async.associateWithIOCompletionPort fd iocp) +#else +withIOManager = \f -> f (AssociateWithIOCP $ \_ -> pure ()) +#endif From 4733dfcfde733832deced0c28b9b51846ac7389f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 13:26:39 +0100 Subject: [PATCH 11/33] ConnectionId makde polymorphic over address type ConnectionId will be used for sockets and named pipes and thus needs to be polymorphic over the address type. --- ouroboros-network/demo/chain-sync.hs | 20 ++++----- .../src/Ouroboros/Network/Diffusion.hs | 14 +++---- .../src/Ouroboros/Network/NodeToClient.hs | 20 ++++----- .../src/Ouroboros/Network/NodeToNode.hs | 28 ++++++------- .../src/Ouroboros/Network/Socket.hs | 41 ++++++++++--------- .../src/Ouroboros/Network/Tracers.hs | 12 +++--- ouroboros-network/test/Test/Socket.hs | 10 ++--- ouroboros-network/test/Test/Subscription.hs | 6 +-- 8 files changed, 76 insertions(+), 75 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 3a19c91dfbf..bd6e014883f 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -166,7 +166,7 @@ clientPingPong pipelined = defaultLocalSocketAddrInfo where app :: OuroborosApplication InitiatorApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol0 IO LBS.ByteString () Void app = simpleInitiatorApplication protocols @@ -206,7 +206,7 @@ serverPingPong = do wait serverAsync -- block until async exception where app :: OuroborosApplication ResponderApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol0 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -255,7 +255,7 @@ clientPingPong2 = defaultLocalSocketAddrInfo where app :: OuroborosApplication InitiatorApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol1 IO LBS.ByteString () Void app = simpleInitiatorApplication protocols @@ -308,7 +308,7 @@ serverPingPong2 = do wait serverAsync -- block until async exception where app :: OuroborosApplication ResponderApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol1 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -354,7 +354,7 @@ clientChainSync sockAddrs = (mkLocalSocketAddrInfo sockAddr) where app :: OuroborosApplication InitiatorApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol2 IO LBS.ByteString () Void app = simpleInitiatorApplication protocols @@ -386,7 +386,7 @@ serverChainSync sockAddr = do prng = mkSMGen 0 app :: OuroborosApplication ResponderApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol2 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -439,12 +439,12 @@ clientBlockFetch sockAddrs = do currentChainVar <- newTVarIO genesisChainFragment let app :: OuroborosApplication InitiatorApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol3 IO LBS.ByteString () Void app = OuroborosInitiatorApplication protocols - protocols :: ConnectionId + protocols :: ConnectionId Socket.SockAddr -> DemoProtocol3 -> Channel IO LBS.ByteString -> IO () @@ -475,7 +475,7 @@ clientBlockFetch sockAddrs = do (blockFetchClient clientCtx) blockFetchPolicy :: BlockFetchConsensusInterface - ConnectionId BlockHeader Block IO + (ConnectionId Socket.SockAddr) BlockHeader Block IO blockFetchPolicy = BlockFetchConsensusInterface { readCandidateChains = readTVar candidateChainsVar @@ -588,7 +588,7 @@ serverBlockFetch sockAddr = do prng = mkSMGen 0 app :: OuroborosApplication ResponderApp - ConnectionId + (ConnectionId Socket.SockAddr) DemoProtocol3 IO LBS.ByteString Void () app = simpleResponderApplication protocols diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 6b1994d999c..bd2fa9709c0 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -59,14 +59,14 @@ data DiffusionTracers = DiffusionTracers { -- ^ DNS subscription tracer , dtDnsResolverTracer :: Tracer IO (WithDomainName DnsTrace) -- ^ DNS resolver tracer - , dtMuxTracer :: Tracer IO (WithMuxBearer ConnectionId MuxTrace) + , dtMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace) -- ^ Mux tracer - , dtMuxLocalTracer :: Tracer IO (WithMuxBearer ConnectionId MuxTrace) + , dtMuxLocalTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace) -- ^ Mux tracer for local clients - , dtHandshakeTracer :: Tracer IO (WithMuxBearer ConnectionId + , dtHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake NodeToNodeVersion CBOR.Term))) -- ^ Handshake protocol tracer - , dtHandshakeLocalTracer :: Tracer IO (WithMuxBearer ConnectionId + , dtHandshakeLocalTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake NodeToClientVersion CBOR.Term))) -- ^ Handshake protocol tracer for local clients , dtErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace) @@ -93,7 +93,7 @@ data DiffusionApplications = DiffusionApplications { DictVersion (OuroborosApplication 'ResponderApp - ConnectionId + (ConnectionId SockAddr) NodeToNodeProtocols IO ByteString @@ -106,7 +106,7 @@ data DiffusionApplications = DiffusionApplications { DictVersion (OuroborosApplication 'InitiatorApp - ConnectionId + (ConnectionId SockAddr) NodeToNodeProtocols IO ByteString @@ -118,7 +118,7 @@ data DiffusionApplications = DiffusionApplications { DictVersion (OuroborosApplication 'ResponderApp - ConnectionId + (ConnectionId SockAddr) NodeToClientProtocols IO ByteString diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index b0b3e7c9e21..a19ba6f218d 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -153,10 +153,10 @@ nodeToClientCodecCBORTerm = CodecCBORTerm {encodeTerm, decodeTerm} -- protocol. This is mostly useful for future enhancements. -- connectTo - :: NetworkConnectTracers NodeToClientProtocols NodeToClientVersion + :: NetworkConnectTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion -> Versions NodeToClientVersion DictVersion - (OuroborosApplication InitiatorApp ConnectionId NodeToClientProtocols IO BL.ByteString a b) + (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). @@ -171,11 +171,11 @@ connectTo = connectToNode cborTermVersionDataCodec -- the 'NodeToClientV_1' version of the protocol. -- connectTo_V1 - :: NetworkConnectTracers NodeToClientProtocols NodeToClientVersion + :: NetworkConnectTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and -- server must agree on it. - -> (OuroborosApplication InitiatorApp ConnectionId NodeToClientProtocols IO BL.ByteString a b) + -> (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) -- ^ 'OuroborosInitiatorApplication' which is run on an established connection -- using a multiplexer after the initial handshake protocol suceeds. -> Maybe Socket.AddrInfo @@ -204,7 +204,7 @@ withServer -> NetworkMutableState -> Socket.AddrInfo -> Versions NodeToClientVersion DictVersion - (OuroborosApplication appType ConnectionId NodeToClientProtocols IO BL.ByteString a b) + (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) -> ErrorPolicies Socket.SockAddr () -> IO Void withServer tracers networkState addr versions errPolicies = @@ -229,7 +229,7 @@ withServer_V1 -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and -- server must agree on it. - -> (OuroborosApplication appType ConnectionId NodeToClientProtocols IO BL.ByteString a b) + -> (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) -- ^ applications which has the reponder side, i.e. -- 'OuroborosResponderApplication' or -- 'OuroborosInitiatorAndResponderApplication'. @@ -250,7 +250,7 @@ withServer_V1 tracers networkState addr versionData application = ncSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers NodeToClientProtocols NodeToClientVersion + => NetworkIPSubscriptionTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion -> NetworkMutableState -> IPSubscriptionParams () -> Versions @@ -258,7 +258,7 @@ ncSubscriptionWorker DictVersion (OuroborosApplication appType - ConnectionId + (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString x y) -> IO Void @@ -288,13 +288,13 @@ ncSubscriptionWorker ncSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers NodeToClientProtocols NodeToClientVersion + => NetworkIPSubscriptionTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion -> NetworkMutableState -> IPSubscriptionParams () -> NodeToClientVersionData -> (OuroborosApplication appType - ConnectionId + (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString x y) -> IO Void diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index d669fa0941b..968fdcc7d6b 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -185,10 +185,10 @@ nodeToNodeCodecCBORTerm = CodecCBORTerm {encodeTerm, decodeTerm} -- | A specialised version of @'Ouroboros.Network.Socket.connectToNode'@. -- connectTo - :: NetworkConnectTracers NodeToNodeProtocols NodeToNodeVersion + :: NetworkConnectTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> Versions NodeToNodeVersion DictVersion - (OuroborosApplication InitiatorApp ConnectionId NodeToNodeProtocols IO BL.ByteString a b) + (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) -> Maybe Socket.AddrInfo -> Socket.AddrInfo -> IO () @@ -198,9 +198,9 @@ connectTo = connectToNode cborTermVersionDataCodec -- | Like 'connectTo' but specific to 'NodeToNodeV_1'. -- connectTo_V1 - :: NetworkConnectTracers NodeToNodeProtocols NodeToNodeVersion + :: NetworkConnectTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NodeToNodeVersionData - -> (OuroborosApplication InitiatorApp ConnectionId NodeToNodeProtocols IO BL.ByteString a b) + -> (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) -> Maybe Socket.AddrInfo -> Socket.AddrInfo -> IO () @@ -228,7 +228,7 @@ withServer => NetworkServerTracers NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState -> Socket.AddrInfo - -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType ConnectionId NodeToNodeProtocols IO BL.ByteString a b) + -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) -> ErrorPolicies Socket.SockAddr () -> IO Void withServer tracers networkState addr versions errPolicies = @@ -251,7 +251,7 @@ withServer_V1 -> NetworkMutableState -> Socket.AddrInfo -> NodeToNodeVersionData - -> (OuroborosApplication appType ConnectionId NodeToNodeProtocols IO BL.ByteString x y) + -> (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) -> ErrorPolicies Socket.SockAddr () -> IO Void withServer_V1 tracers networkState addr versionData application = @@ -270,7 +270,7 @@ withServer_V1 tracers networkState addr versionData application = ipSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion + => NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState -> IPSubscriptionParams () -> Versions @@ -278,7 +278,7 @@ ipSubscriptionWorker DictVersion (OuroborosApplication appType - ConnectionId + (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) -> IO Void @@ -308,13 +308,13 @@ ipSubscriptionWorker ipSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion + => NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState -> IPSubscriptionParams () -> NodeToNodeVersionData -> (OuroborosApplication appType - ConnectionId + (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) -> IO Void @@ -341,7 +341,7 @@ ipSubscriptionWorker_V1 dnsSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion ConnectionId + => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) -> NetworkMutableState -> DnsSubscriptionParams () -> Versions @@ -349,7 +349,7 @@ dnsSubscriptionWorker DictVersion (OuroborosApplication appType - ConnectionId + (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) -> IO Void @@ -381,13 +381,13 @@ dnsSubscriptionWorker dnsSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion ConnectionId + => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) -> NetworkMutableState -> DnsSubscriptionParams () -> NodeToNodeVersionData -> (OuroborosApplication appType - ConnectionId + (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) -> IO Void diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index a8b80c75966..eca7afdbc34 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -64,10 +65,11 @@ import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy as BL import Data.Int import Data.Void +import GHC.Generics (Generic) import qualified Network.Socket as Socket -import Cardano.Prelude (NoUnexpectedThunks (..), ThunkInfo (..)) +import Cardano.Prelude (NoUnexpectedThunks (..)) import Control.Tracer @@ -94,17 +96,17 @@ import Ouroboros.Network.Server.ConnectionTable -- 'Ouroboros.Network.NodeToNode.connectTo' or -- 'Ouroboros.Network.NodeToClient.connectTo). -- -data NetworkConnectTracers ptcl vNumber = NetworkConnectTracers { - nctMuxTracer :: Tracer IO (Mx.WithMuxBearer ConnectionId Mx.MuxTrace), +data NetworkConnectTracers addr ptcl vNumber = NetworkConnectTracers { + nctMuxTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId addr) Mx.MuxTrace), -- ^ low level mux-network tracer, which logs mux sdu (send and received) -- and other low level multiplexing events. - nctHandshakeTracer :: Tracer IO (Mx.WithMuxBearer ConnectionId + nctHandshakeTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))) -- ^ handshake protocol tracer; it is important for analysing version -- negotation mismatches. } -nullNetworkConnectTracers :: NetworkConnectTracers ptcl vNumber +nullNetworkConnectTracers :: NetworkConnectTracers addr ptcl vNumber nullNetworkConnectTracers = NetworkConnectTracers { nctMuxTracer = nullTracer, nctHandshakeTracer = nullTracer @@ -116,15 +118,14 @@ nullNetworkConnectTracers = NetworkConnectTracers { -- TODO: the type variable which this data type fills in is called `peerid`. We -- should renamed to `connectionId`. -- -data ConnectionId = ConnectionId { - localAddress :: !Socket.SockAddr, - remoteAddress :: !Socket.SockAddr +data ConnectionId addr = ConnectionId { + localAddress :: !addr, + remoteAddress :: !addr } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance NoUnexpectedThunks addr => NoUnexpectedThunks (ConnectionId addr) -instance NoUnexpectedThunks ConnectionId where - showTypeOf _ = "Peer" - whnfNoUnexpectedThunks _ctxt _act = return NoUnexpectedThunks -- | -- We assume that a TCP segment size of 1440 bytes with initial window of size @@ -160,8 +161,8 @@ connectToNode , Mx.HasInitiator appType ~ True ) => VersionDataCodec extra CBOR.Term - -> NetworkConnectTracers ptcl vNumber - -> Versions vNumber extra (OuroborosApplication appType ConnectionId ptcl IO BL.ByteString a b) + -> NetworkConnectTracers Socket.SockAddr ptcl vNumber + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) -- ^ application to run over the connection -> Maybe Socket.AddrInfo -- ^ local address; the created socket will bind to it @@ -213,8 +214,8 @@ connectToNode' , Mx.HasInitiator appType ~ True ) => VersionDataCodec extra CBOR.Term - -> NetworkConnectTracers ptcl vNumber - -> Versions vNumber extra (OuroborosApplication appType ConnectionId ptcl IO BL.ByteString a b) + -> NetworkConnectTracers Socket.SockAddr ptcl vNumber + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) -- ^ application to run over the connection -> Socket.Socket -> IO () @@ -369,10 +370,10 @@ fromSocket tblVar sd = Server.Socket -- | Tracers required by a server which handles inbound connections. -- data NetworkServerTracers ptcl vNumber = NetworkServerTracers { - nstMuxTracer :: Tracer IO (Mx.WithMuxBearer ConnectionId Mx.MuxTrace), + nstMuxTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId Socket.SockAddr) Mx.MuxTrace), -- ^ low level mux-network tracer, which logs mux sdu (send and received) -- and other low level multiplexing events. - nstHandshakeTracer :: Tracer IO (Mx.WithMuxBearer ConnectionId + nstHandshakeTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId Socket.SockAddr) (TraceSendRecv (Handshake vNumber CBOR.Term))), -- ^ handshake protocol tracer; it is important for analysing version -- negotation mismatches. @@ -439,7 +440,7 @@ runServerThread -> Socket.Socket -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) - -> Versions vNumber extra (OuroborosApplication appType ConnectionId ptcl IO BL.ByteString a b) + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) -> ErrorPolicies Socket.SockAddr () -> IO Void runServerThread NetworkServerTracers { nstMuxTracer @@ -533,7 +534,7 @@ withServerNode -> Socket.AddrInfo -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) - -> Versions vNumber extra (OuroborosApplication appType ConnectionId ptcl IO BL.ByteString a b) + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) -- ^ The mux application that will be run on each incoming connection from -- a given address. Note that if @'MuxClientAndServerApplication'@ is -- returned, the connection will run a full duplex set of mini-protocols. diff --git a/ouroboros-network/src/Ouroboros/Network/Tracers.hs b/ouroboros-network/src/Ouroboros/Network/Tracers.hs index b75526d28e1..37149224cfd 100644 --- a/ouroboros-network/src/Ouroboros/Network/Tracers.hs +++ b/ouroboros-network/src/Ouroboros/Network/Tracers.hs @@ -21,24 +21,24 @@ import Ouroboros.Network.Subscription.Dns -- | IP subscription tracers. -- -data NetworkIPSubscriptionTracers ptcl vNumber = NetworkIPSubscriptionTracers { - nistMuxTracer :: Tracer IO (WithMuxBearer ConnectionId MuxTrace), +data NetworkIPSubscriptionTracers addr ptcl vNumber = NetworkIPSubscriptionTracers { + nistMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace), -- ^ low level mux-network tracer, which logs mux sdu (send and received) -- and other low level multiplexing events. - nistHandshakeTracer :: Tracer IO (WithMuxBearer ConnectionId + nistHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))), -- ^ handshake protocol tracer; it is important for analysing version -- negotation mismatches. - nistErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace), + nistErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), -- ^ error policy tracer; must not be 'nullTracer', otherwise all the -- exceptions which are not matched by any error policy will be caught -- and not logged or rethrown. - nistSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr)) + nistSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace addr)) -- ^ subscription tracers; it is infrequent it should not be 'nullTracer' -- by default. } -nullNetworkIPSubscriptionTracers :: NetworkIPSubscriptionTracers ptcl vNumber +nullNetworkIPSubscriptionTracers :: NetworkIPSubscriptionTracers addr ptcl vNumber nullNetworkIPSubscriptionTracers = NetworkIPSubscriptionTracers { nistMuxTracer = nullTracer, nistHandshakeTracer = nullTracer, diff --git a/ouroboros-network/test/Test/Socket.hs b/ouroboros-network/test/Test/Socket.hs index f25c79d0660..afa05c622ec 100644 --- a/ouroboros-network/test/Test/Socket.hs +++ b/ouroboros-network/test/Test/Socket.hs @@ -214,7 +214,7 @@ prop_socket_send_recv initiatorAddr responderAddr f xs = do siblingVar <- newTVarM 2 let -- Server Node; only req-resp server - responderApp :: OuroborosApplication Mx.ResponderApp ConnectionId TestProtocols2 IO BL.ByteString Void () + responderApp :: OuroborosApplication Mx.ResponderApp (ConnectionId Socket.SockAddr) TestProtocols2 IO BL.ByteString Void () responderApp = OuroborosResponderApplication $ \_peerid ReqRespPr channel -> do r <- runPeer nullTracer @@ -225,7 +225,7 @@ prop_socket_send_recv initiatorAddr responderAddr f xs = do waitSibling siblingVar -- Client Node; only req-resp client - initiatorApp :: OuroborosApplication Mx.InitiatorApp ConnectionId TestProtocols2 IO BL.ByteString () Void + initiatorApp :: OuroborosApplication Mx.InitiatorApp (ConnectionId Socket.SockAddr) TestProtocols2 IO BL.ByteString () Void initiatorApp = OuroborosInitiatorApplication $ \_peerid ReqRespPr channel -> do r <- runPeer nullTracer @@ -335,7 +335,7 @@ prop_socket_client_connect_error _ xs = ioProperty $ do cv <- newEmptyTMVarM - let app :: OuroborosApplication Mx.InitiatorApp ConnectionId TestProtocols2 IO BL.ByteString () Void + let app :: OuroborosApplication Mx.InitiatorApp (ConnectionId Socket.SockAddr) TestProtocols2 IO BL.ByteString () Void app = OuroborosInitiatorApplication $ \_peerid ReqRespPr channel -> do _ <- runPeer nullTracer @@ -374,7 +374,7 @@ demo chain0 updates = do let Just expectedChain = Chain.applyChainUpdates updates chain0 target = Chain.headPoint expectedChain - initiatorApp :: OuroborosApplication Mx.InitiatorApp ConnectionId TestProtocols1 IO BL.ByteString () Void + initiatorApp :: OuroborosApplication Mx.InitiatorApp (ConnectionId Socket.SockAddr) TestProtocols1 IO BL.ByteString () Void initiatorApp = simpleInitiatorApplication $ \ChainSyncPr -> MuxPeer nullTracer @@ -386,7 +386,7 @@ demo chain0 updates = do server :: ChainSync.ChainSyncServer block (Tip block) IO () server = ChainSync.chainSyncServerExample () producerVar - responderApp :: OuroborosApplication Mx.ResponderApp ConnectionId TestProtocols1 IO BL.ByteString Void () + responderApp :: OuroborosApplication Mx.ResponderApp (ConnectionId Socket.SockAddr) TestProtocols1 IO BL.ByteString Void () responderApp = simpleResponderApplication $ \ChainSyncPr -> MuxPeer nullTracer diff --git a/ouroboros-network/test/Test/Subscription.hs b/ouroboros-network/test/Test/Subscription.hs index b9f9c049912..e9495134ab7 100644 --- a/ouroboros-network/test/Test/Subscription.hs +++ b/ouroboros-network/test/Test/Subscription.hs @@ -524,7 +524,7 @@ prop_send_recv f xs first = ioProperty $ do clientTbl <- newConnectionTable let -- Server Node; only req-resp server - responderApp :: OuroborosApplication ResponderApp ConnectionId TestProtocols2 IO BL.ByteString Void () + responderApp :: OuroborosApplication ResponderApp (ConnectionId Socket.SockAddr) TestProtocols2 IO BL.ByteString Void () responderApp = OuroborosResponderApplication $ \_peerid ReqRespPr channel -> do r <- runPeer (tagTrace "Responder" activeTracer) @@ -535,7 +535,7 @@ prop_send_recv f xs first = ioProperty $ do waitSiblingSub siblingVar -- Client Node; only req-resp client - initiatorApp :: OuroborosApplication InitiatorApp ConnectionId TestProtocols2 IO BL.ByteString () Void + initiatorApp :: OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) TestProtocols2 IO BL.ByteString () Void initiatorApp = OuroborosInitiatorApplication $ \_peerid ReqRespPr channel -> do r <- runPeer (tagTrace "Initiator" activeTracer) @@ -651,7 +651,7 @@ prop_send_recv_init_and_rsp f xs = ioProperty $ do where - appX :: ReqRspCfg -> OuroborosApplication InitiatorAndResponderApp ConnectionId TestProtocols2 IO BL.ByteString () () + appX :: ReqRspCfg -> OuroborosApplication InitiatorAndResponderApp (ConnectionId Socket.SockAddr) TestProtocols2 IO BL.ByteString () () appX ReqRspCfg {rrcTag, rrcServerVar, rrcClientVar, rrcSiblingVar} = OuroborosInitiatorAndResponderApplication -- Initiator (\_peerid ReqRespPr channel -> do From 261bd1081b5159a381da19191d1954cf58ad5d55 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 14:12:35 +0100 Subject: [PATCH 12/33] NetworkMutableState made polymorphic over address type --- .../src/Ouroboros/Network/Diffusion.hs | 8 ++++---- .../src/Ouroboros/Network/NodeToClient.hs | 8 ++++---- .../src/Ouroboros/Network/NodeToNode.hs | 12 ++++++------ .../src/Ouroboros/Network/Socket.hs | 16 ++++++++-------- .../src/Ouroboros/Network/Subscription/Dns.hs | 4 ++-- .../src/Ouroboros/Network/Subscription/Ip.hs | 4 ++-- 6 files changed, 26 insertions(+), 26 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index bd2fa9709c0..14f751674b6 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -207,7 +207,7 @@ runDataDiffusion tracers remoteErrorPolicy = NodeToNode.remoteNetworkErrorPolicy <> daErrorPolicies localErrorPolicy = NodeToNode.localNetworkErrorPolicy <> daErrorPolicies - runLocalServer :: NetworkMutableState -> IO Void + runLocalServer :: NetworkMutableState SockAddr -> IO Void runLocalServer networkLocalState = NodeToClient.withServer (NetworkServerTracers @@ -219,7 +219,7 @@ runDataDiffusion tracers (daLocalResponderApplication applications) localErrorPolicy - runServer :: NetworkMutableState -> AddrInfo -> IO Void + runServer :: NetworkMutableState SockAddr -> AddrInfo -> IO Void runServer networkState address = NodeToNode.withServer (NetworkServerTracers @@ -231,7 +231,7 @@ runDataDiffusion tracers (daResponderApplication applications) remoteErrorPolicy - runIpSubscriptionWorker :: NetworkMutableState -> IO Void + runIpSubscriptionWorker :: NetworkMutableState SockAddr -> IO Void runIpSubscriptionWorker networkState = NodeToNode.ipSubscriptionWorker (NetworkIPSubscriptionTracers dtMuxTracer @@ -247,7 +247,7 @@ runDataDiffusion tracers } (daInitiatorApplication applications) - runDnsSubscriptionWorker :: NetworkMutableState -> DnsSubscriptionTarget -> IO Void + runDnsSubscriptionWorker :: NetworkMutableState SockAddr -> DnsSubscriptionTarget -> IO Void runDnsSubscriptionWorker networkState dnsProducer = NodeToNode.dnsSubscriptionWorker (NetworkDNSSubscriptionTracers dtMuxTracer diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index a19ba6f218d..fd3ff828976 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -201,7 +201,7 @@ connectTo_V1 tracers versionData application = withServer :: ( HasResponder appType ~ True ) => NetworkServerTracers NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> Versions NodeToClientVersion DictVersion (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) @@ -224,7 +224,7 @@ withServer tracers networkState addr versions errPolicies = withServer_V1 :: ( HasResponder appType ~ True ) => NetworkServerTracers NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and @@ -251,7 +251,7 @@ ncSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) => NetworkIPSubscriptionTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams () -> Versions NodeToClientVersion @@ -289,7 +289,7 @@ ncSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) => NetworkIPSubscriptionTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams () -> NodeToClientVersionData -> (OuroborosApplication diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 968fdcc7d6b..46dbdadc4d9 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -226,7 +226,7 @@ connectTo_V1 tracers versionData application localAddr remoteAddr = withServer :: ( HasResponder appType ~ True) => NetworkServerTracers NodeToNodeProtocols NodeToNodeVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) -> ErrorPolicies Socket.SockAddr () @@ -248,7 +248,7 @@ withServer tracers networkState addr versions errPolicies = withServer_V1 :: ( HasResponder appType ~ True ) => NetworkServerTracers NodeToNodeProtocols NodeToNodeVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> NodeToNodeVersionData -> (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) @@ -271,7 +271,7 @@ ipSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) => NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams () -> Versions NodeToNodeVersion @@ -309,7 +309,7 @@ ipSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) => NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams () -> NodeToNodeVersionData -> (OuroborosApplication @@ -342,7 +342,7 @@ dnsSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams () -> Versions NodeToNodeVersion @@ -382,7 +382,7 @@ dnsSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams () -> NodeToNodeVersionData -> (OuroborosApplication diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index eca7afdbc34..6e53af354da 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -393,26 +393,26 @@ nullNetworkServerTracers = NetworkServerTracers { -- | Mutable state maintained by the network component. -- -data NetworkMutableState = NetworkMutableState { - nmsConnectionTable :: ConnectionTable IO Socket.SockAddr, +data NetworkMutableState addr = NetworkMutableState { + nmsConnectionTable :: ConnectionTable IO addr, -- ^ 'ConnectionTable' which maintains information about current upstream and -- downstream connections. - nmsPeerStates :: StrictTVar IO (PeerStates IO Socket.SockAddr) + nmsPeerStates :: StrictTVar IO (PeerStates IO addr) -- ^ 'PeerStates' which maintains state of each downstream / upstream peer -- that errored, misbehaved or was not interesting to us. } -newNetworkMutableStateSTM :: STM.STM NetworkMutableState +newNetworkMutableStateSTM :: STM.STM (NetworkMutableState addr) newNetworkMutableStateSTM = NetworkMutableState <$> newConnectionTableSTM <*> newPeerStatesVarSTM -newNetworkMutableState :: IO NetworkMutableState +newNetworkMutableState :: IO (NetworkMutableState addr) newNetworkMutableState = atomically newNetworkMutableStateSTM -- | Clean 'PeerStates' within 'NetworkMutableState' every 200s -- -cleanNetworkMutableState :: NetworkMutableState +cleanNetworkMutableState :: NetworkMutableState addr -> IO () cleanNetworkMutableState NetworkMutableState {nmsPeerStates} = cleanPeerStates 200 nmsPeerStates @@ -436,7 +436,7 @@ runServerThread , Show vNumber ) => NetworkServerTracers ptcl vNumber - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Socket.Socket -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) @@ -530,7 +530,7 @@ withServerNode , Show vNumber ) => NetworkServerTracers ptcl vNumber - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs index beec1f57128..d7484d11b37 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs @@ -223,7 +223,7 @@ dnsSubscriptionWorker' :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) -> Tracer IO (WithDomainName DnsTrace) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> Resolver IO -> DnsSubscriptionParams a -> Main IO (PeerStates IO Socket.SockAddr) x @@ -260,7 +260,7 @@ dnsSubscriptionWorker :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) -> Tracer IO (WithDomainName DnsTrace) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams a -> (Socket.Socket -> IO a) -> IO Void diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs index c2e6d2345d3..c5c1251d757 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs @@ -78,7 +78,7 @@ ipSubscriptionWorker :: forall a. Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr)) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams a -> (Socket.Socket -> IO a) -> IO Void @@ -175,7 +175,7 @@ mainTx PeerStates{} = retry subscriptionWorker :: Tracer IO (SubscriptionTrace Socket.SockAddr) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) - -> NetworkMutableState + -> NetworkMutableState Socket.SockAddr -> WorkerParams IO Socket.SockAddr -> ErrorPolicies Socket.SockAddr a -> Main IO (PeerStates IO Socket.SockAddr) x From 44e8d9cadb3760c9036538033b451fc4362b68d8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 13:57:58 +0100 Subject: [PATCH 13/33] NetworkServerTracers made polymorphic over address type --- .../src/Ouroboros/Network/NodeToClient.hs | 4 ++-- .../src/Ouroboros/Network/NodeToNode.hs | 4 ++-- ouroboros-network/src/Ouroboros/Network/Socket.hs | 14 +++++++------- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index fd3ff828976..b80c8920dc2 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -200,7 +200,7 @@ connectTo_V1 tracers versionData application = -- withServer :: ( HasResponder appType ~ True ) - => NetworkServerTracers NodeToClientProtocols NodeToClientVersion + => NetworkServerTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> Versions NodeToClientVersion DictVersion @@ -223,7 +223,7 @@ withServer tracers networkState addr versions errPolicies = -- withServer_V1 :: ( HasResponder appType ~ True ) - => NetworkServerTracers NodeToClientProtocols NodeToClientVersion + => NetworkServerTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> NodeToClientVersionData diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 46dbdadc4d9..2d0b284f549 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -225,7 +225,7 @@ connectTo_V1 tracers versionData application localAddr remoteAddr = -- withServer :: ( HasResponder appType ~ True) - => NetworkServerTracers NodeToNodeProtocols NodeToNodeVersion + => NetworkServerTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) @@ -247,7 +247,7 @@ withServer tracers networkState addr versions errPolicies = -- withServer_V1 :: ( HasResponder appType ~ True ) - => NetworkServerTracers NodeToNodeProtocols NodeToNodeVersion + => NetworkServerTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> NodeToNodeVersionData diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index 6e53af354da..600c59f0370 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -369,21 +369,21 @@ fromSocket tblVar sd = Server.Socket -- | Tracers required by a server which handles inbound connections. -- -data NetworkServerTracers ptcl vNumber = NetworkServerTracers { - nstMuxTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId Socket.SockAddr) Mx.MuxTrace), +data NetworkServerTracers addr ptcl vNumber = NetworkServerTracers { + nstMuxTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId addr) Mx.MuxTrace), -- ^ low level mux-network tracer, which logs mux sdu (send and received) -- and other low level multiplexing events. - nstHandshakeTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId Socket.SockAddr) + nstHandshakeTracer :: Tracer IO (Mx.WithMuxBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))), -- ^ handshake protocol tracer; it is important for analysing version -- negotation mismatches. - nstErrorPolicyTracer :: Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) + nstErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace) -- ^ error policy tracer; must not be 'nullTracer', otherwise all the -- exceptions which are not matched by any error policy will be caught -- and not logged or rethrown. } -nullNetworkServerTracers :: NetworkServerTracers ptcl vNumber +nullNetworkServerTracers :: NetworkServerTracers addr ptcl vNumber nullNetworkServerTracers = NetworkServerTracers { nstMuxTracer = nullTracer, nstHandshakeTracer = nullTracer, @@ -435,7 +435,7 @@ runServerThread , Typeable vNumber , Show vNumber ) - => NetworkServerTracers ptcl vNumber + => NetworkServerTracers Socket.SockAddr ptcl vNumber -> NetworkMutableState Socket.SockAddr -> Socket.Socket -> VersionDataCodec extra CBOR.Term @@ -529,7 +529,7 @@ withServerNode , Typeable vNumber , Show vNumber ) - => NetworkServerTracers ptcl vNumber + => NetworkServerTracers Socket.SockAddr ptcl vNumber -> NetworkMutableState Socket.SockAddr -> Socket.AddrInfo -> VersionDataCodec extra CBOR.Term From e6bc5e8bb35e7259b2db2f5c9d6a87ecdd81f41c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 18:02:05 +0100 Subject: [PATCH 14/33] Snocket interface Snocket interface allows to use Berkeley sockets and Windows named pipes. There difference between these two interfaces mostly lies how one accepts connections. In Berkeley sockets there is an accepting socket and the accept syscall returns a new file descriptor in a connected state. In named pipes, one creates a file descriptor and accepts a connection on it, next connection is accepted be creating a new file descriptor (with the same name) and accept connection on it. In this PR we introduce `Accept` recursive data type which allows to embrace both interfaces. See included haddock comments. There is also difference how one connects. In berkeley sockets one creates a socket and connects it to a remote peer. In named pipes interface one creates a file which shares the name. To meet both interfaces we have a `openToConnect` call and `connect` call. For Berkeley sockets `openToConnect` creates the socket and `connect` connects to the remote peer (like `socket` and `connect` syscalls), for named pipe, `openToConnect` creates the file and connect is no-op. Implementation for Berkeley sockets and names pipes will come in a following commits. --- ouroboros-network/ouroboros-network.cabal | 1 + .../src/Ouroboros/Network/Snocket.hs | 131 ++++++++++++++++++ 2 files changed, 132 insertions(+) create mode 100644 ouroboros-network/src/Ouroboros/Network/Snocket.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 8e49fb21ebb..34186f0fa49 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -73,6 +73,7 @@ library Ouroboros.Network.Server.Socket Ouroboros.Network.Server.Version.CBOR Ouroboros.Network.Server.Version.Protocol + Ouroboros.Network.Snocket Ouroboros.Network.Socket Ouroboros.Network.Subscription Ouroboros.Network.Subscription.Ip diff --git a/ouroboros-network/src/Ouroboros/Network/Snocket.hs b/ouroboros-network/src/Ouroboros/Network/Snocket.hs new file mode 100644 index 00000000000..e7dd3b608f8 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Snocket.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.Snocket + ( Accept (..) + , AddressFamily (..) + , Snocket (..) + ) where + +import Control.Exception +import Control.Tracer (Tracer) +import Network.Socket (Socket, SockAddr) +import qualified Network.Socket as Socket +#if defined(mingw32_HOST_OS) +import qualified System.Win32.Async as Win32.Async +#endif + +import Network.Mux.Types (MuxBearer) +import Network.Mux.Trace (MuxTrace) + +import Ouroboros.Network.IOManager + + +-- | Named pipes and Berkeley sockets have different API when accepting +-- a connection. For named pipes the file descriptor created by 'createNamedPipe' is +-- supposed to be used for the first connected client. Named pipe accept loop +-- looks this way: +-- +-- > acceptLoop k = do +-- > h <- createNamedPipe name +-- > connectNamedPipe h +-- > -- h is now in connected state +-- > forkIO (k h) +-- > acceptLoop k +-- +-- For Berkeley sockets equivalent loop starts by creating a socket +-- which accepts connections and accept returns a new socket in connected +-- state +-- +-- > acceptLoop k = do +-- > s <- socket ... +-- > bind s address +-- > listen s +-- > loop s +-- > where +-- > loop s = do +-- > (s' , _addr') <- accept s +-- > -- s' is in connected state +-- > forkIO (k s') +-- > loop s +-- +-- To make common API for both we use a recursive type 'Accept', see +-- 'berkeleyAccept' below. Creation of the socket / named pipe is part of +-- 'Snocket', but this means we need to have different recursion step for named +-- pipe & sockets. For sockets its recursion step will always return 'accept' +-- syscall; for named pipes the first callback wil reuse the file descriptor +-- created by 'open' and only subsequent calls will create a new file +-- descriptor by `createNamedPipe`, see 'namedPipeSnocket'. +-- +newtype Accept addr fd = Accept + { runAccept :: IO (fd, addr, Accept addr fd) + } + +data AddressFamily addr where + + SocketFamily :: !Socket.Family + -> AddressFamily Socket.SockAddr + + NamedPipeFamily :: AddressFamily FilePath + + +berkeleyAccept :: AssociateWithIOCP + -> Socket + -> Accept SockAddr Socket +berkeleyAccept iocp sock = go + where + go = Accept $ do + (sock', addr') <- +#if !defined(mingw32_HOST_OS) + Socket.accept sock +#else + Win32.Async.accept sock +#endif + associateWithIOCP iocp (Right sock') + `catch` \(e :: IOException) -> do + Socket.close sock' + throwIO e + `catch` \(SomeAsyncException _) -> do + Socket.close sock' + throwIO e + return (sock', addr', go) + + +-- | Abstract communication interface that can be used by more than +-- 'Socket'. Snockets are polymorphic over moand which is used, this feature +-- is useful for testing and/or simulations. +-- +data Snocket m fd addr = Snocket { + getLocalAddr :: fd -> m addr + , getRemoteAddr :: fd -> m addr + + , addrFamily :: addr -> AddressFamily addr + + -- | Open a file descriptor (socket / namedPipe). For named pipes this is + -- using 'CreateNamedPipe' syscall, for Berkeley sockets 'socket' is used.. + -- + , open :: AddressFamily addr -> m fd + + -- | A way to create 'fd' to pass to 'connect'. For named pipes it will + -- use 'CreateFile' syscall. For Berkeley sockets this the same as 'open'. + -- + -- For named pipes we need full 'addr' rather than just address family as + -- it is for sockets. + -- + , openToConnect :: addr -> m fd + + -- | `connect` is only needed for Berkeley sockets, for named pipes this is + -- no-op. + -- + , connect :: fd -> addr -> m () + , bind :: fd -> addr -> m () + , listen :: fd -> m () + + , accept :: fd -> Accept addr fd + + , close :: fd -> m () + + , toBearer :: Tracer m MuxTrace -> fd -> (MuxBearer m) + } From cf96fa75df74dc08b7e728d667874c1e4d6228ba Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 18:02:58 +0100 Subject: [PATCH 15/33] socketSnocket: Snocket interface for Berkeley sockets --- .../src/Ouroboros/Network/Snocket.hs | 118 ++++++++++++++++++ 1 file changed, 118 insertions(+) diff --git a/ouroboros-network/src/Ouroboros/Network/Snocket.hs b/ouroboros-network/src/Ouroboros/Network/Snocket.hs index e7dd3b608f8..a8959688745 100644 --- a/ouroboros-network/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Snocket.hs @@ -7,9 +7,13 @@ module Ouroboros.Network.Snocket ( Accept (..) , AddressFamily (..) , Snocket (..) + , SocketSnocket + , socketSnocket + , rawSocketSnocket ) where import Control.Exception +import Control.Monad (when) import Control.Tracer (Tracer) import Network.Socket (Socket, SockAddr) import qualified Network.Socket as Socket @@ -19,6 +23,7 @@ import qualified System.Win32.Async as Win32.Async import Network.Mux.Types (MuxBearer) import Network.Mux.Trace (MuxTrace) +import qualified Network.Mux.Bearer.Socket as Mx import Ouroboros.Network.IOManager @@ -129,3 +134,116 @@ data Snocket m fd addr = Snocket { , toBearer :: Tracer m MuxTrace -> fd -> (MuxBearer m) } + + +socketAddrFamily + :: Socket.SockAddr + -> AddressFamily Socket.SockAddr +socketAddrFamily (Socket.SockAddrInet _ _ ) = SocketFamily Socket.AF_INET +socketAddrFamily (Socket.SockAddrInet6 _ _ _ _) = SocketFamily Socket.AF_INET6 +socketAddrFamily (Socket.SockAddrUnix _ ) = SocketFamily Socket.AF_UNIX + +type SocketSnocket = Snocket IO Socket SockAddr + +-- | Create a 'Snocket' for the given 'Socket.Family'. In the 'bind' method set +-- 'Socket.ReuseAddr` and 'Socket.ReusePort'. +-- +socketSnocket + :: AssociateWithIOCP + -- ^ associate the socket with I/O CP. We use it when we create a new socket + -- and when we accept a connection. + -- + -- Though it could be used in `open`, but that is going to be used in + -- a bracket so it's better to keep it simple. + -- + -> SocketSnocket +socketSnocket iocp = Snocket { + getLocalAddr = Socket.getSocketName + , getRemoteAddr = Socket.getPeerName + , addrFamily = socketAddrFamily + , open = openSocket + , openToConnect = \addr -> openSocket (socketAddrFamily addr) + , connect = \s a -> do +#if !defined(mingw32_HOST_OS) + Socket.connect s a +#else + Win32.Async.connect s a +#endif + , bind = \sd addr -> do + let SocketFamily fml = socketAddrFamily addr + when (fml == Socket.AF_INET || + fml == Socket.AF_INET6) $ do + Socket.setSocketOption sd Socket.ReuseAddr 1 +#if !defined(mingw32_HOST_OS) + -- not supported on Windows 10 + Socket.setSocketOption sd Socket.ReusePort 1 +#endif + when (fml == Socket.AF_INET6) + -- An AF_INET6 socket can be used to talk to both IPv4 and IPv6 end points, and + -- it is enabled by default on some systems. Disabled here since we run a separate + -- IPv4 server instance if configured to use IPv4. + $ Socket.setSocketOption sd Socket.IPv6Only 1 + + Socket.bind sd addr + , listen = \s -> Socket.listen s 8 + , accept = berkeleyAccept iocp + , close = Socket.close + , toBearer = Mx.socketAsMuxBearer + } + where + openSocket :: AddressFamily SockAddr -> IO Socket + openSocket (SocketFamily family_) = do + sd <- Socket.socket family_ Socket.Stream Socket.defaultProtocol + associateWithIOCP iocp (Right sd) + -- open is designed to be used in `bracket`, and thus it's called with + -- async exceptions masked. The 'associteWithIOCP' is a blocking + -- operation and thus it may throw. + `catch` \(e :: IOException) -> do + Socket.close sd + throwIO e + `catch` \(SomeAsyncException _) -> do + Socket.close sd + throwIO e + return sd + + + +-- | Create a snocket for the given 'Socket.Family'. This snocket does not set +-- any options on the underlaying socket. +-- +rawSocketSnocket + :: AssociateWithIOCP + -> SocketSnocket +rawSocketSnocket iocp = Snocket { + getLocalAddr = Socket.getSocketName + , getRemoteAddr = Socket.getPeerName + , addrFamily = socketAddrFamily + , connect = \s a -> do +#if !defined(mingw32_HOST_OS) + Socket.connect s a +#else + Win32.Async.connect s a +#endif + , bind = \fd addr -> Socket.bind fd addr + , listen = flip Socket.listen 1 + , accept = berkeleyAccept iocp + , open = openSocket + , openToConnect = \addr -> openSocket (socketAddrFamily addr) + , close = Socket.close + , toBearer = Mx.socketAsMuxBearer + } + where + openSocket :: AddressFamily SockAddr -> IO Socket + openSocket (SocketFamily family_) = do + sd <- Socket.socket family_ Socket.Stream Socket.defaultProtocol + associateWithIOCP iocp (Right sd) + -- open is designed to be used in `bracket`, and thus it's called with + -- async exceptions masked. The 'associteWithIOCP' is a blocking + -- operation and thus it may throw. + `catch` \(e :: IOException) -> do + Socket.close sd + throwIO e + `catch` \(SomeAsyncException _) -> do + Socket.close sd + throwIO e + return sd From f35038ede62c8ff52cd4ac72dc9352e042aaeb3e Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 17:30:25 +0100 Subject: [PATCH 16/33] namedPipeSnocket: snocket interface for named pipes --- .../src/Ouroboros/Network/Snocket.hs | 96 ++++++++++++++++++- 1 file changed, 93 insertions(+), 3 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Snocket.hs b/ouroboros-network/src/Ouroboros/Network/Snocket.hs index a8959688745..1072268c813 100644 --- a/ouroboros-network/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Snocket.hs @@ -18,7 +18,12 @@ import Control.Tracer (Tracer) import Network.Socket (Socket, SockAddr) import qualified Network.Socket as Socket #if defined(mingw32_HOST_OS) +import Data.Bits +import qualified System.Win32 as Win32 +import qualified System.Win32.NamedPipes as Win32 import qualified System.Win32.Async as Win32.Async + +import Network.Mux.Bearer.NamedPipe (namedPipeAsBearer) #endif import Network.Mux.Types (MuxBearer) @@ -60,7 +65,7 @@ import Ouroboros.Network.IOManager -- 'berkeleyAccept' below. Creation of the socket / named pipe is part of -- 'Snocket', but this means we need to have different recursion step for named -- pipe & sockets. For sockets its recursion step will always return 'accept' --- syscall; for named pipes the first callback wil reuse the file descriptor +-- syscall; for named pipes the first callback will reuse the file descriptor -- created by 'open' and only subsequent calls will create a new file -- descriptor by `createNamedPipe`, see 'namedPipeSnocket'. -- @@ -99,7 +104,7 @@ berkeleyAccept iocp sock = go -- | Abstract communication interface that can be used by more than --- 'Socket'. Snockets are polymorphic over moand which is used, this feature +-- 'Socket'. Snockets are polymorphic over monad which is used, this feature -- is useful for testing and/or simulations. -- data Snocket m fd addr = Snocket { @@ -209,7 +214,7 @@ socketSnocket iocp = Snocket { -- | Create a snocket for the given 'Socket.Family'. This snocket does not set --- any options on the underlaying socket. +-- any options on the underlying socket. -- rawSocketSnocket :: AssociateWithIOCP @@ -247,3 +252,88 @@ rawSocketSnocket iocp = Snocket { Socket.close sd throwIO e return sd + + +#if defined(mingw32_HOST_OS) +type HANDLESnocket = Snocket IO Win32.HANDLE FilePath + +-- | Create a Windows Named Pipe Snocket. +-- +namedPipeSnocket + :: AssociateWithIOCP + -> FilePath + -> HANDLESnocket +namedPipeSnocket iocp name = Snocket { + getLocalAddr = \_ -> return name + , getRemoteAddr = \_ -> return name + , addrFamily = \_ -> NamedPipeFamily + + , open = \_addrFamily -> do + hpipe <- Win32.createNamedPipe + name + (Win32.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED) + (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE) + Win32.pIPE_UNLIMITED_INSTANCES + maxBound + maxBound + 0 + Nothing + associateWithIOCP iocp (Left hpipe) + `catch` \(e :: IOException) -> do + Win32.closeHandle hpipe + throwIO e + `catch` \(SomeAsyncException _) -> do + Win32.closeHandle hpipe + throwIO e + pure hpipe + + -- To connect, simply create a file whose name is the named pipe name. + , openToConnect = \pipeName -> do + hpipe <- Win32.createFile pipeName + (Win32.gENERIC_READ .|. Win32.gENERIC_WRITE ) + Win32.fILE_SHARE_NONE + Nothing + Win32.oPEN_EXISTING + Win32.fILE_FLAG_OVERLAPPED + Nothing + associateWithIOCP iocp (Left hpipe) + `catch` \(e :: IOException) -> do + Win32.closeHandle hpipe + throwIO e + `catch` \(SomeAsyncException _) -> do + Win32.closeHandle hpipe + throwIO e + return hpipe + , connect = \_ _ -> pure () + + -- Bind and listen are no-op. + , bind = \_ _ -> pure () + , listen = \_ -> pure () + + , accept = \hpipe -> Accept $ do + Win32.Async.connectNamedPipe hpipe + return (hpipe, name, acceptNext) + + , close = Win32.closeHandle + + , toBearer = namedPipeAsBearer + } + where + acceptNext :: Accept FilePath Win32.HANDLE + acceptNext = Accept $ do + hpipe <- Win32.createNamedPipe + name + (Win32.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED) + (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE) + Win32.pIPE_UNLIMITED_INSTANCES + maxBound + maxBound + 0 + Nothing + `catch` \(e :: IOException) -> do + putStrLn $ "accept: " ++ show e + throwIO e + associateWithIOCP iocp (Left hpipe) + Win32.Async.connectNamedPipe hpipe + return (hpipe, name, acceptNext) +#endif From 36b41830d713641f2fd0de00da32944e9ea787cd Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 17:31:02 +0100 Subject: [PATCH 17/33] LocalSnocket shim layer A shim layer for local snockets: which on windows will use named pipes and on *nix - unix sockets. --- .../src/Ouroboros/Network/Snocket.hs | 30 +++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/ouroboros-network/src/Ouroboros/Network/Snocket.hs b/ouroboros-network/src/Ouroboros/Network/Snocket.hs index 1072268c813..c33495c1abb 100644 --- a/ouroboros-network/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Snocket.hs @@ -10,6 +10,10 @@ module Ouroboros.Network.Snocket , SocketSnocket , socketSnocket , rawSocketSnocket + , LocalSnocket + , localSnocket + , LocalAddress + , localAddressFromPath ) where import Control.Exception @@ -337,3 +341,29 @@ namedPipeSnocket iocp name = Snocket { Win32.Async.connectNamedPipe hpipe return (hpipe, name, acceptNext) #endif + +-- | System dependent LocalSnocket type +#if defined(mingw32_HOST_OS) +type LocalSnocket = HANDLESnocket + +localSnocket :: AssociateWithIOCP -> FilePath -> LocalSnocket +localSnocket = namedPipeSnocket +#else +type LocalSnocket = SocketSnocket + +localSnocket :: AssociateWithIOCP -> FilePath -> LocalSnocket +localSnocket iocp _ = rawSocketSnocket iocp +#endif + +#if defined(mingw32_HOST_OS) +type LocalAddress = FilePath +#else +type LocalAddress = Socket.SockAddr +#endif + +localAddressFromPath :: FilePath -> LocalAddress +#if defined(mingw32_HOST_OS) +localAddressFromPath = id +#else +localAddressFromPath = Socket.SockAddrUnix +#endif From 99c4e280e6e296444e9e2443847263f117ef678d Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 18:22:36 +0100 Subject: [PATCH 18/33] Snockets: integrate with ouroboros-network --- ouroboros-network/ouroboros-network.cabal | 1 + .../src/Ouroboros/Network/Diffusion.hs | 47 ++-- .../src/Ouroboros/Network/NodeToClient.hs | 101 +++++--- .../src/Ouroboros/Network/NodeToNode.hs | 62 +++-- .../src/Ouroboros/Network/Server/Socket.hs | 27 +- .../src/Ouroboros/Network/Socket.hs | 236 ++++++++++-------- .../src/Ouroboros/Network/Subscription.hs | 3 - .../src/Ouroboros/Network/Subscription/Dns.hs | 15 +- .../src/Ouroboros/Network/Subscription/Ip.hs | 17 +- .../Ouroboros/Network/Subscription/Worker.hs | 81 ++---- ouroboros-network/test/Test/PeerState.hs | 80 +++--- ouroboros-network/test/Test/Socket.hs | 78 ++++-- ouroboros-network/test/Test/Subscription.hs | 128 ++++++---- 13 files changed, 508 insertions(+), 368 deletions(-) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 34186f0fa49..13f61bc42c9 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -352,3 +352,4 @@ executable demo-chain-sync typed-protocols-examples default-language: Haskell2010 ghc-options: -Wall + -threaded diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 14f751674b6..a7567955605 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -28,10 +28,14 @@ import Network.Mux (MuxTrace (..), WithMuxBearer (..)) import Network.Socket (SockAddr, AddrInfo) import qualified Network.Socket as Socket +import Ouroboros.Network.Snocket (SocketSnocket) +import qualified Ouroboros.Network.Snocket as Snocket + import Ouroboros.Network.Protocol.Handshake.Type (Handshake) import Ouroboros.Network.Protocol.Handshake.Version import Ouroboros.Network.ErrorPolicy +import Ouroboros.Network.IOManager import Ouroboros.Network.Mux import Ouroboros.Network.NodeToClient ( NodeToClientProtocols (..) , NodeToClientVersion (..) @@ -143,7 +147,12 @@ runDataDiffusion tracers , daIpProducers , daDnsProducers } - applications@DiffusionApplications { daErrorPolicies } = do + applications@DiffusionApplications { daErrorPolicies } = + withIOManager $ \iocp -> do + + let snocket :: SocketSnocket + snocket = Snocket.socketSnocket iocp + -- networking mutable state networkState <- newNetworkMutableState networkLocalState <- newNetworkMutableState @@ -156,22 +165,23 @@ runDataDiffusion tracers Async.withAsync (cleanNetworkMutableState networkLocalState) $ \cleanLocalNetworkStateThread -> -- fork server for local clients - Async.withAsync (runLocalServer networkLocalState) $ \_ -> + Async.withAsync (runLocalServer snocket networkLocalState) $ \_ -> -- fork servers for remote peers - withAsyncs (runServer networkState <$> daAddresses) $ \_ -> + withAsyncs (runServer snocket networkState . Socket.addrAddress <$> daAddresses) $ \_ -> -- fork ip subscription - Async.withAsync (runIpSubscriptionWorker networkState) $ \_ -> + Async.withAsync (runIpSubscriptionWorker snocket networkState) $ \_ -> -- fork dns subscriptions - withAsyncs (runDnsSubscriptionWorker networkState <$> daDnsProducers) $ \_ -> + withAsyncs (runDnsSubscriptionWorker snocket networkState <$> daDnsProducers) $ \_ -> -- If any other threads throws 'cleanNetowrkStateThread' and -- 'cleanLocalNetworkStateThread' threads will will finish. Async.waitEither_ cleanNetworkStateThread cleanLocalNetworkStateThread where + -- TODO: this is POSIX only, Windows support will be built later DiffusionTracers { dtIpSubscriptionTracer , dtDnsSubscriptionTracer @@ -207,21 +217,23 @@ runDataDiffusion tracers remoteErrorPolicy = NodeToNode.remoteNetworkErrorPolicy <> daErrorPolicies localErrorPolicy = NodeToNode.localNetworkErrorPolicy <> daErrorPolicies - runLocalServer :: NetworkMutableState SockAddr -> IO Void - runLocalServer networkLocalState = + runLocalServer :: SocketSnocket -> NetworkMutableState SockAddr -> IO Void + runLocalServer sn networkLocalState = NodeToClient.withServer + sn (NetworkServerTracers dtMuxLocalTracer dtHandshakeLocalTracer dtErrorPolicyTracer) networkLocalState - daLocalAddress + (Socket.addrAddress daLocalAddress) (daLocalResponderApplication applications) localErrorPolicy - runServer :: NetworkMutableState SockAddr -> AddrInfo -> IO Void - runServer networkState address = + runServer :: SocketSnocket -> NetworkMutableState SockAddr -> SockAddr -> IO Void + runServer sn networkState address = NodeToNode.withServer + sn (NetworkServerTracers dtMuxTracer dtHandshakeTracer @@ -231,8 +243,11 @@ runDataDiffusion tracers (daResponderApplication applications) remoteErrorPolicy - runIpSubscriptionWorker :: NetworkMutableState SockAddr -> IO Void - runIpSubscriptionWorker networkState = NodeToNode.ipSubscriptionWorker + runIpSubscriptionWorker :: SocketSnocket + -> NetworkMutableState SockAddr + -> IO Void + runIpSubscriptionWorker sn networkState = NodeToNode.ipSubscriptionWorker + sn (NetworkIPSubscriptionTracers dtMuxTracer dtHandshakeTracer @@ -247,8 +262,12 @@ runDataDiffusion tracers } (daInitiatorApplication applications) - runDnsSubscriptionWorker :: NetworkMutableState SockAddr -> DnsSubscriptionTarget -> IO Void - runDnsSubscriptionWorker networkState dnsProducer = NodeToNode.dnsSubscriptionWorker + runDnsSubscriptionWorker :: SocketSnocket + -> NetworkMutableState SockAddr + -> DnsSubscriptionTarget + -> IO Void + runDnsSubscriptionWorker sn networkState dnsProducer = NodeToNode.dnsSubscriptionWorker + sn (NetworkDNSSubscriptionTracers dtMuxTracer dtHandshakeTracer diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index b80c8920dc2..9efa5289032 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -70,6 +70,7 @@ import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Term as CBOR import Codec.Serialise (Serialise (..), DeserialiseFailure) import Codec.SerialiseTerm + import qualified Network.Socket as Socket import Network.Mux hiding (MiniProtocolLimits(..)) @@ -84,6 +85,7 @@ import Ouroboros.Network.Protocol.ChainSync.Client (chainSyncClientNul import Ouroboros.Network.Protocol.LocalTxSubmission.Client (localTxSubmissionClientNull) import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version +import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Subscription.Ip (IPSubscriptionParams, SubscriptionParams (..)) import qualified Ouroboros.Network.Subscription.Ip as Subscription @@ -153,38 +155,41 @@ nodeToClientCodecCBORTerm = CodecCBORTerm {encodeTerm, decodeTerm} -- protocol. This is mostly useful for future enhancements. -- connectTo - :: NetworkConnectTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion + :: Snocket IO fd addr + -> NetworkConnectTracers addr NodeToClientProtocols NodeToClientVersion -> Versions NodeToClientVersion DictVersion - (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) + (OuroborosApplication InitiatorApp (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). - -> Maybe Socket.AddrInfo + -> Maybe addr -- ^ local address; the created socket will bind to it - -> Socket.AddrInfo + -> addr -- ^ remote address -> IO () -connectTo = connectToNode cborTermVersionDataCodec +connectTo sn = connectToNode sn cborTermVersionDataCodec -- | A version of 'Ouroboros.Network.Socket.connectToNode' which connects using -- the 'NodeToClientV_1' version of the protocol. -- connectTo_V1 - :: NetworkConnectTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion + :: Snocket IO fd addr + -> NetworkConnectTracers addr NodeToClientProtocols NodeToClientVersion -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and -- server must agree on it. - -> (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) + -> (OuroborosApplication InitiatorApp (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) -- ^ 'OuroborosInitiatorApplication' which is run on an established connection -- using a multiplexer after the initial handshake protocol suceeds. - -> Maybe Socket.AddrInfo + -> Maybe addr -- ^ local address; the created socket will bind to it - -> Socket.AddrInfo + -> addr -- ^ remote address -> IO () -connectTo_V1 tracers versionData application = +connectTo_V1 sn tracers versionData application = connectTo + sn tracers (simpleSingletonVersions NodeToClientV_1 @@ -192,6 +197,7 @@ connectTo_V1 tracers versionData application = (DictVersion nodeToClientCodecCBORTerm) application) + -- | A specialised version of 'Ouroboros.Network.Socket.withServerNode'; Use -- 'withServer_V1' instead of you would like to use 'NodeToCLientV_1' version of -- the protocols. @@ -199,16 +205,20 @@ connectTo_V1 tracers versionData application = -- Comments to 'Ouroboros.Network.NodeToNode.withServer' apply here as well. -- withServer - :: ( HasResponder appType ~ True ) - => NetworkServerTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState Socket.SockAddr - -> Socket.AddrInfo + :: ( HasResponder appType ~ True + , Ord addr + ) + => Snocket IO fd addr + -> NetworkServerTracers addr NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState addr + -> addr -> Versions NodeToClientVersion DictVersion - (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) - -> ErrorPolicies Socket.SockAddr () + (OuroborosApplication appType (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) + -> ErrorPolicies addr () -> IO Void -withServer tracers networkState addr versions errPolicies = +withServer sn tracers networkState addr versions errPolicies = withServerNode + sn tracers networkState addr @@ -221,23 +231,28 @@ withServer tracers networkState addr versions errPolicies = -- | A specialised version of 'withServer' which can only communicate using -- 'NodeToClientV_1' version of the protocol. -- +-- TODO: do not leak 'Snocket' abstraction, specialise it to 'Socket's and pipes. +-- withServer_V1 - :: ( HasResponder appType ~ True ) - => NetworkServerTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState Socket.SockAddr - -> Socket.AddrInfo + :: ( HasResponder appType ~ True + , Ord addr + ) + => Snocket IO fd addr + -> NetworkServerTracers addr NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState addr + -> addr -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and -- server must agree on it. - -> (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToClientProtocols IO BL.ByteString a b) + -> (OuroborosApplication appType (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) -- ^ applications which has the reponder side, i.e. -- 'OuroborosResponderApplication' or -- 'OuroborosInitiatorAndResponderApplication'. - -> ErrorPolicies Socket.SockAddr () + -> ErrorPolicies addr () -> IO Void -withServer_V1 tracers networkState addr versionData application = +withServer_V1 sn tracers networkState addr versionData application = withServer - tracers networkState addr + sn tracers networkState addr (simpleSingletonVersions NodeToClientV_1 versionData @@ -248,21 +263,27 @@ withServer_V1 tracers networkState addr versionData application = -- established connection. -- ncSubscriptionWorker - :: forall appType x y. - ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState Socket.SockAddr + :: forall appType fd addr x y. + ( HasInitiator appType ~ True + -- TODO: lift this constraints + , fd ~ Socket.Socket + , addr ~ Socket.SockAddr + ) + => Snocket IO fd addr + -> NetworkIPSubscriptionTracers addr NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState addr -> IPSubscriptionParams () -> Versions NodeToClientVersion DictVersion (OuroborosApplication appType - (ConnectionId Socket.SockAddr) + (ConnectionId addr) NodeToClientProtocols IO BL.ByteString x y) -> IO Void ncSubscriptionWorker + sn NetworkIPSubscriptionTracers { nistSubscriptionTracer , nistMuxTracer @@ -273,11 +294,13 @@ ncSubscriptionWorker subscriptionParams versions = Subscription.ipSubscriptionWorker + sn nistSubscriptionTracer nistErrorPolicyTracer networkState subscriptionParams (connectToNode' + sn cborTermVersionDataCodec (NetworkConnectTracers nistMuxTracer nistHandshakeTracer) versions) @@ -286,25 +309,31 @@ ncSubscriptionWorker -- | Like 'ncSubscriptionWorker' but specific to 'NodeToClientV_1'. -- ncSubscriptionWorker_V1 - :: forall appType x y. - ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers Socket.SockAddr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState Socket.SockAddr + :: forall appType fd addr x y. + ( HasInitiator appType ~ True + , fd ~ Socket.Socket + , addr ~ Socket.SockAddr + ) + => Snocket IO fd addr + -> NetworkIPSubscriptionTracers addr NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState addr -> IPSubscriptionParams () -> NodeToClientVersionData -> (OuroborosApplication appType - (ConnectionId Socket.SockAddr) + (ConnectionId addr) NodeToClientProtocols IO BL.ByteString x y) -> IO Void ncSubscriptionWorker_V1 + sn tracers networkState subscriptionParams versionData application = ncSubscriptionWorker + sn tracers networkState subscriptionParams @@ -327,7 +356,7 @@ ncSubscriptionWorker_V1 -- -- If a trusted node sends us a wrong data or -- -networkErrorPolicies :: ErrorPolicies Socket.SockAddr a +networkErrorPolicies :: ErrorPolicies addr a networkErrorPolicies = ErrorPolicies { epAppErrorPolicies = [ -- Handshake client protocol error: we either did not recognise received diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 2d0b284f549..c2665df9378 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -114,6 +114,7 @@ import Ouroboros.Network.Subscription.Dns ( DnsSubscriptionTarget (..) , WithDomainName (..) ) import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) +import Ouroboros.Network.Snocket -- | An index type used with the mux to enumerate all the mini-protocols that @@ -185,27 +186,31 @@ nodeToNodeCodecCBORTerm = CodecCBORTerm {encodeTerm, decodeTerm} -- | A specialised version of @'Ouroboros.Network.Socket.connectToNode'@. -- connectTo - :: NetworkConnectTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion + :: Snocket IO Socket.Socket Socket.SockAddr + -> NetworkConnectTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> Versions NodeToNodeVersion DictVersion (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) - -> Maybe Socket.AddrInfo - -> Socket.AddrInfo + -> Maybe Socket.SockAddr + -> Socket.SockAddr -> IO () -connectTo = connectToNode cborTermVersionDataCodec +connectTo sn = + connectToNode sn cborTermVersionDataCodec -- | Like 'connectTo' but specific to 'NodeToNodeV_1'. -- connectTo_V1 - :: NetworkConnectTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion + :: SocketSnocket + -> NetworkConnectTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NodeToNodeVersionData -> (OuroborosApplication InitiatorApp (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) - -> Maybe Socket.AddrInfo - -> Socket.AddrInfo + -> Maybe Socket.SockAddr + -> Socket.SockAddr -> IO () -connectTo_V1 tracers versionData application localAddr remoteAddr = +connectTo_V1 sn tracers versionData application localAddr remoteAddr = connectTo + sn tracers (simpleSingletonVersions NodeToNodeV_1 @@ -224,15 +229,17 @@ connectTo_V1 tracers versionData application localAddr remoteAddr = -- will be cancelled as well (by 'withAsync') -- withServer - :: ( HasResponder appType ~ True) - => NetworkServerTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion + :: ( HasResponder appType ~ True ) + => SocketSnocket + -> NetworkServerTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState Socket.SockAddr - -> Socket.AddrInfo + -> Socket.SockAddr -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) -> ErrorPolicies Socket.SockAddr () -> IO Void -withServer tracers networkState addr versions errPolicies = +withServer sn tracers networkState addr versions errPolicies = withServerNode + sn tracers networkState addr @@ -247,16 +254,17 @@ withServer tracers networkState addr versions errPolicies = -- withServer_V1 :: ( HasResponder appType ~ True ) - => NetworkServerTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion + => SocketSnocket + -> NetworkServerTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState Socket.SockAddr - -> Socket.AddrInfo + -> Socket.SockAddr -> NodeToNodeVersionData -> (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) -> ErrorPolicies Socket.SockAddr () -> IO Void -withServer_V1 tracers networkState addr versionData application = +withServer_V1 sn tracers networkState addr versionData application = withServer - tracers networkState addr + sn tracers networkState addr (simpleSingletonVersions NodeToNodeV_1 versionData @@ -270,7 +278,8 @@ withServer_V1 tracers networkState addr versionData application = ipSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion + => SocketSnocket + -> NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams () -> Versions @@ -283,6 +292,7 @@ ipSubscriptionWorker IO BL.ByteString x y) -> IO Void ipSubscriptionWorker + sn NetworkIPSubscriptionTracers { nistSubscriptionTracer , nistMuxTracer @@ -293,11 +303,13 @@ ipSubscriptionWorker subscriptionParams versions = Subscription.ipSubscriptionWorker + sn nistSubscriptionTracer nistErrorPolicyTracer networkState subscriptionParams (connectToNode' + sn cborTermVersionDataCodec (NetworkConnectTracers nistMuxTracer nistHandshakeTracer) versions) @@ -308,7 +320,8 @@ ipSubscriptionWorker ipSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion + => SocketSnocket + -> NetworkIPSubscriptionTracers Socket.SockAddr NodeToNodeProtocols NodeToNodeVersion -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams () -> NodeToNodeVersionData @@ -319,12 +332,14 @@ ipSubscriptionWorker_V1 IO BL.ByteString x y) -> IO Void ipSubscriptionWorker_V1 + sn tracers networkState subscriptionParams versionData application = ipSubscriptionWorker + sn tracers networkState subscriptionParams @@ -341,7 +356,8 @@ ipSubscriptionWorker_V1 dnsSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) + => SocketSnocket + -> NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams () -> Versions @@ -354,6 +370,7 @@ dnsSubscriptionWorker IO BL.ByteString x y) -> IO Void dnsSubscriptionWorker + sn NetworkDNSSubscriptionTracers { ndstSubscriptionTracer , ndstDnsTracer @@ -365,12 +382,14 @@ dnsSubscriptionWorker subscriptionParams versions = Subscription.dnsSubscriptionWorker + sn ndstSubscriptionTracer ndstDnsTracer ndstErrorPolicyTracer networkState subscriptionParams (connectToNode' + sn cborTermVersionDataCodec (NetworkConnectTracers ndstMuxTracer ndstHandshakeTracer) versions) @@ -381,7 +400,8 @@ dnsSubscriptionWorker dnsSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) - => NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) + => SocketSnocket + -> NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams () -> NodeToNodeVersionData @@ -392,12 +412,14 @@ dnsSubscriptionWorker_V1 IO BL.ByteString x y) -> IO Void dnsSubscriptionWorker_V1 + sn tracers networkState subscriptionParams versionData application = dnsSubscriptionWorker + sn tracers networkState subscriptionParams diff --git a/ouroboros-network/src/Ouroboros/Network/Server/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Server/Socket.hs index f14375a290c..844a10166ef 100644 --- a/ouroboros-network/src/Ouroboros/Network/Server/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Server/Socket.hs @@ -28,7 +28,7 @@ import Control.Concurrent.Async (Async) import qualified Control.Concurrent.Async as Async import Control.Concurrent.STM (STM) import qualified Control.Concurrent.STM as STM -import Control.Monad (forever, forM_, join) +import Control.Monad (forM_, join) import Control.Monad.Class.MonadTime (Time, getMonotonicTime) import Control.Tracer (Tracer, traceWith) import Data.Foldable (traverse_) @@ -43,7 +43,7 @@ import Ouroboros.Network.ErrorPolicy (CompleteApplicationResult (..), WithAddr, -- It's not defined in here, though, because we don't want the dependency -- on typed-protocols or even on network. data Socket addr channel = Socket - { acceptConnection :: IO (addr, channel, IO ()) + { acceptConnection :: IO (addr, channel, IO (), Socket addr channel) -- ^ The address, a channel, IO to close the channel. } @@ -52,7 +52,7 @@ ioSocket :: IO (addr, channel) -> Socket addr channel ioSocket io = Socket { acceptConnection = do (addr, channel) <- io - pure (addr, channel, pure ()) + pure (addr, channel, pure (), ioSocket io) } type StatusVar st = STM.TVar st @@ -158,9 +158,13 @@ acceptLoop -> ApplicationStart addr st -> (IOException -> IO ()) -- ^ Exception on `Socket.accept`. -> Socket addr channel - -> IO x -acceptLoop resQ threadsVar statusVar beginConnection applicationStart acceptException socket = forever $ - acceptOne resQ threadsVar statusVar beginConnection applicationStart acceptException socket + -> IO () +acceptLoop resQ threadsVar statusVar beginConnection applicationStart acceptException socket = do + mNextSocket <- acceptOne resQ threadsVar statusVar beginConnection applicationStart acceptException socket + case mNextSocket of + Nothing -> pure () + Just nextSocket -> + acceptLoop resQ threadsVar statusVar beginConnection applicationStart acceptException nextSocket -- | Accept once from the socket, use the `Accept` to make a decision (accept -- or reject), and spawn the thread if accepted. @@ -173,13 +177,15 @@ acceptOne -> ApplicationStart addr st -> (IOException -> IO ()) -- ^ Exception on `Socket.accept`. -> Socket addr channel - -> IO () + -> IO (Maybe (Socket addr channel)) acceptOne resQ threadsVar statusVar beginConnection applicationStart acceptException socket = mask $ \restore -> do -- mask is to assure that every socket is closed. outcome <- try (restore (acceptConnection socket)) - case outcome :: Either IOException (addr, channel, IO ()) of - Left ex -> restore (acceptException ex) - Right (addr, channel, close) -> do + case outcome :: Either IOException (addr, channel, IO (), Socket addr channel) of + Left ex -> do + restore (acceptException ex) + pure Nothing + Right (addr, channel, close, nextSocket) -> do -- Decide whether to accept or reject, using the current state, and -- update it according to the decision. t <- getMonotonicTime @@ -199,6 +205,7 @@ acceptOne resQ threadsVar statusVar beginConnection applicationStart acceptExcep case choice of Nothing -> close Just io -> spawnOne addr statusVar resQ threadsVar applicationStart (io channel `finally` close) + pure (Just nextSocket) -- | Main server loop, which runs alongside the `acceptLoop`. It waits for -- the results of connection threads, as well as the `Main` action, which diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index 600c59f0370..60cfd329144 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -23,6 +23,7 @@ module Ouroboros.Network.Socket ( , ConnectionId (..) , withServerNode , connectToNode + , connectToNodeSocket , connectToNode' -- * Traces @@ -48,11 +49,13 @@ module Ouroboros.Network.Socket ( , remValencyCounter , waitValencyCounter , readValencyCounter + + -- * Auxiliary functions + , sockAddrFamily ) where import Control.Concurrent.Async import Control.Exception (IOException, SomeException (..)) -import Control.Monad (when) -- TODO: remove this, it will not be needed when `orElse` PR will be merged. import qualified Control.Monad.STM as STM import Control.Monad.Class.MonadSTM.Strict @@ -79,15 +82,18 @@ import Network.TypedProtocol.Driver (TraceSendRecv) import qualified Network.Mux as Mx import Network.Mux.DeltaQ.TraceTransformer import qualified Network.Mux.Types as Mx -import qualified Network.Mux.Bearer.Socket as Mx +import Network.Mux.Types (MuxBearer) import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.Subscription.PeerState import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version import Ouroboros.Network.Protocol.Handshake.Codec +import Ouroboros.Network.IOManager (AssociateWithIOCP) import Ouroboros.Network.Mux import Ouroboros.Network.Channel +import Ouroboros.Network.Snocket (Snocket) +import qualified Ouroboros.Network.Snocket as Snocket import qualified Ouroboros.Network.Server.Socket as Server import Ouroboros.Network.Server.ConnectionTable @@ -113,6 +119,14 @@ nullNetworkConnectTracers = NetworkConnectTracers { } +sockAddrFamily + :: Socket.SockAddr + -> Socket.Family +sockAddrFamily (Socket.SockAddrInet _ _ ) = Socket.AF_INET +sockAddrFamily (Socket.SockAddrInet6 _ _ _ _) = Socket.AF_INET6 +sockAddrFamily (Socket.SockAddrUnix _ ) = Socket.AF_UNIX + + -- | Connection is identified by local and remote address. -- -- TODO: the type variable which this data type fills in is called `peerid`. We @@ -146,7 +160,7 @@ maxTransmissionUnit = 4 * 1440 -- -- Exceptions thrown by @'MuxApplication'@ are rethrown by @'connectTo'@. connectToNode - :: forall appType ptcl vNumber extra a b. + :: forall appType ptcl vNumber extra a b fd addr. ( ProtocolEnum ptcl , Ord ptcl , Enum ptcl @@ -160,34 +174,26 @@ connectToNode , MiniProtocolLimits ptcl , Mx.HasInitiator appType ~ True ) - => VersionDataCodec extra CBOR.Term - -> NetworkConnectTracers Socket.SockAddr ptcl vNumber - -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) + => Snocket IO fd addr + -> VersionDataCodec extra CBOR.Term + -> NetworkConnectTracers addr ptcl vNumber + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId addr) ptcl IO BL.ByteString a b) -- ^ application to run over the connection - -> Maybe Socket.AddrInfo + -> Maybe addr -- ^ local address; the created socket will bind to it - -> Socket.AddrInfo + -> addr -- ^ remote address -> IO () -connectToNode versionDataCodec tracers versions localAddr remoteAddr = +connectToNode sn versionDataCodec tracers versions localAddr remoteAddr = bracket - (Socket.socket (Socket.addrFamily remoteAddr) Socket.Stream Socket.defaultProtocol) - Socket.close + (Snocket.openToConnect sn remoteAddr) + (Snocket.close sn) (\sd -> do - when (Socket.addrFamily remoteAddr == Socket.AF_INET || - Socket.addrFamily remoteAddr == Socket.AF_INET6) $ do - Socket.setSocketOption sd Socket.ReuseAddr 1 -#if !defined(mingw32_HOST_OS) - Socket.setSocketOption sd Socket.ReusePort 1 -#endif case localAddr of - Just addr -> do - when (Socket.addrFamily remoteAddr == Socket.AF_INET6) $ - Socket.setSocketOption sd Socket.IPv6Only 1 - Socket.bind sd (Socket.addrAddress addr) + Just addr -> Snocket.bind sn sd addr Nothing -> return () - Socket.connect sd (Socket.addrAddress remoteAddr) - connectToNode' versionDataCodec tracers versions sd + Snocket.connect sn sd remoteAddr + connectToNode' sn versionDataCodec tracers versions sd ) -- | @@ -199,7 +205,7 @@ connectToNode versionDataCodec tracers versions localAddr remoteAddr = -- -- Exceptions thrown by @'MuxApplication'@ are rethrown by @'connectTo'@. connectToNode' - :: forall appType ptcl vNumber extra a b. + :: forall appType ptcl vNumber extra a b fd addr. ( ProtocolEnum ptcl , Ord ptcl , Enum ptcl @@ -213,20 +219,19 @@ connectToNode' , MiniProtocolLimits ptcl , Mx.HasInitiator appType ~ True ) - => VersionDataCodec extra CBOR.Term - -> NetworkConnectTracers Socket.SockAddr ptcl vNumber - -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) + => Snocket IO fd addr + -> VersionDataCodec extra CBOR.Term + -> NetworkConnectTracers addr ptcl vNumber + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId addr) ptcl IO BL.ByteString a b) -- ^ application to run over the connection - -> Socket.Socket + -> fd -> IO () -connectToNode' versionDataCodec NetworkConnectTracers {nctMuxTracer, nctHandshakeTracer } versions sd = do - connectionId <- ConnectionId <$> Socket.getSocketName sd <*> Socket.getPeerName sd +connectToNode' sn versionDataCodec NetworkConnectTracers {nctMuxTracer, nctHandshakeTracer } versions sd = do + connectionId <- ConnectionId <$> Snocket.getLocalAddr sn sd <*> Snocket.getRemoteAddr sn sd muxTracer <- initDeltaQTracer' $ Mx.WithMuxBearer connectionId `contramap` nctMuxTracer - let bearer = Mx.socketAsMuxBearer muxTracer sd - Mx.traceMuxBearerState muxTracer Mx.Connected - traceWith muxTracer $ Mx.MuxTraceHandshakeStart + let bearer = Snocket.toBearer sn muxTracer sd ts_start <- getMonotonicTime - !mapp <- runPeerWithByteLimit + mapp <- runPeerWithByteLimit maxTransmissionUnit BL.length (contramap (Mx.WithMuxBearer connectionId) nctHandshakeTracer) @@ -236,12 +241,43 @@ connectToNode' versionDataCodec NetworkConnectTracers {nctMuxTracer, nctHandshak ts_end <- getMonotonicTime case mapp of Left err -> do - traceWith muxTracer $ Mx.MuxTraceHandshakeClientError err (diffTime ts_end ts_start) - throwIO err + traceWith muxTracer $ Mx.MuxTraceHandshakeClientError err (diffTime ts_end ts_start) + throwIO err Right app -> do - traceWith muxTracer $ Mx.MuxTraceHandshakeClientEnd (diffTime ts_end ts_start) - Mx.muxStart muxTracer (toApplication app connectionId) bearer + traceWith muxTracer $ Mx.MuxTraceHandshakeClientEnd (diffTime ts_end ts_start) + Mx.muxStart muxTracer (toApplication app connectionId) bearer + +-- Wraps a Socket inside a Snocket and calls connectToNode' +connectToNodeSocket + :: forall appType ptcl vNumber extra a b. + ( ProtocolEnum ptcl + , Ord ptcl + , Enum ptcl + , Bounded ptcl + , Ord vNumber + , Enum vNumber + , Serialise vNumber + , Typeable vNumber + , Show vNumber + , Show ptcl + , MiniProtocolLimits ptcl + , Mx.HasInitiator appType ~ True + ) + => AssociateWithIOCP + -> VersionDataCodec extra CBOR.Term + -> NetworkConnectTracers Socket.SockAddr ptcl vNumber + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) + -- ^ application to run over the connection + -> Socket.Socket + -> IO () +connectToNodeSocket iocp versionDataCodec tracers versions sd = + connectToNode' + (Snocket.socketSnocket iocp) + versionDataCodec + tracers + versions + sd -- | -- Accept or reject an incoming connection. Each record contains the new state @@ -275,7 +311,7 @@ data AcceptConnection st vNumber extra peerid ptcl m bytes where -- of the incoming connection. -- beginConnection - :: forall peerid ptcl vNumber extra addr st. + :: forall peerid ptcl vNumber extra addr st fd. ( ProtocolEnum ptcl , Ord ptcl , Enum ptcl @@ -288,20 +324,21 @@ beginConnection , Typeable vNumber , Show vNumber ) - => Tracer IO (Mx.WithMuxBearer peerid Mx.MuxTrace) + => Snocket IO fd addr + -> Tracer IO (Mx.WithMuxBearer peerid Mx.MuxTrace) -> Tracer IO (Mx.WithMuxBearer peerid (TraceSendRecv (Handshake vNumber CBOR.Term))) -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) -> (Time -> addr -> st -> STM.STM (AcceptConnection st vNumber extra peerid ptcl IO BL.ByteString)) -- ^ either accept or reject a connection. - -> Server.BeginConnection addr Socket.Socket st () -beginConnection muxTracer handshakeTracer versionDataCodec acceptVersion fn t addr st = do + -> Server.BeginConnection addr fd st () +beginConnection sn muxTracer handshakeTracer versionDataCodec acceptVersion fn t addr st = do accept <- fn t addr st case accept of AcceptConnection st' peerid versions -> pure $ Server.Accept st' $ \sd -> do muxTracer' <- initDeltaQTracer' $ Mx.WithMuxBearer peerid `contramap` muxTracer - let bearer = Mx.socketAsMuxBearer muxTracer' sd - Mx.traceMuxBearerState muxTracer' Mx.Connected + let bearer :: MuxBearer IO + bearer = Snocket.toBearer sn muxTracer' sd traceWith muxTracer' $ Mx.MuxTraceHandshakeStart mapp <- runPeerWithByteLimit maxTransmissionUnit @@ -319,52 +356,43 @@ beginConnection muxTracer handshakeTracer versionDataCodec acceptVersion fn t ad Mx.muxStart muxTracer' (toApplication app peerid) bearer RejectConnection st' _peerid -> pure $ Server.Reject st' - --- Make the server listening socket mkListeningSocket - :: Socket.Family - -> Maybe Socket.SockAddr - -> IO Socket.Socket -mkListeningSocket addrFamily_ addr = do - sd <- Socket.socket addrFamily_ Socket.Stream Socket.defaultProtocol - when (addrFamily_ == Socket.AF_INET || - addrFamily_ == Socket.AF_INET6) $ do - Socket.setSocketOption sd Socket.ReuseAddr 1 -#if !defined(mingw32_HOST_OS) - Socket.setSocketOption sd Socket.ReusePort 1 -#endif + :: Snocket IO fd addr + -> Maybe addr + -> Snocket.AddressFamily addr + -> IO fd +mkListeningSocket sn addr family_ = do + sd <- Snocket.open sn family_ + case addr of Nothing -> pure () Just addr_ -> do - when (addrFamily_ == Socket.AF_INET6) $ - -- An AF_INET6 socket can be used to talk to both IPv4 and IPv6 end points, and - -- it is enabled by default on some systems. Disabled here since we run a separate - -- IPv4 server instance if configured to use IPv4. - Socket.setSocketOption sd Socket.IPv6Only 1 - - Socket.bind sd addr_ - Socket.listen sd 1 + Snocket.bind sn sd addr_ + Snocket.listen sn sd pure sd - -- | -- Make a server-compatible socket from a network socket. -- fromSocket - :: ConnectionTable IO Socket.SockAddr - -> Socket.Socket - -> Server.Socket Socket.SockAddr Socket.Socket -fromSocket tblVar sd = Server.Socket - { Server.acceptConnection = do - (sd', remoteAddr) <- Socket.accept sd - localAddr <- Socket.getSocketName sd' - atomically $ addConnection tblVar remoteAddr localAddr Nothing - pure (remoteAddr, sd', close remoteAddr localAddr sd') - } + :: forall fd addr. Ord addr + => ConnectionTable IO addr + -> Snocket IO fd addr + -> fd -- ^ socket or handle + -> Server.Socket addr fd +fromSocket tblVar sn sd = go (Snocket.accept sn sd) where + go :: Snocket.Accept addr fd -> Server.Socket addr fd + go (Snocket.Accept accept) = Server.Socket $ do + (sd', remoteAddr, next) <- accept + -- TOOD: we don't need to that on each accept + localAddr <- Snocket.getLocalAddr sn sd' + atomically $ addConnection tblVar remoteAddr localAddr Nothing + pure (remoteAddr, sd', close remoteAddr localAddr sd', go next) + close remoteAddr localAddr sd' = do removeConnection tblVar remoteAddr localAddr - Socket.close sd' + Snocket.close sn sd' -- | Tracers required by a server which handles inbound connections. @@ -421,7 +449,7 @@ cleanNetworkMutableState NetworkMutableState {nmsPeerStates} = -- Thin wrapper around @'Server.run'@. -- runServerThread - :: forall appType ptcl vNumber extra a b. + :: forall appType ptcl vNumber extra fd addr a b. ( Mx.HasResponder appType ~ True , ProtocolEnum ptcl , Ord ptcl @@ -434,38 +462,41 @@ runServerThread , Serialise vNumber , Typeable vNumber , Show vNumber + , Ord addr ) - => NetworkServerTracers Socket.SockAddr ptcl vNumber - -> NetworkMutableState Socket.SockAddr - -> Socket.Socket + => NetworkServerTracers addr ptcl vNumber + -> NetworkMutableState addr + -> Snocket IO fd addr + -> fd -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) - -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) - -> ErrorPolicies Socket.SockAddr () + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId addr) ptcl IO BL.ByteString a b) + -> ErrorPolicies addr () -> IO Void runServerThread NetworkServerTracers { nstMuxTracer , nstHandshakeTracer , nstErrorPolicyTracer } NetworkMutableState { nmsConnectionTable , nmsPeerStates } + sn sd versionDataCodec acceptVersion versions errorPolicies = do - sockAddr <- Socket.getSocketName sd + sockAddr <- Snocket.getLocalAddr sn sd Server.run nstErrorPolicyTracer - (fromSocket nmsConnectionTable sd) + (fromSocket nmsConnectionTable sn sd) (acceptException sockAddr) - (beginConnection nstMuxTracer nstHandshakeTracer versionDataCodec acceptVersion (acceptConnectionTx sockAddr)) + (beginConnection sn nstMuxTracer nstHandshakeTracer versionDataCodec acceptVersion (acceptConnectionTx sockAddr)) -- register producer when application starts, it will be unregistered -- using 'CompleteConnection' (\remoteAddr thread st -> pure $ registerProducer remoteAddr thread st) completeTx mainTx (toLazyTVar nmsPeerStates) where - mainTx :: Server.Main (PeerStates IO Socket.SockAddr) Void + mainTx :: Server.Main (PeerStates IO addr) Void mainTx (ThrowException e) = throwM e mainTx PeerStates{} = retry @@ -473,9 +504,9 @@ runServerThread NetworkServerTracers { nstMuxTracer -- Crucially: we don't re-throw exceptions, because doing so would -- bring down the server. completeTx :: Server.CompleteConnection - Socket.SockAddr - (PeerStates IO Socket.SockAddr) - (WithAddr Socket.SockAddr ErrorPolicyTrace) + addr + (PeerStates IO addr) + (WithAddr addr ErrorPolicyTrace) () completeTx result st = case result of @@ -487,7 +518,7 @@ runServerThread NetworkServerTracers { nstMuxTracer fmap (unregisterProducer remoteAddr thread) <$> completeApplicationTx errorPolicies (ApplicationResult t remoteAddr r) st - acceptException :: Socket.SockAddr -> IOException -> IO () + acceptException :: addr -> IOException -> IO () acceptException a e = do traceWith (WithAddr a `contramap` nstErrorPolicyTracer) $ ErrorPolicyAcceptException e @@ -515,7 +546,7 @@ runServerThread NetworkServerTracers { nstMuxTracer -- thread which runs the server. This makes it useful for testing, where we -- need to guarantee that a socket is open before we try to connect to it. withServerNode - :: forall appType ptcl vNumber extra t a b. + :: forall appType ptcl vNumber extra t fd addr a b. ( Mx.HasResponder appType ~ True , ProtocolEnum ptcl , Ord ptcl @@ -528,29 +559,32 @@ withServerNode , Serialise vNumber , Typeable vNumber , Show vNumber + , Ord addr ) - => NetworkServerTracers Socket.SockAddr ptcl vNumber - -> NetworkMutableState Socket.SockAddr - -> Socket.AddrInfo + => Snocket IO fd addr + -> NetworkServerTracers addr ptcl vNumber + -> NetworkMutableState addr + -> addr -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) - -> Versions vNumber extra (OuroborosApplication appType (ConnectionId Socket.SockAddr) ptcl IO BL.ByteString a b) + -> Versions vNumber extra (OuroborosApplication appType (ConnectionId addr) ptcl IO BL.ByteString a b) -- ^ The mux application that will be run on each incoming connection from -- a given address. Note that if @'MuxClientAndServerApplication'@ is -- returned, the connection will run a full duplex set of mini-protocols. - -> ErrorPolicies Socket.SockAddr () - -> (Socket.SockAddr -> Async Void -> IO t) + -> ErrorPolicies addr () + -> (addr -> Async Void -> IO t) -- ^ callback which takes the @Async@ of the thread that is running the server. -- Note: the server thread will terminate when the callback returns or -- throws an exception. -> IO t -withServerNode tracers networkState addr versionDataCodec acceptVersion versions errorPolicies k = - bracket (mkListeningSocket (Socket.addrFamily addr) (Just $ Socket.addrAddress addr)) Socket.close $ \sd -> do - addr' <- Socket.getSocketName sd +withServerNode sn tracers networkState addr versionDataCodec acceptVersion versions errorPolicies k = + bracket (mkListeningSocket sn (Just addr) (Snocket.addrFamily sn addr)) (Snocket.close sn) $ \sd -> do + addr' <- Snocket.getLocalAddr sn sd withAsync (runServerThread tracers networkState + sn sd versionDataCodec acceptVersion diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription.hs b/ouroboros-network/src/Ouroboros/Network/Subscription.hs index af01edff2ac..a6ebbca3ef3 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription.hs @@ -17,9 +17,6 @@ module Ouroboros.Network.Subscription , ipRetryDelay , resolutionDelay - -- * Auxiliary functions - , sockAddrFamily - -- * Errors , SubscriberError (..) diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs index d7484d11b37..b6ee09a6df5 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs @@ -46,6 +46,7 @@ import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.Subscription.Ip import Ouroboros.Network.Subscription.Subscriber import Ouroboros.Network.Subscription.Worker +import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Socket @@ -220,7 +221,8 @@ dnsResolve tracer resolver peerStatesVar beforeConnect (DnsSubscriptionTarget do dnsSubscriptionWorker' - :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) + :: Snocket IO Socket.Socket Socket.SockAddr + -> Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) -> Tracer IO (WithDomainName DnsTrace) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) -> NetworkMutableState Socket.SockAddr @@ -229,7 +231,7 @@ dnsSubscriptionWorker' -> Main IO (PeerStates IO Socket.SockAddr) x -> (Socket.Socket -> IO a) -> IO x -dnsSubscriptionWorker' subTracer dnsTracer errorPolicyTracer +dnsSubscriptionWorker' snocket subTracer dnsTracer errorPolicyTracer networkState@NetworkMutableState { nmsPeerStates } resolver SubscriptionParams { spLocalAddresses @@ -238,7 +240,8 @@ dnsSubscriptionWorker' subTracer dnsTracer errorPolicyTracer , spErrorPolicies } main k = - subscriptionWorker (WithDomainName (dstDomain dst) `contramap` subTracer) + subscriptionWorker snocket + (WithDomainName (dstDomain dst) `contramap` subTracer) errorPolicyTracer networkState WorkerParams { wpLocalAddresses = spLocalAddresses @@ -257,18 +260,20 @@ dnsSubscriptionWorker' subTracer dnsTracer errorPolicyTracer type DnsSubscriptionParams a = SubscriptionParams a DnsSubscriptionTarget dnsSubscriptionWorker - :: Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) + :: Snocket IO Socket.Socket Socket.SockAddr + -> Tracer IO (WithDomainName (SubscriptionTrace Socket.SockAddr)) -> Tracer IO (WithDomainName DnsTrace) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams a -> (Socket.Socket -> IO a) -> IO Void -dnsSubscriptionWorker subTracer dnsTracer errTrace networkState +dnsSubscriptionWorker snocket subTracer dnsTracer errTrace networkState params@SubscriptionParams { spSubscriptionTarget } k = do rs <- DNS.makeResolvSeed DNS.defaultResolvConf DNS.withResolver rs $ \dnsResolver -> dnsSubscriptionWorker' + snocket subTracer dnsTracer errTrace networkState (Resolver diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs index c5c1251d757..06b40745cae 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs @@ -43,6 +43,7 @@ import Data.Void (Void) import qualified Network.Socket as Socket import Text.Printf +import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Socket import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.Subscription.PeerState @@ -76,13 +77,14 @@ type IPSubscriptionParams a = SubscriptionParams a IPSubscriptionTarget -- ipSubscriptionWorker :: forall a. - Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr)) + Snocket IO Socket.Socket Socket.SockAddr + -> Tracer IO (WithIPList (SubscriptionTrace Socket.SockAddr)) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) -> NetworkMutableState Socket.SockAddr -> IPSubscriptionParams a -> (Socket.Socket -> IO a) -> IO Void -ipSubscriptionWorker subscriptionTracer errorPolicyTracer +ipSubscriptionWorker snocket subscriptionTracer errorPolicyTracer networkState@NetworkMutableState { nmsPeerStates } SubscriptionParams { spLocalAddresses , spConnectionAttemptDelay @@ -90,7 +92,8 @@ ipSubscriptionWorker subscriptionTracer errorPolicyTracer , spErrorPolicies } k = - subscriptionWorker subscriptionTracer' + subscriptionWorker snocket + subscriptionTracer' errorPolicyTracer networkState workerParams @@ -173,7 +176,8 @@ mainTx PeerStates{} = retry -- callback is left as it's useful for testing purposes. -- subscriptionWorker - :: Tracer IO (SubscriptionTrace Socket.SockAddr) + :: Snocket IO Socket.Socket Socket.SockAddr + -> Tracer IO (SubscriptionTrace Socket.SockAddr) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) -> NetworkMutableState Socket.SockAddr -> WorkerParams IO Socket.SockAddr @@ -183,7 +187,8 @@ subscriptionWorker -> (Socket.Socket -> IO a) -- ^ application to run on each connection -> IO x -subscriptionWorker tracer +subscriptionWorker snocket + tracer errorPolicyTracer NetworkMutableState { nmsConnectionTable, nmsPeerStates } workerParams @@ -193,7 +198,7 @@ subscriptionWorker tracer errorPolicyTracer nmsConnectionTable nmsPeerStates - ioSocket + snocket WorkerCallbacks { wcSocketStateChangeTx = socketStateChangeTx , wcCompleteApplicationTx = completeApplicationTx errorPolicies diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs index 433c05ce5e9..faa5171d06a 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs @@ -23,8 +23,6 @@ module Ouroboros.Network.Subscription.Worker , WorkerParams (..) , worker -- * Socket API - , Socket (..) - , ioSocket , safeConnect -- * Constants , defaultConnectionAttemptDelay @@ -35,8 +33,6 @@ module Ouroboros.Network.Subscription.Worker , SubscriberError (..) -- * Tracing , SubscriptionTrace (..) - -- * Auxiliary functions - , sockAddrFamily ) where import Control.Exception (SomeException (..)) @@ -50,8 +46,6 @@ import Data.Void (Void) import GHC.Stack import Text.Printf -import qualified Network.Socket as Socket - import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSTM.Strict @@ -62,6 +56,8 @@ import Control.Tracer import Ouroboros.Network.ErrorPolicy (CompleteApplication, Result (..), CompleteApplicationResult (..), WithAddr, ErrorPolicyTrace) import Ouroboros.Network.Server.ConnectionTable +import Ouroboros.Network.Snocket (Snocket (..)) +import qualified Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Subscription.Subscriber -- | Time to wait between connection attempts when we don't have any DeltaQ @@ -130,16 +126,6 @@ type SocketStateChange m s addr = SocketState m addr -> s -> STM m s -- type Main m s t = s -> STM m t --- | Abstract socket interface --- -data Socket m addr sock = Socket { - allocate :: addr -> m sock - , connect :: addr -> addr -> sock -> m () - , close :: sock -> m () - , getSocketName :: sock -> m addr - , getPeerName :: sock -> m addr - } - data LocalAddresses addr = LocalAddresses { -- | Local IPv4 address to use, Nothing indicates don't use IPv4 laIpv4 :: Maybe addr @@ -149,36 +135,6 @@ data LocalAddresses addr = LocalAddresses { , laUnix :: Maybe addr } deriving (Eq, Show) -sockAddrFamily - :: Socket.SockAddr - -> Socket.Family -sockAddrFamily (Socket.SockAddrInet _ _ ) = Socket.AF_INET -sockAddrFamily (Socket.SockAddrInet6 _ _ _ _) = Socket.AF_INET6 -sockAddrFamily (Socket.SockAddrUnix _ ) = Socket.AF_UNIX - --- | 'Socket' term instanciated with 'Network.Socket'. --- -ioSocket :: Socket IO Socket.SockAddr Socket.Socket -ioSocket = Socket { - - allocate = \remoteAddr -> do - sock <- Socket.socket (sockAddrFamily remoteAddr) Socket.Stream Socket.defaultProtocol - return sock - - , connect = \remoteAddr localAddr sock -> do - let af = sockAddrFamily remoteAddr - when (af == Socket.AF_INET || af == Socket.AF_INET6) $ do - Socket.setSocketOption sock Socket.ReuseAddr 1 -#if !defined(mingw32_HOST_OS) - Socket.setSocketOption sock Socket.ReusePort 1 -#endif - Socket.bind sock localAddr - Socket.connect sock remoteAddr - - , close = Socket.close - , getSocketName = Socket.getSocketName - , getPeerName = Socket.getPeerName - } -- | Allocate a socket and connect to a peer, execute the continuation with -- async exceptions masked. The continuation receives the 'unmask' callback. @@ -186,7 +142,7 @@ ioSocket = Socket { safeConnect :: ( MonadThrow m , MonadMask m ) - => Socket m addr sock + => Snocket m sock addr -> addr -- ^ remote addr -> addr @@ -202,16 +158,17 @@ safeConnect :: ( MonadThrow m -- masked; it receives: unmask function, allocated socket and -- connection error. -> m t -safeConnect Socket {allocate, connect, close} remoteAddr localAddr malloc mclean k = +safeConnect sn remoteAddr localAddr malloc mclean k = bracket - (do sock <- allocate remoteAddr + (do sock <- Snocket.open sn (Snocket.addrFamily sn remoteAddr) malloc pure sock ) - (\sock -> close sock >> mclean) + (\sock -> Snocket.close sn sock >> mclean) (\sock -> mask $ \unmask -> do + Snocket.bind sn sock localAddr res :: Either SomeException () - <- try (unmask $ connect remoteAddr localAddr sock) + <- try (unmask $ Snocket.connect sn sock remoteAddr) k unmask sock res) @@ -256,7 +213,7 @@ subscriptionLoop -> StateVar m s -> ThreadsVar m - -> Socket m addr sock + -> Snocket m sock addr -> WorkerCallbacks m s addr a x -> WorkerParams m addr @@ -266,7 +223,7 @@ subscriptionLoop -- ^ application -> m Void subscriptionLoop - tr tbl resQ sVar threadsVar socket + tr tbl resQ sVar threadsVar snocket WorkerCallbacks { wcSocketStateChangeTx = socketStateChangeTx , wcCompleteApplicationTx = completeApplicationTx } @@ -305,14 +262,6 @@ subscriptionLoop threadDelay $ ipRetryDelay - duration where - -- if socket allocation errors, we log the exception and rethrow it - -- which will kill the connection thread, but not the application itself. - socket' = socket { allocate = \remoteAddr -> allocate socket remoteAddr `catch` - (\(SomeException e) -> do - traceWith tr (SubscriptionTraceSocketAllocationException remoteAddr e) - throwM e - ) - } -- a single run through @sTarget :: SubcriptionTarget m addr@. innerLoop :: StrictTVar m (Set (Async m ())) -> ValencyCounter m @@ -379,7 +328,7 @@ subscriptionLoop -- exceptions masked, and receives the unmask function from -- this bracket. safeConnect - socket' + snocket remoteAddr localAddr (do @@ -428,7 +377,7 @@ subscriptionLoop -> Either SomeException () -> m () connAction thread conThreads valencyVar remoteAddr unmask sock connectionRes = do - localAddr <- getSocketName socket sock + localAddr <- Snocket.getLocalAddr snocket sock t <- getMonotonicTime case connectionRes of -- connection error @@ -592,7 +541,7 @@ worker -> ConnectionTable IO addr -> StateVar IO s - -> Socket IO addr sock + -> Snocket IO sock addr -> WorkerCallbacks IO s addr a x -> WorkerParams IO addr @@ -601,11 +550,11 @@ worker -> (sock -> IO a) -- ^ application -> IO x -worker tr errTrace tbl sVar socket workerCallbacks@WorkerCallbacks {wcCompleteApplicationTx, wcMainTx} workerParams selectAddress k = do +worker tr errTrace tbl sVar snocket workerCallbacks@WorkerCallbacks {wcCompleteApplicationTx, wcMainTx} workerParams selectAddress k = do resQ <- newResultQ threadsVar <- atomically $ newTVar Set.empty withAsync - (subscriptionLoop tr tbl resQ sVar threadsVar socket + (subscriptionLoop tr tbl resQ sVar threadsVar snocket workerCallbacks workerParams selectAddress k) $ \_ -> mainLoop errTrace resQ threadsVar sVar wcCompleteApplicationTx wcMainTx `finally` killThreads threadsVar diff --git a/ouroboros-network/test/Test/PeerState.hs b/ouroboros-network/test/Test/PeerState.hs index 31e406c1699..8c2bc0278e5 100644 --- a/ouroboros-network/test/Test/PeerState.hs +++ b/ouroboros-network/test/Test/PeerState.hs @@ -32,6 +32,7 @@ import Control.Tracer import Data.Semigroup.Action import Ouroboros.Network.ErrorPolicy +import Ouroboros.Network.Snocket import Ouroboros.Network.Server.ConnectionTable import Ouroboros.Network.Subscription.Ip import Ouroboros.Network.Subscription.PeerState @@ -216,59 +217,80 @@ data Sock addr = Sock { , localAddr :: addr } -data SocketType where +data SnocketType where -- socket which allocates and connects with out an error, any error can -- only come from an application - WorkingSocket :: SocketType + WorkingSnocket :: SnocketType -- socket which errors when allocating a socket AllocateError :: forall e. Exception e => e - -> SocketType + -> SnocketType -- socket which errors when attempting a connection ConnectError :: forall e. Exception e => e - -> SocketType + -> SnocketType -instance Show SocketType where +instance Show SnocketType where show (AllocateError e) = "AllocateError " ++show e show (ConnectError e) = "ConnectError " ++show e - show WorkingSocket = "WorkingSocket" + show WorkingSnocket = "WorkingSnocket" -instance Arbitrary SocketType where +instance Arbitrary SnocketType where arbitrary = oneof -- we are not generating 'AllocateErrors', they will not kill the worker, -- but only the connection thread. [ (\(ArbException e) -> ConnectError e) <$> arbitrary - , pure WorkingSocket + , pure WorkingSnocket ] -mkSocket :: MonadThrow m - => SocketType +-- | 'addrFamily', 'accept' and 'toBearer' are not needed to run the test suite. +-- +mkSnocket :: MonadThrow m + => SnocketType + -> addr -> addr - -> Socket m addr (Sock addr) -mkSocket (AllocateError e) _remoteAddr = Socket { - allocate = \_ -> throwM e - , connect = \_ _ _ -> pure () + -> Snocket m (Sock addr) addr +mkSnocket (AllocateError e) _localAddr _remoteAddr = Snocket { + getLocalAddr = \Sock{localAddr} -> pure localAddr + , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr + , addrFamily = error "not supported" + , open = \_ -> throwM e + , openToConnect = \_ -> throwM e + , connect = \_ _ -> pure () + , bind = \_ _ -> pure () + , listen = \_ -> pure () + , accept = \_ -> error "not supported" , close = \_ -> pure () - , getSocketName = \Sock{localAddr} -> pure localAddr - , getPeerName = \Sock{remoteAddr = addr} -> pure addr + , toBearer = \_ _ -> error "not supported" } -mkSocket (ConnectError e) remoteAddr = Socket { - allocate = \localAddr -> pure Sock {remoteAddr, localAddr} - , connect = \_ _ _ -> throwM e +mkSnocket (ConnectError e) localAddr remoteAddr = Snocket { + getLocalAddr = \Sock{localAddr = addr} -> pure addr + , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr + , addrFamily = error "not supported" + , open = \_ -> pure Sock {remoteAddr, localAddr} + , openToConnect = \_ -> pure Sock {remoteAddr, localAddr} + , connect = \_ _ -> throwM e + , accept = \_ -> error "not supported" + , bind = \_ _ -> pure () + , listen = \_ -> pure () , close = \_ -> pure () - , getSocketName = \Sock{localAddr} -> pure localAddr - , getPeerName = \Sock{remoteAddr = addr} -> pure addr + , toBearer = \_ _ -> error "not supported" } -mkSocket WorkingSocket remoteAddr = Socket { - allocate = \localAddr -> pure Sock {remoteAddr, localAddr} - , connect = \_ _ _ -> pure () +mkSnocket WorkingSnocket localAddr remoteAddr = Snocket { + getLocalAddr = \Sock{localAddr = addr} -> pure addr + , getRemoteAddr = \Sock{remoteAddr = addr} -> pure addr + , addrFamily = error "not supported" + , open = \_ -> pure Sock {remoteAddr, localAddr} + , openToConnect = \_ -> pure Sock {remoteAddr, localAddr} + , connect = \_ _ -> pure () + , bind = \_ _ -> pure () + , listen = \_ -> pure () + , accept = \_ -> error "not supported" , close = \_ -> pure () - , getSocketName = \Sock{localAddr} -> pure localAddr - , getPeerName = \Sock{remoteAddr = addr} -> pure addr + , toBearer = \_ _ -> error "not supported" } data ArbApp addr = ArbApp (Maybe ArbException) (Sock addr -> IO ()) @@ -318,7 +340,7 @@ instance Function ArbTime where function = functionRealFrac prop_subscriptionWorker - :: SocketType + :: SnocketType -> Int -- local address -> Int -- remote address -> ArbValidPeerState IO @@ -340,7 +362,7 @@ prop_subscriptionWorker nullTracer tbl peerStatesVar - (mkSocket sockType remoteAddr) + (mkSnocket sockType localAddr remoteAddr) WorkerCallbacks { wcSocketStateChangeTx = \ss s -> do s' <- socketStateChangeTx ss s @@ -378,7 +400,7 @@ prop_subscriptionWorker main doneVar s = do done <- maybe False (const True) <$> tryReadTMVar doneVar let r = case sockType of - WorkingSocket -> case merr of + WorkingSnocket -> case merr of -- TODO: we don't have access to the time when the transition was -- evaluated. Nothing -> True diff --git a/ouroboros-network/test/Test/Socket.hs b/ouroboros-network/test/Test/Socket.hs index afa05c622ec..0fec6f10906 100644 --- a/ouroboros-network/test/Test/Socket.hs +++ b/ouroboros-network/test/Test/Socket.hs @@ -21,13 +21,21 @@ import Control.Monad.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTimer import qualified Data.ByteString.Lazy as BL +#if defined(mingw32_HOST_OS) +import qualified Data.ByteString as BS +#endif + import Data.Functor ((<$)) import Data.Int (Int64) import Data.List (mapAccumL) import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Void (Void) import qualified Network.Socket as Socket +#if defined(mingw32_HOST_OS) +import qualified System.Win32.Async as Win32.Async +#else import qualified Network.Socket.ByteString.Lazy as Socket (sendAll) +#endif #ifndef mingw32_HOST_OS import System.Directory (removeFile) import System.IO.Error @@ -48,9 +56,11 @@ import qualified Network.Mux as Mx hiding (MiniProtocolLimits (..)) import qualified Network.Mux.Bearer.Socket as Mx import Ouroboros.Network.Mux as Mx +import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Block (Tip, decodeTip, encodeTip) +import Ouroboros.Network.IOManager import Ouroboros.Network.Magic import Ouroboros.Network.MockChain.Chain (Chain, ChainUpdate, Point) import qualified Ouroboros.Network.MockChain.Chain as Chain @@ -101,7 +111,7 @@ tests = , after AllFinish LAST_IP_TEST $ testProperty "socket close during receive" prop_socket_recv_close , after AllFinish "socket close during receive" $ - testProperty "socket client connection failure" prop_socket_client_connect_error + testProperty "socket client connection failure" (withMaxSuccess 25 prop_socket_client_connect_error) , after AllFinish "socket client connection failure" $ testProperty "socket sync demo" prop_socket_demo ] @@ -154,7 +164,7 @@ prop_socket_send_recv_ipv4 prop_socket_send_recv_ipv4 f xs = ioProperty $ do server:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6061") client:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") - prop_socket_send_recv client server f xs + prop_socket_send_recv (Socket.addrAddress client) (Socket.addrAddress server) f xs #ifdef OUROBOROS_NETWORK_IPV6 @@ -182,7 +192,8 @@ prop_socket_send_recv_unix request response = ioProperty $ do (Socket.SockAddrUnix serverName) Nothing clientAddr = Socket.AddrInfo [] Socket.AF_UNIX Socket.Stream Socket.defaultProtocol (Socket.SockAddrUnix clientName) Nothing - r <- prop_socket_send_recv clientAddr serverAddr request response + r <- prop_socket_send_recv (Socket.addrAddress clientAddr) (Socket.addrAddress serverAddr) + request response cleanUp serverName cleanUp clientName return $ r @@ -196,12 +207,12 @@ prop_socket_send_recv_unix request response = ioProperty $ do -- | Verify that an initiator and a responder can send and receive messages from each other -- over a TCP socket. Large DummyPayloads will be split into smaller segments and the -- testcases will verify that they are correctly reassembled into the original message. -prop_socket_send_recv :: Socket.AddrInfo - -> Socket.AddrInfo +prop_socket_send_recv :: Socket.SockAddr + -> Socket.SockAddr -> (Int -> Int -> (Int, Int)) -> [Int] -> IO Bool -prop_socket_send_recv initiatorAddr responderAddr f xs = do +prop_socket_send_recv initiatorAddr responderAddr f xs = withIOManager $ \iocp -> do cv <- newEmptyTMVarM sv <- newEmptyTMVarM @@ -235,8 +246,10 @@ prop_socket_send_recv initiatorAddr responderAddr f xs = do atomically $ putTMVar cv r waitSibling siblingVar + let snocket = socketSnocket iocp res <- withServerNode + snocket networkTracers networkState responderAddr @@ -246,6 +259,7 @@ prop_socket_send_recv initiatorAddr responderAddr f xs = do nullErrorPolicies $ \_ _ -> do connectToNode + snocket cborTermVersionDataCodec (NetworkConnectTracers activeMuxTracer nullTracer) (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) initiatorApp) @@ -259,7 +273,7 @@ prop_socket_send_recv initiatorAddr responderAddr f xs = do networkTracers = NetworkServerTracers { nstMuxTracer = activeMuxTracer, nstHandshakeTracer = nullTracer, - nstErrorPolicyTracer = nullTracer + nstErrorPolicyTracer = showTracing stdoutTracer } @@ -276,7 +290,7 @@ prop_socket_send_recv initiatorAddr responderAddr f xs = do prop_socket_recv_close :: (Int -> Int -> (Int, Int)) -> [Int] -> Property -prop_socket_recv_close f _ = ioProperty $ do +prop_socket_recv_close f _ = ioProperty $ withIOManager $ \iocp -> do sv <- newEmptyTMVarM @@ -289,9 +303,12 @@ prop_socket_recv_close f _ = ioProperty $ do (ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL (\a -> pure . f a) 0)) atomically $ putTMVar sv r + let snocket :: SocketSnocket + snocket = rawSocketSnocket iocp + bracket - (Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol) - Socket.close + (open snocket (SocketFamily Socket.AF_INET)) + (close snocket) $ \sd -> do -- bind the socket muxAddress:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6061") @@ -300,21 +317,26 @@ prop_socket_recv_close f _ = ioProperty $ do Socket.listen sd 1 withAsync - -- accept a connection and start mux on it - (bracket - (Socket.accept sd) - (\(sd',_) -> Socket.close sd') $ \(sd',_) -> do - let bearer = Mx.socketAsMuxBearer nullTracer sd' - Mx.traceMuxBearerState nullTracer Mx.Connected - Mx.muxStart nullTracer (toApplication app ()) bearer + ( + -- accept a connection and start mux on it + bracket + (runAccept $ accept snocket sd) + (\(sd', _, _) -> Socket.close sd') + $ \(sd', _, _) -> do + let bearer = Mx.socketAsMuxBearer nullTracer sd' + Mx.muxStart nullTracer (toApplication app ()) bearer ) $ \muxAsync -> do -- connect to muxAddress - sd' <- Socket.socket (Socket.addrFamily muxAddress) Socket.Stream Socket.defaultProtocol - Socket.connect sd' (Socket.addrAddress muxAddress) + sd' <- openToConnect snocket (Socket.addrAddress muxAddress) + _ <- connect snocket sd' (Socket.addrAddress muxAddress) +#if defined(mingw32_HOST_OS) + Win32.Async.sendAll sd' $ BS.singleton 0xa +#else Socket.sendAll sd' $ BL.singleton 0xa +#endif Socket.close sd' res <- waitCatch muxAsync @@ -329,7 +351,7 @@ prop_socket_recv_close f _ = ioProperty $ do prop_socket_client_connect_error :: (Int -> Int -> (Int, Int)) -> [Int] -> Property -prop_socket_client_connect_error _ xs = ioProperty $ do +prop_socket_client_connect_error _ xs = ioProperty $ withIOManager $ \iocp -> do serverAddr:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6061") clientAddr:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") @@ -348,11 +370,12 @@ prop_socket_client_connect_error _ xs = ioProperty $ do (res :: Either IOException Bool) <- try $ False <$ connectToNode + (socketSnocket iocp) cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) - (Just clientAddr) - serverAddr + (Just $ Socket.addrAddress clientAddr) + (Socket.addrAddress serverAddr) -- XXX Disregarding the exact exception type pure $ either (const True) id res @@ -362,9 +385,12 @@ demo :: forall block . ( Chain.HasHeader block, Serialise (Chain.HeaderHash block) , Serialise block, Eq block, Show block ) => Chain block -> [ChainUpdate block block] -> IO Bool -demo chain0 updates = do - producerAddress:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6061") - consumerAddress:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") +demo chain0 updates = withIOManager $ \iocp -> do + producerAddressInfo:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6061") + consumerAddressInfo:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") + + let producerAddress = Socket.addrAddress producerAddressInfo + consumerAddress = Socket.addrAddress consumerAddressInfo producerVar <- newTVarM (CPS.initChainProducerState chain0) consumerVar <- newTVarM chain0 @@ -398,6 +424,7 @@ demo chain0 updates = do (encodeTip encode) (decodeTip decode) withServerNode + (socketSnocket iocp) nullNetworkServerTracers networkState producerAddress @@ -408,6 +435,7 @@ demo chain0 updates = do $ \_ _ -> do withAsync (connectToNode + (socketSnocket iocp) cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) initiatorApp) diff --git a/ouroboros-network/test/Test/Subscription.hs b/ouroboros-network/test/Test/Subscription.hs index e9495134ab7..cf60262ddcb 100644 --- a/ouroboros-network/test/Test/Subscription.hs +++ b/ouroboros-network/test/Test/Subscription.hs @@ -52,10 +52,13 @@ import Ouroboros.Network.Protocol.Handshake.Type (acceptEq, cborTermVe import Ouroboros.Network.Protocol.Handshake.Version (simpleSingletonVersions) +import Ouroboros.Network.IOManager import Ouroboros.Network.Magic import Ouroboros.Network.Mux -import Ouroboros.Network.NodeToNode hiding (dnsSubscriptionWorker, - ipSubscriptionWorker) +import Ouroboros.Network.NodeToNode hiding ( ipSubscriptionWorker + , dnsSubscriptionWorker + ) +import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Subscription import Ouroboros.Network.Subscription.Dns @@ -375,7 +378,7 @@ _prop_resolv_io lr = ioProperty $ prop_resolv lr prop_sub_io :: LookupResultIO -> Property -prop_sub_io lr = ioProperty $ do +prop_sub_io lr = ioProperty $ withIOManager $ \iocp -> do let serverIdsv4 = case lrioIpv4Result lr of Left _ -> [] Right r -> zip (repeat Socket.AF_INET) r @@ -415,6 +418,7 @@ prop_sub_io lr = ioProperty $ do serverPortMap <- atomically $ readTVar serverPortMapVar networkState <- newNetworkMutableState dnsSubscriptionWorker' + (socketSnocket iocp) activeTracer activeTracer activeTracer @@ -501,8 +505,9 @@ prop_send_recv -> [Int] -> Socket.Family -> Property -prop_send_recv f xs first = ioProperty $ do +prop_send_recv f xs _first = ioProperty $ withIOManager $ \iocp -> do + let first = Socket.AF_INET6 let lr = LookupResultIO (Right [0]) (Right [0]) first 1 serverPortMap = M.fromList [((Socket.AF_INET, 0), 6062), ((Socket.AF_INET6, 0), 6062)] @@ -546,18 +551,20 @@ prop_send_recv f xs first = ioProperty $ do waitSiblingSub siblingVar peerStatesVar <- newPeerStatesVar + let sn = socketSnocket iocp withDummyServer faultyAddress $ withServerNode + sn nullNetworkServerTracers (NetworkMutableState tbl peerStatesVar) - responderAddr + (Socket.addrAddress responderAddr) cborTermVersionDataCodec (\(DictVersion _) -> acceptEq) (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) responderApp) nullErrorPolicies $ \_ _ -> do dnsSubscriptionWorker' - activeTracer activeTracer activeTracer + sn activeTracer activeTracer activeTracer (NetworkMutableState clientTbl peerStatesVar) (mockResolverIO firstDoneVar serverPortMap lr) SubscriptionParams { @@ -571,7 +578,8 @@ prop_send_recv f xs first = ioProperty $ do spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6062 1 } (\_ -> waitSiblingSTM siblingVar) - (connectToNode' + (connectToNodeSocket + iocp cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) @@ -581,6 +589,9 @@ prop_send_recv f xs first = ioProperty $ do return (res == mapAccumL f 0 xs) where + withDummyServer :: Socket.AddrInfo + -> IO a + -> IO a withDummyServer addr k = bracket (Socket.socket (Socket.addrFamily addr) Socket.Stream Socket.defaultProtocol) @@ -610,7 +621,7 @@ prop_send_recv_init_and_rsp :: (Int -> Int -> (Int, Int)) -> [Int] -> Property -prop_send_recv_init_and_rsp f xs = ioProperty $ do +prop_send_recv_init_and_rsp f xs = ioProperty $ withIOManager $ \iocp -> do responderAddr4A:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") responderAddr4B:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0") @@ -632,16 +643,18 @@ prop_send_recv_init_and_rsp f xs = ioProperty $ do stVar <- newPeerStatesVar a_aid <- async $ startPassiveServer + iocp tblA stVar - responderAddr4A + (Socket.addrAddress responderAddr4A) addrAVar rrcfgA b_aid <- async $ startActiveServer + iocp tblB stVar - responderAddr4B + (Socket.addrAddress responderAddr4B) addrBVar addrAVar rrcfgB @@ -675,7 +688,8 @@ prop_send_recv_init_and_rsp f xs = ioProperty $ do waitSiblingSub rrcSiblingVar ) - startPassiveServer tbl stVar responderAddr localAddrVar rrcfg = withServerNode + startPassiveServer iocp tbl stVar responderAddr localAddrVar rrcfg = withServerNode + (socketSnocket iocp) nullNetworkServerTracers (NetworkMutableState tbl stVar) responderAddr @@ -690,38 +704,43 @@ prop_send_recv_init_and_rsp f xs = ioProperty $ do waitSibling (rrcSiblingVar rrcfg) return r - startActiveServer tbl stVar responderAddr localAddrVar remoteAddrVar rrcfg = withServerNode - nullNetworkServerTracers - (NetworkMutableState tbl stVar) - responderAddr - cborTermVersionDataCodec - (\(DictVersion _) -> acceptEq) - ((simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) (appX rrcfg))) - nullErrorPolicies - $ \localAddr _ -> do - peerStatesVar <- newPeerStatesVar - atomically $ putTMVar localAddrVar localAddr - remoteAddr <- atomically $ takeTMVar remoteAddrVar - _ <- subscriptionWorker - activeTracer - activeTracer - (NetworkMutableState tbl peerStatesVar) - WorkerParams { - wpLocalAddresses = LocalAddresses (Just localAddr) Nothing Nothing, - wpConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, - wpSubscriptionTarget = pure $ listSubscriptionTarget [remoteAddr], - wpValency = 1 - } - nullErrorPolicies - (\_ -> waitSiblingSTM (rrcSiblingVar rrcfg)) - (connectToNode' - cborTermVersionDataCodec - nullNetworkConnectTracers - (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) - (DictVersion nodeToNodeCodecCBORTerm) $ appX rrcfg)) - - atomically $ (,) <$> takeTMVar (rrcServerVar rrcfg) - <*> takeTMVar (rrcClientVar rrcfg) + startActiveServer iocp tbl stVar responderAddr localAddrVar remoteAddrVar rrcfg = + let sn = socketSnocket iocp + in withServerNode + sn + nullNetworkServerTracers + (NetworkMutableState tbl stVar) + responderAddr + cborTermVersionDataCodec + (\(DictVersion _) -> acceptEq) + ((simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) (appX rrcfg))) + nullErrorPolicies + $ \localAddr _ -> do + peerStatesVar <- newPeerStatesVar + atomically $ putTMVar localAddrVar localAddr + remoteAddr <- atomically $ takeTMVar remoteAddrVar + _ <- subscriptionWorker + sn + activeTracer + activeTracer + (NetworkMutableState tbl peerStatesVar) + WorkerParams { + wpLocalAddresses = LocalAddresses (Just localAddr) Nothing Nothing, + wpConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, + wpSubscriptionTarget = pure $ listSubscriptionTarget [remoteAddr], + wpValency = 1 + } + nullErrorPolicies + (\_ -> waitSiblingSTM (rrcSiblingVar rrcfg)) + (connectToNodeSocket + iocp + cborTermVersionDataCodec + nullNetworkConnectTracers + (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) + (DictVersion nodeToNodeCodecCBORTerm) $ appX rrcfg)) + + atomically $ (,) <$> takeTMVar (rrcServerVar rrcfg) + <*> takeTMVar (rrcClientVar rrcfg) waitSiblingSub :: StrictTVar IO Int -> IO () waitSiblingSub cntVar = do @@ -751,7 +770,7 @@ local-data: "shelley-1.iohk.example. IN AAAA ::1" local-data: "shelley-0.iohk.example. IN AAAA ::1" -} _demo :: Property -_demo = ioProperty $ do +_demo = ioProperty $ withIOManager $ \iocp -> do server:_ <- Socket.getAddrInfo Nothing (Just "192.168.1.100") (Just "6062") server':_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6062") server6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6062") @@ -764,12 +783,13 @@ _demo = ioProperty $ do peerStatesVar <- newPeerStatesVar stVar <- newPeerStatesVar - spawnServer tbl stVar server 10000 - spawnServer tbl stVar server' 10000 - spawnServer tbl stVar server6 100 - spawnServer tbl stVar server6' 45 + spawnServer iocp tbl stVar server 10000 + spawnServer iocp tbl stVar server' 10000 + spawnServer iocp tbl stVar server6 100 + spawnServer iocp tbl stVar server6' 45 _ <- dnsSubscriptionWorker + (socketSnocket iocp) activeTracer activeTracer activeTracer (NetworkMutableState clientTbl peerStatesVar) SubscriptionParams { @@ -783,7 +803,8 @@ _demo = ioProperty $ do spErrorPolicies = nullErrorPolicies } - (connectToNode' + (connectToNodeSocket + iocp cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) @@ -791,18 +812,19 @@ _demo = ioProperty $ do threadDelay 130 -- bring the servers back again - spawnServer tbl stVar server6 10000 - spawnServer tbl stVar server6' 10000 + spawnServer iocp tbl stVar server6 10000 + spawnServer iocp tbl stVar server6' 10000 threadDelay 1000 return () where - spawnServer tbl stVar addr delay = + spawnServer iocp tbl stVar addr delay = void $ async $ withServerNode + (socketSnocket iocp) nullNetworkServerTracers (NetworkMutableState tbl stVar) - addr + (Socket.addrAddress addr) cborTermVersionDataCodec (\(DictVersion _) -> acceptEq) (simpleSingletonVersions NodeToNodeV_1 (NodeToNodeVersionData $ NetworkMagic 0) From edcad9fc3fdccac181860c164504ac07fefa2461 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 18:22:52 +0100 Subject: [PATCH 19/33] demo-chain-sync - use snocket This patch also makes it runnable on Windows using named pipes. --- ouroboros-network/demo/chain-sync.hs | 105 ++++++++++-------- .../src/Ouroboros/Network/NodeToClient.hs | 3 + 2 files changed, 59 insertions(+), 49 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index bd6e014883f..5cb54fca2b8 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -44,8 +45,11 @@ import qualified Ouroboros.Network.ChainFragment as CF import Ouroboros.Network.Magic import qualified Ouroboros.Network.MockChain.Chain as Chain import Ouroboros.Network.Mux +import Ouroboros.Network.NodeToClient (LocalConnectionId) import Ouroboros.Network.NodeToNode +import Ouroboros.Network.IOManager import Ouroboros.Network.Point (WithOrigin (..)) +import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Testing.ConcreteBlock @@ -119,22 +123,15 @@ usage = do hPutStrLn stderr "usage: demo-chain-sync [pingpong|pingpong2|chainsync|blockfetch] {client|server} [addr]" exitFailure -mkLocalSocketAddrInfo :: FilePath -> Socket.AddrInfo -mkLocalSocketAddrInfo socketPath = - Socket.AddrInfo - [] - Socket.AF_UNIX - Socket.Stream - Socket.defaultProtocol - (Socket.SockAddrUnix socketPath) - Nothing - defaultLocalSocketAddrPath :: FilePath +#if defined(mingw32_HOST_OS) +defaultLocalSocketAddrPath = "\\\\.\\pipe\\demo-chain-sync" +#else defaultLocalSocketAddrPath = "./demo-chain-sync.sock" +#endif -defaultLocalSocketAddrInfo :: Socket.AddrInfo -defaultLocalSocketAddrInfo = - mkLocalSocketAddrInfo defaultLocalSocketAddrPath +defaultLocalSocketAddr :: LocalAddress +defaultLocalSocketAddr = localAddressFromPath defaultLocalSocketAddrPath rmIfExists :: FilePath -> IO () rmIfExists path = do @@ -157,16 +154,17 @@ instance MiniProtocolLimits DemoProtocol0 where clientPingPong :: Bool -> IO () -clientPingPong pipelined = +clientPingPong pipelined = withIOManager $ \iocp -> connectToNode + (localSnocket iocp defaultLocalSocketAddrPath) cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) Nothing - defaultLocalSocketAddrInfo + defaultLocalSocketAddr where app :: OuroborosApplication InitiatorApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol0 IO LBS.ByteString () Void app = simpleInitiatorApplication protocols @@ -191,13 +189,14 @@ pingPongClientCount 0 = PingPong.SendMsgDone () pingPongClientCount n = SendMsgPing (pure (pingPongClientCount (n-1))) serverPingPong :: IO Void -serverPingPong = do +serverPingPong = withIOManager $ \iocp -> do networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode + (localSnocket iocp defaultLocalSocketAddrPath) nullNetworkServerTracers networkState - defaultLocalSocketAddrInfo + defaultLocalSocketAddr cborTermVersionDataCodec (\(DictVersion _) -> acceptEq) (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) @@ -206,7 +205,7 @@ serverPingPong = do wait serverAsync -- block until async exception where app :: OuroborosApplication ResponderApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol0 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -246,16 +245,17 @@ instance MiniProtocolLimits DemoProtocol1 where clientPingPong2 :: IO () -clientPingPong2 = +clientPingPong2 = withIOManager $ \iocp -> connectToNode + (localSnocket iocp defaultLocalSocketAddrPath) cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) Nothing - defaultLocalSocketAddrInfo + defaultLocalSocketAddr where app :: OuroborosApplication InitiatorApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol1 IO LBS.ByteString () Void app = simpleInitiatorApplication protocols @@ -293,13 +293,14 @@ pingPongClientPipelinedMax c = (\n' -> go (Right n' : acc) o n) serverPingPong2 :: IO Void -serverPingPong2 = do +serverPingPong2 = withIOManager $ \iocp -> do networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode + (localSnocket iocp defaultLocalSocketAddrPath) nullNetworkServerTracers networkState - defaultLocalSocketAddrInfo + defaultLocalSocketAddr cborTermVersionDataCodec (\(DictVersion _) -> acceptEq) (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) @@ -308,7 +309,7 @@ serverPingPong2 = do wait serverAsync -- block until async exception where app :: OuroborosApplication ResponderApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol1 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -344,17 +345,19 @@ instance MiniProtocolLimits DemoProtocol2 where clientChainSync :: [FilePath] -> IO () -clientChainSync sockAddrs = - forConcurrently_ sockAddrs $ \sockAddr -> +clientChainSync sockPaths = withIOManager $ \iocp -> + forConcurrently_ sockPaths $ \sockPath -> connectToNode + (localSnocket iocp sockPath) cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) Nothing - (mkLocalSocketAddrInfo sockAddr) + (localAddressFromPath sockPath) + where app :: OuroborosApplication InitiatorApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol2 IO LBS.ByteString () Void app = simpleInitiatorApplication protocols @@ -369,13 +372,14 @@ clientChainSync sockAddrs = serverChainSync :: FilePath -> IO Void -serverChainSync sockAddr = do +serverChainSync sockAddr = withIOManager $ \iocp -> do networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode + (localSnocket iocp defaultLocalSocketAddrPath) nullNetworkServerTracers networkState - (mkLocalSocketAddrInfo sockAddr) + (localAddressFromPath sockAddr) cborTermVersionDataCodec (\(DictVersion _) -> acceptEq) (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) @@ -386,7 +390,7 @@ serverChainSync sockAddr = do prng = mkSMGen 0 app :: OuroborosApplication ResponderApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol2 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -431,7 +435,7 @@ instance MiniProtocolLimits DemoProtocol3 where clientBlockFetch :: [FilePath] -> IO () -clientBlockFetch sockAddrs = do +clientBlockFetch sockAddrs = withIOManager $ \iocp -> do registry <- newFetchClientRegistry blockHeap <- mkTestFetchedBlockHeap [] @@ -439,12 +443,12 @@ clientBlockFetch sockAddrs = do currentChainVar <- newTVarIO genesisChainFragment let app :: OuroborosApplication InitiatorApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol3 IO LBS.ByteString () Void app = OuroborosInitiatorApplication protocols - protocols :: ConnectionId Socket.SockAddr + protocols :: LocalConnectionId -> DemoProtocol3 -> Channel IO LBS.ByteString -> IO () @@ -475,7 +479,7 @@ clientBlockFetch sockAddrs = do (blockFetchClient clientCtx) blockFetchPolicy :: BlockFetchConsensusInterface - (ConnectionId Socket.SockAddr) BlockHeader Block IO + LocalConnectionId BlockHeader Block IO blockFetchPolicy = BlockFetchConsensusInterface { readCandidateChains = readTVar candidateChainsVar @@ -536,11 +540,12 @@ clientBlockFetch sockAddrs = do peerAsyncs <- sequence [ async $ connectToNode + (localSnocket iocp defaultLocalSocketAddrPath) cborTermVersionDataCodec nullNetworkConnectTracers (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) Nothing - (mkLocalSocketAddrInfo sockAddr) + (localAddressFromPath sockAddr) | sockAddr <- sockAddrs ] fetchAsync <- async $ @@ -571,13 +576,14 @@ clientBlockFetch sockAddrs = do serverBlockFetch :: FilePath -> IO Void -serverBlockFetch sockAddr = do +serverBlockFetch sockAddr = withIOManager $ \iocp -> do networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode + (localSnocket iocp defaultLocalSocketAddrPath) nullNetworkServerTracers networkState - (mkLocalSocketAddrInfo sockAddr) + (localAddressFromPath sockAddr) cborTermVersionDataCodec (\(DictVersion _) -> acceptEq) (simpleSingletonVersions (0::Int) (NodeToNodeVersionData $ NetworkMagic 0) (DictVersion nodeToNodeCodecCBORTerm) app) @@ -588,7 +594,7 @@ serverBlockFetch sockAddr = do prng = mkSMGen 0 app :: OuroborosApplication ResponderApp - (ConnectionId Socket.SockAddr) + LocalConnectionId DemoProtocol3 IO LBS.ByteString Void () app = simpleResponderApplication protocols @@ -839,15 +845,16 @@ bodyDataCycle :: Int bodyDataCycle = length doloremIpsum doloremIpsum :: String -doloremIpsum = - "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam hendrerit\ - \ nisi sed sollicitudin pellentesque. Nunc posuere purus rhoncus pulvinar\ - \ aliquam. Ut aliquet tristique nisl vitae volutpat. Nulla aliquet porttitor\ - \ venenatis. Donec a dui et dui fringilla consectetur id nec massa. Aliquam\ - \ erat volutpat. Sed ut dui ut lacus dictum fermentum vel tincidunt neque.\ - \ Sed sed lacinia lectus. Duis sit amet sodales felis. Duis nunc eros,\ - \ mattis at dui ac, convallis semper risus. In adipiscing ultrices tellus,\ - \ in suscipit massa vehicula eu." +doloremIpsum = concat + [ "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nam hendrerit" + , "nisi sed sollicitudin pellentesque. Nunc posuere purus rhoncus pulvinar" + , "aliquam. Ut aliquet tristique nisl vitae volutpat. Nulla aliquet porttitor" + , "venenatis. Donec a dui et dui fringilla consectetur id nec massa. Aliquam" + , "erat volutpat. Sed ut dui ut lacus dictum fermentum vel tincidunt neque." + , "Sed sed lacinia lectus. Duis sit amet sodales felis. Duis nunc eros," + , "mattis at dui ac, convallis semper risus. In adipiscing ultrices tellus," + , "in suscipit massa vehicula eu." + ] -- -- Mock downloaded block heap diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 9efa5289032..8cbfe49cfa1 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -41,6 +41,7 @@ module Ouroboros.Network.NodeToClient ( -- * Re-exports , ConnectionId (..) + , LocalConnectionId , ErrorPolicies (..) , networkErrorPolicies , nullErrorPolicies @@ -409,3 +410,5 @@ networkErrorPolicies = ErrorPolicies shortDelay :: DiffTime shortDelay = 20 -- seconds + +type LocalConnectionId = ConnectionId LocalAddress From 0c93670d3025fa703f36196871f61f4014e013e7 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 17:25:34 +0100 Subject: [PATCH 20/33] Win32-network: derive Show instance for IOCompletionPort --- Win32-network/src/System/Win32/Async/IOManager.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Win32-network/src/System/Win32/Async/IOManager.hs b/Win32-network/src/System/Win32/Async/IOManager.hs index 45de0df4833..ce8170ae46e 100644 --- a/Win32-network/src/System/Win32/Async/IOManager.hs +++ b/Win32-network/src/System/Win32/Async/IOManager.hs @@ -34,6 +34,7 @@ import System.Win32.Async.ErrCode -- -- newtype IOCompletionPort = IOCompletionPort HANDLE + deriving Show closeIOCompletionPort :: IOCompletionPort -> IO () closeIOCompletionPort (IOCompletionPort iocp) = Win32.closeHandle iocp From aff62d1710a09e12c5d4d93276f227e2c0825ed7 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 21 Jan 2020 18:39:10 +0100 Subject: [PATCH 21/33] Rename Ouroboros.Network.Socket.fromSocket to fromSnocket --- ouroboros-network/src/Ouroboros/Network/Socket.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index 60cfd329144..b1b3dec77f2 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -33,7 +33,7 @@ module Ouroboros.Network.Socket ( , nullNetworkServerTracers -- * Helper function for creating servers - , fromSocket + , fromSnocket , beginConnection -- * Re-export of PeerStates @@ -374,13 +374,13 @@ mkListeningSocket sn addr family_ = do -- | -- Make a server-compatible socket from a network socket. -- -fromSocket +fromSnocket :: forall fd addr. Ord addr => ConnectionTable IO addr -> Snocket IO fd addr -> fd -- ^ socket or handle -> Server.Socket addr fd -fromSocket tblVar sn sd = go (Snocket.accept sn sd) +fromSnocket tblVar sn sd = go (Snocket.accept sn sd) where go :: Snocket.Accept addr fd -> Server.Socket addr fd go (Snocket.Accept accept) = Server.Socket $ do @@ -487,7 +487,7 @@ runServerThread NetworkServerTracers { nstMuxTracer sockAddr <- Snocket.getLocalAddr sn sd Server.run nstErrorPolicyTracer - (fromSocket nmsConnectionTable sn sd) + (fromSnocket nmsConnectionTable sn sd) (acceptException sockAddr) (beginConnection sn nstMuxTracer nstHandshakeTracer versionDataCodec acceptVersion (acceptConnectionTx sockAddr)) -- register producer when application starts, it will be unregistered From 9682241931aa96284906f83a055e8e27df451180 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 23 Jan 2020 14:19:23 +0100 Subject: [PATCH 22/33] Added debugging tracers to Ouroboros.Network.Socket These are useful for pluging in tests for debugging purposes. --- .../src/Ouroboros/Network/Socket.hs | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index b1b3dec77f2..13677b6a487 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -29,8 +29,10 @@ module Ouroboros.Network.Socket ( -- * Traces , NetworkConnectTracers (..) , nullNetworkConnectTracers + , debuggingNetworkConnectTracers , NetworkServerTracers (..) , nullNetworkServerTracers + , debuggingNetworkServerTracers -- * Helper function for creating servers , fromSnocket @@ -119,6 +121,13 @@ nullNetworkConnectTracers = NetworkConnectTracers { } +debuggingNetworkConnectTracers :: (Show addr, Show ptcl, Show vNumber) + => NetworkConnectTracers addr ptcl vNumber +debuggingNetworkConnectTracers = NetworkConnectTracers { + nctMuxTracer = showTracing stdoutTracer, + nctHandshakeTracer = showTracing stdoutTracer + } + sockAddrFamily :: Socket.SockAddr -> Socket.Family @@ -418,6 +427,14 @@ nullNetworkServerTracers = NetworkServerTracers { nstErrorPolicyTracer = nullTracer } +debuggingNetworkServerTracers :: (Show addr, Show ptcl, Show vNumber) + => NetworkServerTracers addr ptcl vNumber +debuggingNetworkServerTracers = NetworkServerTracers { + nstMuxTracer = showTracing stdoutTracer, + nstHandshakeTracer = showTracing stdoutTracer, + nstErrorPolicyTracer = showTracing stdoutTracer + } + -- | Mutable state maintained by the network component. -- From 09590748b06b5a6e7c2a14606d634794b771fb2c Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 23 Jan 2020 14:50:12 +0100 Subject: [PATCH 23/33] NetworkDNSSubscriptionTracers take addr rather than peerid --- ouroboros-network/src/Ouroboros/Network/NodeToNode.hs | 4 ++-- ouroboros-network/src/Ouroboros/Network/Tracers.hs | 11 +++++------ 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index c2665df9378..5f48f389a8c 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -357,7 +357,7 @@ dnsSubscriptionWorker :: forall appType x y. ( HasInitiator appType ~ True ) => SocketSnocket - -> NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) + -> NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion Socket.SockAddr -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams () -> Versions @@ -401,7 +401,7 @@ dnsSubscriptionWorker_V1 :: forall appType x y. ( HasInitiator appType ~ True ) => SocketSnocket - -> NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion (ConnectionId Socket.SockAddr) + -> NetworkDNSSubscriptionTracers NodeToNodeProtocols NodeToNodeVersion Socket.SockAddr -> NetworkMutableState Socket.SockAddr -> DnsSubscriptionParams () -> NodeToNodeVersionData diff --git a/ouroboros-network/src/Ouroboros/Network/Tracers.hs b/ouroboros-network/src/Ouroboros/Network/Tracers.hs index 37149224cfd..1fb9d39c91c 100644 --- a/ouroboros-network/src/Ouroboros/Network/Tracers.hs +++ b/ouroboros-network/src/Ouroboros/Network/Tracers.hs @@ -8,7 +8,6 @@ module Ouroboros.Network.Tracers import Control.Tracer (Tracer, nullTracer) import qualified Codec.CBOR.Term as CBOR -import Network.Socket (SockAddr) import Network.Mux.Trace import Network.TypedProtocol.Driver (TraceSendRecv) @@ -48,19 +47,19 @@ nullNetworkIPSubscriptionTracers = NetworkIPSubscriptionTracers { -- | DNS subscription tracers. -- -data NetworkDNSSubscriptionTracers ptcl vNumber peerid = NetworkDNSSubscriptionTracers { - ndstMuxTracer :: Tracer IO (WithMuxBearer peerid MuxTrace), +data NetworkDNSSubscriptionTracers ptcl vNumber addr = NetworkDNSSubscriptionTracers { + ndstMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace), -- ^ low level mux-network tracer, which logs mux sdu (send and received) -- and other low level multiplexing events. - ndstHandshakeTracer :: Tracer IO (WithMuxBearer peerid + ndstHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))), -- ^ handshake protocol tracer; it is important for analysing version -- negotation mismatches. - ndstErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace), + ndstErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), -- ^ error policy tracer; must not be 'nullTracer', otherwise all the -- exceptions which are not matched by any error policy will be caught -- and not logged or rethrown. - ndstSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr)), + ndstSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace addr)), -- ^ subscription tracer; it is infrequent it should not be 'nullTracer' -- by default. ndstDnsTracer :: Tracer IO (WithDomainName DnsTrace) From 3821baf346a2807a6cad1ac036eedc3e05cca72f Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 24 Jan 2020 07:50:46 +0100 Subject: [PATCH 24/33] Updated ouroboros-consensus * ConnectionId NoUnexpectedThunks is now derived via 'UseIsNormalForm', rather than via generics. This way we get an instance for 'ConnectionId SockAddr' as well ('SockAddr' does not have Generic instance) * 'NodeToNode' module exports 'RemoteConnectionId' type allias. This way 'ouroboros-'consensus does not need to import 'Network.Socket'. * updated 'Ouroboros.Consensus.Node' module --- .../src/Ouroboros/Consensus/Node.hs | 60 +++++++++---------- .../src/Ouroboros/Consensus/NodeNetwork.hs | 47 ++++++++------- .../test-consensus/Test/ThreadNet/Network.hs | 5 +- .../src/Ouroboros/Network/NodeToNode.hs | 3 + .../src/Ouroboros/Network/Socket.hs | 7 ++- 5 files changed, 64 insertions(+), 58 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index e9affc1a33e..12a1d8adb46 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -26,6 +26,7 @@ module Ouroboros.Consensus.Node , IPSubscriptionTarget (..) , DnsSubscriptionTarget (..) , ConnectionId (..) + , RemoteConnectionId -- * Internal helpers , openChainDB , mkChainDbArgs @@ -43,12 +44,12 @@ import Data.Time.Clock (secondsToDiffTime) import Ouroboros.Network.Diffusion import Ouroboros.Network.Magic import Ouroboros.Network.NodeToClient (DictVersion (..), - NodeToClientVersionData (..), nodeToClientCodecCBORTerm) + LocalConnectionId, NodeToClientVersionData (..), + nodeToClientCodecCBORTerm) import Ouroboros.Network.NodeToNode (NodeToNodeVersionData (..), - nodeToNodeCodecCBORTerm) + RemoteConnectionId, nodeToNodeCodecCBORTerm) import Ouroboros.Network.Protocol.ChainSync.PipelineDecision (pipelineDecisionLowHighMark) -import Ouroboros.Network.Socket (ConnectionId) import Ouroboros.Consensus.Block (BlockProtocol) import Ouroboros.Consensus.BlockchainTime @@ -94,8 +95,8 @@ data IsProducer run :: forall blk. RunNode blk - => Tracers IO ConnectionId blk -- ^ Consensus tracers - -> ProtocolTracers IO ConnectionId blk DeserialiseFailure + => Tracers IO RemoteConnectionId blk -- ^ Consensus tracers + -> ProtocolTracers IO RemoteConnectionId LocalConnectionId blk DeserialiseFailure -- ^ Protocol tracers -> Tracer IO (ChainDB.TraceEvent blk) -- ^ ChainDB tracer -> DiffusionTracers -- ^ Diffusion tracers @@ -106,9 +107,9 @@ run -> IsProducer -> (ChainDbArgs IO blk -> ChainDbArgs IO blk) -- ^ Customise the 'ChainDbArgs' - -> (NodeArgs IO ConnectionId blk -> NodeArgs IO ConnectionId blk) + -> (NodeArgs IO RemoteConnectionId blk -> NodeArgs IO RemoteConnectionId blk) -- ^ Customise the 'NodeArgs' - -> (ResourceRegistry IO -> NodeKernel IO ConnectionId blk -> IO ()) + -> (ResourceRegistry IO -> NodeKernel IO RemoteConnectionId blk -> IO ()) -- ^ Called on the 'NodeKernel' after creating it, but before the network -- layer is initialised. -> IO () @@ -163,13 +164,12 @@ run tracers protocolTracers chainDbTracer diffusionTracers diffusionArguments let nodeArgs = customiseNodeArgs $ mkNodeArgs registry - cfg - initState - tracers - btime - chainDB - isProducer - + cfg + initState + tracers + btime + chainDB + isProducer nodeKernel <- initNodeKernel nodeArgs onNodeKernel registry nodeKernel @@ -195,11 +195,11 @@ run tracers protocolTracers chainDbTracer diffusionTracers diffusionArguments nodeToClientVersionData = NodeToClientVersionData { networkMagic = networkMagic } mkNetworkApps - :: NodeArgs IO ConnectionId blk - -> NodeKernel IO ConnectionId blk + :: NodeArgs IO RemoteConnectionId blk + -> NodeKernel IO RemoteConnectionId blk -> NetworkProtocolVersion blk -> NetworkApplication - IO ConnectionId + IO RemoteConnectionId LocalConnectionId ByteString ByteString ByteString ByteString ByteString ByteString () mkNetworkApps nodeArgs nodeKernel version = consensusNetworkApps @@ -211,20 +211,20 @@ run tracers protocolTracers chainDbTracer diffusionTracers diffusionArguments mkDiffusionApplications :: ( NetworkProtocolVersion blk -> NetworkApplication - IO ConnectionId - ByteString ByteString ByteString ByteString ByteString ByteString - () + IO RemoteConnectionId LocalConnectionId + ByteString ByteString ByteString ByteString ByteString ByteString + () ) -> DiffusionApplications mkDiffusionApplications networkApps = DiffusionApplications - { daResponderApplication = combineVersions [ - simpleSingletonVersions - (nodeToNodeProtocolVersion (Proxy @blk) version) - nodeToNodeVersionData - (DictVersion nodeToNodeCodecCBORTerm) - (responderNetworkApplication $ networkApps version) - | version <- supportedNetworkProtocolVersions (Proxy @blk) - ] + { daResponderApplication = combineVersions [ + simpleSingletonVersions + (nodeToNodeProtocolVersion (Proxy @blk) version) + nodeToNodeVersionData + (DictVersion nodeToNodeCodecCBORTerm) + (responderNetworkApplication $ networkApps version) + | version <- supportedNetworkProtocolVersions (Proxy @blk) + ] , daInitiatorApplication = combineVersions [ simpleSingletonVersions (nodeToNodeProtocolVersion (Proxy @blk) version) @@ -318,11 +318,11 @@ mkNodeArgs => ResourceRegistry IO -> NodeConfig (BlockProtocol blk) -> NodeState (BlockProtocol blk) - -> Tracers IO ConnectionId blk + -> Tracers IO RemoteConnectionId blk -> BlockchainTime IO -> ChainDB IO blk -> IsProducer - -> NodeArgs IO ConnectionId blk + -> NodeArgs IO RemoteConnectionId blk mkNodeArgs registry cfg initState tracers btime chainDB isProducer = NodeArgs { tracers , registry diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs index 98d224cc14f..084911290b4 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs @@ -315,20 +315,20 @@ protocolCodecsId = ProtocolCodecs { } -- | A record of 'Tracer's for the different protocols. -type ProtocolTracers m peer blk failure = ProtocolTracers' peer blk failure (Tracer m) +type ProtocolTracers m peer localPeer blk failure = ProtocolTracers' peer localPeer blk failure (Tracer m) -data ProtocolTracers' peer blk failure f = ProtocolTracers { +data ProtocolTracers' peer localPeer blk failure f = ProtocolTracers { ptChainSyncTracer :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Header blk) (Tip blk)))) , ptChainSyncSerialisedTracer :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised (Header blk)) (Tip blk)))) , ptBlockFetchTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch blk))) , ptBlockFetchSerialisedTracer :: f (TraceLabelPeer peer (TraceSendRecv (BlockFetch (Serialised blk)))) , ptTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk)))) - , ptLocalChainSyncTracer :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised blk) (Tip blk)))) - , ptLocalTxSubmissionTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))) - , ptLocalStateQueryTracer :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Query blk)))) + , ptLocalChainSyncTracer :: f (TraceLabelPeer localPeer (TraceSendRecv (ChainSync (Serialised blk) (Tip blk)))) + , ptLocalTxSubmissionTracer :: f (TraceLabelPeer localPeer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))) + , ptLocalStateQueryTracer :: f (TraceLabelPeer localPeer (TraceSendRecv (LocalStateQuery blk (Query blk)))) } -instance (forall a. Semigroup (f a)) => Semigroup (ProtocolTracers' peer blk failure f) where +instance (forall a. Semigroup (f a)) => Semigroup (ProtocolTracers' peer localPeer blk failure f) where l <> r = ProtocolTracers { ptChainSyncTracer = f ptChainSyncTracer , ptChainSyncSerialisedTracer = f ptChainSyncSerialisedTracer @@ -341,12 +341,12 @@ instance (forall a. Semigroup (f a)) => Semigroup (ProtocolTracers' peer blk fai } where f :: forall a. Semigroup a - => (ProtocolTracers' peer blk failure f -> a) + => (ProtocolTracers' peer localPeer blk failure f -> a) -> a f prj = prj l <> prj r -- | Use a 'nullTracer' for each protocol. -nullProtocolTracers :: Monad m => ProtocolTracers m peer blk failure +nullProtocolTracers :: Monad m => ProtocolTracers m peer localPeer blk failure nullProtocolTracers = ProtocolTracers { ptChainSyncTracer = nullTracer , ptChainSyncSerialisedTracer = nullTracer @@ -360,6 +360,7 @@ nullProtocolTracers = ProtocolTracers { showProtocolTracers :: ( Show blk , Show peer + , Show localPeer , Show (Header blk) , Show (GenTx blk) , Show (GenTxId blk) @@ -367,7 +368,7 @@ showProtocolTracers :: ( Show blk , ShowQuery (Query blk) , HasHeader blk ) - => Tracer m String -> ProtocolTracers m peer blk failure + => Tracer m String -> ProtocolTracers m peer localPeer blk failure showProtocolTracers tr = ProtocolTracers { ptChainSyncTracer = showTracing tr , ptChainSyncSerialisedTracer = showTracing tr @@ -385,7 +386,7 @@ showProtocolTracers tr = ProtocolTracers { -- useful for running different encoding on each channel in tests (identity -- codecs). -- -data NetworkApplication m peer +data NetworkApplication m peer localPeer bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ a = NetworkApplication { -- | Start a chain sync client that communicates with the given upstream @@ -410,13 +411,13 @@ data NetworkApplication m peer , naTxSubmissionServer :: peer -> Channel m bytesTX -> m a -- | Start a local chain sync server. - , naLocalChainSyncServer :: peer -> Channel m bytesLCS -> m a + , naLocalChainSyncServer :: localPeer -> Channel m bytesLCS -> m a -- | Start a local transaction submission server. - , naLocalTxSubmissionServer :: peer -> Channel m bytesLTX -> m a + , naLocalTxSubmissionServer :: localPeer -> Channel m bytesLTX -> m a -- | Start a local state query server. - , naLocalStateQueryServer :: peer -> Channel m bytesLSQ -> m a + , naLocalStateQueryServer :: localPeer -> Channel m bytesLSQ -> m a } @@ -424,7 +425,7 @@ data NetworkApplication m peer -- for the 'NodeToNodeProtocols'. -- initiatorNetworkApplication - :: NetworkApplication m peer bytes bytes bytes bytes bytes bytes a + :: NetworkApplication m peer localPeer bytes bytes bytes bytes bytes bytes a -> OuroborosApplication 'InitiatorApp peer NodeToNodeProtocols m bytes a Void initiatorNetworkApplication NetworkApplication {..} = OuroborosInitiatorApplication $ \them ptcl -> case ptcl of @@ -436,7 +437,7 @@ initiatorNetworkApplication NetworkApplication {..} = -- for the 'NodeToNodeProtocols'. -- responderNetworkApplication - :: NetworkApplication m peer bytes bytes bytes bytes bytes bytes a + :: NetworkApplication m peer localPeer bytes bytes bytes bytes bytes bytes a -> OuroborosApplication 'ResponderApp peer NodeToNodeProtocols m bytes Void a responderNetworkApplication NetworkApplication {..} = OuroborosResponderApplication $ \them ptcl -> case ptcl of @@ -448,8 +449,8 @@ responderNetworkApplication NetworkApplication {..} = -- for the 'NodeToClientProtocols'. -- localResponderNetworkApplication - :: NetworkApplication m peer bytes bytes bytes bytes bytes bytes a - -> OuroborosApplication 'ResponderApp peer NodeToClientProtocols m bytes Void a + :: NetworkApplication m peer localPeer bytes bytes bytes bytes bytes bytes a + -> OuroborosApplication 'ResponderApp localPeer NodeToClientProtocols m bytes Void a localResponderNetworkApplication NetworkApplication {..} = OuroborosResponderApplication $ \peer ptcl -> case ptcl of ChainSyncWithBlocksPtcl -> naLocalChainSyncServer peer @@ -461,17 +462,17 @@ localResponderNetworkApplication NetworkApplication {..} = -- 'NodeToNodeVersions'. -- consensusNetworkApps - :: forall m peer blk failure bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ. + :: forall m peer localPeer blk failure bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ. ( IOLike m , Ord peer , Exception failure , ProtocolLedgerView blk ) => NodeKernel m peer blk - -> ProtocolTracers m peer blk failure + -> ProtocolTracers m peer localPeer blk failure -> ProtocolCodecs blk failure m bytesCS bytesCS bytesBF bytesBF bytesTX bytesLCS bytesLTX bytesLSQ -> ProtocolHandlers m peer blk - -> NetworkApplication m peer bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ () + -> NetworkApplication m peer localPeer bytesCS bytesBF bytesTX bytesLCS bytesLTX bytesLSQ () consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHandlers {..} = NetworkApplication { naChainSyncClient, @@ -569,7 +570,7 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan (txSubmissionServerPeerPipelined phTxSubmissionServer) naLocalChainSyncServer - :: peer + :: localPeer -> Channel m bytesLCS -> m () naLocalChainSyncServer them channel = withRegistry $ \registry -> @@ -581,7 +582,7 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan $ phLocalChainSyncServer registry naLocalTxSubmissionServer - :: peer + :: localPeer -> Channel m bytesLTX -> m () naLocalTxSubmissionServer them channel = @@ -592,7 +593,7 @@ consensusNetworkApps kernel ProtocolTracers {..} ProtocolCodecs {..} ProtocolHan (localTxSubmissionServerPeer (pure phLocalTxSubmissionServer)) naLocalStateQueryServer - :: peer + :: localPeer -> Channel m bytesLSQ -> m () naLocalStateQueryServer them channel = diff --git a/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs b/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs index c8aae966d26..92cf12d76e0 100644 --- a/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus/test-consensus/Test/ThreadNet/Network.hs @@ -1072,9 +1072,10 @@ nullDebugProtocolTracers :: , HasHeader blk , TracingConstraints blk , Show peer + , Show localPeer , Show failure ) - => ProtocolTracers m peer blk failure + => ProtocolTracers m peer localPeer blk failure nullDebugProtocolTracers = nullProtocolTracers `asTypeOf` showProtocolTracers debugTracer @@ -1121,7 +1122,7 @@ data LimitedApp m peer blk = -- -- Used internal to this module, essentially as an abbreviation. type LimitedApp' m peer blk unused1 unused2 unused3 = - NetworkApplication m peer + NetworkApplication m peer peer -- The 'ChainSync' and 'BlockFetch' protocols use @'Serialised' x@ for -- the servers and @x@ for the clients. Since both have to match to be -- sent across a channel, we can't use @'AnyMessage' ..@, instead, we diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 5f48f389a8c..a8599361a3f 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -50,6 +50,7 @@ module Ouroboros.Network.NodeToNode ( -- * Re-exports , ConnectionId (..) + , RemoteConnectionId , DecoderFailureOrTooMuchInput , Handshake , LocalAddresses (..) @@ -553,3 +554,5 @@ localNetworkErrorPolicy = ErrorPolicies { where ourBug :: SuspendDecision DiffTime ourBug = Throw + +type RemoteConnectionId = ConnectionId Socket.SockAddr diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index 13677b6a487..14b77308fec 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} @@ -56,6 +57,8 @@ module Ouroboros.Network.Socket ( , sockAddrFamily ) where +import Cardano.Prelude (UseIsNormalForm (..)) + import Control.Concurrent.Async import Control.Exception (IOException, SomeException (..)) -- TODO: remove this, it will not be needed when `orElse` PR will be merged. @@ -146,9 +149,7 @@ data ConnectionId addr = ConnectionId { remoteAddress :: !addr } deriving (Eq, Ord, Show, Generic) - -instance NoUnexpectedThunks addr => NoUnexpectedThunks (ConnectionId addr) - + deriving NoUnexpectedThunks via (UseIsNormalForm (ConnectionId addr)) -- | -- We assume that a TCP segment size of 1440 bytes with initial window of size From 2a603f8f80a6bf36b0282c799fff7342537bd3fb Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 14 Feb 2020 18:50:40 +0100 Subject: [PATCH 25/33] fixup! demo-chain-sync - use snocket --- ouroboros-network/demo/chain-sync.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 5cb54fca2b8..207b33f0743 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -37,8 +37,6 @@ import System.Random.SplitMix import Codec.Serialise (DeserialiseFailure) import qualified Codec.Serialise as CBOR -import qualified Network.Socket as Socket - import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block import qualified Ouroboros.Network.ChainFragment as CF From 44c7f80e0683dad5d915196347f05601c51d9d61 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 31 Jan 2020 10:36:35 +0100 Subject: [PATCH 26/33] Added docs to associateWithIOCompletionPort --- Win32-network/src/System/Win32/Async/IOManager.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Win32-network/src/System/Win32/Async/IOManager.hs b/Win32-network/src/System/Win32/Async/IOManager.hs index ce8170ae46e..6d03b55f734 100644 --- a/Win32-network/src/System/Win32/Async/IOManager.hs +++ b/Win32-network/src/System/Win32/Async/IOManager.hs @@ -56,6 +56,9 @@ createIOCompletionPort concurrentThreads foreign import ccall unsafe "windows.h CreateIoCompletionPort" c_CreateIoCompletionPort :: HANDLE -> HANDLE -> Ptr () -> DWORD -> IO HANDLE +-- | Associate with I/O completion port. This can be used multiple times on +-- a file descriptor. +-- associateWithIOCompletionPort :: Either HANDLE Socket -> IOCompletionPort -> IO () From 36c5e79f761557b3d5d1eed02301298c2fb12e51 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 31 Jan 2020 11:18:29 +0100 Subject: [PATCH 27/33] Improved documentation and layout of the Snocket module --- .../src/Ouroboros/Network/Snocket.hs | 54 +++++++++++++++---- 1 file changed, 45 insertions(+), 9 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Snocket.hs b/ouroboros-network/src/Ouroboros/Network/Snocket.hs index c33495c1abb..5de96b94cb6 100644 --- a/ouroboros-network/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Snocket.hs @@ -4,12 +4,17 @@ {-# LANGUAGE ScopedTypeVariables #-} module Ouroboros.Network.Snocket - ( Accept (..) + ( -- * Snocket Interface + Accept (..) , AddressFamily (..) , Snocket (..) + -- ** Socket based Snocktes , SocketSnocket , socketSnocket , rawSocketSnocket + -- ** Local Snockets + -- Using unix sockets (posix) or named pipes (windows) + -- , LocalSnocket , localSnocket , LocalAddress @@ -66,7 +71,7 @@ import Ouroboros.Network.IOManager -- > loop s -- -- To make common API for both we use a recursive type 'Accept', see --- 'berkeleyAccept' below. Creation of the socket / named pipe is part of +-- 'berkeleyAccept' below. Creation of a socket / named pipe is part of -- 'Snocket', but this means we need to have different recursion step for named -- pipe & sockets. For sockets its recursion step will always return 'accept' -- syscall; for named pipes the first callback will reuse the file descriptor @@ -77,14 +82,9 @@ newtype Accept addr fd = Accept { runAccept :: IO (fd, addr, Accept addr fd) } -data AddressFamily addr where - - SocketFamily :: !Socket.Family - -> AddressFamily Socket.SockAddr - - NamedPipeFamily :: AddressFamily FilePath - +-- | BSD accept loop. +-- berkeleyAccept :: AssociateWithIOCP -> Socket -> Accept SockAddr Socket @@ -107,6 +107,24 @@ berkeleyAccept iocp sock = go return (sock', addr', go) +-- | We support either sockets or named pipes. +-- +data AddressFamily addr where + + SocketFamily :: !Socket.Family + -> AddressFamily Socket.SockAddr + + NamedPipeFamily :: AddressFamily FilePath + +instance Eq (AddressFamily addr) where + SocketFamily fam0 == SocketFamily fam1 = fam0 == fam1 + NamedPipeFamily == NamedPipeFamily = True + +instance Show (AddressFamily addr) where + show (SocketFamily fam) = show fam + show NamedPipeFamily = "NamedPipeFamily" + + -- | Abstract communication interface that can be used by more than -- 'Socket'. Snockets are polymorphic over monad which is used, this feature -- is useful for testing and/or simulations. @@ -145,6 +163,11 @@ data Snocket m fd addr = Snocket { } +-- +-- Socket based Snockets +-- + + socketAddrFamily :: Socket.SockAddr -> AddressFamily Socket.SockAddr @@ -152,8 +175,10 @@ socketAddrFamily (Socket.SockAddrInet _ _ ) = SocketFamily Socket.AF_INET socketAddrFamily (Socket.SockAddrInet6 _ _ _ _) = SocketFamily Socket.AF_INET6 socketAddrFamily (Socket.SockAddrUnix _ ) = SocketFamily Socket.AF_UNIX + type SocketSnocket = Snocket IO Socket SockAddr + -- | Create a 'Snocket' for the given 'Socket.Family'. In the 'bind' method set -- 'Socket.ReuseAddr` and 'Socket.ReusePort'. -- @@ -258,6 +283,11 @@ rawSocketSnocket iocp = Snocket { return sd +-- +-- NamedPipes based Snocket +-- + + #if defined(mingw32_HOST_OS) type HANDLESnocket = Snocket IO Win32.HANDLE FilePath @@ -342,6 +372,12 @@ namedPipeSnocket iocp name = Snocket { return (hpipe, name, acceptNext) #endif + +-- +-- Windows/POSIX type aliases +-- + + -- | System dependent LocalSnocket type #if defined(mingw32_HOST_OS) type LocalSnocket = HANDLESnocket From 855f5f6d7840a0289a826c49ac73131c7e1ecca5 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Mon, 20 Jan 2020 11:49:02 +0100 Subject: [PATCH 28/33] ouroboros-network: pipe tests on windows Run pipe tests on windows using `pipeChannelFromNamedPipe` This patch makes test-network buildable again and enables pipes tests on Windows. --- ouroboros-network/ouroboros-network.cabal | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 13f61bc42c9..b51532ab81f 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -287,6 +287,10 @@ test-suite test-network build-depends: Win32-network <0.2.0.0, Win32 >= 2.5.4.1 && <2.9 + if os(windows) + build-depends: Win32-network <0.2.0.0, + Win32 >= 2.5.4.1 && <2.9 + ghc-options: -Wall -Wno-unticked-promoted-constructors -fno-ignore-asserts From 8dbe1de24a64ae3d9cf2aa7c986f99b3d202ddd9 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 24 Jan 2020 16:56:01 +0100 Subject: [PATCH 29/33] Diffusion - support local clients This allows to connect to the diffusion layer using unix socket or named pipe. Currently we don't support local clients connected using a tcp socket, but this could be easily added in the future. --- .../src/Ouroboros/Network/Diffusion.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index a7567955605..4e1bbc2fbf8 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -28,7 +28,7 @@ import Network.Mux (MuxTrace (..), WithMuxBearer (..)) import Network.Socket (SockAddr, AddrInfo) import qualified Network.Socket as Socket -import Ouroboros.Network.Snocket (SocketSnocket) +import Ouroboros.Network.Snocket (SocketSnocket, LocalSnocket) import qualified Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Protocol.Handshake.Type (Handshake) @@ -82,7 +82,7 @@ data DiffusionTracers = DiffusionTracers { data DiffusionArguments = DiffusionArguments { daAddresses :: [AddrInfo] -- ^ diffusion addresses - , daLocalAddress :: AddrInfo + , daLocalAddress :: FilePath -- ^ address for local clients , daIpProducers :: IPSubscriptionTarget -- ^ ip subscription addresses @@ -150,9 +150,16 @@ runDataDiffusion tracers applications@DiffusionApplications { daErrorPolicies } = withIOManager $ \iocp -> do - let snocket :: SocketSnocket + let -- snocket for remote communication. + snocket :: SocketSnocket snocket = Snocket.socketSnocket iocp + -- snocket for local clients connected using Unix socket or named pipe. + -- we currently don't support remotely connected local clients. If we + -- need to we can add another adress for local clients. + localSnocket :: LocalSnocket + localSnocket = Snocket.localSnocket iocp daLocalAddress + -- networking mutable state networkState <- newNetworkMutableState networkLocalState <- newNetworkMutableState @@ -165,7 +172,7 @@ runDataDiffusion tracers Async.withAsync (cleanNetworkMutableState networkLocalState) $ \cleanLocalNetworkStateThread -> -- fork server for local clients - Async.withAsync (runLocalServer snocket networkLocalState) $ \_ -> + Async.withAsync (runLocalServer localSnocket networkLocalState) $ \_ -> -- fork servers for remote peers withAsyncs (runServer snocket networkState . Socket.addrAddress <$> daAddresses) $ \_ -> @@ -181,8 +188,6 @@ runDataDiffusion tracers Async.waitEither_ cleanNetworkStateThread cleanLocalNetworkStateThread where - -- TODO: this is POSIX only, Windows support will be built later - DiffusionTracers { dtIpSubscriptionTracer , dtDnsSubscriptionTracer , dtDnsResolverTracer @@ -226,7 +231,7 @@ runDataDiffusion tracers dtHandshakeLocalTracer dtErrorPolicyTracer) networkLocalState - (Socket.addrAddress daLocalAddress) + (Snocket.localAddressFromPath daLocalAddress) (daLocalResponderApplication applications) localErrorPolicy From d2205e259ece5aca90483aec56a79ab1de934989 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 24 Jan 2020 20:12:28 +0100 Subject: [PATCH 30/33] Use ClientSnocket in NodeToClient This only allows to connect to a node using a unix socket or a named pipe. --- .../src/Ouroboros/Network/NodeToClient.hs | 84 ++++++++++--------- 1 file changed, 45 insertions(+), 39 deletions(-) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 8cbfe49cfa1..3adefbe3cc3 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -39,6 +39,13 @@ module Ouroboros.Network.NodeToClient ( , chainSyncClientNull , localTxSubmissionClientNull + -- * Re-exported network interface + , AssociateWithIOCP + , withIOManager + , LocalSnocket + , localSnocket + , LocalAddress + -- * Re-exports , ConnectionId (..) , LocalConnectionId @@ -95,6 +102,7 @@ import Ouroboros.Network.Subscription.Ip ( IPSubscriptionTarget (..) , SubscriptionTrace (..) ) import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) +import Ouroboros.Network.IOManager -- | An index type used with the mux to enumerate all the mini-protocols that -- make up the overall node-to-client protocol. @@ -156,41 +164,44 @@ nodeToClientCodecCBORTerm = CodecCBORTerm {encodeTerm, decodeTerm} -- protocol. This is mostly useful for future enhancements. -- connectTo - :: Snocket IO fd addr - -> NetworkConnectTracers addr NodeToClientProtocols NodeToClientVersion + :: LocalSnocket + -- ^ callback constructed by 'Ouroboros.Network.IOManager.withIOManager' + -> NetworkConnectTracers LocalAddress NodeToClientProtocols NodeToClientVersion -> Versions NodeToClientVersion DictVersion - (OuroborosApplication InitiatorApp (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) + (OuroborosApplication InitiatorApp (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString a b) -- ^ A dictionary of protocol versions & applications to run on an established -- connection. The application to run will be chosen by initial handshake -- protocol (the highest shared version will be chosen). - -> Maybe addr - -- ^ local address; the created socket will bind to it - -> addr - -- ^ remote address + -> FilePath + -- ^ path of the unix socket or named pipe -> IO () -connectTo sn = connectToNode sn cborTermVersionDataCodec +connectTo snocket tracers versions path = + connectToNode snocket + cborTermVersionDataCodec + tracers + versions + Nothing + (localAddressFromPath path) -- | A version of 'Ouroboros.Network.Socket.connectToNode' which connects using -- the 'NodeToClientV_1' version of the protocol. -- connectTo_V1 - :: Snocket IO fd addr - -> NetworkConnectTracers addr NodeToClientProtocols NodeToClientVersion + :: LocalSnocket + -> NetworkConnectTracers LocalAddress NodeToClientProtocols NodeToClientVersion -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and -- server must agree on it. - -> (OuroborosApplication InitiatorApp (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) + -> (OuroborosApplication InitiatorApp (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString a b) -- ^ 'OuroborosInitiatorApplication' which is run on an established connection -- using a multiplexer after the initial handshake protocol suceeds. - -> Maybe addr - -- ^ local address; the created socket will bind to it - -> addr - -- ^ remote address + -> FilePath + -- ^ path to unix socket or named pipe -> IO () -connectTo_V1 sn tracers versionData application = +connectTo_V1 snocket tracers versionData application = connectTo - sn + snocket tracers (simpleSingletonVersions NodeToClientV_1 @@ -207,15 +218,14 @@ connectTo_V1 sn tracers versionData application = -- withServer :: ( HasResponder appType ~ True - , Ord addr ) - => Snocket IO fd addr - -> NetworkServerTracers addr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState addr - -> addr + => LocalSnocket + -> NetworkServerTracers LocalAddress NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState LocalAddress + -> LocalAddress -> Versions NodeToClientVersion DictVersion - (OuroborosApplication appType (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) - -> ErrorPolicies addr () + (OuroborosApplication appType (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString a b) + -> ErrorPolicies LocalAddress () -> IO Void withServer sn tracers networkState addr versions errPolicies = withServerNode @@ -236,20 +246,19 @@ withServer sn tracers networkState addr versions errPolicies = -- withServer_V1 :: ( HasResponder appType ~ True - , Ord addr ) - => Snocket IO fd addr - -> NetworkServerTracers addr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState addr - -> addr + => LocalSnocket + -> NetworkServerTracers LocalAddress NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState LocalAddress + -> LocalAddress -> NodeToClientVersionData -- ^ Client version data sent during initial handshake protocol. Client and -- server must agree on it. - -> (OuroborosApplication appType (ConnectionId addr) NodeToClientProtocols IO BL.ByteString a b) + -> (OuroborosApplication appType (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString a b) -- ^ applications which has the reponder side, i.e. -- 'OuroborosResponderApplication' or -- 'OuroborosInitiatorAndResponderApplication'. - -> ErrorPolicies addr () + -> ErrorPolicies LocalAddress () -> IO Void withServer_V1 sn tracers networkState addr versionData application = withServer @@ -264,22 +273,19 @@ withServer_V1 sn tracers networkState addr versionData application = -- established connection. -- ncSubscriptionWorker - :: forall appType fd addr x y. + :: forall appType x y. ( HasInitiator appType ~ True - -- TODO: lift this constraints - , fd ~ Socket.Socket - , addr ~ Socket.SockAddr ) - => Snocket IO fd addr - -> NetworkIPSubscriptionTracers addr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState addr + => LocalSnocket + -> NetworkIPSubscriptionTracers LocalAddress NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState LocalAddress -> IPSubscriptionParams () -> Versions NodeToClientVersion DictVersion (OuroborosApplication appType - (ConnectionId addr) + (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString x y) -> IO Void From aea86dc27cb3bdd390f0290287199dbcd9771e12 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 28 Jan 2020 14:05:29 +0100 Subject: [PATCH 31/33] ErrorPolicies - remove return callback and simplify types --- .../Ouroboros/Consensus/Node/ErrorPolicy.hs | 9 +--- .../src/Ouroboros/Network/Diffusion.hs | 6 +-- .../src/Ouroboros/Network/ErrorPolicy.hs | 41 +++++++------------ .../src/Ouroboros/Network/NodeToClient.hs | 7 ++-- .../src/Ouroboros/Network/NodeToNode.hs | 22 +++------- .../src/Ouroboros/Network/Socket.hs | 4 +- .../src/Ouroboros/Network/Subscription/Ip.hs | 4 +- ouroboros-network/test/Test/PeerState.hs | 8 +--- 8 files changed, 32 insertions(+), 69 deletions(-) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ErrorPolicy.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ErrorPolicy.hs index c54ea2826f4..12bf354d46d 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/ErrorPolicy.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/ErrorPolicy.hs @@ -24,20 +24,13 @@ import Ouroboros.Consensus.Node.ProtocolInfo.Byron import Ouroboros.Consensus.Util.ResourceRegistry (RegistryClosedException, ResourceRegistryThreadException) -consensusErrorPolicy :: ErrorPolicies addr () +consensusErrorPolicy :: ErrorPolicies consensusErrorPolicy = ErrorPolicies { -- Exception raised during connect -- -- This is entirely a network-side concern. epConErrorPolicies = [] - -- What to do when the protocol exits cleanly - -- - -- This never happens (we always throw an exception), so this function - -- should never be called; if for some reason it /does/, we make it - -- throw an exception. - , epReturnCallback = \_time _addr () -> ourBug - -- Exception raised during interaction with the peer -- -- The list below should contain an entry for every type declared as an diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 4e1bbc2fbf8..a228dfee051 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -130,10 +130,8 @@ data DiffusionApplications = DiffusionApplications { ()) -- ^ NodeToClient responder applicaton (server role) - , daErrorPolicies :: ErrorPolicies SockAddr () + , daErrorPolicies :: ErrorPolicies -- ^ error policies - -- - -- TODO: one cannot use `forall a. ErrorPolicies SockAddr a` } runDataDiffusion @@ -218,7 +216,7 @@ runDataDiffusion tracers , laUnix = Nothing } - remoteErrorPolicy, localErrorPolicy :: ErrorPolicies SockAddr () + remoteErrorPolicy, localErrorPolicy :: ErrorPolicies remoteErrorPolicy = NodeToNode.remoteNetworkErrorPolicy <> daErrorPolicies localErrorPolicy = NodeToNode.localNetworkErrorPolicy <> daErrorPolicies diff --git a/ouroboros-network/src/Ouroboros/Network/ErrorPolicy.hs b/ouroboros-network/src/Ouroboros/Network/ErrorPolicy.hs index d31d8aaf4c0..232b1bb20d1 100644 --- a/ouroboros-network/src/Ouroboros/Network/ErrorPolicy.hs +++ b/ouroboros-network/src/Ouroboros/Network/ErrorPolicy.hs @@ -31,7 +31,7 @@ module Ouroboros.Network.ErrorPolicy import Control.Exception (Exception, IOException, SomeException (..)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Data.Semigroup (sconcat) import Data.Set (Set) import qualified Data.Set as Set @@ -47,8 +47,6 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadTime -import Data.Semigroup.Action - import Ouroboros.Network.Subscription.PeerState data ErrorPolicy where @@ -99,20 +97,19 @@ evalErrorPolicies e = -- | List of error policies for exception handling and a policy for handing -- application return values. -- -data ErrorPolicies addr a = ErrorPolicies { +data ErrorPolicies = ErrorPolicies { -- | Application Error Policies epAppErrorPolicies :: [ErrorPolicy] -- | `connect` Error Policies , epConErrorPolicies :: [ErrorPolicy] - , epReturnCallback :: Time -> addr -> a -> SuspendDecision DiffTime } -nullErrorPolicies :: ErrorPolicies addr a -nullErrorPolicies = ErrorPolicies [] [] (\_ _ _ -> Throw) +nullErrorPolicies :: ErrorPolicies +nullErrorPolicies = ErrorPolicies [] [] -instance Semigroup (ErrorPolicies addr a) where - ErrorPolicies aep cep fn <> ErrorPolicies aep' cep' fn' - = ErrorPolicies (aep <> aep') (cep <> cep') (fn <> fn') +instance Semigroup ErrorPolicies where + ErrorPolicies aep cep <> ErrorPolicies aep' cep' + = ErrorPolicies (aep <> aep') (cep <> cep') -- | Sum type which distinguishes between connection and application -- exception traces. @@ -181,7 +178,7 @@ completeApplicationTx , Ord addr , Ord (Async m ()) ) - => ErrorPolicies addr a + => ErrorPolicies -> CompleteApplication m (PeerStates m addr) addr @@ -196,22 +193,12 @@ completeApplicationTx _ _ ps@ThrowException{} = pure $ } -- application returned; classify the return value and update the state. -completeApplicationTx ErrorPolicies {epReturnCallback} (ApplicationResult t addr r) (PeerStates ps) = - let cmd = epReturnCallback t addr r - fn :: Maybe (PeerState m) - -> ( Set (Async m ()) - , Maybe (PeerState m) - ) - fn mbps = ( maybe Set.empty (`threadsToCancel` cmd) mbps - , mbps <| (flip addTime t <$> cmd) - ) - in case alterAndLookup fn addr ps of - (ps', mbthreads) -> pure $ - CompleteApplicationResult { - carState = PeerStates ps', - carThreads = fromMaybe Set.empty mbthreads, - carTrace = WithAddr addr <$> traceErrorPolicy (Right r) cmd - } +completeApplicationTx _ ApplicationResult{} ps = + pure $ CompleteApplicationResult { + carState = ps, + carThreads = Set.empty, + carTrace = Nothing + } -- application errored completeApplicationTx ErrorPolicies {epAppErrorPolicies} (ApplicationError t addr e) ps = diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 3adefbe3cc3..0c8395e8257 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -225,7 +225,7 @@ withServer -> LocalAddress -> Versions NodeToClientVersion DictVersion (OuroborosApplication appType (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString a b) - -> ErrorPolicies LocalAddress () + -> ErrorPolicies -> IO Void withServer sn tracers networkState addr versions errPolicies = withServerNode @@ -258,7 +258,7 @@ withServer_V1 -- ^ applications which has the reponder side, i.e. -- 'OuroborosResponderApplication' or -- 'OuroborosInitiatorAndResponderApplication'. - -> ErrorPolicies LocalAddress () + -> ErrorPolicies -> IO Void withServer_V1 sn tracers networkState addr versionData application = withServer @@ -363,7 +363,7 @@ ncSubscriptionWorker_V1 -- -- If a trusted node sends us a wrong data or -- -networkErrorPolicies :: ErrorPolicies addr a +networkErrorPolicies :: ErrorPolicies networkErrorPolicies = ErrorPolicies { epAppErrorPolicies = [ -- Handshake client protocol error: we either did not recognise received @@ -408,7 +408,6 @@ networkErrorPolicies = ErrorPolicies ErrorPolicy $ \(_ :: IOException) -> Just $ SuspendPeer shortDelay shortDelay ] - , epReturnCallback = \_ _ _ -> ourBug } where ourBug :: SuspendDecision DiffTime diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index a8599361a3f..f0edf658ce6 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -236,7 +236,7 @@ withServer -> NetworkMutableState Socket.SockAddr -> Socket.SockAddr -> Versions NodeToNodeVersion DictVersion (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString a b) - -> ErrorPolicies Socket.SockAddr () + -> ErrorPolicies -> IO Void withServer sn tracers networkState addr versions errPolicies = withServerNode @@ -261,7 +261,7 @@ withServer_V1 -> Socket.SockAddr -> NodeToNodeVersionData -> (OuroborosApplication appType (ConnectionId Socket.SockAddr) NodeToNodeProtocols IO BL.ByteString x y) - -> ErrorPolicies Socket.SockAddr () + -> ErrorPolicies -> IO Void withServer_V1 sn tracers networkState addr versionData application = withServer @@ -433,7 +433,7 @@ dnsSubscriptionWorker_V1 -- | A minimal error policy for remote peers, which only handles exceptions -- raised by `ouroboros-network`. -- -remoteNetworkErrorPolicy :: ErrorPolicies Socket.SockAddr a +remoteNetworkErrorPolicy :: ErrorPolicies remoteNetworkErrorPolicy = ErrorPolicies { epAppErrorPolicies = [ -- Handshake client protocol error: we either did not recognise received @@ -500,9 +500,7 @@ remoteNetworkErrorPolicy = ErrorPolicies { epConErrorPolicies = [ ErrorPolicy $ \(_ :: IOException) -> Just $ SuspendConsumer shortDelay - ], - - epReturnCallback = \_ _ _ -> ourBug + ] } where theyBuggyOrEvil :: SuspendDecision DiffTime @@ -511,9 +509,6 @@ remoteNetworkErrorPolicy = ErrorPolicies { misconfiguredPeer :: SuspendDecision DiffTime misconfiguredPeer = SuspendConsumer defaultDelay - ourBug :: SuspendDecision DiffTime - ourBug = Throw - defaultDelay :: DiffTime defaultDelay = 200 -- seconds @@ -528,7 +523,7 @@ remoteNetworkErrorPolicy = ErrorPolicies { -- killed and not penalised by this policy. This allows to restart the local -- client without a delay. -- -localNetworkErrorPolicy :: ErrorPolicies Socket.SockAddr a +localNetworkErrorPolicy :: ErrorPolicies localNetworkErrorPolicy = ErrorPolicies { epAppErrorPolicies = [ -- exception thrown by `runDecoderWithByteLimit` @@ -547,12 +542,7 @@ localNetworkErrorPolicy = ErrorPolicies { ], -- The node never connects to a local client - epConErrorPolicies = [], - - epReturnCallback = \_ _ _ -> ourBug + epConErrorPolicies = [] } - where - ourBug :: SuspendDecision DiffTime - ourBug = Throw type RemoteConnectionId = ConnectionId Socket.SockAddr diff --git a/ouroboros-network/src/Ouroboros/Network/Socket.hs b/ouroboros-network/src/Ouroboros/Network/Socket.hs index 14b77308fec..463062e9e8c 100644 --- a/ouroboros-network/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Socket.hs @@ -489,7 +489,7 @@ runServerThread -> VersionDataCodec extra CBOR.Term -> (forall vData. extra vData -> vData -> vData -> Accept) -> Versions vNumber extra (OuroborosApplication appType (ConnectionId addr) ptcl IO BL.ByteString a b) - -> ErrorPolicies addr () + -> ErrorPolicies -> IO Void runServerThread NetworkServerTracers { nstMuxTracer , nstHandshakeTracer @@ -589,7 +589,7 @@ withServerNode -- ^ The mux application that will be run on each incoming connection from -- a given address. Note that if @'MuxClientAndServerApplication'@ is -- returned, the connection will run a full duplex set of mini-protocols. - -> ErrorPolicies addr () + -> ErrorPolicies -> (addr -> Async Void -> IO t) -- ^ callback which takes the @Async@ of the thread that is running the server. -- Note: the server thread will terminate when the callback returns or diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs index 06b40745cae..aa0a7d3141f 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs @@ -65,7 +65,7 @@ data SubscriptionParams a target = SubscriptionParams { spLocalAddresses :: LocalAddresses Socket.SockAddr , spConnectionAttemptDelay :: Socket.SockAddr -> Maybe DiffTime -- ^ should return expected delay for the given address - , spErrorPolicies :: ErrorPolicies Socket.SockAddr a + , spErrorPolicies :: ErrorPolicies , spSubscriptionTarget :: target } @@ -181,7 +181,7 @@ subscriptionWorker -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) -> NetworkMutableState Socket.SockAddr -> WorkerParams IO Socket.SockAddr - -> ErrorPolicies Socket.SockAddr a + -> ErrorPolicies -> Main IO (PeerStates IO Socket.SockAddr) x -- ^ main callback -> (Socket.Socket -> IO a) diff --git a/ouroboros-network/test/Test/PeerState.hs b/ouroboros-network/test/Test/PeerState.hs index 8c2bc0278e5..bc463df045d 100644 --- a/ouroboros-network/test/Test/PeerState.hs +++ b/ouroboros-network/test/Test/PeerState.hs @@ -344,13 +344,12 @@ prop_subscriptionWorker -> Int -- local address -> Int -- remote address -> ArbValidPeerState IO - -> (Fun (ArbTime, Int, ()) (ArbSuspendDecision ArbDiffTime)) -> ArbErrorPolicies -> (Blind (ArbApp Int)) -> Property prop_subscriptionWorker sockType localAddr remoteAddr (ArbValidPeerState ps) - returnCallback (ArbErrorPolicies appErrPolicies conErrPolicies) + (ArbErrorPolicies appErrPolicies conErrPolicies) (Blind (ArbApp merr app)) = tabulate "peer states & app errors" [printf "%-20s %s" (peerStateType ps) (exceptionType merr)] $ @@ -391,10 +390,7 @@ prop_subscriptionWorker completeTx = completeApplicationTx (ErrorPolicies appErrPolicies - conErrPolicies - (\t addr r -> fmap getArbDiffTime . getArbSuspendDecision $ case returnCallback of - Fn3 f -> f (ArbTime t) addr r - _ -> error "impossible happend")) + conErrPolicies) main :: StrictTMVar IO () -> Main IO (PeerStates IO Int) Bool main doneVar s = do From c59bb7a117ba1f65484ce241f89c89fb06698205 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 28 Jan 2020 12:59:31 +0100 Subject: [PATCH 32/33] clientSubscriptionWorker A subscription worker which works over ClientSnocket. It is integrated into data diffusion `Ouroboros.Network.Diffusion`. * `ouroboros-network` - compiler and runs all its tests on Windows. * `ouroboros-consensus` - windows support is tracked in #1082 --- ouroboros-network/ouroboros-network.cabal | 1 + .../src/Ouroboros/Network/Diffusion.hs | 28 ++++--- .../src/Ouroboros/Network/NodeToClient.hs | 65 +++++++-------- .../src/Ouroboros/Network/NodeToNode.hs | 21 ++--- .../src/Ouroboros/Network/Snocket.hs | 3 + .../Ouroboros/Network/Subscription/Client.hs | 80 +++++++++++++++++++ .../src/Ouroboros/Network/Subscription/Dns.hs | 1 + .../src/Ouroboros/Network/Subscription/Ip.hs | 26 +++--- .../Ouroboros/Network/Subscription/Worker.hs | 25 +++--- .../src/Ouroboros/Network/Tracers.hs | 29 ++++--- ouroboros-network/test/Test/PeerState.hs | 2 +- ouroboros-network/test/Test/Subscription.hs | 1 + 12 files changed, 187 insertions(+), 95 deletions(-) create mode 100644 ouroboros-network/src/Ouroboros/Network/Subscription/Client.hs diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index b51532ab81f..9dc3880f7b1 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -78,6 +78,7 @@ library Ouroboros.Network.Subscription Ouroboros.Network.Subscription.Ip Ouroboros.Network.Subscription.Dns + Ouroboros.Network.Subscription.Client Ouroboros.Network.Subscription.Subscriber Ouroboros.Network.Subscription.PeerState Ouroboros.Network.Subscription.Worker diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index a228dfee051..53dcc7c9861 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -28,7 +28,7 @@ import Network.Mux (MuxTrace (..), WithMuxBearer (..)) import Network.Socket (SockAddr, AddrInfo) import qualified Network.Socket as Socket -import Ouroboros.Network.Snocket (SocketSnocket, LocalSnocket) +import Ouroboros.Network.Snocket (LocalAddress, SocketSnocket, LocalSnocket) import qualified Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Protocol.Handshake.Type (Handshake) @@ -57,23 +57,24 @@ import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) import Ouroboros.Network.Tracers data DiffusionTracers = DiffusionTracers { - dtIpSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr)) + dtIpSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace SockAddr)) -- ^ IP subscription tracer - , dtDnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr)) + , dtDnsSubscriptionTracer :: Tracer IO (WithDomainName (SubscriptionTrace SockAddr)) -- ^ DNS subscription tracer - , dtDnsResolverTracer :: Tracer IO (WithDomainName DnsTrace) + , dtDnsResolverTracer :: Tracer IO (WithDomainName DnsTrace) -- ^ DNS resolver tracer - , dtMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace) + , dtMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace) -- ^ Mux tracer - , dtMuxLocalTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) MuxTrace) + , dtMuxLocalTracer :: Tracer IO (WithMuxBearer (ConnectionId LocalAddress) MuxTrace) -- ^ Mux tracer for local clients - , dtHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) + , dtHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) (TraceSendRecv (Handshake NodeToNodeVersion CBOR.Term))) -- ^ Handshake protocol tracer - , dtHandshakeLocalTracer :: Tracer IO (WithMuxBearer (ConnectionId SockAddr) + , dtHandshakeLocalTracer :: Tracer IO (WithMuxBearer (ConnectionId LocalAddress) (TraceSendRecv (Handshake NodeToClientVersion CBOR.Term))) -- ^ Handshake protocol tracer for local clients - , dtErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace) + , dtErrorPolicyTracer :: Tracer IO (WithAddr SockAddr ErrorPolicyTrace) + , dtLocalErrorPolicyTracer :: Tracer IO (WithAddr LocalAddress ErrorPolicyTrace) } @@ -122,7 +123,7 @@ data DiffusionApplications = DiffusionApplications { DictVersion (OuroborosApplication 'ResponderApp - (ConnectionId SockAddr) + (ConnectionId LocalAddress) NodeToClientProtocols IO ByteString @@ -194,6 +195,7 @@ runDataDiffusion tracers , dtHandshakeTracer , dtHandshakeLocalTracer , dtErrorPolicyTracer + , dtLocalErrorPolicyTracer } = tracers initiatorLocalAddresses :: LocalAddresses SockAddr @@ -220,14 +222,14 @@ runDataDiffusion tracers remoteErrorPolicy = NodeToNode.remoteNetworkErrorPolicy <> daErrorPolicies localErrorPolicy = NodeToNode.localNetworkErrorPolicy <> daErrorPolicies - runLocalServer :: SocketSnocket -> NetworkMutableState SockAddr -> IO Void + runLocalServer :: LocalSnocket -> NetworkMutableState LocalAddress -> IO Void runLocalServer sn networkLocalState = NodeToClient.withServer sn (NetworkServerTracers dtMuxLocalTracer dtHandshakeLocalTracer - dtErrorPolicyTracer) + dtLocalErrorPolicyTracer) networkLocalState (Snocket.localAddressFromPath daLocalAddress) (daLocalResponderApplication applications) @@ -251,7 +253,7 @@ runDataDiffusion tracers -> IO Void runIpSubscriptionWorker sn networkState = NodeToNode.ipSubscriptionWorker sn - (NetworkIPSubscriptionTracers + (NetworkSubscriptionTracers dtMuxTracer dtHandshakeTracer dtErrorPolicyTracer diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 0c8395e8257..807f5db7142 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -29,9 +29,10 @@ module Ouroboros.Network.NodeToClient ( , withServer_V1 , withServer - , NetworkIPSubscriptionTracers (..) - , IPSubscriptionParams - , SubscriptionParams (..) + + , NetworkClientSubcriptionTracers + , NetworkSubscriptionTracers (..) + , ClientSubscriptionParams (..) , ncSubscriptionWorker , ncSubscriptionWorker_V1 @@ -60,14 +61,14 @@ module Ouroboros.Network.NodeToClient ( , DecoderFailureOrTooMuchInput , Handshake , LocalAddresses (..) - , IPSubscriptionTarget (..) , SubscriptionTrace (..) - , WithIPList (..) ) where import qualified Control.Concurrent.Async as Async import Control.Exception (IOException) import qualified Data.ByteString.Lazy as BL +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Contravariant (contramap) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock @@ -79,8 +80,6 @@ import qualified Codec.CBOR.Term as CBOR import Codec.Serialise (Serialise (..), DeserialiseFailure) import Codec.SerialiseTerm -import qualified Network.Socket as Socket - import Network.Mux hiding (MiniProtocolLimits(..)) import Network.TypedProtocol.Driver.ByteLimit (DecoderFailureOrTooMuchInput) import Network.TypedProtocol.Driver (TraceSendRecv (..)) @@ -95,12 +94,9 @@ import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version import Ouroboros.Network.Snocket import Ouroboros.Network.Socket -import Ouroboros.Network.Subscription.Ip (IPSubscriptionParams, SubscriptionParams (..)) -import qualified Ouroboros.Network.Subscription.Ip as Subscription -import Ouroboros.Network.Subscription.Ip ( IPSubscriptionTarget (..) - , WithIPList (..) - , SubscriptionTrace (..) - ) +import Ouroboros.Network.Subscription.Client ( ClientSubscriptionParams (..) ) +import qualified Ouroboros.Network.Subscription.Client as Subscription +import Ouroboros.Network.Subscription.Ip (SubscriptionTrace (..)) import Ouroboros.Network.Subscription.Worker (LocalAddresses (..)) import Ouroboros.Network.IOManager @@ -269,6 +265,10 @@ withServer_V1 sn tracers networkState addr versionData application = (DictVersion nodeToClientCodecCBORTerm) application) +type NetworkClientSubcriptionTracers + = NetworkSubscriptionTracers Identity LocalAddress NodeToClientProtocols NodeToClientVersion + + -- | 'ncSubscriptionWorker' which starts given application versions on each -- established connection. -- @@ -277,9 +277,9 @@ ncSubscriptionWorker ( HasInitiator appType ~ True ) => LocalSnocket - -> NetworkIPSubscriptionTracers LocalAddress NodeToClientProtocols NodeToClientVersion + -> NetworkClientSubcriptionTracers -> NetworkMutableState LocalAddress - -> IPSubscriptionParams () + -> ClientSubscriptionParams () -> Versions NodeToClientVersion DictVersion @@ -291,44 +291,41 @@ ncSubscriptionWorker -> IO Void ncSubscriptionWorker sn - NetworkIPSubscriptionTracers - { nistSubscriptionTracer - , nistMuxTracer - , nistHandshakeTracer - , nistErrorPolicyTracer + NetworkSubscriptionTracers + { nsSubscriptionTracer + , nsMuxTracer + , nsHandshakeTracer + , nsErrorPolicyTracer } networkState subscriptionParams versions - = Subscription.ipSubscriptionWorker + = Subscription.clientSubscriptionWorker sn - nistSubscriptionTracer - nistErrorPolicyTracer + (Identity `contramap` nsSubscriptionTracer) + nsErrorPolicyTracer networkState subscriptionParams (connectToNode' sn cborTermVersionDataCodec - (NetworkConnectTracers nistMuxTracer nistHandshakeTracer) + (NetworkConnectTracers nsMuxTracer nsHandshakeTracer) versions) -- | Like 'ncSubscriptionWorker' but specific to 'NodeToClientV_1'. -- ncSubscriptionWorker_V1 - :: forall appType fd addr x y. - ( HasInitiator appType ~ True - , fd ~ Socket.Socket - , addr ~ Socket.SockAddr - ) - => Snocket IO fd addr - -> NetworkIPSubscriptionTracers addr NodeToClientProtocols NodeToClientVersion - -> NetworkMutableState addr - -> IPSubscriptionParams () + :: forall appType x y. + ( HasInitiator appType ~ True ) + => LocalSnocket + -> NetworkSubscriptionTracers Identity LocalAddress NodeToClientProtocols NodeToClientVersion + -> NetworkMutableState LocalAddress + -> ClientSubscriptionParams () -> NodeToClientVersionData -> (OuroborosApplication appType - (ConnectionId addr) + (ConnectionId LocalAddress) NodeToClientProtocols IO BL.ByteString x y) -> IO Void diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index f0edf658ce6..5d75c0be235 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -33,8 +33,9 @@ module Ouroboros.Network.NodeToNode ( -- * Subscription Workers -- ** IP subscriptin worker , IPSubscriptionTarget (..) - , NetworkIPSubscriptionTracers (..) - , nullNetworkIPSubscriptionTracers + , NetworkIPSubscriptionTracers + , NetworkSubscriptionTracers (..) + , nullNetworkSubscriptionTracers , SubscriptionParams (..) , IPSubscriptionParams , ipSubscriptionWorker @@ -294,25 +295,25 @@ ipSubscriptionWorker -> IO Void ipSubscriptionWorker sn - NetworkIPSubscriptionTracers - { nistSubscriptionTracer - , nistMuxTracer - , nistHandshakeTracer - , nistErrorPolicyTracer + NetworkSubscriptionTracers + { nsSubscriptionTracer + , nsMuxTracer + , nsHandshakeTracer + , nsErrorPolicyTracer } networkState subscriptionParams versions = Subscription.ipSubscriptionWorker sn - nistSubscriptionTracer - nistErrorPolicyTracer + nsSubscriptionTracer + nsErrorPolicyTracer networkState subscriptionParams (connectToNode' sn cborTermVersionDataCodec - (NetworkConnectTracers nistMuxTracer nistHandshakeTracer) + (NetworkConnectTracers nsMuxTracer nsHandshakeTracer) versions) diff --git a/ouroboros-network/src/Ouroboros/Network/Snocket.hs b/ouroboros-network/src/Ouroboros/Network/Snocket.hs index 5de96b94cb6..ae5664adc9e 100644 --- a/ouroboros-network/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network/src/Ouroboros/Network/Snocket.hs @@ -18,6 +18,7 @@ module Ouroboros.Network.Snocket , LocalSnocket , localSnocket , LocalAddress + , LocalFD , localAddressFromPath ) where @@ -381,11 +382,13 @@ namedPipeSnocket iocp name = Snocket { -- | System dependent LocalSnocket type #if defined(mingw32_HOST_OS) type LocalSnocket = HANDLESnocket +type LocalFD = Win32.HANDLE localSnocket :: AssociateWithIOCP -> FilePath -> LocalSnocket localSnocket = namedPipeSnocket #else type LocalSnocket = SocketSnocket +type LocalFD = Socket localSnocket :: AssociateWithIOCP -> FilePath -> LocalSnocket localSnocket iocp _ = rawSocketSnocket iocp diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Client.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Client.hs new file mode 100644 index 00000000000..44c68205059 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Client.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NamedFieldPuns #-} + +-- Subscription worker for client applications connecting with 'LocalSnocket' +-- which is using either unix sockets or Windows' named pipes. +-- +module Ouroboros.Network.Subscription.Client + ( ClientSubscriptionParams (..) + , clientSubscriptionWorker + ) where + +import Control.Monad.Class.MonadTime +import Control.Tracer + +import Data.Void (Void) +import Data.Functor.Identity (Identity (..)) + +import Ouroboros.Network.Snocket ( LocalAddress + , LocalSnocket + , LocalFD + ) +import Ouroboros.Network.ErrorPolicy ( ErrorPolicies + , ErrorPolicyTrace + , WithAddr + , completeApplicationTx + ) +import Ouroboros.Network.Socket (NetworkMutableState (..)) +import Ouroboros.Network.Subscription.Ip (socketStateChangeTx, mainTx) +import Ouroboros.Network.Subscription.Worker +import Ouroboros.Network.Subscription.Subscriber + + +data ClientSubscriptionParams a = ClientSubscriptionParams + { cspAddress :: !LocalAddress + -- ^ unix socket or named pipe address + , cspConnectionAttemptDelay :: !(Maybe DiffTime) + -- ^ delay between connection attempts + , cspErrorPolicies :: !ErrorPolicies + -- ^ error policies for subscription worker + } + +-- | Client subscription worker keeps subsribing to the 'LocalAddress' using +-- either unix socket or named pipe. +-- +clientSubscriptionWorker + :: LocalSnocket + -> Tracer IO (SubscriptionTrace LocalAddress) + -> Tracer IO (WithAddr LocalAddress ErrorPolicyTrace) + -> NetworkMutableState LocalAddress + -> ClientSubscriptionParams a + -> (LocalFD -> IO a) + -> IO Void +clientSubscriptionWorker snocket + tracer + errorPolicyTracer + NetworkMutableState { nmsConnectionTable, nmsPeerStates } + ClientSubscriptionParams { cspAddress + , cspConnectionAttemptDelay + , cspErrorPolicies + } + k = + worker tracer + errorPolicyTracer + nmsConnectionTable + nmsPeerStates + snocket + WorkerCallbacks + { wcSocketStateChangeTx = socketStateChangeTx + , wcCompleteApplicationTx = completeApplicationTx cspErrorPolicies + , wcMainTx = mainTx + } + workerParams + k + where + workerParams = WorkerParams { + wpLocalAddresses = Identity cspAddress, + wpSelectAddress = \_ (Identity addr) -> Just addr, + wpConnectionAttemptDelay = const cspConnectionAttemptDelay, + wpSubscriptionTarget = pure (constantSubscriptionTarget cspAddress), + wpValency = 1 + } diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs index b6ee09a6df5..453f15e9e71 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Dns.hs @@ -251,6 +251,7 @@ dnsSubscriptionWorker' snocket subTracer dnsTracer errorPolicyTracer (WithDomainName (dstDomain dst) `contramap` dnsTracer) resolver nmsPeerStates beforeConnectTx dst , wpValency = dstValency dst + , wpSelectAddress = selectSockAddr } spErrorPolicies main diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs index aa0a7d3141f..698b4dd9871 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Ip.hs @@ -27,6 +27,9 @@ module Ouroboros.Network.Subscription.Ip , completeApplicationTx , socketStateChangeTx , mainTx + + -- * Utilitity functions + , selectSockAddr ) where @@ -107,12 +110,21 @@ ipSubscriptionWorker snocket subscriptionTracer errorPolicyTracer wpSubscriptionTarget = pure $ ipSubscriptionTarget subscriptionTracer' nmsPeerStates (ispIps spSubscriptionTarget), - wpValency = ispValency spSubscriptionTarget + wpValency = ispValency spSubscriptionTarget, + wpSelectAddress = selectSockAddr } subscriptionTracer' = (WithIPList spLocalAddresses (ispIps spSubscriptionTarget) `contramap` subscriptionTracer) +selectSockAddr :: Socket.SockAddr + -> LocalAddresses Socket.SockAddr + -> Maybe Socket.SockAddr +selectSockAddr Socket.SockAddrInet{} (LocalAddresses (Just localAddr) _ _ ) = Just localAddr +selectSockAddr Socket.SockAddrInet6{} (LocalAddresses _ (Just localAddr) _ ) = Just localAddr +selectSockAddr Socket.SockAddrUnix{} (LocalAddresses _ _ (Just localAddr) ) = Just localAddr +selectSockAddr _ _ = Nothing + ipSubscriptionTarget :: forall m addr. ( MonadSTM m @@ -180,7 +192,7 @@ subscriptionWorker -> Tracer IO (SubscriptionTrace Socket.SockAddr) -> Tracer IO (WithAddr Socket.SockAddr ErrorPolicyTrace) -> NetworkMutableState Socket.SockAddr - -> WorkerParams IO Socket.SockAddr + -> WorkerParams IO LocalAddresses Socket.SockAddr -> ErrorPolicies -> Main IO (PeerStates IO Socket.SockAddr) x -- ^ main callback @@ -205,18 +217,8 @@ subscriptionWorker snocket , wcMainTx = main } workerParams - selectAddress k - where - selectAddress :: Socket.SockAddr - -> LocalAddresses Socket.SockAddr - -> Maybe Socket.SockAddr - selectAddress Socket.SockAddrInet{} (LocalAddresses (Just localAddr) _ _ ) = Just localAddr - selectAddress Socket.SockAddrInet6{} (LocalAddresses _ (Just localAddr) _ ) = Just localAddr - selectAddress Socket.SockAddrUnix{} (LocalAddresses _ _ (Just localAddr) ) = Just localAddr - selectAddress _ _ = Nothing - data WithIPList a = WithIPList { wilSrc :: !(LocalAddresses Socket.SockAddr) , wilDsts :: ![Socket.SockAddr] diff --git a/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs b/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs index faa5171d06a..b567f7189c3 100644 --- a/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs +++ b/ouroboros-network/src/Ouroboros/Network/Subscription/Worker.hs @@ -193,7 +193,7 @@ data ConnectResult = -- | Traverse 'SubscriptionTarget's in an infinite loop. -- subscriptionLoop - :: forall m s sock addr a x. + :: forall m s sock localAddrs addr a x. ( MonadAsync m , MonadFork m , MonadMask m @@ -216,8 +216,7 @@ subscriptionLoop -> Snocket m sock addr -> WorkerCallbacks m s addr a x - -> WorkerParams m addr - -> (addr -> LocalAddresses addr -> Maybe addr) + -> WorkerParams m localAddrs addr -- ^ given a remote address, pick the local one -> (sock -> m a) -- ^ application @@ -231,8 +230,8 @@ subscriptionLoop , wpConnectionAttemptDelay = connectionAttemptDelay , wpSubscriptionTarget = subscriptionTargets , wpValency = valency + , wpSelectAddress } - selectAddress k = do valencyVar <- atomically $ newValencyCounter tbl valency @@ -310,7 +309,7 @@ subscriptionLoop r <- refConnection tbl remoteAddr valencyVar case r of ConnectionTableCreate -> - case selectAddress remoteAddr localAddresses of + case wpSelectAddress remoteAddr localAddresses of Nothing -> traceWith tr (SubscriptionTraceUnsupportedRemoteAddr remoteAddr) @@ -515,8 +514,11 @@ data WorkerCallbacks m s addr a t = WorkerCallbacks { -- | Worker parameters -- -data WorkerParams m addr = WorkerParams { - wpLocalAddresses :: LocalAddresses addr, +data WorkerParams m localAddrs addr = WorkerParams { + wpLocalAddresses :: localAddrs addr, + -- ^ local addresses of the server + wpSelectAddress :: addr -> localAddrs addr -> Maybe addr, + -- ^ given remote addr pick the local address wpConnectionAttemptDelay :: addr -> Maybe DiffTime, -- ^ delay after a connection attempt to 'addr' wpSubscriptionTarget :: m (SubscriptionTarget m addr), @@ -532,7 +534,7 @@ data WorkerParams m addr = WorkerParams { -- 'orElse', PR #432. -- worker - :: forall s sock addr a x. + :: forall s sock localAddrs addr a x. ( Ord addr , Show addr ) @@ -544,18 +546,17 @@ worker -> Snocket IO sock addr -> WorkerCallbacks IO s addr a x - -> WorkerParams IO addr - -> (addr -> LocalAddresses addr -> Maybe addr) + -> WorkerParams IO localAddrs addr -> (sock -> IO a) -- ^ application -> IO x -worker tr errTrace tbl sVar snocket workerCallbacks@WorkerCallbacks {wcCompleteApplicationTx, wcMainTx} workerParams selectAddress k = do +worker tr errTrace tbl sVar snocket workerCallbacks@WorkerCallbacks {wcCompleteApplicationTx, wcMainTx } workerParams k = do resQ <- newResultQ threadsVar <- atomically $ newTVar Set.empty withAsync (subscriptionLoop tr tbl resQ sVar threadsVar snocket - workerCallbacks workerParams selectAddress k) $ \_ -> + workerCallbacks workerParams k) $ \_ -> mainLoop errTrace resQ threadsVar sVar wcCompleteApplicationTx wcMainTx `finally` killThreads threadsVar where diff --git a/ouroboros-network/src/Ouroboros/Network/Tracers.hs b/ouroboros-network/src/Ouroboros/Network/Tracers.hs index 1fb9d39c91c..f13c5ca9650 100644 --- a/ouroboros-network/src/Ouroboros/Network/Tracers.hs +++ b/ouroboros-network/src/Ouroboros/Network/Tracers.hs @@ -1,6 +1,7 @@ module Ouroboros.Network.Tracers - ( NetworkIPSubscriptionTracers (..) - , nullNetworkIPSubscriptionTracers + ( NetworkSubscriptionTracers (..) + , NetworkIPSubscriptionTracers + , nullNetworkSubscriptionTracers , NetworkDNSSubscriptionTracers (..) , nullNetworkDNSSubscriptionTracers ) where @@ -20,29 +21,31 @@ import Ouroboros.Network.Subscription.Dns -- | IP subscription tracers. -- -data NetworkIPSubscriptionTracers addr ptcl vNumber = NetworkIPSubscriptionTracers { - nistMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace), +data NetworkSubscriptionTracers withIPList addr ptcl vNumber = NetworkSubscriptionTracers { + nsMuxTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) MuxTrace), -- ^ low level mux-network tracer, which logs mux sdu (send and received) -- and other low level multiplexing events. - nistHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) + nsHandshakeTracer :: Tracer IO (WithMuxBearer (ConnectionId addr) (TraceSendRecv (Handshake vNumber CBOR.Term))), -- ^ handshake protocol tracer; it is important for analysing version -- negotation mismatches. - nistErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), + nsErrorPolicyTracer :: Tracer IO (WithAddr addr ErrorPolicyTrace), -- ^ error policy tracer; must not be 'nullTracer', otherwise all the -- exceptions which are not matched by any error policy will be caught -- and not logged or rethrown. - nistSubscriptionTracer :: Tracer IO (WithIPList (SubscriptionTrace addr)) + nsSubscriptionTracer :: Tracer IO (withIPList (SubscriptionTrace addr)) -- ^ subscription tracers; it is infrequent it should not be 'nullTracer' -- by default. } -nullNetworkIPSubscriptionTracers :: NetworkIPSubscriptionTracers addr ptcl vNumber -nullNetworkIPSubscriptionTracers = NetworkIPSubscriptionTracers { - nistMuxTracer = nullTracer, - nistHandshakeTracer = nullTracer, - nistErrorPolicyTracer = nullTracer, - nistSubscriptionTracer = nullTracer +type NetworkIPSubscriptionTracers addr ptcl vNumber = NetworkSubscriptionTracers WithIPList addr ptcl vNumber + +nullNetworkSubscriptionTracers :: NetworkSubscriptionTracers withIPList addr ptcl vNumber +nullNetworkSubscriptionTracers = NetworkSubscriptionTracers { + nsMuxTracer = nullTracer, + nsHandshakeTracer = nullTracer, + nsErrorPolicyTracer = nullTracer, + nsSubscriptionTracer = nullTracer } -- | DNS subscription tracers. diff --git a/ouroboros-network/test/Test/PeerState.hs b/ouroboros-network/test/Test/PeerState.hs index bc463df045d..eb3c64cf69c 100644 --- a/ouroboros-network/test/Test/PeerState.hs +++ b/ouroboros-network/test/Test/PeerState.hs @@ -377,12 +377,12 @@ prop_subscriptionWorker laIpv6 = Just localAddr, laUnix = Nothing }, + wpSelectAddress = \_ LocalAddresses {laIpv4, laIpv6} -> getFirst (First laIpv4 <> First laIpv6), wpConnectionAttemptDelay = const Nothing, wpSubscriptionTarget = pure $ ipSubscriptionTarget nullTracer peerStatesVar [remoteAddr], wpValency = 1 } - (\_ LocalAddresses {laIpv4, laIpv6} -> getFirst (First laIpv4 <> First laIpv6)) (\sock -> app sock `finally` (void $ atomically $ tryPutTMVar doneVar ())) diff --git a/ouroboros-network/test/Test/Subscription.hs b/ouroboros-network/test/Test/Subscription.hs index cf60262ddcb..70b52c86dab 100644 --- a/ouroboros-network/test/Test/Subscription.hs +++ b/ouroboros-network/test/Test/Subscription.hs @@ -726,6 +726,7 @@ prop_send_recv_init_and_rsp f xs = ioProperty $ withIOManager $ \iocp -> do (NetworkMutableState tbl peerStatesVar) WorkerParams { wpLocalAddresses = LocalAddresses (Just localAddr) Nothing Nothing, + wpSelectAddress = selectSockAddr, wpConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay, wpSubscriptionTarget = pure $ listSubscriptionTarget [remoteAddr], wpValency = 1 From 810dba2ed1fe4dd97cbd9122fb6a8125c02477d8 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 28 Jan 2020 14:47:09 +0100 Subject: [PATCH 33/33] scripts/test.sh - run all ouroboros-network tests This is useful for running all tests on windows. Currently it does not include `ouroboros-consensus` tests, since `ouroboros-consensus` does not compile on windows. --- scripts/test.sh | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100755 scripts/test.sh diff --git a/scripts/test.sh b/scripts/test.sh new file mode 100755 index 00000000000..e3d78778434 --- /dev/null +++ b/scripts/test.sh @@ -0,0 +1,17 @@ +#!/bin/bash +# Run all the tests using `cabal`. This is useful for runing tests on Windows. + +# Any arguments are passed to `cabal run` command. + +cabal run ${@} test-Win32-network && \ +cabal run ${@} test-protocols && \ +cabal run ${@} test-sim && \ +cabal run ${@} test-network-mux && \ +cabal run ${@} ntp-client-test && \ +cabal run ${@} test-typed-protocols-cbor && \ +cabal run ${@} test-network +# consensus tests are disabled due to #1082 +# cabal run ${@} test-consensus && \ +# cabal run ${@} test-storage +# cddl tests are disabled - one needs the cddl tool +# cabal run ${@} cddl