WinIO work

CHANGELOG.md

@@ -1,5 +1,10 @@
 # CHANGELOG for network
 
+## Version 3.3.0.0
+
+* Basic support for WINIO
+  [#509](https://github.com/haskell/network/pull/509)
+
 ## Version 3.2.8.0
 
 * sockopt: add IP_DONTFRAG/IP_MTU_DISCOVER option.

Network/Socket/Buffer.hsc

@@ -1,8 +1,12 @@
 {-# LANGUAGE CPP #-}
+{-# 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 (
@@ -30,6 +34,11 @@ import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)
 import Network.Socket.Win32.CmsgHdr
 import Network.Socket.Win32.MsgHdr
 import Network.Socket.Win32.WSABuf
+# if defined(HAS_WINIO)
+import qualified GHC.Event.Windows as Mgr
+import GHC.IO.SubSystem ((<!>))
+import Foreign.Ptr (wordPtrToPtr)
+# endif
 #else
 import Network.Socket.Posix.CmsgHdr
 import Network.Socket.Posix.MsgHdr
@@ -71,7 +80,8 @@ socket2FD :: Socket -> IO FD
 socket2FD s = do
   fd <- unsafeFdSocket s
   -- HACK, 1 means True
-  return $ FD{ fdFD = fd, fdIsSocket_ = 1 }
+  -- TODO: remove fromIntegral for WinIO
+  return $ FD{ fdFD = fromIntegral fd, fdIsSocket_ = 1 }
 #endif
 
 -- | Send data to the socket. The socket must be connected to a remote
@@ -114,7 +124,31 @@ sendBuf s str len = fromIntegral <$> do
 recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)
 recvBufFrom s ptr nbytes
     | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom")
-    | otherwise = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len ->
+    | otherwise   = do
+#if defined(mingw32_HOST_OS)
+# if defined(HAS_WINIO)
+        recvBufFromMIO s ptr nbytes <!> recvBufFromWinIO s ptr nbytes
+# else
+        recvBufFromMIO s ptr nbytes
+# endif
+#else
+        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)
+-- MIO (old I/O manager) implementation
+recvBufFromMIO :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)
+recvBufFromMIO s ptr nbytes =
+    withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len ->
         withFdSocket s $ \fd -> do
             poke ptr_len (fromIntegral sz)
             let cnbytes = fromIntegral nbytes
@@ -125,6 +159,51 @@ recvBufFrom s ptr nbytes
                 `catchIOError` \_ -> getPeerName s
             return (fromIntegral len, sockaddr)
 
+# if defined(HAS_WINIO)
+recvBufFromWinIO :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)
+recvBufFromWinIO s ptr nbytes =
+    withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len ->
+        withFdSocket s $ \sock -> do
+            poke ptr_len (fromIntegral sz)
+            len <- fmap fromIntegral $ Mgr.withException "recvBufFrom" $
+                Mgr.withOverlapped "recvBufFrom" (wordPtrToPtr $ fromIntegral sock) 0
+                    (startCB sock ptr_sa ptr_len) completionCB
+            sockaddr <- peekSocketAddress ptr_sa
+                `catchIOError` \_ -> getPeerName s
+            return (len, sockaddr)
+  where
+    startCB :: CSocket -> Ptr sa -> Ptr CInt -> Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
+    startCB sock ptr_sa ptr_len lpOverlapped = do
+        alloca $ \flags -> do
+            poke flags 0
+            with (WSABuf (castPtr ptr) (fromIntegral nbytes)) $ \pWsaBuf -> do
+                ret <- c_WSARecvFrom sock pWsaBuf 1 nullPtr flags ptr_sa ptr_len (castPtr lpOverlapped) nullPtr
+                -- Check WSAGetLastError immediately: if the operation didn't
+                -- complete synchronously (ret /= 0), we must distinguish
+                -- ERROR_IO_PENDING (async completion forthcoming) from real
+                -- errors (no IOCP notification will arrive, so CbPending
+                -- would hang forever).
+                err <- c_WSAGetLastError
+                if ret == 0
+                    then return $ Mgr.CbDone Nothing
+                    else if err == #{const ERROR_IO_PENDING}
+                        then return Mgr.CbPending
+                        else return $ Mgr.CbError (fromIntegral err)
+
+    completionCB err dwBytes
+        | err == #{const ERROR_SUCCESS}           = Mgr.ioSuccess $ fromIntegral dwBytes
+        | err == #{const WSAECONNABORTED}         = Mgr.ioSuccess 0
+        | err == #{const WSAECONNRESET}           = Mgr.ioSuccess 0
+        | err == #{const WSAEDISCON}              = Mgr.ioSuccess 0
+        | err == #{const ERROR_HANDLE_EOF}        = Mgr.ioSuccess 0
+        | err == #{const ERROR_BROKEN_PIPE}       = Mgr.ioSuccess 0
+        | err == #{const ERROR_NO_MORE_ITEMS}     = Mgr.ioSuccess 0
+        | err == #{const ERROR_OPERATION_ABORTED} = Mgr.ioSuccess 0
+        | err == #{const ERROR_IO_INCOMPLETE}     = Mgr.ioSuccess 0
+        | otherwise                               = Mgr.ioFailed err
+# endif /* HAS_WINIO */
+#endif /* mingw32_HOST_OS */
+
 -- | 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
