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
812module Network.Socket.Buffer (
@@ -30,6 +34,11 @@ import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)
3034import Network.Socket.Win32.CmsgHdr
3135import Network.Socket.Win32.MsgHdr
3236import 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
3443import Network.Socket.Posix.CmsgHdr
3544import Network.Socket.Posix.MsgHdr
@@ -45,6 +54,28 @@ import Network.Socket.Flag
4554#if defined(mingw32_HOST_OS)
4655type DWORD = Word32
4756type 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
71102socket2FD 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
114146recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int , sa )
115147recvBufFrom 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)
300448foreign import ccall unsafe " send"
301- c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt
449+ c_send :: CSocket -> Ptr a -> CSize -> CInt -> IO CInt
302450foreign 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
304452foreign 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
307455foreign import CALLCONV SAFE_ON_WIN " ioctlsocket"
308- c_ioctlsocket :: CInt -> CLong -> Ptr CULong -> IO CInt
456+ c_ioctlsocket :: CSocket -> CLong -> Ptr CULong -> IO CInt
309457foreign import CALLCONV SAFE_ON_WIN " WSAGetLastError"
310458 c_WSAGetLastError :: IO CInt
311459foreign 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
314462foreign 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
318516foreign import ccall unsafe " recv"
319- c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
517+ c_recv :: CSocket -> Ptr CChar -> CSize -> CInt -> IO CInt
320518foreign 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
322520foreign 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
0 commit comments