Skip to content

Commit cc88a6c

Browse files
committed
Merge PR haskell#612
2 parents 7a177c1 + 7efebaa commit cc88a6c

16 files changed

Lines changed: 352 additions & 86 deletions

File tree

CHANGELOG.md

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,10 @@
11
# CHANGELOG for network
22

3+
## Version 3.3.0.0
4+
5+
* Basic support for WINIO
6+
[#509](https://github.com/haskell/network/pull/509)
7+
38
## Version 3.2.8.0
49

510
* sockopt: add IP_DONTFRAG/IP_MTU_DISCOVER option.

Network/Socket/Buffer.hsc

Lines changed: 220 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,12 @@
11
{-# LANGUAGE CPP #-}
2+
{-# LANGUAGE LambdaCase #-}
23

34
##include "HsNetDef.h"
45
#if defined(mingw32_HOST_OS)
6+
# include "winsock2.h"
57
# include "windows.h"
8+
# include "mswsock.h"
9+
# include "ntstatus.h"
610
#endif
711

812
module Network.Socket.Buffer (
@@ -30,6 +34,11 @@ import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)
3034
import Network.Socket.Win32.CmsgHdr
3135
import Network.Socket.Win32.MsgHdr
3236
import Network.Socket.Win32.WSABuf
37+
## if __IO_MANAGER_WINIO__ >= 2
38+
import qualified GHC.Event.Windows as Mgr
39+
import GHC.IO.SubSystem ((<!>))
40+
import Foreign.Ptr (wordPtrToPtr)
41+
## endif
3342
#else
3443
import Network.Socket.Posix.CmsgHdr
3544
import Network.Socket.Posix.MsgHdr
@@ -45,6 +54,28 @@ import Network.Socket.Flag
4554
#if defined(mingw32_HOST_OS)
4655
type DWORD = Word32
4756
type LPDWORD = Ptr DWORD
57+
58+
-- Windows error/status codes for WinIO completion callbacks.
59+
-- Defined here so they are expanded by hsc2hs and available inside
60+
-- ##if blocks that are deferred to GHC's CPP.
61+
_ERROR_SUCCESS, _ERROR_IO_PENDING, _ERROR_HANDLE_EOF,
62+
_ERROR_BROKEN_PIPE, _ERROR_NO_MORE_ITEMS,
63+
_ERROR_OPERATION_ABORTED, _ERROR_IO_INCOMPLETE,
64+
_WSAECONNABORTED, _WSAECONNRESET, _WSAEDISCON,
65+
_WSAEMSGSIZE, _WSAESHUTDOWN, _STATUS_BUFFER_OVERFLOW :: Num a => a
66+
_ERROR_SUCCESS = #{const ERROR_SUCCESS}
67+
_ERROR_IO_PENDING = #{const ERROR_IO_PENDING}
68+
_ERROR_HANDLE_EOF = #{const ERROR_HANDLE_EOF}
69+
_ERROR_BROKEN_PIPE = #{const ERROR_BROKEN_PIPE}
70+
_ERROR_NO_MORE_ITEMS = #{const ERROR_NO_MORE_ITEMS}
71+
_ERROR_OPERATION_ABORTED = #{const ERROR_OPERATION_ABORTED}
72+
_ERROR_IO_INCOMPLETE = #{const ERROR_IO_INCOMPLETE}
73+
_WSAECONNABORTED = #{const WSAECONNABORTED}
74+
_WSAECONNRESET = #{const WSAECONNRESET}
75+
_WSAEDISCON = #{const WSAEDISCON}
76+
_WSAEMSGSIZE = #{const WSAEMSGSIZE}
77+
_WSAESHUTDOWN = #{const WSAESHUTDOWN}
78+
_STATUS_BUFFER_OVERFLOW = #{const STATUS_BUFFER_OVERFLOW}
4879
#endif
4980

5081
-- | Send data to the socket. The recipient can be specified
@@ -71,7 +102,8 @@ socket2FD :: Socket -> IO FD
71102
socket2FD s = do
72103
fd <- unsafeFdSocket s
73104
-- HACK, 1 means True
74-
return $ FD{ fdFD = fd, fdIsSocket_ = 1 }
105+
-- TODO: remove fromIntegral for WinIO
106+
return $ FD{ fdFD = fromIntegral fd, fdIsSocket_ = 1 }
75107
#endif
76108

77109
-- | Send data to the socket. The socket must be connected to a remote
@@ -114,7 +146,16 @@ sendBuf s str len = fromIntegral <$> do
114146
recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)
115147
recvBufFrom s ptr nbytes
116148
| nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom")
117-
| otherwise = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len ->
149+
| otherwise =
150+
##if __IO_MANAGER_WINIO__ >= 2
151+
recvBufFromImpl s ptr nbytes <!> recvBufFromWinIO s ptr nbytes
152+
##else
153+
recvBufFromImpl s ptr nbytes
154+
##endif
155+
156+
recvBufFromImpl :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)
157+
recvBufFromImpl s ptr nbytes =
158+
withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len ->
118159
withFdSocket s $ \fd -> do
119160
poke ptr_len (fromIntegral sz)
120161
let cnbytes = fromIntegral nbytes
@@ -125,6 +166,50 @@ recvBufFrom s ptr nbytes
125166
`catchIOError` \_ -> getPeerName s
126167
return (fromIntegral len, sockaddr)
127168

169+
##if __IO_MANAGER_WINIO__ >= 2
170+
recvBufFromWinIO :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)
171+
recvBufFromWinIO s ptr nbytes =
172+
withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len ->
173+
withFdSocket s $ \sock -> do
174+
poke ptr_len (fromIntegral sz)
175+
len <- fmap fromIntegral $ Mgr.withException "recvBufFrom" $
176+
Mgr.withOverlapped "recvBufFrom" (wordPtrToPtr $ fromIntegral sock) 0
177+
(startCB sock ptr_sa ptr_len) completionCB
178+
sockaddr <- peekSocketAddress ptr_sa
179+
`catchIOError` \_ -> getPeerName s
180+
return (len, sockaddr)
181+
where
182+
startCB :: CSocket -> Ptr sa -> Ptr CInt -> Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
183+
startCB sock ptr_sa ptr_len lpOverlapped = do
184+
alloca $ \flags -> do
185+
poke flags 0
186+
with (WSABuf (castPtr ptr) (fromIntegral nbytes)) $ \pWsaBuf -> do
187+
ret <- c_WSARecvFrom sock pWsaBuf 1 nullPtr flags ptr_sa ptr_len (castPtr lpOverlapped) nullPtr
188+
-- Check WSAGetLastError immediately: if the operation didn't
189+
-- complete synchronously (ret /= 0), we must distinguish
190+
-- ERROR_IO_PENDING (async completion forthcoming) from real
191+
-- errors (no IOCP notification will arrive, so CbPending
192+
-- would hang forever).
193+
err <- c_WSAGetLastError
194+
if ret == 0
195+
then return $ Mgr.CbDone Nothing
196+
else if err == _ERROR_IO_PENDING
197+
then return Mgr.CbPending
198+
else return $ Mgr.CbError (fromIntegral err)
199+
200+
completionCB err dwBytes
201+
| err == _ERROR_SUCCESS = Mgr.ioSuccess $ fromIntegral dwBytes
202+
| err == _WSAECONNABORTED = Mgr.ioSuccess 0
203+
| err == _WSAECONNRESET = Mgr.ioSuccess 0
204+
| err == _WSAEDISCON = Mgr.ioSuccess 0
205+
| err == _ERROR_HANDLE_EOF = Mgr.ioSuccess 0
206+
| err == _ERROR_BROKEN_PIPE = Mgr.ioSuccess 0
207+
| err == _ERROR_NO_MORE_ITEMS = Mgr.ioSuccess 0
208+
| err == _ERROR_OPERATION_ABORTED = Mgr.ioSuccess 0
209+
| err == _ERROR_IO_INCOMPLETE = Mgr.ioSuccess 0
210+
| otherwise = Mgr.ioFailed err
211+
##endif /* __IO_MANAGER_WINIO__ */
212+
128213
-- | Receive data from the socket. The socket must be in a connected
129214
-- state. This function may return fewer bytes than specified. If the
130215
-- message is longer than the specified length, it may be discarded
@@ -142,18 +227,68 @@ recvBuf s ptr nbytes
142227
| nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf")
143228
| otherwise = do
144229
#if defined(mingw32_HOST_OS)
145-
-- see comment in sendBuf above.
146-
fd <- socket2FD s
147-
let cnbytes = fromIntegral nbytes
148-
len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $
149-
readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes
230+
## if __IO_MANAGER_WINIO__ >= 2
231+
recvBufMIO s ptr nbytes <!> recvBufWinIO s ptr nbytes
232+
## else
233+
recvBufMIO s ptr nbytes
234+
## endif
150235
#else
151236
len <- withFdSocket s $ \fd ->
152237
throwSocketErrorWaitRead s "Network.Socket.recvBuf" $
153238
c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-}
239+
return $ fromIntegral len
154240
#endif
241+
242+
#if defined(mingw32_HOST_OS)
243+
-- MIO (old I/O manager) implementation
244+
recvBufMIO :: Socket -> Ptr Word8 -> Int -> IO Int
245+
recvBufMIO s ptr nbytes = do
246+
-- see comment in sendBuf above.
247+
fd <- socket2FD s
248+
let cnbytes = fromIntegral nbytes
249+
len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $
250+
readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes
155251
return $ fromIntegral len
156252