@@ -142,18 +221,68 @@ recvBuf s ptr nbytes
  | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf")
  | otherwise   = do
 #if defined(mingw32_HOST_OS)
--- see comment in sendBuf above.
-    fd <- socket2FD s
-    let cnbytes = fromIntegral nbytes
-    len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $
-             readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes
+# if defined(HAS_WINIO)
+    recvBufMIO s ptr nbytes <!> recvBufWinIO s ptr nbytes
+# else
+    recvBufMIO s ptr nbytes
+# endif
 #else
     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)
+-- MIO (old I/O manager) implementation
+recvBufMIO :: Socket -> Ptr Word8 -> Int -> IO Int
+recvBufMIO s ptr nbytes = do
+    -- see comment in sendBuf above.
+    fd <- socket2FD s
+    let cnbytes = fromIntegral nbytes
+    len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $
+             readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes
     return $ fromIntegral len
 
+# if defined(HAS_WINIO)
+recvBufWinIO :: Socket -> Ptr Word8 -> Int -> IO Int
+recvBufWinIO s ptr nbytes = withFdSocket s $ \sock ->
+    fmap fromIntegral $ Mgr.withException "recvBuf" $
+        Mgr.withOverlapped "recvBuf" (wordPtrToPtr $ fromIntegral sock) 0 (startCB sock) completionCB
+  where
+    startCB :: CSocket -> Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
+    startCB sock lpOverlapped = do
+        alloca $ \flags -> do
+            poke flags 0
+            with (WSABuf (castPtr ptr) (fromIntegral nbytes)) $ \pWsaBuf -> do
+                ret <- c_WSARecv sock pWsaBuf 1 nullPtr flags (castPtr lpOverlapped) nullPtr
+                -- Check WSAGetLastError immediately: if the operation didn't
+                -- complete synchronously (ret /= 0), we must distinguish
+                -- ERROR_IO_PENDING (async completion forthcoming) from real
+                -- errors (no IOCP notification will arrive, so CbPending
+                -- would hang forever).
+                err <- c_WSAGetLastError
+                if ret == 0
+                    then return $ Mgr.CbDone Nothing
+                    else if err == #{const ERROR_IO_PENDING}
+                        then return Mgr.CbPending
+                        else return $ Mgr.CbError (fromIntegral err)
+
+    -- https://learn.microsoft.com/en-us/windows/win32/api/winsock2/nf-winsock2-wsarecv#return-value
+    completionCB err dwBytes
+        | err == #{const ERROR_SUCCESS}           = Mgr.ioSuccess $ fromIntegral dwBytes
+        | err == #{const WSAECONNABORTED}         = Mgr.ioSuccess 0
+        | err == #{const WSAECONNRESET}           = Mgr.ioSuccess 0
+        | err == #{const WSAEDISCON}              = Mgr.ioSuccess 0
+        | err == #{const ERROR_HANDLE_EOF}        = Mgr.ioSuccess 0
+        | err == #{const ERROR_BROKEN_PIPE}       = Mgr.ioSuccess 0
+        | err == #{const ERROR_NO_MORE_ITEMS}     = Mgr.ioSuccess 0
+        | err == #{const ERROR_OPERATION_ABORTED} = Mgr.ioSuccess 0
+        | err == #{const ERROR_IO_INCOMPLETE}     = Mgr.ioSuccess 0
+        | otherwise                               = Mgr.ioFailed err
+# endif /* HAS_WINIO */
+#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.
@@ -280,45 +409,101 @@ recvBufMsg s bufsizs clen flags = do
             _cflags = fromMsgFlag flags
         withFdSocket s $ \fd -> do
           with msgHdr $ \msgHdrPtr -> do
