From dedfcbcdfe6eb64d487c9393144f561b6cc8a7e6 Mon Sep 17 00:00:00 2001 From: Tamar Christina Date: Mon, 24 Aug 2026 18:37:10 +0100 Subject: [PATCH] import mrkline buffer changes --- Network/Socket/Buffer.hsc | 114 ++++++++++++++++++++++++++++++++++---- 1 file changed, 103 insertions(+), 11 deletions(-) diff --git a/Network/Socket/Buffer.hsc b/Network/Socket/Buffer.hsc index ddc39745..4a09195b 100644 --- a/Network/Socket/Buffer.hsc +++ b/Network/Socket/Buffer.hsc @@ -89,6 +89,14 @@ sendBufTo :: SocketAddress sa => -> sa -> IO Int -- Number of Bytes sent sendBufTo s ptr nbytes sa = +##if __IO_MANAGER_WINIO__ >= 2 + sendBufToMIO s ptr nbytes sa sendBufToWinIO s ptr nbytes sa +##else + sendBufToMIO s ptr nbytes sa +##endif + +sendBufToMIO :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> IO Int +sendBufToMIO s ptr nbytes sa = withSocketAddress sa $ \p_sa siz -> fromIntegral <$> do withFdSocket s $ \fd -> do let sz = fromIntegral siz @@ -97,6 +105,28 @@ sendBufTo s ptr nbytes sa = throwSocketErrorWaitWrite s "Network.Socket.sendBufTo" $ c_sendto fd ptr n flags p_sa sz +##if __IO_MANAGER_WINIO__ >= 2 +sendBufToWinIO :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> IO Int +sendBufToWinIO s ptr nbytes sa = + withSocketAddress sa $ \p_sa siz -> + withFdSocket s $ \sock -> + with (WSABuf (castPtr ptr) (fromIntegral nbytes)) $ \wbuf -> + fmap fromIntegral $ Mgr.withException "sendBufTo" $ + Mgr.withOverlapped "sendBufTo" (wordPtrToPtr $ fromIntegral sock) 0 + (\lpOverlapped -> do + ret <- c_WSASendTo sock wbuf 1 nullPtr 0 p_sa + (fromIntegral siz) (castPtr lpOverlapped) nullPtr + if ret == 0 + then return Mgr.CbPending + else c_WSAGetLastError >>= \err -> + return $ if err == _ERROR_IO_PENDING + then Mgr.CbPending + else Mgr.CbError (fromIntegral err)) + (\err bytes -> if err == _ERROR_SUCCESS + then Mgr.ioSuccess $ fromIntegral bytes + else Mgr.ioFailed err) +##endif + #if defined(mingw32_HOST_OS) socket2FD :: Socket -> IO FD socket2FD s = do @@ -113,8 +143,24 @@ 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 <$> do +sendBuf s str len = #if defined(mingw32_HOST_OS) +## if __IO_MANAGER_WINIO__ >= 2 + sendBufMIO s str len sendBufWinIO s str len +## else + sendBufMIO s str len +## endif +#else + 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) +sendBufMIO :: Socket -> Ptr Word8 -> Int -> IO Int +sendBufMIO s str len = fromIntegral <$> do -- writeRawBufferPtr is supposed to handle checking for errors, but it's broken -- on x86_64 because of GHC bug #12010 so we duplicate the check here. The call -- to throwSocketErrorIfMinus1Retry can be removed when no GHC version with the @@ -123,12 +169,25 @@ sendBuf s str len = fromIntegral <$> do let clen = fromIntegral len throwSocketErrorIfMinus1Retry "Network.Socket.sendBuf" $ writeRawBufferPtr "Network.Socket.sendBuf" fd (castPtr str) 0 clen -#else - withFdSocket s $ \fd -> do - let flags = 0 - clen = fromIntegral len - throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $ - c_send fd str clen flags + +## if __IO_MANAGER_WINIO__ >= 2 +sendBufWinIO :: Socket -> Ptr Word8 -> Int -> IO Int +sendBufWinIO s ptr len = withFdSocket s $ \sock -> + with (WSABuf ptr (fromIntegral len)) $ \wbuf -> + fmap fromIntegral $ Mgr.withException "sendBuf" $ + Mgr.withOverlapped "sendBuf" (wordPtrToPtr $ fromIntegral sock) 0 + (\lpOverlapped -> do + ret <- c_WSASend sock wbuf 1 nullPtr 0 (castPtr lpOverlapped) nullPtr + if ret == 0 + then return Mgr.CbPending + else c_WSAGetLastError >>= \err -> + return $ if err == _ERROR_IO_PENDING + then Mgr.CbPending + else Mgr.CbError (fromIntegral err)) + (\err bytes -> if err == _ERROR_SUCCESS + then Mgr.ioSuccess $ fromIntegral bytes + else Mgr.ioFailed err) +## endif #endif -- | Receive data from the socket, writing it into buffer instead of @@ -364,12 +423,16 @@ sendBufMsg s sa bufsizs cmsgs flags = do cflags = fromMsgFlag flags withFdSocket s $ \fd -> with msgHdr $ \msgHdrPtr -> +#if defined(mingw32_HOST_OS) +## if __IO_MANAGER_WINIO__ >= 2 + sendBufMsgMIO s fd msgHdrPtr cflags + sendBufMsgWinIO fd msgHdrPtr cflags +## else + sendBufMsgMIO s fd msgHdrPtr cflags +## endif +#else throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $ -#if !defined(mingw32_HOST_OS) c_sendmsg fd msgHdrPtr cflags -#else - alloca $ \send_ptr -> - c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr #endif return $ fromIntegral sz @@ -459,6 +522,10 @@ foreign import CALLCONV SAFE_ON_WIN "WSAGetLastError" foreign import CALLCONV SAFE_ON_WIN "WSASendMsg" -- fixme Handle for SOCKET, see #426 c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt +foreign import CALLCONV unsafe "WSASend" + c_WSASend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt +foreign import CALLCONV unsafe "WSASendTo" + c_WSASendTo :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr sa -> CInt -> Ptr () -> Ptr () -> IO CInt foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg" c_recvmsg_mio :: CSocket -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt foreign import CALLCONV unsafe "WSARecv" @@ -470,6 +537,31 @@ foreign import CALLCONV unsafe "WSARecvMsg" c_recvmsg_winio :: CSocket -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt ## endif +sendBufMsgMIO :: Socket -> CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt +sendBufMsgMIO s fd msgHdrPtr cflags = + throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $ + alloca $ \send_ptr -> + c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr + +## if __IO_MANAGER_WINIO__ >= 2 +sendBufMsgWinIO :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt +sendBufMsgWinIO fd msgHdrPtr cflags = + fmap fromIntegral $ Mgr.withException "sendBufMsg" $ + Mgr.withOverlapped "sendBufMsg" (wordPtrToPtr $ fromIntegral fd) 0 + (\lpOverlapped -> do + ret <- c_sendmsg fd msgHdrPtr (fromIntegral cflags) nullPtr + (castPtr lpOverlapped) nullPtr + if ret == 0 + then return Mgr.CbPending + else c_WSAGetLastError >>= \err -> + return $ if err == _ERROR_IO_PENDING + then Mgr.CbPending + else Mgr.CbError (fromIntegral err)) + (\err bytes -> if err == _ERROR_SUCCESS + then Mgr.ioSuccess $ fromIntegral bytes + else Mgr.ioFailed err) +## endif + -- Helper functions for recvBufMsg on Windows recvBufMsgMIO :: Socket -> CSocket -> Ptr (MsgHdr sa) -> IO Int recvBufMsgMIO s fd msgHdrPtr = alloca $ \len_ptr -> do