Winio

.github/workflows/haskell.yml

@@ -67,7 +67,7 @@ jobs:
       fail-fast: false
       matrix:
         os:  [ 'ubuntu-latest', 'macOS-latest', 'windows-latest' ]
-        ghc: [ '8.10', '9.0', '9.2', '9.4', '9.6' ]
+        ghc: [ '9.0', '9.2', '9.4', '9.6' ]
 
     steps:
     - uses: actions/checkout@v3

CHANGELOG.md

@@ -1,3 +1,8 @@
+## Version 3.2.0.0
+
+* Basic support for WINIO
+  [#509](https://github.com/haskell/network/pull/509)
+
 ## Version 3.1.4.0
 
 * Install and use afunix_compat.h header.

Network/Socket/Buffer.hsc

@@ -71,7 +71,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
@@ -298,27 +299,27 @@ recvBufMsg s bufsizs clen flags = do
 
 #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
+  c_recvmsg :: CSocket -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
 #endif
 
 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

Network/Socket/Fcntl.hs

@@ -2,6 +2,7 @@
 
 module Network.Socket.Fcntl where
 
+import Network.Socket.Types
 import qualified System.Posix.Internals
 
 #if !defined(mingw32_HOST_OS)
@@ -11,15 +12,16 @@ import Network.Socket.Imports
 
 -- | Set the nonblocking flag on Unix.
 --   On Windows, nothing is done.
-setNonBlockIfNeeded :: CInt -> IO ()
+setNonBlockIfNeeded :: CSocket -> IO ()
 setNonBlockIfNeeded fd =
-    System.Posix.Internals.setNonBlockingFD fd True
+    System.Posix.Internals.setNonBlockingFD (fromIntegral fd) True
+-- TODO: remove fromIntegral for WinIO
 
 -- | Set the close_on_exec flag on Unix.
 --   On Windows, nothing is done.
 --
 --   Since 2.7.0.0.
-setCloseOnExecIfNeeded :: CInt -> IO ()
+setCloseOnExecIfNeeded :: CSocket -> IO ()
 #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
 setCloseOnExecIfNeeded _ = return ()
 #else
@@ -28,14 +30,14 @@ setCloseOnExecIfNeeded fd = System.Posix.Internals.setCloseOnExec fd
 
 #if !defined(mingw32_HOST_OS)
 foreign import ccall unsafe "fcntl"
-  c_fcntl_read  :: CInt -> CInt -> CInt -> IO CInt
+  c_fcntl_read  :: CSocket -> CInt -> CInt -> IO CInt
 #endif
 
 -- | Get the close_on_exec flag.
 --   On Windows, this function always returns 'False'.
 --
 --   Since 2.7.0.0.
-getCloseOnExec :: CInt -> IO Bool
+getCloseOnExec :: CSocket -> IO Bool
 #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
 getCloseOnExec _ = return False
 #else
@@ -49,8 +51,9 @@ getCloseOnExec fd = do
 --   On Windows, this function always returns 'False'.
 --
 --   Since 2.7.0.0.
-getNonBlock :: CInt -> IO Bool
+getNonBlock :: CSocket -> IO Bool
 #if defined(mingw32_HOST_OS)
+-- | TODO: Query socket for async flag
 getNonBlock _ = return False
 #else
 getNonBlock fd = do

Network/Socket/Handle.hs

@@ -20,9 +20,11 @@ import Network.Socket.Types
 -- cooperate with peer's 'gracefulClose', i.e. proper shutdown
 -- sequence with appropriate handshakes specified by the protocol.
 
+-- TODO: WinIO doesn't use fd, add support
+--       Need to remove fromIntegral.
 socketToHandle :: Socket -> IOMode -> IO Handle
 socketToHandle s mode = invalidateSocket s err $ \oldfd -> do
-    h <- fdToHandle' oldfd (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-}
+    h <- fdToHandle' (fromIntegral oldfd) (Just GHC.IO.Device.Stream) True (show s) mode True{-bin-}
     hSetBuffering h NoBuffering
     return h
   where

Network/Socket/Name.hs

@@ -35,9 +35,9 @@ getSocketName s =
      peekSocketAddress ptr
 
 foreign import CALLCONV unsafe "getpeername"
-  c_getpeername :: CInt -> Ptr sa -> Ptr CInt -> IO CInt
+  c_getpeername :: CSocket -> Ptr sa -> Ptr CInt -> IO CInt
 foreign import CALLCONV unsafe "getsockname"
-  c_getsockname :: CInt -> Ptr sa -> Ptr CInt -> IO CInt
+  c_getsockname :: CSocket -> Ptr sa -> Ptr CInt -> IO CInt
 
 -- ---------------------------------------------------------------------------
 -- socketPort

Network/Socket/Options.hsc

@@ -511,6 +511,6 @@ instance Storable SocketTimeout where
 ----------------------------------------------------------------
 
 foreign import CALLCONV unsafe "getsockopt"
-  c_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt
+  c_getsockopt :: CSocket -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt
 foreign import CALLCONV unsafe "setsockopt"
-  c_setsockopt :: CInt -> CInt -> CInt -> Ptr a -> CInt -> IO CInt
+  c_setsockopt :: CSocket -> CInt -> CInt -> Ptr a -> CInt -> IO CInt

Network/Socket/Shutdown.hs

@@ -38,7 +38,7 @@ shutdown s stype = void $ withFdSocket s $ \fd ->
     c_shutdown fd $ sdownCmdToInt stype
 
 foreign import CALLCONV unsafe "shutdown"
-  c_shutdown :: CInt -> CInt -> IO CInt
+  c_shutdown :: CSocket -> CInt -> IO CInt
 
 -- | Closing a socket gracefully.
 --   This sends TCP FIN and check if TCP FIN is received from the peer.

Network/Socket/Syscall.hs

@@ -223,31 +223,31 @@ accept listing_sock = withNewSocketAddress $ \new_sa sz ->
 #endif
 
 foreign import CALLCONV unsafe "socket"
-  c_socket :: CInt -> CInt -> CInt -> IO CInt
+  c_socket :: CInt -> CInt -> CInt -> IO CSocket
 foreign import CALLCONV unsafe "bind"
-  c_bind :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt
+  c_bind :: CSocket -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt
 foreign import CALLCONV SAFE_ON_WIN "connect"
-  c_connect :: CInt -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt
+  c_connect :: CSocket -> Ptr sa -> CInt{-CSockLen???-} -> IO CInt
 foreign import CALLCONV unsafe "listen"
-  c_listen :: CInt -> CInt -> IO CInt
+  c_listen :: CSocket -> CInt -> IO CInt
 
 #ifdef HAVE_ADVANCED_SOCKET_FLAGS
 foreign import CALLCONV unsafe "accept4"
-  c_accept4 :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> CInt -> IO CInt
+  c_accept4 :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> CInt -> IO CSocket
 #else
 foreign import CALLCONV unsafe "accept"
-  c_accept :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt
+  c_accept :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CSocket
 #endif
 
 #if defined(mingw32_HOST_OS)
 foreign import CALLCONV safe "accept"
-  c_accept_safe :: CInt -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CInt
+  c_accept_safe :: CSocket -> Ptr sa -> Ptr CInt{-CSockLen???-} -> IO CSocket
 foreign import ccall unsafe "rtsSupportsBoundThreads"
   threaded :: Bool
 foreign import ccall unsafe "HsNet.h acceptNewSock"
-  c_acceptNewSock :: Ptr () -> IO CInt
+  c_acceptNewSock :: Ptr () -> IO CSocket
 foreign import ccall unsafe "HsNet.h newAcceptParams"
-  c_newAcceptParams :: CInt -> CInt -> Ptr a -> IO (Ptr ())
+  c_newAcceptParams :: CSocket -> CInt -> Ptr a -> IO (Ptr ())
 foreign import ccall unsafe "HsNet.h &acceptDoProc"
   c_acceptDoProc :: FunPtr (Ptr () -> IO Int)
 foreign import ccall unsafe "free"

Network/Socket/Types.hsc

@@ -14,6 +14,7 @@
 module Network.Socket.Types (
     -- * Socket type
       Socket
+    , CSocket
     , withFdSocket
     , unsafeFdSocket
     , touchSocket
@@ -103,8 +104,14 @@ import Network.Socket.ReadShow
 
 -----------------------------------------------------------------------------
 
+#if defined(mingw32_HOST_OS)
+type CSocket = CULong
+#else
+type CSocket = CInt
+#endif
+
 -- | Basic type for a socket.
-data Socket = Socket (IORef CInt) CInt {- for Show -}
+data Socket = Socket (IORef CSocket) CSocket {- for Show -}
 
 instance Show Socket where
     show (Socket _ ofd) = "<socket: " ++ show ofd ++ ">"
@@ -114,7 +121,7 @@ instance Eq Socket where
 
 {-# DEPRECATED fdSocket "Use withFdSocket or unsafeFdSocket instead" #-}
 -- | Currently, this is an alias of `unsafeFdSocket`.
-fdSocket :: Socket -> IO CInt
+fdSocket :: Socket -> IO CSocket
 fdSocket = unsafeFdSocket
 
 -- | Getting a file descriptor from a socket.
@@ -139,7 +146,7 @@ fdSocket = unsafeFdSocket
 --   'touchSocket' can be used for this purpose.
 --
 --   A safer option is to use 'withFdSocket' instead.
-unsafeFdSocket :: Socket -> IO CInt
+unsafeFdSocket :: Socket -> IO CSocket
 unsafeFdSocket (Socket ref _) = readIORef ref
 
 -- | Ensure that the given 'Socket' stays alive (i.e. not garbage-collected)
@@ -171,7 +178,7 @@ touch (IORef (STRef mutVar)) =
 -- descriptor.
 --
 -- Since: 3.1.0.0
-withFdSocket :: Socket -> (CInt -> IO r) -> IO r
+withFdSocket :: Socket -> (CSocket -> IO r) -> IO r
 withFdSocket (Socket ref _) f = do
   fd <- readIORef ref
   -- Should we throw an exception if the socket is already invalid?
@@ -187,7 +194,7 @@ withFdSocket (Socket ref _) f = do
 --   of unexpectedly being closed if the socket is finalized. It is
 --   now the caller's responsibility to ultimately close the
 --   duplicated file descriptor.
-socketToFd :: Socket -> IO CInt
+socketToFd :: Socket -> IO CSocket
 socketToFd s = do
 #if defined(mingw32_HOST_OS)
     fd <- unsafeFdSocket s
@@ -197,7 +204,7 @@ socketToFd s = do
     return fd2
 
 foreign import ccall unsafe "wsaDuplicate"
-   c_wsaDuplicate :: CInt -> IO CInt
+   c_wsaDuplicate :: CSocket -> IO CSocket
 #else
     fd <- unsafeFdSocket s
     -- FIXME: throw error no if -1
@@ -206,18 +213,18 @@ foreign import ccall unsafe "wsaDuplicate"
     return fd2
 
 foreign import ccall unsafe "dup"
-   c_dup :: CInt -> IO CInt
+   c_dup :: CSocket -> IO CSocket
 #endif
 
 -- | Creating a socket from a file descriptor.
-mkSocket :: CInt -> IO Socket
+mkSocket :: CSocket -> IO Socket
 mkSocket fd = do
     ref <- newIORef fd
     let s = Socket ref fd
     void $ mkWeakIORef ref $ close s
     return s
 
-invalidSocket :: CInt
+invalidSocket :: CSocket
 #if defined(mingw32_HOST_OS)
 invalidSocket = #const INVALID_SOCKET
 #else
@@ -226,8 +233,8 @@ invalidSocket = -1
 
 invalidateSocket ::
       Socket
-   -> (CInt -> IO a)
-   -> (CInt -> IO a)
+   -> (CSocket -> IO a)
+   -> (CSocket -> IO a)
    -> IO a
 invalidateSocket (Socket ref _) errorAction normalAction = do
     oldfd <- atomicModifyIORef' ref $ \cur -> (invalidSocket, cur)
@@ -246,7 +253,7 @@ close s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do
     -- closeFdWith avoids the deadlock of IO manager.
     closeFdWith closeFd (toFd oldfd)
   where
-    toFd :: CInt -> Fd
+    toFd :: CSocket -> Fd
     toFd = fromIntegral
     -- closeFd ignores the return value of c_close and
     -- does not throw exceptions
@@ -260,7 +267,7 @@ close' s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do
     -- closeFdWith avoids the deadlock of IO manager.
     closeFdWith closeFd (toFd oldfd)
   where
-    toFd :: CInt -> Fd
+    toFd :: CSocket -> Fd
     toFd = fromIntegral
     closeFd :: Fd -> IO ()
     closeFd fd = do
@@ -269,10 +276,10 @@ close' s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do
 
 #if defined(mingw32_HOST_OS)
 foreign import CALLCONV unsafe "closesocket"
-  c_close :: CInt -> IO CInt
+  c_close :: CSocket -> IO CInt
 #else
 foreign import ccall unsafe "close"
-  c_close :: CInt -> IO CInt
+  c_close :: CSocket -> IO CInt
 #endif
 
 -----------------------------------------------------------------------------

cbits/cmsg.c

@@ -38,6 +38,9 @@ WSASendMsg (SOCKET s, LPWSAMSG lpMsg, DWORD flags,
     DWORD len;
     if (WSAIoctl(s, SIO_GET_EXTENSION_FUNCTION_POINTER,
         &WSASendMsgGUID, sizeof(WSASendMsgGUID), &ptr_SendMsg,
+        /* Sadly we can't perform this async for now as C code can't wait for
+           completion events from the Haskell RTS.  This needs to be moved to
+           Haskell on a re-designed async Network.  */
         sizeof(ptr_SendMsg), &len, NULL, NULL) != 0)
       return -1;
   }
@@ -58,6 +61,9 @@ WSARecvMsg (SOCKET s, LPWSAMSG lpMsg, LPDWORD lpdwNumberOfBytesRecvd,
     DWORD len;
     if (WSAIoctl(s, SIO_GET_EXTENSION_FUNCTION_POINTER,
         &WSARecvMsgGUID, sizeof(WSARecvMsgGUID), &ptr_RecvMsg,
+        /* Sadly we can't perform this async for now as C code can't wait for
+           completion events from the Haskell RTS.  This needs to be moved to
+           Haskell on a re-designed async Network.  */
         sizeof(ptr_RecvMsg), &len, NULL, NULL) != 0)
       return -1;
   }

include/HsNetDef.h

@@ -41,10 +41,6 @@
 # define CALLCONV ccall
 #endif
 
-#if defined(mingw32_HOST_OS)
-# define SAFE_ON_WIN safe
-#else
-# define SAFE_ON_WIN unsafe
-#endif
+#define SAFE_ON_WIN unsafe
 
 #endif /* HSNETDEF_H */