253+
## if __IO_MANAGER_WINIO__ >= 2
254+
recvBufWinIO :: Socket -> Ptr Word8 -> Int -> IO Int
255+
recvBufWinIO s ptr nbytes = withFdSocket s $ \sock ->
256+
fmap fromIntegral $ Mgr.withException "recvBuf" $
257+
Mgr.withOverlapped "recvBuf" (wordPtrToPtr $ fromIntegral sock) 0 (startCB sock) completionCB
258+
where
259+
startCB :: CSocket -> Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
260+
startCB sock lpOverlapped = do
261+
alloca $ \flags -> do
262+
poke flags 0
263+
with (WSABuf (castPtr ptr) (fromIntegral nbytes)) $ \pWsaBuf -> do
264+
ret <- c_WSARecv sock pWsaBuf 1 nullPtr flags (castPtr lpOverlapped) nullPtr
265+
-- Check WSAGetLastError immediately: if the operation didn't
266+
-- complete synchronously (ret /= 0), we must distinguish
267+
-- ERROR_IO_PENDING (async completion forthcoming) from real
268+
-- errors (no IOCP notification will arrive, so CbPending
269+
-- would hang forever).
270+
err <- c_WSAGetLastError
271+
if ret == 0
272+
then return $ Mgr.CbDone Nothing
273+
else if err == _ERROR_IO_PENDING
274+
then return Mgr.CbPending
275+
else return $ Mgr.CbError (fromIntegral err)
276+
277+
-- https://learn.microsoft.com/en-us/windows/win32/api/winsock2/nf-winsock2-wsarecv#return-value
278+
completionCB err dwBytes
279+
| err == _ERROR_SUCCESS = Mgr.ioSuccess $ fromIntegral dwBytes
280+
| err == _WSAECONNABORTED = Mgr.ioSuccess 0
281+
| err == _WSAECONNRESET = Mgr.ioSuccess 0
282+
| err == _WSAEDISCON = Mgr.ioSuccess 0
283+
| err == _ERROR_HANDLE_EOF = Mgr.ioSuccess 0
284+
| err == _ERROR_BROKEN_PIPE = Mgr.ioSuccess 0
285+
| err == _ERROR_NO_MORE_ITEMS = Mgr.ioSuccess 0
286+
| err == _ERROR_OPERATION_ABORTED = Mgr.ioSuccess 0
287+
| err == _ERROR_IO_INCOMPLETE = Mgr.ioSuccess 0
288+
| otherwise = Mgr.ioFailed err
289+
## endif /* __IO_MANAGER_WINIO__ */
290+
#endif /* mingw32_HOST_OS */
291+
157292
-- | Receive data from the socket. This function returns immediately
158293
-- even if data is not available. In other words, IO manager is NOT
159294
-- involved. The length of data is returned if received.
@@ -280,45 +415,107 @@ recvBufMsg s bufsizs clen flags = do
280415
_cflags = fromMsgFlag flags
281416
withFdSocket s $ \fd -> do
282417
with msgHdr $ \msgHdrPtr -> do
283-
len <- (fmap fromIntegral) <$>
418+
len <-
284419
#if !defined(mingw32_HOST_OS)
420+
fmap fromIntegral <$>
285421
throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmsg" $
286422
c_recvmsg fd msgHdrPtr _cflags
287423
#else
288-
alloca $ \len_ptr -> do
289-
_ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmsg" $
290-
c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
291-
peek len_ptr
424+
## if __IO_MANAGER_WINIO__ >= 2
425+
recvBufMsgMIO fd msgHdrPtr <!> recvBufMsgWinIO fd msgHdrPtr
426+
## else
427+
recvBufMsgMIO fd msgHdrPtr
428+
## endif
292429
#endif
293430
sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s
294431
hdr <- peek msgHdrPtr
432+
433+
#if !defined(mingw32_HOST_OS)
295434
cmsgs <- parseCmsgs msgHdrPtr
296435
let flags' = MsgFlag $ fromIntegral $ msgFlags hdr
436+
#else
437+
let flags' = MsgFlag $ fromIntegral (msgFlags hdr)
438+
-- If the control buffer was truncated (MSG_CTRUNC), the
439+
-- control data may be invalid and parsing could segfault.
440+
cmsgs <- if msgCtrl hdr == nullPtr || (msgFlags hdr .&. #{const MSG_CTRUNC}) /= 0
441+
then return []
442+
else parseCmsgs msgHdrPtr
443+
#endif
444+
297445
return (sockaddr, len, cmsgs, flags')
298446

299447
#if !defined(mingw32_HOST_OS)
300448
foreign import ccall unsafe "send"
301-
c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt
449+
c_send :: CSocket -> Ptr a -> CSize -> CInt -> IO CInt
302450
foreign import ccall unsafe "sendmsg"
303-
c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize
451+
c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize
304452
foreign import ccall unsafe "recvmsg"
305-
c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt
453+
c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt
306454
#else
307455
foreign import CALLCONV SAFE_ON_WIN "ioctlsocket"
308-
c_ioctlsocket :: CInt -> CLong -> Ptr CULong -> IO CInt
456+
c_ioctlsocket :: CSocket -> CLong -> Ptr CULong -> IO CInt
309457
foreign import CALLCONV SAFE_ON_WIN "WSAGetLastError"
310458
c_WSAGetLastError :: IO CInt
311459
foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"
312460
-- fixme Handle for SOCKET, see #426
313-
c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
461+
c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
314462
foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
315-
c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
316-
#endif
463+
c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
464+
foreign import CALLCONV unsafe "WSARecv"
465+
c_WSARecv :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
466+
foreign import CALLCONV unsafe "WSARecvFrom"
467+
c_WSARecvFrom :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> LPDWORD -> Ptr sa -> Ptr CInt -> Ptr () -> Ptr () -> IO CInt
468+
469+
-- Helper functions for recvBufMsg on Windows
470+
recvBufMsgMIO :: CSocket -> Ptr (MsgHdr sa) -> IO Int
471+
recvBufMsgMIO fd msgHdrPtr = alloca $ \len_ptr -> do
472+
_ <- throwSocketErrorIfMinus1Retry "Network.Socket.Buffer.recvmsg" $
473+
c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
474+
fromIntegral <$> peek len_ptr
475+
476+
## if __IO_MANAGER_WINIO__ >= 2
477+
recvBufMsgWinIO :: CSocket -> Ptr (MsgHdr sa) -> IO Int
478+
recvBufMsgWinIO fd msgHdrPtr = do
479+
-- Perform async WSARecvMsg using withOverlapped
480+
-- (socket already associated in socket creation)
481+
fmap fromIntegral $ Mgr.withException "recvMsg" $
482+
Mgr.withOverlapped "recvMsg" (wordPtrToPtr $ fromIntegral fd) 0 startCB completionCB
483+
where
484+
startCB :: Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
485+
startCB lpOverlapped = do
486+
ret <- c_recvmsg fd msgHdrPtr nullPtr (castPtr lpOverlapped) nullPtr
487+
-- Check WSAGetLastError immediately: if the operation didn't
488+
-- complete synchronously (ret /= 0), we must distinguish
489+
-- ERROR_IO_PENDING (async completion forthcoming) from real
490+
-- errors (no IOCP notification will arrive, so CbPending
491+
-- would hang forever).
492+
err <- c_WSAGetLastError
493+
if ret == 0
494+
then return $ Mgr.CbDone Nothing
495+
else if err == _ERROR_IO_PENDING
496+
then return Mgr.CbPending
497+
else return $ Mgr.CbError (fromIntegral err)
498+
499+
completionCB err dwBytes
500+
| err == _ERROR_SUCCESS = Mgr.ioSuccess $ fromIntegral dwBytes
501+
| err == _WSAEMSGSIZE = Mgr.ioSuccess $ fromIntegral dwBytes
502+
| err == _STATUS_BUFFER_OVERFLOW = Mgr.ioSuccess $ fromIntegral dwBytes -- truncated msg
503+
| err == _WSAECONNRESET = Mgr.ioSuccess 0
504+
| err == _WSAECONNABORTED = Mgr.ioSuccess 0
505+
| err == _WSAESHUTDOWN = Mgr.ioSuccess 0
506+
| err == _WSAEDISCON = Mgr.ioSuccess 0
507+
| err == _ERROR_HANDLE_EOF = Mgr.ioSuccess 0
508+
| err == _ERROR_BROKEN_PIPE = Mgr.ioSuccess 0
509+
| err == _ERROR_NO_MORE_ITEMS = Mgr.ioSuccess 0
510+
| err == _ERROR_OPERATION_ABORTED = Mgr.ioSuccess 0
511+
| err == _ERROR_IO_INCOMPLETE = Mgr.ioSuccess 0
512+
| otherwise = Mgr.ioFailed err
513+
## endif /* __IO_MANAGER_WINIO__ */
514+
#endif /* mingw32_HOST_OS */
317515

318516
foreign import ccall unsafe "recv"
319-
c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
517+
c_recv :: CSocket -> Ptr CChar -> CSize -> CInt -> IO CInt
320518
foreign import CALLCONV SAFE_ON_WIN "sendto"
321-
c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt
519+
c_sendto :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt
322520
foreign import CALLCONV SAFE_ON_WIN "recvfrom"
323-
c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt
324-
521+
c_recvfrom :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt

Network/Socket/ByteString/Internal.hs

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -53,19 +53,19 @@ mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError
5353

5454
#if !defined(mingw32_HOST_OS)
5555
foreign import ccall unsafe "writev"
56-
c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize
56+
c_writev :: CSocket -> Ptr IOVec -> CInt -> IO CSsize
5757

5858
foreign import ccall unsafe "sendmsg"
59-
c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
59+
c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
6060

6161
foreign import ccall unsafe "recvmsg"
62-
c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
62+
c_recvmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
6363
#else
6464
-- fixme Handle for SOCKET, see #426
6565
foreign import CALLCONV SAFE_ON_WIN "WSASend"
66-
c_wsasend :: CInt -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
66+
c_wsasend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
6767
foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"
68-
c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
68+
c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
6969
foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
70-
c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
70+
c_recvmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
7171
#endif

0 commit comments

Comments
 (0)