From 78ce9693e887248de92a6509cc2e5bbb512ab06e Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Nov 2026 11:43:48 +0900 Subject: [PATCH 1/6] Join two adjacent platform conditionals into one Co-Authored-By: Claude Opus 5.5 --- Network/Socket/ByteString/IO.hsc | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/Network/Socket/ByteString/IO.hsc b/Network/Socket/ByteString/IO.hsc index 63bfa55c..0ff80184 100644 --- a/Network/Socket/ByteString/IO.hsc +++ b/Network/Socket/ByteString/IO.hsc @@ -69,10 +69,6 @@ import System.Posix.Types (Fd(..)) import Network.Socket.Flag import Network.Socket.SockAddr (annotateWithSocket) -#if defined(mingw32_HOST_OS) -import Network.Socket.Win32.Load -#endif - #if !defined(mingw32_HOST_OS) import Network.Socket.Posix.Cmsg import Network.Socket.Posix.IOVec @@ -80,6 +76,7 @@ import Network.Socket.Posix.MsgHdr (MsgHdr(..)) #else import Foreign.Marshal.Alloc (alloca) import Network.Socket.Win32.Cmsg +import Network.Socket.Win32.Load import Network.Socket.Win32.WSABuf import Network.Socket.Win32.MsgHdr (MsgHdr(..)) #endif From 08ef40dcb3ec64f43ce58bb5c132a975bde666ef Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Nov 2026 11:48:14 +0900 Subject: [PATCH 2/6] Split Network.Socket.Buffer into Posix and Win32 modules Each platform defines the same functions in a module of its own, and Network.Socket.Buffer keeps their types and documentation, the argument checks, and a single conditional import. Co-Authored-By: Claude Opus 5.5 --- Network/Socket/Buffer.hs | 125 ++++++++++++++ Network/Socket/Posix/Buffer.hsc | 161 ++++++++++++++++++ Network/Socket/{ => Win32}/Buffer.hsc | 230 +------------------------- network.cabal | 2 + 4 files changed, 296 insertions(+), 222 deletions(-) create mode 100644 Network/Socket/Buffer.hs create mode 100644 Network/Socket/Posix/Buffer.hsc rename Network/Socket/{ => Win32}/Buffer.hsc (67%) diff --git a/Network/Socket/Buffer.hs b/Network/Socket/Buffer.hs new file mode 100644 index 00000000..908535ff --- /dev/null +++ b/Network/Socket/Buffer.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE CPP #-} + +-- | Sending and receiving with buffers. The work is done by +-- "Network.Socket.Posix.Buffer" or "Network.Socket.Win32.Buffer". +module Network.Socket.Buffer ( + sendBufTo + , sendBuf + , recvBufFrom + , recvBuf + , recvBufNoWait + , recvBufNoWaitOr + , sendBufMsg + , recvBufMsg + ) where + +import GHC.IO.Exception (IOErrorType(InvalidArgument)) +import System.IO.Error (mkIOError, ioeSetErrorString) + +import Network.Socket.Flag +import Network.Socket.Imports +import Network.Socket.Types +#if defined(mingw32_HOST_OS) +import Network.Socket.Win32.Cmsg (Cmsg) +import qualified Network.Socket.Win32.Buffer as P +#else +import Network.Socket.Posix.Cmsg (Cmsg) +import qualified Network.Socket.Posix.Buffer as P +#endif + +-- | Send data to the socket. The recipient can be specified +-- explicitly, so the socket need not be in a connected state. +-- Returns the number of bytes sent. Applications are responsible for +-- ensuring that all data has been sent. +sendBufTo :: SocketAddress sa => + Socket -- (possibly) bound/connected Socket + -> Ptr a + -> Int -- Data to send + -> sa + -> IO Int -- Number of Bytes sent +sendBufTo = P.sendBufTo + +-- | Send data to the socket. The socket must be connected to a remote +-- socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +sendBuf :: Socket -- Bound/Connected Socket + -> Ptr Word8 -- Pointer to the data to send + -> Int -- Length of the buffer + -> IO Int -- Number of Bytes sent +sendBuf = P.sendBuf + +-- | Receive data from the socket, writing it into buffer instead of +-- creating a new string. The socket need not be in a connected +-- state. Returns @(nbytes, address)@ where @nbytes@ is the number of +-- bytes received and @address@ is a 'SockAddr' representing the +-- address of the sending socket. +-- +-- If the first return value is zero, it means EOF. +-- +-- For 'Stream' sockets, the second return value would be invalid. +recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa) +recvBufFrom s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") + | otherwise = P.recvBufFrom s ptr nbytes + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If the +-- message is longer than the specified length, it may be discarded +-- depending on the type of socket. This function may block until a +-- message arrives. +-- +-- Considering hardware and network realities, the maximum number of +-- bytes to receive should be a small power of 2, e.g., 4096. +-- +-- The return value is the length of received data. Zero means +-- EOF. Historical note: Version 2.8.x.y or earlier, +-- an EOF error was thrown. This was changed in version 3.0. +recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int +recvBuf s ptr nbytes + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") + | otherwise = P.recvBuf s ptr nbytes + +-- | Receive data from the socket. This function returns immediately +-- even if data is not available. In other words, IO manager is NOT +-- involved. The length of data is returned if received. +-- -1 is returned in the case of EAGAIN or EWOULDBLOCK. +-- -2 is returned in other error cases. +recvBufNoWait :: Socket -> Ptr Word8 -> Int -> IO Int +recvBufNoWait = recvBufNoWaitOr $ return (-2) + +-- | 'recvBufNoWait' which runs the action on an error, in place of +-- answering -2. The error is gone from the socket once read, so this +-- is where to raise it. +recvBufNoWaitOr :: IO CInt -> Socket -> Ptr Word8 -> Int -> IO Int +recvBufNoWaitOr = P.recvBufNoWaitOr + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError + InvalidArgument + loc Nothing Nothing) "non-positive length" + +-- | Send data to the socket using sendmsg(2). +sendBufMsg :: SocketAddress sa + => Socket -- ^ Socket + -> sa -- ^ Destination address + -> [(Ptr Word8,Int)] -- ^ Data to be sent + -> [Cmsg] -- ^ Control messages + -> MsgFlag -- ^ Message flags + -> IO Int -- ^ The length actually sent +sendBufMsg = P.sendBufMsg + +-- | Receive data from the socket using recvmsg(2). The supplied +-- buffers are filled in order, with subsequent buffers used only +-- after all the preceding buffers are full. If the message is short +-- enough some of the supplied buffers may remain unused. +recvBufMsg :: SocketAddress sa + => Socket -- ^ Socket + -> [(Ptr Word8,Int)] -- ^ A list of (buffer, buffer-length) pairs. + -- If the total length is not large enough, + -- 'MSG_TRUNC' is returned + -> Int -- ^ The buffer size for control messages. + -- If the length is not large enough, + -- 'MSG_CTRUNC' is returned + -> MsgFlag -- ^ Message flags + -> IO (sa,Int,[Cmsg],MsgFlag) -- ^ Source address, total bytes received, control messages and message flags +recvBufMsg = P.recvBufMsg diff --git a/Network/Socket/Posix/Buffer.hsc b/Network/Socket/Posix/Buffer.hsc new file mode 100644 index 00000000..76a45a37 --- /dev/null +++ b/Network/Socket/Posix/Buffer.hsc @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +##include "HsNetDef.h" + +module Network.Socket.Posix.Buffer ( + sendBufTo + , sendBuf + , recvBufFrom + , recvBuf + , recvBufNoWaitOr + , sendBufMsg + , recvBufMsg + ) where + +import Foreign.C.Error (getErrno, eAGAIN, eWOULDBLOCK) +import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Utils (with) +import System.IO.Error (catchIOError) + +import Network.Socket.Posix.CmsgHdr +import Network.Socket.Posix.MsgHdr +import Network.Socket.Posix.IOVec + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Name +import Network.Socket.Types +import Network.Socket.Flag + +sendBufTo :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> IO Int +sendBufTo s ptr nbytes sa = + withSocketAddress sa $ \p_sa siz -> fromIntegral <$> do + withFdSocket s $ \fd -> do + let sz = fromIntegral siz + n = fromIntegral nbytes + flags = 0 + throwSocketErrorWaitWrite s "Network.Socket.sendBufTo" $ + c_sendto fd ptr n flags p_sa sz + +sendBuf :: Socket -- Bound/Connected Socket + -> Ptr Word8 -- Pointer to the data to send + -> Int -- Length of the buffer + -> IO Int -- Number of Bytes sent +sendBuf s str len = + fromIntegral <$> withFdSocket s (\fd -> do + let flags = 0 + clen = fromIntegral len + throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $ + c_send fd str clen flags) + +recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa) +recvBufFrom s ptr nbytes = + withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> + withFdSocket s $ \fd -> do + poke ptr_len (fromIntegral sz) + let cnbytes = fromIntegral nbytes + flags = 0 + len <- throwSocketErrorWaitRead s "Network.Socket.recvBufFrom" $ + c_recvfrom fd ptr cnbytes flags ptr_sa ptr_len + sockaddr <- peekSocketAddress ptr_sa + `catchIOError` \_ -> getPeerName s + return (fromIntegral len, sockaddr) + +recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int +recvBuf s ptr nbytes = do + len <- withFdSocket s $ \fd -> + throwSocketErrorWaitRead s "Network.Socket.recvBuf" $ + c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} + return $ fromIntegral len + +recvBufNoWaitOr :: IO CInt -> Socket -> Ptr Word8 -> Int -> IO Int +recvBufNoWaitOr onError s ptr nbytes = withFdSocket s $ \fd -> do + r <- c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} + if r >= 0 then + return $ fromIntegral r + else do + err <- getErrno + if err == eAGAIN || err == eWOULDBLOCK then + return (-1) + else + fromIntegral <$> onError + +sendBufMsg :: SocketAddress sa + => Socket -- ^ Socket + -> sa -- ^ Destination address + -> [(Ptr Word8,Int)] -- ^ Data to be sent + -> [Cmsg] -- ^ Control messages + -> MsgFlag -- ^ Message flags + -> IO Int -- ^ The length actually sent +sendBufMsg s sa bufsizs cmsgs flags = do + sz <- withSocketAddress sa $ \addrPtr addrSize -> + withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do + withCmsgs cmsgs $ \ctrlPtr ctrlLen -> do + let msgHdr = MsgHdr { + msgName = addrPtr + , msgNameLen = fromIntegral addrSize + , msgIov = iovsPtr + , msgIovLen = fromIntegral iovsLen + , msgCtrl = castPtr ctrlPtr + , msgCtrlLen = fromIntegral ctrlLen + , msgFlags = 0 + } + cflags = fromMsgFlag flags + withFdSocket s $ \fd -> + with msgHdr $ \msgHdrPtr -> + throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $ + c_sendmsg fd msgHdrPtr cflags + return $ fromIntegral sz + +recvBufMsg :: SocketAddress sa + => Socket -- ^ Socket + -> [(Ptr Word8,Int)] -- ^ A list of (buffer, buffer-length) pairs. + -- If the total length is not large enough, + -- 'MSG_TRUNC' is returned + -> Int -- ^ The buffer size for control messages. + -- If the length is not large enough, + -- 'MSG_CTRUNC' is returned + -> MsgFlag -- ^ Message flags + -> IO (sa,Int,[Cmsg],MsgFlag) -- ^ Source address, total bytes received, control messages and message flags +recvBufMsg s bufsizs clen flags = do + withNewSocketAddress $ \addrPtr addrSize -> + allocaBytes clen $ \ctrlPtr -> + withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do + let msgHdr = MsgHdr { + msgName = addrPtr + , msgNameLen = fromIntegral addrSize + , msgIov = iovsPtr + , msgIovLen = fromIntegral iovsLen + , msgCtrl = castPtr ctrlPtr + , msgCtrlLen = fromIntegral clen + , msgFlags = 0 + } + _cflags = fromMsgFlag flags + withFdSocket s $ \fd -> do + with msgHdr $ \msgHdrPtr -> do + len <- + fmap fromIntegral <$> + throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmsg" $ + c_recvmsg fd msgHdrPtr _cflags + sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s + hdr <- peek msgHdrPtr + + cmsgs <- parseCmsgs msgHdrPtr + let flags' = MsgFlag $ fromIntegral $ msgFlags hdr + + return (sockaddr, len, cmsgs, flags') + +foreign import ccall unsafe "send" + c_send :: CSocket -> Ptr a -> CSize -> CInt -> IO CInt +foreign import ccall unsafe "sendmsg" + c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize +foreign import ccall unsafe "recvmsg" + c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt + +foreign import ccall unsafe "recv" + c_recv :: CSocket -> Ptr CChar -> CSize -> CInt -> IO CInt +foreign import ccall unsafe "sendto" + c_sendto :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt +foreign import ccall unsafe "recvfrom" + c_recvfrom :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt diff --git a/Network/Socket/Buffer.hsc b/Network/Socket/Win32/Buffer.hsc similarity index 67% rename from Network/Socket/Buffer.hsc rename to Network/Socket/Win32/Buffer.hsc index b83d503e..bfeeb5e6 100644 --- a/Network/Socket/Buffer.hsc +++ b/Network/Socket/Win32/Buffer.hsc @@ -2,43 +2,30 @@ {-# LANGUAGE LambdaCase #-} ##include "HsNetDef.h" -#if defined(mingw32_HOST_OS) # include "winsock2.h" # include "windows.h" # include "mswsock.h" # include "ntstatus.h" -#endif -module Network.Socket.Buffer ( +module Network.Socket.Win32.Buffer ( sendBufTo , sendBuf , recvBufFrom , recvBuf - , recvBufNoWait , recvBufNoWaitOr , sendBufMsg , recvBufMsg ) where -#if !defined(mingw32_HOST_OS) -import Foreign.C.Error (getErrno, eAGAIN, eWOULDBLOCK) -#endif import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Marshal.Utils (with) -import GHC.IO.Exception (IOErrorType(InvalidArgument)) -import System.IO.Error (mkIOError, ioeSetErrorString, catchIOError) +import System.IO.Error (catchIOError) -#if defined(mingw32_HOST_OS) import qualified GHC.Event.Windows as Mgr import Network.Socket.Win32.CmsgHdr import Network.Socket.Win32.Load import Network.Socket.Win32.MsgHdr import Network.Socket.Win32.WSABuf -#else -import Network.Socket.Posix.CmsgHdr -import Network.Socket.Posix.MsgHdr -import Network.Socket.Posix.IOVec -#endif import Network.Socket.Imports import Network.Socket.Internal @@ -46,7 +33,6 @@ import Network.Socket.Name import Network.Socket.Types import Network.Socket.Flag -#if defined(mingw32_HOST_OS) type DWORD = Word32 type LPDWORD = Ptr DWORD @@ -71,39 +57,9 @@ _WSAEDISCON = #{const WSAEDISCON} _WSAEMSGSIZE = #{const WSAEMSGSIZE} _WSAESHUTDOWN = #{const WSAESHUTDOWN} _STATUS_BUFFER_OVERFLOW = #{const STATUS_BUFFER_OVERFLOW} -#endif --- | Send data to the socket. The recipient can be specified --- explicitly, so the socket need not be in a connected state. --- Returns the number of bytes sent. Applications are responsible for --- ensuring that all data has been sent. -sendBufTo :: SocketAddress sa => - Socket -- (possibly) bound/connected Socket - -> Ptr a - -> Int -- Data to send - -> sa - -> IO Int -- Number of Bytes sent -#if defined(mingw32_HOST_OS) -sendBufTo = sendBufToWinIO -#else -sendBufTo = sendBufToPosix -#endif - -#if !defined(mingw32_HOST_OS) -sendBufToPosix :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> IO Int -sendBufToPosix s ptr nbytes sa = - withSocketAddress sa $ \p_sa siz -> fromIntegral <$> do - withFdSocket s $ \fd -> do - let sz = fromIntegral siz - n = fromIntegral nbytes - flags = 0 - throwSocketErrorWaitWrite s "Network.Socket.sendBufTo" $ - c_sendto fd ptr n flags p_sa sz -#endif - -#if defined(mingw32_HOST_OS) -sendBufToWinIO :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> IO Int -sendBufToWinIO s ptr nbytes sa = +sendBufTo :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> IO Int +sendBufTo s ptr nbytes sa = withSocketAddress sa $ \p_sa siz -> withFdSocket s $ \sock -> with (WSABuf (castPtr ptr) (fromIntegral nbytes)) $ \wbuf -> @@ -121,29 +77,9 @@ sendBufToWinIO s ptr nbytes sa = (\err bytes -> if err == _ERROR_SUCCESS then Mgr.ioSuccess $ fromIntegral bytes else Mgr.ioFailed err) -#endif - --- | Send data to the socket. The socket must be connected to a remote --- socket. Returns the number of bytes sent. Applications are --- responsible for ensuring that all data has been sent. -sendBuf :: Socket -- Bound/Connected Socket - -> Ptr Word8 -- Pointer to the data to send - -> Int -- Length of the buffer - -> IO Int -- Number of Bytes sent -#if defined(mingw32_HOST_OS) -sendBuf = sendBufWinIO -#else -sendBuf s str len = - fromIntegral <$> withFdSocket s (\fd -> do - let flags = 0 - clen = fromIntegral len - throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $ - c_send fd str clen flags) -#endif -#if defined(mingw32_HOST_OS) -sendBufWinIO :: Socket -> Ptr Word8 -> Int -> IO Int -sendBufWinIO s ptr len = withFdSocket s $ \sock -> +sendBuf :: Socket -> Ptr Word8 -> Int -> IO Int +sendBuf s ptr len = withFdSocket s $ \sock -> with (WSABuf ptr (fromIntegral len)) $ \wbuf -> fmap fromIntegral $ throwWinIOError "Network.Socket.sendBuf" $ Mgr.withOverlapped "sendBuf" (wordPtrToPtr $ fromIntegral sock) 0 @@ -158,44 +94,9 @@ sendBufWinIO s ptr len = withFdSocket s $ \sock -> (\err bytes -> if err == _ERROR_SUCCESS then Mgr.ioSuccess $ fromIntegral bytes else Mgr.ioFailed err) -#endif --- | Receive data from the socket, writing it into buffer instead of --- creating a new string. The socket need not be in a connected --- state. Returns @(nbytes, address)@ where @nbytes@ is the number of --- bytes received and @address@ is a 'SockAddr' representing the --- address of the sending socket. --- --- If the first return value is zero, it means EOF. --- --- For 'Stream' sockets, the second return value would be invalid. recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa) -recvBufFrom s ptr nbytes - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") -#if defined(mingw32_HOST_OS) - | otherwise = recvBufFromWinIO s ptr nbytes -#else - | otherwise = recvBufFromImpl s ptr nbytes -#endif - -#if !defined(mingw32_HOST_OS) -recvBufFromImpl :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa) -recvBufFromImpl s ptr nbytes = - withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> - withFdSocket s $ \fd -> do - poke ptr_len (fromIntegral sz) - let cnbytes = fromIntegral nbytes - flags = 0 - len <- throwSocketErrorWaitRead s "Network.Socket.recvBufFrom" $ - c_recvfrom fd ptr cnbytes flags ptr_sa ptr_len - sockaddr <- peekSocketAddress ptr_sa - `catchIOError` \_ -> getPeerName s - return (fromIntegral len, sockaddr) -#endif - -#if defined(mingw32_HOST_OS) -recvBufFromWinIO :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa) -recvBufFromWinIO s ptr nbytes = +recvBufFrom s ptr nbytes = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> withFdSocket s $ \sock -> do poke ptr_len (fromIntegral sz) @@ -240,36 +141,9 @@ recvBufFromWinIO s ptr nbytes = | err == _ERROR_OPERATION_ABORTED = Mgr.ioSuccess 0 | err == _ERROR_IO_INCOMPLETE = Mgr.ioSuccess 0 | otherwise = Mgr.ioFailed err -#endif --- | Receive data from the socket. The socket must be in a connected --- state. This function may return fewer bytes than specified. If the --- message is longer than the specified length, it may be discarded --- depending on the type of socket. This function may block until a --- message arrives. --- --- Considering hardware and network realities, the maximum number of --- bytes to receive should be a small power of 2, e.g., 4096. --- --- The return value is the length of received data. Zero means --- EOF. Historical note: Version 2.8.x.y or earlier, --- an EOF error was thrown. This was changed in version 3.0. recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int -recvBuf s ptr nbytes - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") -#if defined(mingw32_HOST_OS) - | otherwise = recvBufWinIO s ptr nbytes -#else - | otherwise = do - len <- withFdSocket s $ \fd -> - throwSocketErrorWaitRead s "Network.Socket.recvBuf" $ - c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} - return $ fromIntegral len -#endif - -#if defined(mingw32_HOST_OS) -recvBufWinIO :: Socket -> Ptr Word8 -> Int -> IO Int -recvBufWinIO s ptr nbytes = withFdSocket s $ \sock -> +recvBuf s ptr nbytes = withFdSocket s $ \sock -> fmap fromIntegral $ throwWinIOError "Network.Socket.recvBuf" $ Mgr.withOverlapped "recvBuf" (wordPtrToPtr $ fromIntegral sock) 0 (startCB sock) completionCB where @@ -309,22 +183,8 @@ recvBufWinIO s ptr nbytes = withFdSocket s $ \sock -> | err == _ERROR_IO_INCOMPLETE = Mgr.ioSuccess 0 | otherwise = Mgr.ioFailed err -#endif /* mingw32_HOST_OS */ - --- | Receive data from the socket. This function returns immediately --- even if data is not available. In other words, IO manager is NOT --- involved. The length of data is returned if received. --- -1 is returned in the case of EAGAIN or EWOULDBLOCK. --- -2 is returned in other error cases. -recvBufNoWait :: Socket -> Ptr Word8 -> Int -> IO Int -recvBufNoWait = recvBufNoWaitOr $ return (-2) - --- | 'recvBufNoWait' which runs the action on an error, in place of --- answering -2. The error is gone from the socket once read, so this --- is where to raise it. recvBufNoWaitOr :: IO CInt -> Socket -> Ptr Word8 -> Int -> IO Int recvBufNoWaitOr onError s ptr nbytes = withFdSocket s $ \fd -> do -#if defined(mingw32_HOST_OS) alloca $ \ptr_bytes -> do res <- c_ioctlsocket fd #{const FIONREAD} ptr_bytes avail <- peek ptr_bytes @@ -347,24 +207,6 @@ recvBufNoWaitOr onError s ptr nbytes = withFdSocket s $ \fd -> do else failed return $ fromIntegral r -#else - r <- c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} - if r >= 0 then - return $ fromIntegral r - else do - err <- getErrno - if err == eAGAIN || err == eWOULDBLOCK then - return (-1) - else - fromIntegral <$> onError -#endif - -mkInvalidRecvArgError :: String -> IOError -mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError - InvalidArgument - loc Nothing Nothing) "non-positive length" - --- | Send data to the socket using sendmsg(2). sendBufMsg :: SocketAddress sa => Socket -- ^ Socket -> sa -- ^ Destination address @@ -374,22 +216,13 @@ sendBufMsg :: SocketAddress sa -> IO Int -- ^ The length actually sent sendBufMsg s sa bufsizs cmsgs flags = do sz <- withSocketAddress sa $ \addrPtr addrSize -> -#if !defined(mingw32_HOST_OS) - withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do -#else withWSABuf bufsizs $ \(wsaBPtr, wsaBLen) -> do -#endif withCmsgs cmsgs $ \ctrlPtr ctrlLen -> do let msgHdr = MsgHdr { msgName = addrPtr , msgNameLen = fromIntegral addrSize -#if !defined(mingw32_HOST_OS) - , msgIov = iovsPtr - , msgIovLen = fromIntegral iovsLen -#else , msgBuffer = wsaBPtr , msgBufferLen = fromIntegral wsaBLen -#endif , msgCtrl = castPtr ctrlPtr , msgCtrlLen = fromIntegral ctrlLen , msgFlags = 0 @@ -397,18 +230,9 @@ sendBufMsg s sa bufsizs cmsgs flags = do cflags = fromMsgFlag flags withFdSocket s $ \fd -> with msgHdr $ \msgHdrPtr -> -#if defined(mingw32_HOST_OS) sendBufMsgWinIO fd msgHdrPtr cflags -#else - throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $ - c_sendmsg fd msgHdrPtr cflags -#endif return $ fromIntegral sz --- | Receive data from the socket using recvmsg(2). The supplied --- buffers are filled in order, with subsequent buffers used only --- after all the preceding buffers are full. If the message is short --- enough some of the supplied buffers may remain unused. recvBufMsg :: SocketAddress sa => Socket -- ^ Socket -> [(Ptr Word8,Int)] -- ^ A list of (buffer, buffer-length) pairs. @@ -422,17 +246,6 @@ recvBufMsg :: SocketAddress sa recvBufMsg s bufsizs clen flags = do withNewSocketAddress $ \addrPtr addrSize -> allocaBytes clen $ \ctrlPtr -> -#if !defined(mingw32_HOST_OS) - withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do - let msgHdr = MsgHdr { - msgName = addrPtr - , msgNameLen = fromIntegral addrSize - , msgIov = iovsPtr - , msgIovLen = fromIntegral iovsLen - , msgCtrl = castPtr ctrlPtr - , msgCtrlLen = fromIntegral clen - , msgFlags = 0 -#else withWSABuf bufsizs $ \(wsaBPtr, wsaBLen) -> do let msgHdr = MsgHdr { msgName = addrPtr @@ -442,44 +255,24 @@ recvBufMsg s bufsizs clen flags = do , msgCtrl = if clen == 0 then nullPtr else castPtr ctrlPtr , msgCtrlLen = fromIntegral clen , msgFlags = fromIntegral $ fromMsgFlag flags -#endif } _cflags = fromMsgFlag flags withFdSocket s $ \fd -> do with msgHdr $ \msgHdrPtr -> do len <- -#if !defined(mingw32_HOST_OS) - fmap fromIntegral <$> - throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmsg" $ - c_recvmsg fd msgHdrPtr _cflags -#else recvBufMsgWinIO fd msgHdrPtr -#endif sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s hdr <- peek msgHdrPtr -#if !defined(mingw32_HOST_OS) - cmsgs <- parseCmsgs msgHdrPtr - let flags' = MsgFlag $ fromIntegral $ msgFlags hdr -#else let flags' = MsgFlag $ fromIntegral (msgFlags hdr) -- If the control buffer was truncated (MSG_CTRUNC), the -- control data may be invalid and parsing could segfault. cmsgs <- if msgCtrl hdr == nullPtr || (msgFlags hdr .&. #{const MSG_CTRUNC}) /= 0 then return [] else parseCmsgs msgHdrPtr -#endif return (sockaddr, len, cmsgs, flags') -#if !defined(mingw32_HOST_OS) -foreign import ccall unsafe "send" - c_send :: CSocket -> Ptr a -> CSize -> CInt -> IO CInt -foreign import ccall unsafe "sendmsg" - c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize -foreign import ccall unsafe "recvmsg" - c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt -#else foreign import CALLCONV unsafe "ioctlsocket" c_ioctlsocket :: CSocket -> CLong -> Ptr CULong -> IO CInt foreign import CALLCONV unsafe "WSAGetLastError" @@ -564,13 +357,6 @@ recvBufMsgWinIO fd msgHdrPtr = do | err == _ERROR_OPERATION_ABORTED = Mgr.ioSuccess 0 | err == _ERROR_IO_INCOMPLETE = Mgr.ioSuccess 0 | otherwise = Mgr.ioFailed err -#endif /* mingw32_HOST_OS */ foreign import ccall unsafe "recv" c_recv :: CSocket -> Ptr CChar -> CSize -> CInt -> IO CInt -#if !defined(mingw32_HOST_OS) -foreign import ccall unsafe "sendto" - c_sendto :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt -foreign import ccall unsafe "recvfrom" - c_recvfrom :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt -#endif diff --git a/network.cabal b/network.cabal index a77f13b8..f094fb93 100644 --- a/network.cabal +++ b/network.cabal @@ -142,6 +142,7 @@ library if !os(windows) other-modules: Network.Socket.ByteString.Lazy.Posix + Network.Socket.Posix.Buffer Network.Socket.Posix.Cmsg Network.Socket.Posix.CmsgHdr Network.Socket.Posix.HostName @@ -164,6 +165,7 @@ library other-modules: Network.Socket.ByteString.Lazy.Windows Network.Socket.Win32.AfdPoll + Network.Socket.Win32.Buffer Network.Socket.Win32.Cmsg Network.Socket.Win32.CmsgHdr Network.Socket.Win32.HostName From 84da66997f1813005a79a291e92aedbd8f69a1e5 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Nov 2026 11:52:36 +0900 Subject: [PATCH 3/6] Split Network.Socket.Internal into Posix and Win32 modules The error guards, the readiness waits and withSocketsDo are defined per platform; Network.Socket.Internal keeps their documentation and what is shared. The POSIX definitions no longer sit under each other's types. Co-Authored-By: Claude Opus 5.5 --- Network/Socket/Internal.hs | 208 ++++--------------------------- Network/Socket/Posix/Internal.hs | 61 +++++++++ Network/Socket/Win32/Internal.hs | 138 ++++++++++++++++++++ network.cabal | 2 + 4 files changed, 226 insertions(+), 183 deletions(-) create mode 100644 Network/Socket/Posix/Internal.hs create mode 100644 Network/Socket/Win32/Internal.hs diff --git a/Network/Socket/Internal.hs b/Network/Socket/Internal.hs index b57a91d6..dccc52b2 100644 --- a/Network/Socket/Internal.hs +++ b/Network/Socket/Internal.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -#include "HsNetDef.h" - ----------------------------------------------------------------------------- -- | -- Module : Network.Socket.Internal @@ -26,8 +24,8 @@ module Network.Socket.Internal throwSocketError , throwSocketErrorCode #if defined(mingw32_HOST_OS) - , c_getLastError - , winsockErrorString + , P.c_getLastError + , P.winsockErrorString #endif -- * Guards for socket operations that may fail @@ -36,7 +34,7 @@ module Network.Socket.Internal , throwSocketErrorIfMinus1Retry_ , throwSocketErrorIfMinus1RetryMayBlock #if defined(mingw32_HOST_OS) - , throwSocketErrorIfMinus1ButRetry + , P.throwSocketErrorIfMinus1ButRetry #endif , annotateIOException -- ** Guards that wait and retry if the operation would block @@ -49,7 +47,7 @@ module Network.Socket.Internal , waitReadSocket , waitWriteSocket #if defined(mingw32_HOST_OS) - , throwWinIOError + , P.throwWinIOError #endif -- * Initialization @@ -62,30 +60,18 @@ module Network.Socket.Internal , zeroMemory ) where -#if defined(mingw32_HOST_OS) -import qualified Control.Exception as E -import System.IO.Unsafe (unsafePerformIO) -import System.IO.Error (ioeSetErrorString, mkIOError) -import GHC.IO.SubSystem (IoSubSystem (..), ioSubSystem) -import qualified GHC.Event.Windows as Mgr -import Network.Socket.Win32.AfdPoll -#else -import GHC.Conc (threadWaitRead, threadWaitWrite) -import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry, - throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_, - Errno(..), errnoToIOError) -#endif - -#if defined(mingw32_HOST_OS) -import Network.Socket.Cbits -#endif -import Network.Socket.Imports -import Network.Socket.Types - import qualified Foreign.C.Error as C import GHC.IO.Exception (IOException (..)) import System.IO.Error (modifyIOError) +import Network.Socket.Imports +import Network.Socket.Types +#if defined(mingw32_HOST_OS) +import qualified Network.Socket.Win32.Internal as P +#else +import qualified Network.Socket.Posix.Internal as P +#endif + annotateIOException :: IO a -> String -> IO a annotateIOException io anno = modifyIOError f io where @@ -147,12 +133,7 @@ errnoNames = [ -- | Throw an 'IOError' corresponding to the current socket error. throwSocketError :: String -- ^ textual description of the error location -> IO a -#if defined(mingw32_HOST_OS) -throwSocketError name = - c_getLastError >>= throwSocketErrorCode name -#else -throwSocketError = throwErrno -#endif +throwSocketError = P.throwSocketError -- | Like 'throwSocketError', but the error code is supplied as an argument. -- @@ -160,16 +141,7 @@ throwSocketError = throwErrno -- is kept in 'ioe_errno' all the same, and the error type is the one -- the errno of the same name has elsewhere. throwSocketErrorCode :: String -> CInt -> IO a -#if defined(mingw32_HOST_OS) -throwSocketErrorCode name rc = do - str <- winsockErrorString rc - let typ = winsockErrorType rc - ioe = (mkIOError typ name Nothing Nothing){ioe_errno = Just rc} - ioError (ioeSetErrorString ioe str) -#else -throwSocketErrorCode loc errno = - ioError (errnoToIOError loc (Errno errno) Nothing Nothing) -#endif +throwSocketErrorCode = P.throwSocketErrorCode -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@. Discards the result of the @@ -179,15 +151,8 @@ throwSocketErrorIfMinus1_ => String -- ^ textual description of the location -> IO a -- ^ the 'IO' operation to be executed -> IO () -#if defined(mingw32_HOST_OS) -throwSocketErrorIfMinus1_ name act = do - _ <- throwSocketErrorIfMinus1Retry name act - return () -#else -throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry -#endif - -{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} +throwSocketErrorIfMinus1_ = P.throwSocketErrorIfMinus1_ +{-# INLINE throwSocketErrorIfMinus1_ #-} -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@, but retries in case of an @@ -197,14 +162,8 @@ throwSocketErrorIfMinus1Retry => String -- ^ textual description of the location -> IO a -- ^ the 'IO' operation to be executed -> IO a -#if defined(mingw32_HOST_OS) -throwSocketErrorIfMinus1Retry - = throwSocketErrorIfMinus1ButRetry (const False) -#else -throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ -#endif - -{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} +throwSocketErrorIfMinus1Retry = P.throwSocketErrorIfMinus1Retry +{-# INLINE throwSocketErrorIfMinus1Retry #-} -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@, but retries in case of an @@ -230,84 +189,8 @@ throwSocketErrorIfMinus1RetryMayBlock -- immediate retry would block -> IO a -- ^ the 'IO' operation to be executed -> IO a -#if defined(mingw32_HOST_OS) -throwSocketErrorIfMinus1RetryMayBlock - = throwSocketErrorIfMinus1RetryMayBlockBut (const False) -#else -throwSocketErrorIfMinus1RetryMayBlock name on_block act = - throwErrnoIfMinus1RetryMayBlock name act on_block -#endif - -{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock - :: String -> IO b -> IO CInt -> IO CInt #-} - - --- | Throw an 'IOError' corresponding to the current socket error if --- the IO action returns a result of @-1@, but retries in case of an --- interrupted operation. Checks for operations that would block and --- executes an alternative action before retrying in that case. If the error --- is one handled by the exempt filter then ignore it and return the error code. -throwSocketErrorIfMinus1RetryMayBlockBut - :: (Eq a, Num a) - => (CInt -> Bool) -- ^ exception exempt filter - -> String -- ^ textual description of the location - -> IO b -- ^ action to execute before retrying if an - -- immediate retry would block - -> IO a -- ^ the 'IO' operation to be executed - -> IO a -#if defined(mingw32_HOST_OS) -throwSocketErrorIfMinus1RetryMayBlockBut exempt name on_block act = loop - where - loop = do - r <- throwSocketErrorIfMinus1ButRetry exempt' name act - if r /= -1 then return r else do - rc <- c_getLastError - if rc == wsaEWOULDBLOCK then on_block >> loop else return r - exempt' rc = rc == wsaEWOULDBLOCK || exempt rc -#else -throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act = - throwErrnoIfMinus1RetryMayBlock name act on_block -#endif - -{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock - :: String -> IO b -> IO CInt -> IO CInt #-} - --- --------------------------------------------------------------------- - -#if defined(mingw32_HOST_OS) -throwSocketErrorIfMinus1ButRetry :: (Eq a, Num a) => - (CInt -> Bool) -> String -> IO a -> IO a -throwSocketErrorIfMinus1ButRetry exempt name act = do - r <- act - if (r == -1) - then do - rc <- c_getLastError - if rc == wsaNotInitialized then do - withSocketsDo (return ()) - r' <- act - if (r' == -1) - then throwSocketError name - else return r' - else - if (exempt rc) - then return r - else throwSocketError name - else return r - -foreign import CALLCONV unsafe "WSAGetLastError" - c_getLastError :: IO CInt - -foreign import ccall unsafe "getWSErrorDescr" - c_getWSError :: CInt -> IO (Ptr CChar) - --- | A description of a Winsock error code. -winsockErrorString :: CInt -> IO String -winsockErrorString rc = do - pstr <- c_getWSError rc - if pstr == nullPtr - then return $ "Unknown WinSock error: " ++ show rc - else peekCString pstr -#endif +throwSocketErrorIfMinus1RetryMayBlock = P.throwSocketErrorIfMinus1RetryMayBlock +{-# INLINE throwSocketErrorIfMinus1RetryMayBlock #-} -- --------------------------------------------------------------------- @@ -324,7 +207,7 @@ throwSocketErrorWaitRead s name io = withFdSocket s $ \fd -> -- ignore the error throwSocketErrorWaitReadBut :: (Eq a, Num a) => (CInt -> Bool) -> Socket -> String -> IO a -> IO a throwSocketErrorWaitReadBut exempt s name io = withFdSocket s $ \fd -> - throwSocketErrorIfMinus1RetryMayBlockBut exempt name (waitReadSocket s fd) io + P.throwSocketErrorIfMinus1RetryMayBlockBut exempt name (waitReadSocket s fd) io -- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with -- @EWOULDBLOCK@ or similar, wait for the socket to be write-ready, @@ -333,27 +216,11 @@ throwSocketErrorWaitWrite :: (Eq a, Num a) => Socket -> String -> IO a -> IO a throwSocketErrorWaitWrite s name io = withFdSocket s $ \fd -> throwSocketErrorIfMinus1RetryMayBlock name (waitWriteSocket s fd) io -#if defined(mingw32_HOST_OS) --- | 'Mgr.withException', but raising a failure as other socket errors --- are: the Winsock code in 'ioe_errno', with its 'IOErrorType'. -throwWinIOError :: String -> IO (Mgr.IOResult a) -> IO a -throwWinIOError name io = do - r <- io - case r of - Mgr.IOSuccess a -> return a - Mgr.IOFailed e -> throwSocketErrorCode name (maybe 0 fromIntegral e) -#endif - -- | Waiting for the socket to be readable, or writable: through the IO -- manager on POSIX, and through an AFD poll on Windows. waitReadSocket, waitWriteSocket :: Socket -> CSocket -> IO () -#if defined(mingw32_HOST_OS) -waitReadSocket s _ = afdWait "waitReadSocket" afdRead s -waitWriteSocket s _ = afdWait "waitWriteSocket" afdWrite s -#else -waitReadSocket _ fd = threadWaitRead $ fromIntegral fd -waitWriteSocket _ fd = threadWaitWrite $ fromIntegral fd -#endif +waitReadSocket = P.waitReadSocket +waitWriteSocket = P.waitWriteSocket -- --------------------------------------------------------------------------- -- WinSock support @@ -372,31 +239,6 @@ after 'withSocketsDo' has returned. However, for compatibility with older versions on Windows, it is good practice to always call 'withSocketsDo' (it's very cheap). -} -{-# INLINE withSocketsDo #-} withSocketsDo :: IO a -> IO a -#if defined(mingw32_HOST_OS) - -withSocketsDo act = E.evaluate withSocketsInit >> act - -{-# NOINLINE withSocketsInit #-} -withSocketsInit :: () --- Use a CAF to make forcing it do initialisation once, but subsequent forces will be cheap -withSocketsInit = unsafePerformIO $ do - -- The I/O manager is the executable's choice, made at start-up. - case ioSubSystem of - IoNative -> return () - IoPOSIX -> ioError $ userError $ - "Network.Socket: network needs the WinIO I/O manager on Windows: " - ++ "run with +RTS --io-manager=native -RTS, or link with " - ++ "-with-rtsopts=--io-manager=native" - x <- initWinSock - when (x /= 0) $ ioError $ - userError "Network.Socket.Internal.withSocketsDo: Failed to initialise WinSock" - -foreign import ccall unsafe "initWinSock" initWinSock :: IO Int - -#else - -withSocketsDo x = x - -#endif +withSocketsDo = P.withSocketsDo +{-# INLINE withSocketsDo #-} diff --git a/Network/Socket/Posix/Internal.hs b/Network/Socket/Posix/Internal.hs new file mode 100644 index 00000000..f8a16334 --- /dev/null +++ b/Network/Socket/Posix/Internal.hs @@ -0,0 +1,61 @@ +-- | The POSIX side of "Network.Socket.Internal": errors come from errno, +-- and the IO manager waits for readiness. +module Network.Socket.Posix.Internal ( + throwSocketError, + throwSocketErrorCode, + throwSocketErrorIfMinus1_, + throwSocketErrorIfMinus1Retry, + throwSocketErrorIfMinus1RetryMayBlock, + throwSocketErrorIfMinus1RetryMayBlockBut, + waitReadSocket, + waitWriteSocket, + withSocketsDo, +) where + +import Foreign.C.Error ( + Errno (..), + errnoToIOError, + throwErrno, + throwErrnoIfMinus1Retry, + throwErrnoIfMinus1RetryMayBlock, + throwErrnoIfMinus1_, + ) +import GHC.Conc (threadWaitRead, threadWaitWrite) + +import Network.Socket.Imports +import Network.Socket.Types + +throwSocketError :: String -> IO a +throwSocketError = throwErrno + +throwSocketErrorCode :: String -> CInt -> IO a +throwSocketErrorCode loc errno = + ioError (errnoToIOError loc (Errno errno) Nothing Nothing) + +throwSocketErrorIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () +throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ +{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} + +throwSocketErrorIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a +throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry +{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} + +throwSocketErrorIfMinus1RetryMayBlock + :: (Eq a, Num a) => String -> IO b -> IO a -> IO a +throwSocketErrorIfMinus1RetryMayBlock name on_block act = + throwErrnoIfMinus1RetryMayBlock name act on_block +{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock + :: String -> IO b -> IO CInt -> IO CInt #-} + +throwSocketErrorIfMinus1RetryMayBlockBut + :: (Eq a, Num a) => (CInt -> Bool) -> String -> IO b -> IO a -> IO a +throwSocketErrorIfMinus1RetryMayBlockBut _exempt = + throwSocketErrorIfMinus1RetryMayBlock + +waitReadSocket, waitWriteSocket :: Socket -> CSocket -> IO () +waitReadSocket _ fd = threadWaitRead $ fromIntegral fd +waitWriteSocket _ fd = threadWaitWrite $ fromIntegral fd + +withSocketsDo :: IO a -> IO a +withSocketsDo x = x +{-# INLINE withSocketsDo #-} diff --git a/Network/Socket/Win32/Internal.hs b/Network/Socket/Win32/Internal.hs new file mode 100644 index 00000000..922c025a --- /dev/null +++ b/Network/Socket/Win32/Internal.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +-- | The Windows side of "Network.Socket.Internal": errors are Winsock +-- codes from @WSAGetLastError@, and readiness is waited for through an +-- AFD poll. +module Network.Socket.Win32.Internal ( + throwSocketError, + throwSocketErrorCode, + throwSocketErrorIfMinus1_, + throwSocketErrorIfMinus1Retry, + throwSocketErrorIfMinus1RetryMayBlock, + throwSocketErrorIfMinus1RetryMayBlockBut, + waitReadSocket, + waitWriteSocket, + withSocketsDo, + -- * Windows only + c_getLastError, + throwSocketErrorIfMinus1ButRetry, + winsockErrorString, + throwWinIOError, +) where + +import qualified Control.Exception as E +import qualified GHC.Event.Windows as Mgr +import GHC.IO.Exception (IOException (..)) +import GHC.IO.SubSystem (IoSubSystem (..), ioSubSystem) +import System.IO.Error (ioeSetErrorString, mkIOError) +import System.IO.Unsafe (unsafePerformIO) + +import Network.Socket.Cbits +import Network.Socket.Imports +import Network.Socket.Types +import Network.Socket.Win32.AfdPoll + +throwSocketError :: String -> IO a +throwSocketError name = c_getLastError >>= throwSocketErrorCode name + +-- The code is a Winsock code rather than an errno. It is kept in +-- 'ioe_errno' all the same, and the error type is the one the errno of +-- the same name has elsewhere. +throwSocketErrorCode :: String -> CInt -> IO a +throwSocketErrorCode name rc = do + str <- winsockErrorString rc + let typ = winsockErrorType rc + ioe = (mkIOError typ name Nothing Nothing){ioe_errno = Just rc} + ioError (ioeSetErrorString ioe str) + +throwSocketErrorIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO () +throwSocketErrorIfMinus1_ name act = void $ throwSocketErrorIfMinus1Retry name act +{-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} + +throwSocketErrorIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a +throwSocketErrorIfMinus1Retry = throwSocketErrorIfMinus1ButRetry (const False) +{-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} + +throwSocketErrorIfMinus1RetryMayBlock + :: (Eq a, Num a) => String -> IO b -> IO a -> IO a +throwSocketErrorIfMinus1RetryMayBlock = + throwSocketErrorIfMinus1RetryMayBlockBut (const False) +{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock + :: String -> IO b -> IO CInt -> IO CInt #-} + +throwSocketErrorIfMinus1RetryMayBlockBut + :: (Eq a, Num a) => (CInt -> Bool) -> String -> IO b -> IO a -> IO a +throwSocketErrorIfMinus1RetryMayBlockBut exempt name on_block act = loop + where + loop = do + r <- throwSocketErrorIfMinus1ButRetry exempt' name act + if r /= -1 then return r else do + rc <- c_getLastError + if rc == wsaEWOULDBLOCK then on_block >> loop else return r + exempt' rc = rc == wsaEWOULDBLOCK || exempt rc + +throwSocketErrorIfMinus1ButRetry + :: (Eq a, Num a) => (CInt -> Bool) -> String -> IO a -> IO a +throwSocketErrorIfMinus1ButRetry exempt name act = do + r <- act + if r == -1 + then do + rc <- c_getLastError + if rc == wsaNotInitialized + then do + withSocketsDo (return ()) + r' <- act + if r' == -1 then throwSocketError name else return r' + else + if exempt rc then return r else throwSocketError name + else return r + +foreign import CALLCONV unsafe "WSAGetLastError" + c_getLastError :: IO CInt + +foreign import ccall unsafe "getWSErrorDescr" + c_getWSError :: CInt -> IO (Ptr CChar) + +-- | A description of a Winsock error code. +winsockErrorString :: CInt -> IO String +winsockErrorString rc = do + pstr <- c_getWSError rc + if pstr == nullPtr + then return $ "Unknown WinSock error: " ++ show rc + else peekCString pstr + +-- | 'Mgr.withException', but raising a failure as other socket errors +-- are: the Winsock code in 'ioe_errno', with its 'IOErrorType'. +throwWinIOError :: String -> IO (Mgr.IOResult a) -> IO a +throwWinIOError name io = do + r <- io + case r of + Mgr.IOSuccess a -> return a + Mgr.IOFailed e -> throwSocketErrorCode name (maybe 0 fromIntegral e) + +waitReadSocket, waitWriteSocket :: Socket -> CSocket -> IO () +waitReadSocket s _ = afdWait "waitReadSocket" afdRead s +waitWriteSocket s _ = afdWait "waitWriteSocket" afdWrite s + +withSocketsDo :: IO a -> IO a +withSocketsDo act = E.evaluate withSocketsInit >> act +{-# INLINE withSocketsDo #-} + +-- A CAF, so that forcing it initialises Winsock once and is cheap after. +{-# NOINLINE withSocketsInit #-} +withSocketsInit :: () +withSocketsInit = unsafePerformIO $ do + -- The I/O manager is the executable's choice, made at start-up. + case ioSubSystem of + IoNative -> return () + IoPOSIX -> ioError $ userError $ + "Network.Socket: network needs the WinIO I/O manager on Windows: " + ++ "run with +RTS --io-manager=native -RTS, or link with " + ++ "-with-rtsopts=--io-manager=native" + x <- initWinSock + when (x /= 0) $ ioError $ + userError "Network.Socket.Internal.withSocketsDo: Failed to initialise WinSock" + +foreign import ccall unsafe "initWinSock" initWinSock :: IO Int diff --git a/network.cabal b/network.cabal index f094fb93..3b65c578 100644 --- a/network.cabal +++ b/network.cabal @@ -144,6 +144,7 @@ library Network.Socket.ByteString.Lazy.Posix Network.Socket.Posix.Buffer Network.Socket.Posix.Cmsg + Network.Socket.Posix.Internal Network.Socket.Posix.CmsgHdr Network.Socket.Posix.HostName Network.Socket.Posix.IOVec @@ -169,6 +170,7 @@ library Network.Socket.Win32.Cmsg Network.Socket.Win32.CmsgHdr Network.Socket.Win32.HostName + Network.Socket.Win32.Internal Network.Socket.Win32.Load Network.Socket.Win32.WSABuf Network.Socket.Win32.MsgHdr From dfff1c2b4a0929507373f279a153716cf08d9e13 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Nov 2026 11:56:52 +0900 Subject: [PATCH 4/6] Move the platform parts of Network.Socket.Syscall into their own modules Preparing a new or an accepted socket, accepting, telling what a failed connect means, and reportConnReset are defined per platform; socket, bind, connect, listen and accept themselves stay shared. Co-Authored-By: Claude Opus 5.5 --- Network/Socket/Posix/Syscall.hs | 77 +++++++++++++++++++++ Network/Socket/Syscall.hs | 114 ++++---------------------------- Network/Socket/Win32/Syscall.hs | 83 +++++++++++++++++++++++ network.cabal | 2 + 4 files changed, 175 insertions(+), 101 deletions(-) create mode 100644 Network/Socket/Posix/Syscall.hs create mode 100644 Network/Socket/Win32/Syscall.hs diff --git a/Network/Socket/Posix/Syscall.hs b/Network/Socket/Posix/Syscall.hs new file mode 100644 index 00000000..92f81363 --- /dev/null +++ b/Network/Socket/Posix/Syscall.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +-- | The POSIX parts of "Network.Socket.Syscall". +module Network.Socket.Posix.Syscall ( + setupSocket, + setupAccepted, + acceptFd, + reportConnReset, + ConnectNext (..), + connectNext, +) where + +import Foreign.C.Error (eINPROGRESS, eINTR, getErrno) +import Foreign.Marshal.Utils (with) + +#ifdef HAVE_ADVANCED_SOCKET_FLAGS +import Network.Socket.Cbits +#else +import Network.Socket.Fcntl +#endif +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types + +-- | Preparing a new socket: non-blocking, unless 'socket' asked for it. +setupSocket :: CSocket -> IO () +#ifdef HAVE_ADVANCED_SOCKET_FLAGS +setupSocket _ = return () +#else +setupSocket = setNonBlockIfNeeded +#endif + +-- | Preparing an accepted socket: 'acceptFd' has done it. +setupAccepted :: CSocket -> IO () +setupAccepted _ = return () + +-- | Accepting a connection on a non-blocking listening socket. +acceptFd :: Socket -> CSocket -> Ptr sa -> Int -> IO CSocket +acceptFd listing_sock fd sa sz = with (fromIntegral sz) $ \ptr_len -> do +#ifdef HAVE_ADVANCED_SOCKET_FLAGS + throwSocketErrorWaitRead listing_sock "Network.Socket.accept" + (c_accept4 fd sa ptr_len (sockNonBlock .|. sockCloexec)) +#else + new_fd <- throwSocketErrorWaitRead listing_sock "Network.Socket.accept" + (c_accept fd sa ptr_len) + setNonBlockIfNeeded new_fd + setCloseOnExecIfNeeded new_fd + return new_fd +#endif + +-- | POSIX says nothing of an ICMP unreachable to an unconnected socket. +reportConnReset :: Socket -> Bool -> IO () +reportConnReset _ _ = return () + +-- | What to do after @connect@ has failed. +data ConnectNext = ConnectRetry | ConnectWait + +-- | Retrying an interrupted @connect@, waiting for one in progress, or +-- throwing. +connectNext :: String -> IO ConnectNext +connectNext errLoc = do + err <- getErrno + if err == eINTR + then return ConnectRetry + else if err == eINPROGRESS + then return ConnectWait + else throwSocketError errLoc + +#ifdef HAVE_ADVANCED_SOCKET_FLAGS +foreign import CALLCONV unsafe "accept4" + c_accept4 :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> CInt -> IO CSocket +#else +foreign import CALLCONV unsafe "accept" + c_accept :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CSocket +#endif diff --git a/Network/Socket/Syscall.hs b/Network/Socket/Syscall.hs index f93e4258..6e1125d7 100644 --- a/Network/Socket/Syscall.hs +++ b/Network/Socket/Syscall.hs @@ -6,27 +6,21 @@ module Network.Socket.Syscall where import Data.Either (isRight) import qualified Control.Exception as E -import Foreign.Marshal.Utils (with) import System.IO.Error (catchIOError) -#if defined(mingw32_HOST_OS) -import Foreign.Marshal.Alloc (alloca) -import Network.Socket.Cbits -import qualified GHC.Event.Windows as Mgr -#else -import Foreign.C.Error (getErrno, eINTR, eINPROGRESS) -#endif - #ifdef HAVE_ADVANCED_SOCKET_FLAGS import Network.Socket.Cbits -#else -import Network.Socket.Fcntl #endif import Network.Socket.Imports import Network.Socket.Internal import Network.Socket.Options import Network.Socket.Types +#if defined(mingw32_HOST_OS) +import qualified Network.Socket.Win32.Syscall as P +#else +import qualified Network.Socket.Posix.Syscall as P +#endif -- ---------------------------------------------------------------------------- -- On Windows, as on POSIX, sockets are non-blocking, and a call which would @@ -69,10 +63,7 @@ socket family stype protocol = withSocketsDo $ setProp fd = do -- Let's ensure that the socket (file descriptor) is closed even on -- asynchronous exceptions. - setNonBlock fd -#if defined(mingw32_HOST_OS) - associateSocket fd -#endif + P.setupSocket fd s <- mkSocket fd -- This socket is not managed by the IO manager yet. -- So, we don't have to call "close" which uses "closeFdWith". @@ -90,12 +81,6 @@ socket family stype protocol = withSocketsDo $ modifyFlag c_stype = c_stype #endif -#ifdef HAVE_ADVANCED_SOCKET_FLAGS - setNonBlock _ = return () -#else - setNonBlock fd = setNonBlockIfNeeded fd -#endif - #if HAVE_DECL_IPV6_V6ONLY unsetIPv6Only s = when (family == AF_INET6 && stype `elem` [Stream, Datagram]) $ # if defined(mingw32_HOST_OS) @@ -134,15 +119,7 @@ socket family stype protocol = withSocketsDo $ -- It is advice for datagrams alone and does nothing to any other socket, -- so the result is not worth looking at. reportConnReset :: Socket -> Bool -> IO () -#if defined(mingw32_HOST_OS) -reportConnReset s report = - with (if report then 1 else 0 :: Word32) $ \val -> - alloca $ \ret -> - void $ withFdSocket s $ \fd -> - c_WSAIoctl fd sioUDPConnReset val 4 nullPtr 0 ret nullPtr nullPtr -#else -reportConnReset _ _ = return () -#endif +reportConnReset = P.reportConnReset ----------------------------------------------------------------------------- -- Binding a socket @@ -188,19 +165,10 @@ connectLoop s p_sa sz whenWritable = withFdSocket s $ \fd -> loop fd loop fd = do r <- c_connect fd p_sa sz if r /= -1 then return (Right ()) else do -#if defined(mingw32_HOST_OS) - rc <- c_getLastError - if rc == wsaEWOULDBLOCK - then whenWritable connected - else throwSocketErrorCode errLoc rc -#else - err <- getErrno - case () of - _ | err == eINTR -> loop fd - _ | err == eINPROGRESS -> whenWritable connected --- _ | err == eAGAIN -> whenWritable connected - _otherwise -> throwSocketError errLoc -#endif + next <- P.connectNext errLoc + case next of + P.ConnectRetry -> loop fd + P.ConnectWait -> whenWritable connected connected = do err <- getSocketOption s SoError @@ -237,52 +205,12 @@ listen s backlog = withFdSocket s listen' `annotateIOException` show s accept :: SocketAddress sa => Socket -> IO (Socket, sa) accept listing_sock = withNewSocketAddress $ \new_sa sz -> withFdSocket listing_sock $ \listing_fd -> do - new_sock <- E.bracketOnError (callAccept listing_fd new_sa sz) c_close $ \fd -> do -#if defined(mingw32_HOST_OS) - associateSocket fd -#endif + new_sock <- E.bracketOnError (P.acceptFd listing_sock listing_fd new_sa sz) c_close $ \fd -> do + P.setupAccepted fd mkSocket fd new_addr <- peekSocketAddress new_sa return (new_sock, new_addr) - where -#if defined(mingw32_HOST_OS) - -- The listening socket is non-blocking, as on POSIX. - callAccept fd sa sz = with (fromIntegral sz) $ \ ptr_len -> - throwSocketErrorWaitRead listing_sock "Network.Socket.accept" - (c_accept fd sa ptr_len) -#else - callAccept fd sa sz = with (fromIntegral sz) $ \ ptr_len -> do -# ifdef HAVE_ADVANCED_SOCKET_FLAGS - throwSocketErrorWaitRead listing_sock "Network.Socket.accept" - (c_accept4 fd sa ptr_len (sockNonBlock .|. sockCloexec)) -# else - new_fd <- throwSocketErrorWaitRead listing_sock "Network.Socket.accept" - (c_accept fd sa ptr_len) - setNonBlockIfNeeded new_fd - setCloseOnExecIfNeeded new_fd - return new_fd -# endif /* HAVE_ADVANCED_SOCKET_FLAGS */ -#endif - -#if defined(mingw32_HOST_OS) --- | Associate a socket with the I/O manager, skipping the completion port for --- an operation that finishes at once. -associateSocket :: CSocket -> IO () -associateSocket fd = do - let h = wordPtrToPtr $ fromIntegral fd - Mgr.associateHandle' h - -- Not FILE_SKIP_SET_EVENT_ON_HANDLE: cancelling waits on the handle. - ok <- c_SetFileCompletionNotificationModes h fileSkipCompletionPortOnSuccess - unless ok $ ioError (userError "associateSocket: SetFileCompletionNotificationModes failed") - throwSocketErrorIfMinus1_ "associateSocket" $ c_set_nonblock fd -foreign import ccall unsafe "hsnet_set_nonblock" - c_set_nonblock :: CSocket -> IO CInt - -foreign import ccall unsafe "windows.h SetFileCompletionNotificationModes" - c_SetFileCompletionNotificationModes :: Ptr () -> Word8 -> IO Bool - -#endif foreign import CALLCONV unsafe "socket" c_socket :: CInt -> CInt -> CInt -> IO CSocket foreign import CALLCONV unsafe "bind" @@ -291,19 +219,3 @@ foreign import CALLCONV unsafe "connect" c_connect :: CSocket -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt foreign import CALLCONV unsafe "listen" c_listen :: CSocket -> CInt -> IO CInt - -#ifdef HAVE_ADVANCED_SOCKET_FLAGS -foreign import CALLCONV unsafe "accept4" - c_accept4 :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> CInt -> IO CSocket -#else -foreign import CALLCONV unsafe "accept" - c_accept :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CSocket -#endif - -#if defined(mingw32_HOST_OS) --- int WSAIoctl(SOCKET, DWORD, LPVOID, DWORD, LPVOID, DWORD, LPDWORD, --- LPWSAOVERLAPPED, LPWSAOVERLAPPED_COMPLETION_ROUTINE) -foreign import CALLCONV unsafe "WSAIoctl" - c_WSAIoctl :: CSocket -> Word32 -> Ptr Word32 -> Word32 -> Ptr () -> Word32 - -> Ptr Word32 -> Ptr () -> Ptr () -> IO CInt -#endif diff --git a/Network/Socket/Win32/Syscall.hs b/Network/Socket/Win32/Syscall.hs new file mode 100644 index 00000000..77d3cef9 --- /dev/null +++ b/Network/Socket/Win32/Syscall.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +-- | The Windows parts of "Network.Socket.Syscall". +module Network.Socket.Win32.Syscall ( + setupSocket, + setupAccepted, + acceptFd, + reportConnReset, + ConnectNext (..), + connectNext, +) where + +import qualified GHC.Event.Windows as Mgr +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (with) + +import Network.Socket.Cbits +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types + +-- | Preparing a new socket: see 'associateSocket'. +setupSocket :: CSocket -> IO () +setupSocket = associateSocket + +-- | Preparing an accepted socket: see 'associateSocket'. +setupAccepted :: CSocket -> IO () +setupAccepted = associateSocket + +-- | Accepting a connection on a non-blocking listening socket. +acceptFd :: Socket -> CSocket -> Ptr sa -> Int -> IO CSocket +acceptFd listing_sock fd sa sz = with (fromIntegral sz) $ \ptr_len -> + throwSocketErrorWaitRead listing_sock "Network.Socket.accept" + (c_accept fd sa ptr_len) + +-- | Associating a socket with the I/O manager, skipping the completion +-- port for an operation that finishes at once, and making it +-- non-blocking, as on POSIX. +associateSocket :: CSocket -> IO () +associateSocket fd = do + let h = wordPtrToPtr $ fromIntegral fd + Mgr.associateHandle' h + -- Not FILE_SKIP_SET_EVENT_ON_HANDLE: cancelling waits on the handle. + ok <- c_SetFileCompletionNotificationModes h fileSkipCompletionPortOnSuccess + unless ok $ ioError (userError "associateSocket: SetFileCompletionNotificationModes failed") + throwSocketErrorIfMinus1_ "associateSocket" $ c_set_nonblock fd + +-- | Whether the socket reports the ICMP unreachable an earlier send of +-- its own caused: see 'Network.Socket.Syscall.reportConnReset'. +reportConnReset :: Socket -> Bool -> IO () +reportConnReset s report = + with (if report then 1 else 0 :: Word32) $ \val -> + alloca $ \ret -> + void $ withFdSocket s $ \fd -> + c_WSAIoctl fd sioUDPConnReset val 4 nullPtr 0 ret nullPtr nullPtr + +-- | What to do after @connect@ has failed. +data ConnectNext = ConnectRetry | ConnectWait + +-- | Waiting for a @connect@ in progress, or throwing. +connectNext :: String -> IO ConnectNext +connectNext errLoc = do + rc <- c_getLastError + if rc == wsaEWOULDBLOCK + then return ConnectWait + else throwSocketErrorCode errLoc rc + +foreign import CALLCONV unsafe "accept" + c_accept :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CSocket + +foreign import ccall unsafe "hsnet_set_nonblock" + c_set_nonblock :: CSocket -> IO CInt + +foreign import ccall unsafe "windows.h SetFileCompletionNotificationModes" + c_SetFileCompletionNotificationModes :: Ptr () -> Word8 -> IO Bool + +-- int WSAIoctl(SOCKET, DWORD, LPVOID, DWORD, LPVOID, DWORD, LPDWORD, +-- LPWSAOVERLAPPED, LPWSAOVERLAPPED_COMPLETION_ROUTINE) +foreign import CALLCONV unsafe "WSAIoctl" + c_WSAIoctl :: CSocket -> Word32 -> Ptr Word32 -> Word32 -> Ptr () -> Word32 + -> Ptr Word32 -> Ptr () -> Ptr () -> IO CInt diff --git a/network.cabal b/network.cabal index 3b65c578..07dc96a6 100644 --- a/network.cabal +++ b/network.cabal @@ -145,6 +145,7 @@ library Network.Socket.Posix.Buffer Network.Socket.Posix.Cmsg Network.Socket.Posix.Internal + Network.Socket.Posix.Syscall Network.Socket.Posix.CmsgHdr Network.Socket.Posix.HostName Network.Socket.Posix.IOVec @@ -171,6 +172,7 @@ library Network.Socket.Win32.CmsgHdr Network.Socket.Win32.HostName Network.Socket.Win32.Internal + Network.Socket.Win32.Syscall Network.Socket.Win32.Load Network.Socket.Win32.WSABuf Network.Socket.Win32.MsgHdr From 555cbc82bd2c23f46b2b258a83b4d3108ebd858c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Nov 2026 12:16:11 +0900 Subject: [PATCH 5/6] Move the rest of the per-platform code into Posix and Win32 modules The gathering writes of Network.Socket.ByteString with their foreign imports, Network.Socket.Fcntl, and socketPair. The lazy sendWith no longer goes its own way on Windows: that was for the MIO give-ups. c_recvmsg in Network.Socket.ByteString.Internal was unused. Co-Authored-By: Claude Opus 5.5 --- Network/Socket/ByteString/IO.hsc | 87 ++----------------------- Network/Socket/ByteString/Internal.hs | 55 ++++------------ Network/Socket/ByteString/Lazy.hs | 12 ---- Network/Socket/ByteString/Lazy/Posix.hs | 2 +- Network/Socket/Fcntl.hs | 50 ++++---------- Network/Socket/Posix/ByteString.hsc | 60 +++++++++++++++++ Network/Socket/Posix/Fcntl.hs | 45 +++++++++++++ Network/Socket/Posix/Unix.hs | 28 ++++++++ Network/Socket/Unix.hsc | 49 ++------------ Network/Socket/Win32/ByteString.hs | 65 ++++++++++++++++++ Network/Socket/Win32/Fcntl.hs | 25 +++++++ Network/Socket/Win32/Unix.hs | 39 +++++++++++ network.cabal | 6 ++ 13 files changed, 302 insertions(+), 221 deletions(-) create mode 100644 Network/Socket/Posix/ByteString.hsc create mode 100644 Network/Socket/Posix/Fcntl.hs create mode 100644 Network/Socket/Posix/Unix.hs create mode 100644 Network/Socket/Win32/ByteString.hs create mode 100644 Network/Socket/Win32/Fcntl.hs create mode 100644 Network/Socket/Win32/Unix.hs diff --git a/Network/Socket/ByteString/IO.hsc b/Network/Socket/ByteString/IO.hsc index 0ff80184..331b8481 100644 --- a/Network/Socket/ByteString/IO.hsc +++ b/Network/Socket/ByteString/IO.hsc @@ -63,7 +63,6 @@ import Network.Socket.Wait import Data.ByteString.Internal (create, ByteString(..)) import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Marshal.Utils (with) import Network.Socket.Internal import System.Posix.Types (Fd(..)) @@ -71,14 +70,10 @@ import Network.Socket.Flag import Network.Socket.SockAddr (annotateWithSocket) #if !defined(mingw32_HOST_OS) import Network.Socket.Posix.Cmsg -import Network.Socket.Posix.IOVec -import Network.Socket.Posix.MsgHdr (MsgHdr(..)) +import qualified Network.Socket.Posix.ByteString as P #else -import Foreign.Marshal.Alloc (alloca) import Network.Socket.Win32.Cmsg -import Network.Socket.Win32.Load -import Network.Socket.Win32.WSABuf -import Network.Socket.Win32.MsgHdr (MsgHdr(..)) +import qualified Network.Socket.Win32.ByteString as P #endif -- ---------------------------------------------------------------------------- @@ -197,22 +192,7 @@ sendMany s cs = sendMany' `annotateWithSocket` (s, Nothing) -- One gathering write, which may send only part of the data. sendManyOnce :: Socket -> [ByteString] -> IO Int -sendManyOnce s cs = -#if !defined(mingw32_HOST_OS) - fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> - withFdSocket s $ \fd -> do - let len = fromIntegral $ min iovsLen (#const IOV_MAX) - throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $ - c_writev fd iovsPtr len -#else - fmap fromIntegral . withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> - withFdSocket s $ \fd -> do - let len = fromIntegral wsabsLen - alloca $ \send_ptr -> do - _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $ - c_wsasend fd wsabsPtr len send_ptr 0 nullPtr nullPtr - peek send_ptr -#endif +sendManyOnce = P.sendManyOnce -- | 'sendMany' which the caller can give up on. Parts may have been -- sent before it gives up, so a stream given up on is to be closed. @@ -240,45 +220,9 @@ sendManyTo _ [] _ = return () sendManyTo s cs addr = sendManyTo' `annotateWithSocket` (s, Nothing) where sendManyTo' = do - sent <- fromIntegral <$> sendManyToInner + sent <- P.sendManyToOnce s cs addr waitWhen0 sent s when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr - sendManyToInner = - withSockAddr addr $ \addrPtr addrSize -> -#if !defined(mingw32_HOST_OS) - withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> do - let msgHdr = MsgHdr { - msgName = addrPtr - , msgNameLen = fromIntegral addrSize - , msgIov = iovsPtr - , msgIovLen = fromIntegral iovsLen - , msgCtrl = nullPtr - , msgCtrlLen = 0 - , msgFlags = 0 - } - withFdSocket s $ \fd -> - with msgHdr $ \msgHdrPtr -> - throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $ - c_sendmsg fd msgHdrPtr 0 -#else - withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> do - let msgHdr = MsgHdr { - msgName = addrPtr - , msgNameLen = fromIntegral addrSize - , msgBuffer = wsabsPtr - , msgBufferLen = fromIntegral wsabsLen - , msgCtrl = nullPtr - , msgCtrlLen = 0 - , msgFlags = 0 - } - withFdSocket s $ \fd -> do - sendMsg <- mkSendMsgUnsafe <$> getWSASendMsg fd - with msgHdr $ \msgHdrPtr -> - alloca $ \send_ptr -> do - _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $ - sendMsg fd (castPtr msgHdrPtr) 0 send_ptr nullPtr nullPtr - peek send_ptr -#endif -- | Send data and file descriptors over a UNIX-domain socket in -- a single system call. This function does not work on Windows. @@ -392,29 +336,6 @@ remainingChunks i (x:xs) where len = B.length x -#if !defined(mingw32_HOST_OS) --- | @withIOVecfromBS cs f@ executes the computation @f@, passing as argument a pair --- consisting of a pointer to a temporarily allocated array of pointers to --- IOVec made from @cs@ and the number of pointers (@length cs@). --- /Unix only/. -withIOVecfromBS :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a -withIOVecfromBS cs f = withBufSizs cs $ \bufsizs -> withIOVec bufsizs f -#else --- | @withWSABuffromBS cs f@ executes the computation @f@, passing as argument a pair --- consisting of a pointer to a temporarily allocated array of pointers to --- WSABuf made from @cs@ and the number of pointers (@length cs@). --- /Windows only/. -withWSABuffromBS :: [ByteString] -> ((Ptr WSABuf, Int) -> IO a) -> IO a -withWSABuffromBS cs f = withBufSizs cs $ \bufsizs -> withWSABuf bufsizs f -#endif - -withBufSizs :: [ByteString] -> ([(Ptr Word8, Int)] -> IO a) -> IO a -withBufSizs bss0 f = loop bss0 id - where - loop [] build = f $ build [] - loop (PS fptr off len:bss) build = withForeignPtr fptr $ \ptr -> do - let ptr' = ptr `plusPtr` off - loop bss (build . ((ptr',len) :)) -- | Send data to the socket using sendmsg(2). sendMsg :: Socket -- ^ Socket diff --git a/Network/Socket/ByteString/Internal.hs b/Network/Socket/ByteString/Internal.hs index e8e10dce..0ea993c5 100644 --- a/Network/Socket/ByteString/Internal.hs +++ b/Network/Socket/ByteString/Internal.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- | -- Module : Network.Socket.ByteString.Internal -- Copyright : (c) Johan Tibell 2007-2010 @@ -12,57 +10,26 @@ module Network.Socket.ByteString.Internal ( mkInvalidRecvArgError -#if !defined(mingw32_HOST_OS) - , c_writev - , c_sendmsg - , c_recvmsg -#else - , c_wsasend -#endif + , withBufSizs ) where -#include "HsNetDef.h" - +import Data.ByteString.Internal (ByteString (..)) +import Foreign.ForeignPtr (withForeignPtr) import GHC.IO.Exception (IOErrorType(..)) import System.IO.Error (ioeSetErrorString, mkIOError) -#if !defined(mingw32_HOST_OS) -import System.Posix.Types (CSsize(..)) - import Network.Socket.Imports -import Network.Socket.Posix.IOVec (IOVec) -import Network.Socket.Posix.MsgHdr (MsgHdr) -import Network.Socket.Types -#else -import Data.Word -import Foreign.C.Types -import Foreign.Ptr - -import Network.Socket.Win32.WSABuf (WSABuf) -import Network.Socket.Types - -type DWORD = Word32 -type LPDWORD = Ptr DWORD -#endif mkInvalidRecvArgError :: String -> IOError mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError InvalidArgument loc Nothing Nothing) "non-positive length" -#if !defined(mingw32_HOST_OS) -foreign import ccall unsafe "writev" - c_writev :: CSocket -> Ptr IOVec -> CInt -> IO CSsize - -foreign import ccall unsafe "sendmsg" - c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize - -foreign import ccall unsafe "recvmsg" - c_recvmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize -#else - -- fixme Handle for SOCKET, see #426 -foreign import CALLCONV unsafe "WSASend" - c_wsasend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt --- WSASendMsg and WSARecvMsg are extension functions and cannot be --- imported by name; see Network.Socket.Win32.Load. -#endif +-- | The buffers of the parts, with their lengths. +withBufSizs :: [ByteString] -> ([(Ptr Word8, Int)] -> IO a) -> IO a +withBufSizs bss0 f = loop bss0 id + where + loop [] build = f $ build [] + loop (PS fptr off len:bss) build = withForeignPtr fptr $ \ptr -> do + let ptr' = ptr `plusPtr` off + loop bss (build . ((ptr',len) :)) diff --git a/Network/Socket/ByteString/Lazy.hs b/Network/Socket/ByteString/Lazy.hs index 73251f87..6ff39b5c 100644 --- a/Network/Socket/ByteString/Lazy.hs +++ b/Network/Socket/ByteString/Lazy.hs @@ -55,9 +55,7 @@ import qualified Data.ByteString.Lazy as L import qualified Network.Socket.ByteString as N import Network.Socket.Imports import Network.Socket.Types -#if !defined(mingw32_HOST_OS) import Network.Socket.Wait (withWritable) -#endif -- | Send data and file descriptors over a UNIX-domain socket in -- a single system call. This function does not work on Windows. @@ -77,17 +75,7 @@ sendWithFds s lbs fds = N.sendManyWithFds s (L.toChunks lbs) fds -- -- @since 3.2.12.0 sendWith :: Socket -> ByteString -> STM a -> IO (Either a Int64) -#if defined(mingw32_HOST_OS) --- 'send' sends the first chunk here, and so does this, through the --- strict one, whose give-up cancels its own operation alone. -sendWith s lbs giveUp = fmap fromIntegral <$> N.sendWith s chunk giveUp - where - chunk = case L.toChunks lbs of - [] -> S.empty - x : _ -> x -#else sendWith s lbs giveUp = withWritable s giveUp $ send s lbs -#endif -- | 'sendAll' which the caller can give up on. Part of the data may -- have been sent before it gives up, so a stream given up on is to be diff --git a/Network/Socket/ByteString/Lazy/Posix.hs b/Network/Socket/ByteString/Lazy/Posix.hs index 381daa22..40b9f719 100644 --- a/Network/Socket/ByteString/Lazy/Posix.hs +++ b/Network/Socket/ByteString/Lazy/Posix.hs @@ -11,7 +11,7 @@ import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Foreign.Marshal.Array (allocaArray) import Network.Socket.ByteString.IO (waitWhen0) -import Network.Socket.ByteString.Internal (c_writev) +import Network.Socket.Posix.ByteString (c_writev) import Network.Socket.Imports import Network.Socket.Internal import Network.Socket.Posix.IOVec (IOVec (IOVec)) diff --git a/Network/Socket/Fcntl.hs b/Network/Socket/Fcntl.hs index 994d4941..e925130f 100644 --- a/Network/Socket/Fcntl.hs +++ b/Network/Socket/Fcntl.hs @@ -1,52 +1,37 @@ {-# LANGUAGE CPP #-} -module Network.Socket.Fcntl where +module Network.Socket.Fcntl ( + setNonBlockIfNeeded, + setCloseOnExecIfNeeded, + getCloseOnExec, + getNonBlock, +) where import Network.Socket.Types -import qualified System.Posix.Internals - -#if !defined(mingw32_HOST_OS) -import Network.Socket.Cbits -import Network.Socket.Imports +#if defined(mingw32_HOST_OS) +import qualified Network.Socket.Win32.Fcntl as P +#else +import qualified Network.Socket.Posix.Fcntl as P #endif -- | Set the nonblocking flag on Unix. -- On Windows, nothing is done. setNonBlockIfNeeded :: CSocket -> IO () -setNonBlockIfNeeded fd = - System.Posix.Internals.setNonBlockingFD (fromIntegral fd) True - --- TODO: remove fromIntegral for WinIO +setNonBlockIfNeeded = P.setNonBlockIfNeeded -- | Set the close_on_exec flag on Unix. -- On Windows, nothing is done. -- -- Since 2.7.0.0. setCloseOnExecIfNeeded :: CSocket -> IO () -#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) -setCloseOnExecIfNeeded _ = return () -#else -setCloseOnExecIfNeeded fd = System.Posix.Internals.setCloseOnExec fd -#endif - -#if !defined(mingw32_HOST_OS) -foreign import ccall unsafe "hsnet_fcntl_get" - c_fcntl_get :: CSocket -> CInt -> IO CInt -#endif +setCloseOnExecIfNeeded = P.setCloseOnExecIfNeeded -- | Get the close_on_exec flag. -- On Windows, this function always returns 'False'. -- -- Since 2.7.0.0. getCloseOnExec :: CSocket -> IO Bool -#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) -getCloseOnExec _ = return False -#else -getCloseOnExec fd = do - flags <- c_fcntl_get fd fGetFd - let ret = flags .&. fdCloexec - return (ret /= 0) -#endif +getCloseOnExec = P.getCloseOnExec -- | Get the nonblocking flag. -- On Windows, this function always returns 'True': every socket is put @@ -54,11 +39,4 @@ getCloseOnExec fd = do -- -- Since 2.7.0.0. getNonBlock :: CSocket -> IO Bool -#if defined(mingw32_HOST_OS) -getNonBlock _ = return True -#else -getNonBlock fd = do - flags <- c_fcntl_get fd fGetFl - let ret = flags .&. oNonBlock - return (ret /= 0) -#endif +getNonBlock = P.getNonBlock diff --git a/Network/Socket/Posix/ByteString.hsc b/Network/Socket/Posix/ByteString.hsc new file mode 100644 index 00000000..fb6665d1 --- /dev/null +++ b/Network/Socket/Posix/ByteString.hsc @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +#include "HsNet.h" + +-- | The POSIX parts of "Network.Socket.ByteString": gathering writes. +module Network.Socket.Posix.ByteString ( + sendManyOnce, + sendManyToOnce, + c_writev, +) where + +import Data.ByteString (ByteString) +import Foreign.Marshal.Utils (with) +import System.Posix.Types (CSsize (..)) + +import Network.Socket.ByteString.Internal (withBufSizs) +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Posix.IOVec +import Network.Socket.Posix.MsgHdr (MsgHdr (..)) +import Network.Socket.Types + +-- | One gathering write, which may send only part of the data. +sendManyOnce :: Socket -> [ByteString] -> IO Int +sendManyOnce s cs = + fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> + withFdSocket s $ \fd -> do + let len = fromIntegral $ min iovsLen (#const IOV_MAX) + throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $ + c_writev fd iovsPtr len + +-- | One gathering write to the address, which may send only part of the +-- data. +sendManyToOnce :: Socket -> [ByteString] -> SockAddr -> IO Int +sendManyToOnce s cs addr = + fmap fromIntegral $ withSockAddr addr $ \addrPtr addrSize -> + withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> do + let msgHdr = MsgHdr { + msgName = addrPtr + , msgNameLen = fromIntegral addrSize + , msgIov = iovsPtr + , msgIovLen = fromIntegral iovsLen + , msgCtrl = nullPtr + , msgCtrlLen = 0 + , msgFlags = 0 + } + withFdSocket s $ \fd -> + with msgHdr $ \msgHdrPtr -> + throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $ + c_sendmsg fd msgHdrPtr 0 + +-- An array of IOVec made from the parts, and its length. +withIOVecfromBS :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a +withIOVecfromBS cs f = withBufSizs cs $ \bufsizs -> withIOVec bufsizs f + +foreign import ccall unsafe "writev" + c_writev :: CSocket -> Ptr IOVec -> CInt -> IO CSsize + +foreign import ccall unsafe "sendmsg" + c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize diff --git a/Network/Socket/Posix/Fcntl.hs b/Network/Socket/Posix/Fcntl.hs new file mode 100644 index 00000000..66dcc13b --- /dev/null +++ b/Network/Socket/Posix/Fcntl.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} + +-- | The POSIX side of "Network.Socket.Fcntl". +module Network.Socket.Posix.Fcntl ( + setNonBlockIfNeeded, + setCloseOnExecIfNeeded, + getCloseOnExec, + getNonBlock, +) where + +import qualified System.Posix.Internals + +import Network.Socket.Cbits +import Network.Socket.Imports +import Network.Socket.Types + +setNonBlockIfNeeded :: CSocket -> IO () +setNonBlockIfNeeded fd = + System.Posix.Internals.setNonBlockingFD (fromIntegral fd) True + +setCloseOnExecIfNeeded :: CSocket -> IO () +#if defined(ghcjs_HOST_OS) +setCloseOnExecIfNeeded _ = return () +#else +setCloseOnExecIfNeeded fd = System.Posix.Internals.setCloseOnExec fd +#endif + +getCloseOnExec :: CSocket -> IO Bool +#if defined(ghcjs_HOST_OS) +getCloseOnExec _ = return False +#else +getCloseOnExec fd = do + flags <- c_fcntl_get fd fGetFd + let ret = flags .&. fdCloexec + return (ret /= 0) +#endif + +getNonBlock :: CSocket -> IO Bool +getNonBlock fd = do + flags <- c_fcntl_get fd fGetFl + let ret = flags .&. oNonBlock + return (ret /= 0) + +foreign import ccall unsafe "hsnet_fcntl_get" + c_fcntl_get :: CSocket -> CInt -> IO CInt diff --git a/Network/Socket/Posix/Unix.hs b/Network/Socket/Posix/Unix.hs new file mode 100644 index 00000000..e3a94f86 --- /dev/null +++ b/Network/Socket/Posix/Unix.hs @@ -0,0 +1,28 @@ +-- | The POSIX side of "Network.Socket.Unix". +module Network.Socket.Posix.Unix ( + socketPair, +) where + +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (peekArray) + +import Network.Socket.Fcntl +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types + +socketPair :: Family -> SocketType -> ProtocolNumber -> IO (Socket, Socket) +socketPair family stype protocol = + allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do + let c_stype = packSocketType stype + _rc <- throwSocketErrorIfMinus1Retry "Network.Socket.socketpair" $ + c_socketpair (packFamily family) c_stype protocol fdArr + [fd1,fd2] <- peekArray 2 fdArr + setNonBlockIfNeeded fd1 + setNonBlockIfNeeded fd2 + s1 <- mkSocket fd1 + s2 <- mkSocket fd2 + return (s1, s2) + +foreign import ccall unsafe "socketpair" + c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt diff --git a/Network/Socket/Unix.hsc b/Network/Socket/Unix.hsc index 70372271..9522ebdc 100644 --- a/Network/Socket/Unix.hsc +++ b/Network/Socket/Unix.hsc @@ -16,21 +16,17 @@ module Network.Socket.Unix ( import Foreign.Marshal.Alloc (allocaBytes) import Network.Socket.Buffer -import Network.Socket.Fcntl import Network.Socket.Imports import Network.Socket.Types import System.Posix.Types (Fd(..)) #if defined(mingw32_HOST_OS) -import qualified Control.Exception as E -import Network.Socket.Name (getSocketName) -import Network.Socket.Options -import Network.Socket.Syscall import Network.Socket.Win32.Cmsg +import qualified Network.Socket.Win32.Unix as P #else -import Foreign.Marshal.Array (peekArray) import Network.Socket.Internal import Network.Socket.Posix.Cmsg +import qualified Network.Socket.Posix.Unix as P #endif #if defined(HAVE_GETPEEREID) @@ -144,7 +140,7 @@ sendFd s outfd = void $ allocaBytes dummyBufSize $ \buf -> do -- | Receive a file descriptor over a UNIX-domain socket. Note that the resulting -- file descriptor may have to be put into non-blocking mode in order to be --- used safely. See 'setNonBlockIfNeeded'. +-- used safely. See 'Network.Socket.setNonBlockIfNeeded'. -- This function does not work on Windows. recvFd :: Socket -> IO CInt recvFd s = allocaBytes dummyBufSize $ \buf -> do @@ -163,41 +159,4 @@ socketPair :: Family -- Family Name (usually AF_UNIX) -> SocketType -- Socket Type (usually Stream) -> ProtocolNumber -- Protocol Number -> IO (Socket, Socket) -- unnamed and connected. -#if defined(mingw32_HOST_OS) -socketPair _ _ _ = - E.bracket (socket AF_INET Stream defaultProtocol) close $ \listenSock -> do - bind listenSock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1) - listen listenSock 10 - addr :: SockAddr <- getSocketName listenSock - E.bracketOnError (socket AF_INET Stream defaultProtocol) close $ \clientSock -> do - connect clientSock addr - me :: SockAddr <- getSocketName clientSock - serverSock <- acceptFrom listenSock me - mapM_ prepare [clientSock, serverSock] - return (clientSock, serverSock) - where - -- Another process may connect to the port first; it is not our peer. - acceptFrom listenSock me = do - (sock, peer) <- accept listenSock - if peer == me - then return sock - else close sock >> acceptFrom listenSock me - prepare sock = do - setSocketOption sock NoDelay 1 - withFdSocket sock setNonBlockIfNeeded -#else -socketPair family stype protocol = - allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do - let c_stype = packSocketType stype - _rc <- throwSocketErrorIfMinus1Retry "Network.Socket.socketpair" $ - c_socketpair (packFamily family) c_stype protocol fdArr - [fd1,fd2] <- peekArray 2 fdArr - setNonBlockIfNeeded fd1 - setNonBlockIfNeeded fd2 - s1 <- mkSocket fd1 - s2 <- mkSocket fd2 - return (s1, s2) - -foreign import ccall unsafe "socketpair" - c_socketpair :: CInt -> CInt -> CInt -> Ptr CInt -> IO CInt -#endif +socketPair = P.socketPair diff --git a/Network/Socket/Win32/ByteString.hs b/Network/Socket/Win32/ByteString.hs new file mode 100644 index 00000000..53621561 --- /dev/null +++ b/Network/Socket/Win32/ByteString.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} + +#include "HsNetDef.h" + +-- | The Windows parts of "Network.Socket.ByteString": gathering writes. +module Network.Socket.Win32.ByteString ( + sendManyOnce, + sendManyToOnce, +) where + +import Data.ByteString (ByteString) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (with) + +import Network.Socket.ByteString.Internal (withBufSizs) +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Types +import Network.Socket.Win32.Load +import Network.Socket.Win32.MsgHdr (MsgHdr (..)) +import Network.Socket.Win32.WSABuf + +type DWORD = Word32 +type LPDWORD = Ptr DWORD + +-- | One gathering write, which may send only part of the data. +sendManyOnce :: Socket -> [ByteString] -> IO Int +sendManyOnce s cs = + fmap fromIntegral . withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> + withFdSocket s $ \fd -> do + let len = fromIntegral wsabsLen + alloca $ \send_ptr -> do + _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $ + c_wsasend fd wsabsPtr len send_ptr 0 nullPtr nullPtr + peek send_ptr + +-- | One gathering write to the address, which may send only part of the +-- data. +sendManyToOnce :: Socket -> [ByteString] -> SockAddr -> IO Int +sendManyToOnce s cs addr = + fmap fromIntegral $ withSockAddr addr $ \addrPtr addrSize -> + withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> do + let msgHdr = MsgHdr { + msgName = addrPtr + , msgNameLen = fromIntegral addrSize + , msgBuffer = wsabsPtr + , msgBufferLen = fromIntegral wsabsLen + , msgCtrl = nullPtr + , msgCtrlLen = 0 + , msgFlags = 0 + } + withFdSocket s $ \fd -> do + wsaSendMsg <- mkSendMsgUnsafe <$> getWSASendMsg fd + with msgHdr $ \msgHdrPtr -> + alloca $ \send_ptr -> do + _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $ + wsaSendMsg fd (castPtr msgHdrPtr) 0 send_ptr nullPtr nullPtr + peek send_ptr + +-- An array of WSABuf made from the parts, and its length. +withWSABuffromBS :: [ByteString] -> ((Ptr WSABuf, Int) -> IO a) -> IO a +withWSABuffromBS cs f = withBufSizs cs $ \bufsizs -> withWSABuf bufsizs f + +foreign import CALLCONV unsafe "WSASend" + c_wsasend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt diff --git a/Network/Socket/Win32/Fcntl.hs b/Network/Socket/Win32/Fcntl.hs new file mode 100644 index 00000000..af1f96d1 --- /dev/null +++ b/Network/Socket/Win32/Fcntl.hs @@ -0,0 +1,25 @@ +-- | The Windows side of "Network.Socket.Fcntl": there is no fcntl. +module Network.Socket.Win32.Fcntl ( + setNonBlockIfNeeded, + setCloseOnExecIfNeeded, + getCloseOnExec, + getNonBlock, +) where + +import qualified System.Posix.Internals + +import Network.Socket.Types + +setNonBlockIfNeeded :: CSocket -> IO () +setNonBlockIfNeeded fd = + System.Posix.Internals.setNonBlockingFD (fromIntegral fd) True + +setCloseOnExecIfNeeded :: CSocket -> IO () +setCloseOnExecIfNeeded _ = return () + +getCloseOnExec :: CSocket -> IO Bool +getCloseOnExec _ = return False + +-- Every socket is non-blocking, as on POSIX. +getNonBlock :: CSocket -> IO Bool +getNonBlock _ = return True diff --git a/Network/Socket/Win32/Unix.hs b/Network/Socket/Win32/Unix.hs new file mode 100644 index 00000000..a85c374a --- /dev/null +++ b/Network/Socket/Win32/Unix.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The Windows side of "Network.Socket.Unix". +module Network.Socket.Win32.Unix ( + socketPair, +) where + +import qualified Control.Exception as E + +import Network.Socket.Fcntl +import Network.Socket.Name (getSocketName) +import Network.Socket.Options +import Network.Socket.Syscall +import Network.Socket.Types + +-- | A TCP connection over the loopback interface, whatever the arguments +-- are: an 'AF_UNIX' recv may miss the peer's close and wait for ever. +socketPair :: Family -> SocketType -> ProtocolNumber -> IO (Socket, Socket) +socketPair _ _ _ = + E.bracket (socket AF_INET Stream defaultProtocol) close $ \listenSock -> do + bind listenSock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1) + listen listenSock 10 + addr :: SockAddr <- getSocketName listenSock + E.bracketOnError (socket AF_INET Stream defaultProtocol) close $ \clientSock -> do + connect clientSock addr + me :: SockAddr <- getSocketName clientSock + serverSock <- acceptFrom listenSock me + mapM_ prepare [clientSock, serverSock] + return (clientSock, serverSock) + where + -- Another process may connect to the port first; it is not our peer. + acceptFrom listenSock me = do + (sock, peer) <- accept listenSock + if peer == me + then return sock + else close sock >> acceptFrom listenSock me + prepare sock = do + setSocketOption sock NoDelay 1 + withFdSocket sock setNonBlockIfNeeded diff --git a/network.cabal b/network.cabal index 07dc96a6..855432be 100644 --- a/network.cabal +++ b/network.cabal @@ -143,13 +143,16 @@ library other-modules: Network.Socket.ByteString.Lazy.Posix Network.Socket.Posix.Buffer + Network.Socket.Posix.ByteString Network.Socket.Posix.Cmsg + Network.Socket.Posix.Fcntl Network.Socket.Posix.Internal Network.Socket.Posix.Syscall Network.Socket.Posix.CmsgHdr Network.Socket.Posix.HostName Network.Socket.Posix.IOVec Network.Socket.Posix.MsgHdr + Network.Socket.Posix.Unix if os(solaris) cpp-options: -D__EXTENSIONS__ -D_XOPEN_SOURCE=500 @@ -168,14 +171,17 @@ library Network.Socket.ByteString.Lazy.Windows Network.Socket.Win32.AfdPoll Network.Socket.Win32.Buffer + Network.Socket.Win32.ByteString Network.Socket.Win32.Cmsg Network.Socket.Win32.CmsgHdr + Network.Socket.Win32.Fcntl Network.Socket.Win32.HostName Network.Socket.Win32.Internal Network.Socket.Win32.Syscall Network.Socket.Win32.Load Network.Socket.Win32.WSABuf Network.Socket.Win32.MsgHdr + Network.Socket.Win32.Unix extra-libraries: ws2_32 From f915a5e08d1730df64fb37948ae955f8a58793a5 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Sun, 15 Nov 2026 12:21:24 +0900 Subject: [PATCH 6/6] Name the lazy ByteString platform modules like the others Network.Socket.ByteString.Lazy.Posix and .Windows become Network.Socket.Posix.ByteString.Lazy and Network.Socket.Win32.ByteString.Lazy. Co-Authored-By: Claude Opus 5.5 --- Network/Socket/ByteString/Lazy.hs | 4 ++-- .../{ByteString/Lazy/Posix.hs => Posix/ByteString/Lazy.hs} | 2 +- .../{ByteString/Lazy/Windows.hs => Win32/ByteString/Lazy.hs} | 2 +- network.cabal | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) rename Network/Socket/{ByteString/Lazy/Posix.hs => Posix/ByteString/Lazy.hs} (97%) rename Network/Socket/{ByteString/Lazy/Windows.hs => Win32/ByteString/Lazy.hs} (95%) diff --git a/Network/Socket/ByteString/Lazy.hs b/Network/Socket/ByteString/Lazy.hs index 6ff39b5c..4fa0d217 100644 --- a/Network/Socket/ByteString/Lazy.hs +++ b/Network/Socket/ByteString/Lazy.hs @@ -45,9 +45,9 @@ import System.Posix.Types (Fd (..)) import Prelude hiding (getContents) #if defined(mingw32_HOST_OS) -import Network.Socket.ByteString.Lazy.Windows (send, sendAll) +import Network.Socket.Win32.ByteString.Lazy (send, sendAll) #else -import Network.Socket.ByteString.Lazy.Posix (send, sendAll) +import Network.Socket.Posix.ByteString.Lazy (send, sendAll) #endif import qualified Data.ByteString as S diff --git a/Network/Socket/ByteString/Lazy/Posix.hs b/Network/Socket/Posix/ByteString/Lazy.hs similarity index 97% rename from Network/Socket/ByteString/Lazy/Posix.hs rename to Network/Socket/Posix/ByteString/Lazy.hs index 40b9f719..b96448e0 100644 --- a/Network/Socket/ByteString/Lazy/Posix.hs +++ b/Network/Socket/Posix/ByteString/Lazy.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Socket.ByteString.Lazy.Posix ( +module Network.Socket.Posix.ByteString.Lazy ( -- * Send data to a socket send, sendAll, diff --git a/Network/Socket/ByteString/Lazy/Windows.hs b/Network/Socket/Win32/ByteString/Lazy.hs similarity index 95% rename from Network/Socket/ByteString/Lazy/Windows.hs rename to Network/Socket/Win32/ByteString/Lazy.hs index 7a953822..f1bb75ba 100644 --- a/Network/Socket/ByteString/Lazy/Windows.hs +++ b/Network/Socket/Win32/ByteString/Lazy.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.Socket.ByteString.Lazy.Windows ( +module Network.Socket.Win32.ByteString.Lazy ( -- * Send data to a socket send, sendAll, diff --git a/network.cabal b/network.cabal index 855432be..f4faff02 100644 --- a/network.cabal +++ b/network.cabal @@ -141,9 +141,9 @@ library if !os(windows) other-modules: - Network.Socket.ByteString.Lazy.Posix Network.Socket.Posix.Buffer Network.Socket.Posix.ByteString + Network.Socket.Posix.ByteString.Lazy Network.Socket.Posix.Cmsg Network.Socket.Posix.Fcntl Network.Socket.Posix.Internal @@ -168,10 +168,10 @@ library cbits/afdpoll.c other-modules: - Network.Socket.ByteString.Lazy.Windows Network.Socket.Win32.AfdPoll Network.Socket.Win32.Buffer Network.Socket.Win32.ByteString + Network.Socket.Win32.ByteString.Lazy Network.Socket.Win32.Cmsg Network.Socket.Win32.CmsgHdr Network.Socket.Win32.Fcntl