-            len <- (fmap fromIntegral) <$>
+            len <-
 #if !defined(mingw32_HOST_OS)
+                fmap fromIntegral <$>
                 throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmsg" $
                       c_recvmsg fd msgHdrPtr _cflags
 #else
-                alloca $ \len_ptr -> do
-                    _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmsg" $
-                            c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
-                    peek len_ptr
+# if defined(HAS_WINIO)
+                (recvBufMsgMIO fd msgHdrPtr <!> recvBufMsgWinIO fd msgHdrPtr)
+# else
+                recvBufMsgMIO fd msgHdrPtr
+# endif
 #endif
             sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s
             hdr <- peek msgHdrPtr
-            cmsgs <- parseCmsgs msgHdrPtr
-            let flags' = MsgFlag $ fromIntegral $ msgFlags hdr
+            let rawFlags = msgFlags hdr
+                flags' = MsgFlag $ fromIntegral rawFlags
+            -- If the control buffer was truncated (MSG_CTRUNC), the
+            -- control data may be invalid and parsing could segfault.
+            cmsgs <- if msgCtrl hdr == nullPtr || (rawFlags .&. #{const MSG_CTRUNC}) /= 0
+                        then return []
+                        else parseCmsgs msgHdrPtr
             return (sockaddr, len, cmsgs, flags')
 
 #if !defined(mingw32_HOST_OS)
 foreign import ccall unsafe "send"
-  c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt
+  c_send :: CSocket -> Ptr a -> CSize -> CInt -> IO CInt
 foreign import ccall unsafe "sendmsg"
-  c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize
+  c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt -- fixme CSsize
 foreign import ccall unsafe "recvmsg"
-  c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> CInt -> IO CInt
+  c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt
 #else
 foreign import CALLCONV SAFE_ON_WIN "ioctlsocket"
-  c_ioctlsocket :: CInt -> CLong -> Ptr CULong -> IO CInt
+  c_ioctlsocket :: CSocket -> CLong -> Ptr CULong -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "WSAGetLastError"
   c_WSAGetLastError :: IO CInt
 foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"
   -- fixme Handle for SOCKET, see #426
-  c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
+  c_sendmsg :: CSocket -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
-  c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
-#endif
+  c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
+foreign import CALLCONV unsafe "WSARecv"
+  c_WSARecv :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
+foreign import CALLCONV unsafe "WSARecvFrom"
+  c_WSARecvFrom :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> LPDWORD -> Ptr sa -> Ptr CInt -> Ptr () -> Ptr () -> IO CInt
+
+-- Helper functions for recvBufMsg on Windows
+recvBufMsgMIO :: CSocket -> Ptr (MsgHdr sa) -> IO Int
+recvBufMsgMIO fd msgHdrPtr = alloca $ \len_ptr -> do
+    _ <- throwSocketErrorIfMinus1Retry "Network.Socket.Buffer.recvmsg" $
+            c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
+    fromIntegral <$> peek len_ptr
+
+# if defined(HAS_WINIO)
+recvBufMsgWinIO :: CSocket -> Ptr (MsgHdr sa) -> IO Int
+recvBufMsgWinIO fd msgHdrPtr = do
+    -- Perform async WSARecvMsg using withOverlapped
+    -- (socket already associated in socket creation)
+    fmap fromIntegral $ Mgr.withException "recvMsg" $
+      Mgr.withOverlapped "recvMsg" (wordPtrToPtr $ fromIntegral fd) 0 startCB completionCB
+  where
+    startCB :: Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
+    startCB lpOverlapped = do
+        ret <- c_recvmsg fd msgHdrPtr nullPtr (castPtr lpOverlapped) nullPtr
+        -- Check WSAGetLastError immediately: if the operation didn't
+        -- complete synchronously (ret /= 0), we must distinguish
+        -- ERROR_IO_PENDING (async completion forthcoming) from real
+        -- errors (no IOCP notification will arrive, so CbPending
+        -- would hang forever).
+        err <- c_WSAGetLastError
+        if ret == 0
+            then return $ Mgr.CbDone Nothing
+            else if err == #{const ERROR_IO_PENDING}
+                then return Mgr.CbPending
+                else return $ Mgr.CbError (fromIntegral err)
+
+    completionCB err dwBytes
+      | err == #{const ERROR_SUCCESS}           = Mgr.ioSuccess $ fromIntegral dwBytes
+      | err == #{const WSAEMSGSIZE}             = Mgr.ioSuccess $ fromIntegral dwBytes
+      | err == #{const STATUS_BUFFER_OVERFLOW}   = Mgr.ioSuccess $ fromIntegral dwBytes  -- truncated msg
+      | err == #{const WSAECONNRESET}           = Mgr.ioSuccess 0
+      | err == #{const WSAECONNABORTED}         = Mgr.ioSuccess 0
+      | err == #{const WSAESHUTDOWN}            = Mgr.ioSuccess 0
+      | err == #{const WSAEDISCON}              = Mgr.ioSuccess 0
+      | err == #{const ERROR_HANDLE_EOF}        = Mgr.ioSuccess 0
+      | err == #{const ERROR_BROKEN_PIPE}       = Mgr.ioSuccess 0
+      | err == #{const ERROR_NO_MORE_ITEMS}     = Mgr.ioSuccess 0
+      | err == #{const ERROR_OPERATION_ABORTED} = Mgr.ioSuccess 0
+      | err == #{const ERROR_IO_INCOMPLETE}     = Mgr.ioSuccess 0
+      | otherwise                               = Mgr.ioFailed err
+# endif /* HAS_WINIO */
+#endif /* mingw32_HOST_OS */
 
 foreign import ccall unsafe "recv"
-  c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt
+  c_recv :: CSocket -> Ptr CChar -> CSize -> CInt -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "sendto"
-  c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt
+  c_sendto :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "recvfrom"
-  c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt
-
+  c_recvfrom :: CSocket -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt

Network/Socket/ByteString/Internal.hs

@@ -53,19 +53,19 @@ mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError
 
 #if !defined(mingw32_HOST_OS)
 foreign import ccall unsafe "writev"
-  c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize
+  c_writev :: CSocket -> Ptr IOVec -> CInt -> IO CSsize
 
 foreign import ccall unsafe "sendmsg"
-  c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
+  c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
 
 foreign import ccall unsafe "recvmsg"
-  c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
+  c_recvmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> CInt -> IO CSsize
 #else
   -- fixme Handle for SOCKET, see #426
 foreign import CALLCONV SAFE_ON_WIN "WSASend"
-  c_wsasend :: CInt -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
+  c_wsasend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"
-  c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
+  c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
-  c_recvmsg :: CInt -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
+  c_recvmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
 #endif