diff --git a/ouroboros-network-framework/demo/ping-pong.hs b/ouroboros-network-framework/demo/ping-pong.hs index 7a246290f62..0fb9f549cfe 100644 --- a/ouroboros-network-framework/demo/ping-pong.hs +++ b/ouroboros-network-framework/demo/ping-pong.hs @@ -26,6 +26,7 @@ import System.Exit import Ouroboros.Network.Socket import Ouroboros.Network.Snocket +import qualified Ouroboros.Network.Snocket as Snocket import Ouroboros.Network.Mux import Ouroboros.Network.ErrorPolicy import Ouroboros.Network.IOManager @@ -107,7 +108,7 @@ clientPingPong :: Bool -> IO () clientPingPong pipelined = withIOManager $ \iomgr -> connectToNode - (localSnocket iomgr defaultLocalSocketAddrPath) + (Snocket.localSnocket iomgr) unversionedHandshakeCodec noTimeLimitsHandshake (cborTermVersionDataCodec unversionedProtocolDataCodec) @@ -145,7 +146,7 @@ serverPingPong = networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode - (localSnocket iomgr defaultLocalSocketAddrPath) + (Snocket.localSnocket iomgr) nullNetworkServerTracers networkState (AcceptedConnectionsLimit maxBound maxBound 0) @@ -203,9 +204,9 @@ demoProtocol1 pingPong pingPong' = clientPingPong2 :: IO () clientPingPong2 = - withIOManager $ \iomgr -> + withIOManager $ \iomgr -> do connectToNode - (localSnocket iomgr defaultLocalSocketAddrPath) + (Snocket.localSnocket iomgr) unversionedHandshakeCodec noTimeLimitsHandshake (cborTermVersionDataCodec unversionedProtocolDataCodec) @@ -256,7 +257,7 @@ serverPingPong2 = networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode - (localSnocket iomgr defaultLocalSocketAddrPath) + (Snocket.localSnocket iomgr) nullNetworkServerTracers networkState (AcceptedConnectionsLimit maxBound maxBound 0) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs index 34631f48b8a..450030d3e39 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} module Ouroboros.Network.Snocket ( -- * Snocket Interface Accept (..) + , Accepted (..) , AddressFamily (..) , Snocket (..) -- ** Socket based Snocktes @@ -32,7 +35,9 @@ import Control.Monad (when) import Control.Monad.Class.MonadTime (DiffTime) import Control.Tracer (Tracer) import Data.Bifunctor (Bifunctor (..)) +import Data.Bifoldable (Bifoldable (..)) import Data.Hashable +import Data.Word import GHC.Generics (Generic) import Quiet (Quiet (..)) #if !defined(mingw32_HOST_OS) @@ -96,13 +101,26 @@ import Ouroboros.Network.IOManager -- descriptor by `createNamedPipe`, see 'namedPipeSnocket'. -- newtype Accept m fd addr = Accept - { runAccept :: m (fd, addr, Accept m fd addr) + { runAccept :: m (Accepted fd addr, Accept m fd addr) } instance Functor m => Bifunctor (Accept m) where - bimap f g ac = Accept $ h <$> runAccept ac + bimap f g (Accept ac) = Accept (h <$> ac) where - h (fd, addr, next) = (f fd, g addr, bimap f g next) + h (accepted, next) = (bimap f g accepted, bimap f g next) + + +data Accepted fd addr where + AcceptFailure :: !SomeException -> Accepted fd addr + Accepted :: !fd -> !addr -> Accepted fd addr + +instance Bifunctor Accepted where + bimap f g (Accepted fd addr) = Accepted (f fd) (g addr) + bimap _ _ (AcceptFailure err) = AcceptFailure err + +instance Bifoldable Accepted where + bifoldMap f g (Accepted fd addr) = f fd <> g addr + bifoldMap _ _ (AcceptFailure _) = mempty -- | BSD accept loop. @@ -110,23 +128,52 @@ instance Functor m => Bifunctor (Accept m) where berkeleyAccept :: IOManager -> Socket -> Accept IO Socket SockAddr -berkeleyAccept ioManager sock = go +berkeleyAccept ioManager sock = go 0 where - go = Accept $ do - (sock', addr') <- + go cnt = Accept (acceptOne cnt `catch` handleException cnt) + + acceptOne + :: Word64 + -> IO ( Accepted Socket SockAddr + , Accept IO Socket SockAddr + ) + acceptOne !cnt = + bracketOnError #if !defined(mingw32_HOST_OS) - Socket.accept sock + (Socket.accept sock) #else - Win32.Async.accept sock + (Win32.Async.accept sock) #endif - associateWithIOManager ioManager (Right sock') - `catch` \(e :: IOException) -> do - Socket.close sock' - throwIO e - `catch` \(SomeAsyncException _) -> do - Socket.close sock' - throwIO e - return (sock', addr', go) + (Socket.close . fst) + $ \(sock', addr') -> do + associateWithIOManager ioManager (Right sock') + + -- UNIX sockets don't provide a unique endpoint for the remote + -- side, but the InboundGovernor/Server requires one in order to + -- track connections. + -- So to differentiate clients we use a simple counter as the + -- remote end's address. + -- + addr'' <- case addr' of + Socket.SockAddrUnix _ -> + return $ Socket.SockAddrUnix $ + "temp-" ++ show cnt + _ -> return addr' + + return (Accepted sock' addr'', go $ succ cnt) + + -- Only non-async exceptions will be caught and put into the + -- AcceptFailure variant. + handleException + :: Word64 + -> SomeException + -> IO ( Accepted Socket SockAddr + , Accept IO Socket SockAddr + ) + handleException !cnt err = + case fromException err of + Just (SomeAsyncException _) -> throwIO err + Nothing -> pure (AcceptFailure err, go cnt) -- | Local address, on Unix is associated with `Socket.AF_UNIX` family, on -- @@ -141,20 +188,19 @@ instance Hashable LocalAddress where -- | We support either sockets or named pipes. -- +-- 'LocalFamily' requires 'LocalAddress', this is needed to provide path of the +-- openned Win32 'HANDLE'. +-- data AddressFamily addr where SocketFamily :: !Socket.Family -> AddressFamily Socket.SockAddr - LocalFamily :: AddressFamily LocalAddress + LocalFamily :: !LocalAddress -> AddressFamily LocalAddress -instance Eq (AddressFamily addr) where - SocketFamily fam0 == SocketFamily fam1 = fam0 == fam1 - LocalFamily == LocalFamily = True +deriving instance Eq addr => Eq (AddressFamily addr) +deriving instance Show addr => Show (AddressFamily addr) -instance Show (AddressFamily addr) where - show (SocketFamily fam) = show fam - show LocalFamily = "LocalFamily" -- | Abstract communication interface that can be used by more than -- 'Socket'. Snockets are polymorphic over monad which is used, this feature @@ -167,7 +213,7 @@ data Snocket m fd addr = Snocket { , addrFamily :: addr -> AddressFamily addr -- | Open a file descriptor (socket / namedPipe). For named pipes this is - -- using 'CreateNamedPipe' syscall, for Berkeley sockets 'socket' is used.. + -- using 'CreateNamedPipe' syscall, for Berkeley sockets 'socket' is used. -- , open :: AddressFamily addr -> m fd @@ -177,7 +223,7 @@ data Snocket m fd addr = Snocket { -- For named pipes we need full 'addr' rather than just address family as -- it is for sockets. -- - , openToConnect :: addr -> m fd + , openToConnect :: addr -> m fd -- | `connect` is only needed for Berkeley sockets, for named pipes this is -- no-op. @@ -186,14 +232,22 @@ data Snocket m fd addr = Snocket { , bind :: fd -> addr -> m () , listen :: fd -> m () + -- SomeException is chosen here to avoid having to include it in the Snocket + -- type, and therefore refactoring a bunch of stuff. + -- FIXME probably a good idea to abstract it. , accept :: fd -> Accept m fd addr , close :: fd -> m () - , toBearer :: DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer m + , toBearer :: DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m) } +pureBearer :: Monad m + => (DiffTime -> Tracer m MuxTrace -> fd -> MuxBearer m) + -> DiffTime -> Tracer m MuxTrace -> fd -> m (MuxBearer m) +pureBearer f = \timeout tr fd -> return (f timeout tr fd) + -- -- Socket based Snockets -- @@ -257,7 +311,7 @@ socketSnocket ioManager = Snocket { -- should be fixed upstream, once that's done we can remove -- `unitnerruptibleMask_' , close = uninterruptibleMask_ . Socket.close - , toBearer = Mx.socketAsMuxBearer + , toBearer = pureBearer Mx.socketAsMuxBearer } where openSocket :: AddressFamily SockAddr -> IO Socket @@ -288,25 +342,47 @@ type LocalHandle = Socket #endif -- | System dependent LocalSnocket type +-- +#if defined(mingw32_HOST_OS) +data LocalSocket = LocalSocket { getLocalHandle :: !LocalHandle + -- ^ underlying windows 'HANDLE' + , getLocalPath :: !LocalAddress + -- ^ original path, used when creating the handle + , getRemotePath :: !LocalAddress + -- ^ unique identifier (not a real path). It + -- makes the pair of local and remote + -- addresses unique. + } + deriving (Eq, Generic) + deriving Show via Quiet LocalSocket +#else newtype LocalSocket = LocalSocket { getLocalHandle :: LocalHandle } deriving (Eq, Generic) deriving Show via Quiet LocalSocket +#endif -- | System dependent LocalSnocket type LocalSnocket = Snocket IO LocalSocket LocalAddress -localSnocket :: IOManager -> FilePath -> LocalSnocket + +-- | Create a 'LocalSnocket'. +-- +-- On /Windows/, there is no way to get path associated to a named pipe. To go +-- around this, the address passed to 'open' via 'LocalFamily' will be +-- referenced by 'LocalSocket'. +-- +localSnocket :: IOManager -> LocalSnocket #if defined(mingw32_HOST_OS) -localSnocket ioManager path = Snocket { - getLocalAddr = \_ -> return localAddress - , getRemoteAddr = \_ -> return localAddress - , addrFamily = \_ -> LocalFamily +localSnocket ioManager = Snocket { + getLocalAddr = return . getLocalPath + , getRemoteAddr = return . getRemotePath + , addrFamily = LocalFamily - , open = \_addrFamily -> do + , open = \(LocalFamily addr) -> do hpipe <- Win32.createNamedPipe - path + (getFilePath addr) (Win32.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED) - (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE) + (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE) Win32.pIPE_UNLIMITED_INSTANCES 65536 -- outbound pipe size 16384 -- inbound pipe size @@ -319,7 +395,7 @@ localSnocket ioManager path = Snocket { `catch` \(SomeAsyncException _) -> do Win32.closeHandle hpipe throwIO e - pure (LocalSocket hpipe) + pure (LocalSocket hpipe addr (LocalAddress "")) -- To connect, simply create a file whose name is the named pipe name. , openToConnect = \(LocalAddress pipeName) -> do @@ -337,49 +413,71 @@ localSnocket ioManager path = Snocket { `catch` \(SomeAsyncException _) -> do Win32.closeHandle hpipe throwIO e - return (LocalSocket hpipe) + return (LocalSocket hpipe (LocalAddress pipeName) (LocalAddress pipeName)) , connect = \_ _ -> pure () -- Bind and listen are no-op. , bind = \_ _ -> pure () , listen = \_ -> pure () - , accept = \sock@(LocalSocket hpipe) -> Accept $ do + , accept = \sock@(LocalSocket hpipe addr _) -> Accept $ do Win32.Async.connectNamedPipe hpipe - return (sock, localAddress, acceptNext) + return (Accepted sock addr, acceptNext 0 addr) -- Win32.closeHandle is not interrupible , close = Win32.closeHandle . getLocalHandle - , toBearer = \_sduTimeout tr -> namedPipeAsBearer tr . getLocalHandle + , toBearer = \_sduTimeout tr -> pure . namedPipeAsBearer tr . getLocalHandle } where - localAddress :: LocalAddress - localAddress = LocalAddress path - - acceptNext :: Accept IO LocalSocket LocalAddress - acceptNext = Accept $ do - hpipe <- Win32.createNamedPipe - path + acceptNext :: Word64 -> LocalAddress -> Accept IO LocalSocket LocalAddress + acceptNext !cnt addr = Accept (acceptOne `catch` handleIOException) + where + handleIOException + :: IOException + -> IO ( Accepted LocalSocket LocalAddress + , Accept IO LocalSocket LocalAddress + ) + handleIOException err = + pure ( AcceptFailure (toException err) + , acceptNext (succ cnt) addr + ) + + acceptOne + :: IO ( Accepted LocalSocket LocalAddress + , Accept IO LocalSocket LocalAddress + ) + acceptOne = + bracketOnError + (Win32.createNamedPipe + (getFilePath addr) (Win32.pIPE_ACCESS_DUPLEX .|. Win32.fILE_FLAG_OVERLAPPED) - (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE) + (Win32.pIPE_TYPE_BYTE .|. Win32.pIPE_READMODE_BYTE) Win32.pIPE_UNLIMITED_INSTANCES - 65536 -- outbound pipe size - 16384 -- inbound pipe size - 0 -- default timeout - Nothing -- default security - associateWithIOManager ioManager (Left hpipe) - Win32.Async.connectNamedPipe hpipe - return (LocalSocket hpipe, localAddress, acceptNext) + 65536 -- outbound pipe size + 16384 -- inbound pipe size + 0 -- default timeout + Nothing) -- default security + Win32.closeHandle + $ \hpipe -> do + associateWithIOManager ioManager (Left hpipe) + Win32.Async.connectNamedPipe hpipe + -- InboundGovernor/Server requires a unique address for the + -- remote end one in order to track connections. + -- So to differentiate clients we use a simple counter as the + -- remote end's address. + -- + let addr' = LocalAddress $ "\\\\.\\pipe\\ouroboros-network-temp-" ++ show cnt + return (Accepted (LocalSocket hpipe addr addr') addr', acceptNext (succ cnt) addr) -- local snocket on unix #else -localSnocket ioManager _ = +localSnocket ioManager = Snocket { getLocalAddr = fmap toLocalAddress . Socket.getSocketName . getLocalHandle , getRemoteAddr = fmap toLocalAddress . Socket.getPeerName . getLocalHandle - , addrFamily = const LocalFamily + , addrFamily = LocalFamily , connect = \(LocalSocket s) addr -> Socket.connect s (fromLocalAddress addr) , bind = \(LocalSocket fd) addr -> Socket.bind fd (fromLocalAddress addr) @@ -388,9 +486,9 @@ localSnocket ioManager _ = . berkeleyAccept ioManager . getLocalHandle , open = openSocket - , openToConnect = \_addr -> openSocket LocalFamily + , openToConnect = \addr -> openSocket (LocalFamily addr) , close = uninterruptibleMask_ . Socket.close . getLocalHandle - , toBearer = \df tr (LocalSocket sd) -> Mx.socketAsMuxBearer df tr sd + , toBearer = \df tr (LocalSocket sd) -> pure (Mx.socketAsMuxBearer df tr sd) } where toLocalAddress :: SockAddr -> LocalAddress @@ -401,7 +499,7 @@ localSnocket ioManager _ = fromLocalAddress = SockAddrUnix . getFilePath openSocket :: AddressFamily LocalAddress -> IO LocalSocket - openSocket LocalFamily = do + openSocket (LocalFamily _addr) = do sd <- Socket.socket AF_UNIX Socket.Stream Socket.defaultProtocol associateWithIOManager ioManager (Right sd) -- open is designed to be used in `bracket`, and thus it's called with @@ -435,7 +533,7 @@ socketFileDescriptor = fmap (FileDescriptor . fromIntegral) . Socket.unsafeFdSoc localSocketFileDescriptor :: LocalSocket -> IO FileDescriptor #if defined(mingw32_HOST_OS) localSocketFileDescriptor = - \(LocalSocket fd) -> case ptrToIntPtr fd of + \(LocalSocket fd _ _) -> case ptrToIntPtr fd of IntPtr i -> return (FileDescriptor i) #else localSocketFileDescriptor = socketFileDescriptor . getLocalHandle diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index bcc73f0b6b2..cf57b027ee1 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -250,9 +250,10 @@ connectToNode' sn handshakeCodec handshakeTimeLimits versionDataCodec NetworkCon muxTracer <- initDeltaQTracer' $ Mx.WithMuxBearer connectionId `contramap` nctMuxTracer ts_start <- getMonotonicTime + handshakeBearer <- Snocket.toBearer sn sduHandshakeTimeout muxTracer sd app_e <- runHandshakeClient - (Snocket.toBearer sn sduHandshakeTimeout muxTracer sd) + handshakeBearer connectionId -- TODO: push 'HandshakeArguments' up the call stack. HandshakeArguments { @@ -275,10 +276,11 @@ connectToNode' sn handshakeCodec handshakeTimeLimits versionDataCodec NetworkCon Right (app, _versionNumber, _agreedOptions) -> do traceWith muxTracer $ Mx.MuxTraceHandshakeClientEnd (diffTime ts_end ts_start) + bearer <- Snocket.toBearer sn sduTimeout muxTracer sd Mx.muxStart muxTracer (toApplication connectionId (continueForever (Proxy :: Proxy IO)) app) - (Snocket.toBearer sn sduTimeout muxTracer sd) + bearer -- Wraps a Socket inside a Snocket and calls connectToNode' @@ -374,9 +376,12 @@ beginConnection sn muxTracer handshakeTracer handshakeCodec handshakeTimeLimits traceWith muxTracer' $ Mx.MuxTraceHandshakeStart + handshakeBearer <- Snocket.toBearer sn + sduHandshakeTimeout + muxTracer' sd app_e <- runHandshakeServer - (Snocket.toBearer sn sduHandshakeTimeout muxTracer' sd) + handshakeBearer connectionId HandshakeArguments { haHandshakeTracer = handshakeTracer, @@ -398,10 +403,11 @@ beginConnection sn muxTracer handshakeTracer handshakeCodec handshakeTimeLimits Right (SomeResponderApplication app, _versionNumber, _agreedOptions) -> do traceWith muxTracer' $ Mx.MuxTraceHandshakeServerEnd + bearer <- Snocket.toBearer sn sduTimeout muxTracer' sd Mx.muxStart muxTracer' (toApplication connectionId (continueForever (Proxy :: Proxy IO)) app) - (Snocket.toBearer sn sduTimeout muxTracer' sd) + bearer RejectConnection st' _peerid -> pure $ Server.Reject st' @@ -433,11 +439,16 @@ fromSnocket tblVar sn sd = go (Snocket.accept sn sd) where go :: Snocket.Accept IO fd addr -> 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) + (result, next) <- accept + case result of + Snocket.Accepted sd' remoteAddr -> do + -- 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) + Snocket.AcceptFailure err -> + -- the is no way to construct 'Server.Socket'; This will be removed in a later commit! + throwIO err close remoteAddr localAddr sd' = do removeConnection tblVar remoteAddr localAddr diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs index 17c6af852e9..24854ef62c0 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs @@ -13,6 +13,7 @@ module Test.Ouroboros.Network.Socket (tests) where import Data.Void (Void) import Data.List (mapAccumL) +import Data.Bifoldable (bitraverse_) import qualified Data.ByteString.Lazy as BL import Data.Proxy (Proxy (..)) import Data.Time.Clock (UTCTime, getCurrentTime) @@ -335,20 +336,22 @@ prop_socket_recv_error f rerr = -- accept a connection and start mux on it bracket (runAccept $ accept snocket sd) - (\(sd', _, _) -> Socket.close sd') - $ \(sd', _, _) -> do - remoteAddress <- Socket.getPeerName sd' - let timeout = if rerr == RecvSDUTimeout then 0.10 - else (-1) -- No timeout - bearer = Mx.socketAsMuxBearer timeout nullTracer sd' - connectionId = ConnectionId { - localAddress = Socket.addrAddress muxAddress, - remoteAddress - } - _ <- async $ do - threadDelay 0.1 - atomically $ putTMVar lock () - Mx.muxStart nullTracer (toApplication connectionId (continueForever (Proxy :: Proxy IO)) app) bearer + (bitraverse_ Socket.close pure . fst) + $ \(accepted, _acceptNext) -> case accepted of + AcceptFailure err -> throwIO err + Accepted sd' _ -> do + remoteAddress <- Socket.getPeerName sd' + let timeout = if rerr == RecvSDUTimeout then 0.10 + else (-1) -- No timeout + bearer = Mx.socketAsMuxBearer timeout nullTracer sd' + connectionId = ConnectionId { + localAddress = Socket.addrAddress muxAddress, + remoteAddress + } + _ <- async $ do + threadDelay 0.1 + atomically $ putTMVar lock () + Mx.muxStart nullTracer (toApplication connectionId (continueForever (Proxy :: Proxy IO)) app) bearer ) $ \muxAsync -> do @@ -414,22 +417,21 @@ prop_socket_send_error rerr = -- accept a connection and start mux on it bracket (runAccept $ accept snocket sd) - (\(sd', _, _) -> Socket.close sd') - (\(sd', _, _) -> - let sduTimeout = if rerr == SendSDUTimeout then 0.10 - else (-1) -- No timeout - bearer = Mx.socketAsMuxBearer sduTimeout nullTracer sd' - blob = BL.pack $ replicate 0xffff 0xa5 in - withTimeoutSerial $ \timeout -> - -- send maximum mux sdus until we've filled the window. - replicateM 100 $ do - ((), Nothing) <$ write bearer timeout (wrap blob ResponderDir (MiniProtocolNum 0)) - ) - + (bitraverse_ Socket.close pure . fst) + $ \(accepted, _acceptNext) -> case accepted of + AcceptFailure err -> throwIO err + Accepted sd' _ -> do + let sduTimeout = if rerr == SendSDUTimeout then 0.10 + else (-1) -- No timeout + bearer = Mx.socketAsMuxBearer sduTimeout nullTracer sd' + blob = BL.pack $ replicate 0xffff 0xa5 + withTimeoutSerial $ \timeout -> + -- send maximum mux sdus until we've filled the window. + replicateM 100 $ do + ((), Nothing) <$ write bearer timeout (wrap blob ResponderDir (MiniProtocolNum 0)) ) $ \muxAsync -> do - sd' <- openToConnect snocket addr -- connect to muxAddress _ <- connect snocket sd' addr diff --git a/ouroboros-network/demo/chain-sync.hs b/ouroboros-network/demo/chain-sync.hs index 07344bd3a7b..3646fecfad1 100644 --- a/ouroboros-network/demo/chain-sync.hs +++ b/ouroboros-network/demo/chain-sync.hs @@ -152,7 +152,7 @@ clientChainSync sockPaths = withIOManager $ \iocp -> forConcurrently_ (zip [0..] sockPaths) $ \(index, sockPath) -> do threadDelay (50000 * index) connectToNode - (localSnocket iocp sockPath) + (localSnocket iocp) unversionedHandshakeCodec noTimeLimitsHandshake (cborTermVersionDataCodec unversionedProtocolDataCodec) @@ -182,7 +182,7 @@ serverChainSync sockAddr = withIOManager $ \iocp -> do networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode - (localSnocket iocp defaultLocalSocketAddrPath) + (localSnocket iocp) nullNetworkServerTracers networkState (AcceptedConnectionsLimit maxBound maxBound 0) @@ -365,7 +365,7 @@ clientBlockFetch sockAddrs = withIOManager $ \iocp -> do peerAsyncs <- sequence [ async $ connectToNode - (localSnocket iocp defaultLocalSocketAddrPath) + (localSnocket iocp) unversionedHandshakeCodec noTimeLimitsHandshake (cborTermVersionDataCodec unversionedProtocolDataCodec) @@ -417,7 +417,7 @@ serverBlockFetch sockAddr = withIOManager $ \iocp -> do networkState <- newNetworkMutableState _ <- async $ cleanNetworkMutableState networkState withServerNode - (localSnocket iocp defaultLocalSocketAddrPath) + (localSnocket iocp) nullNetworkServerTracers networkState (AcceptedConnectionsLimit maxBound maxBound 0) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs index 64e6c68febf..81954418f1c 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion.hs @@ -349,13 +349,13 @@ runDataDiffusion tracers case a of (Socket.SockAddrUnix path) -> do traceWith dtDiffusionInitializationTracer $ UsingSystemdSocket path - return (LocalSocket sd, Snocket.localSnocket iocp path) + return (LocalSocket sd, Snocket.localSnocket iocp) unsupportedAddr -> do traceWith dtDiffusionInitializationTracer $ UnsupportedLocalSystemdSocket unsupportedAddr throwIO UnsupportedLocalSocketType #endif Right addr -> do - let sn = Snocket.localSnocket iocp addr + let sn = Snocket.localSnocket iocp traceWith dtDiffusionInitializationTracer $ CreateSystemdSocketForSnocketPath addr sd <- Snocket.open sn (Snocket.addrFamily sn $ Snocket.localAddressFromPath addr) traceWith dtDiffusionInitializationTracer $ CreatedLocalSocket addr