Winio

CHANGELOG.md

@@ -1,3 +1,8 @@
+## Version 3.3.0.0
+
+* Basic support for WINIO
+  [#509](https://github.com/haskell/network/pull/509)
+
 ## Version 3.2.7.0
 
 * Using nested `bracket` for `gracefulClose`.

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,24 +2,31 @@
 
 module Network.Socket.Fcntl where
 
+import Network.Socket.Types
 import qualified System.Posix.Internals
 
 #if !defined(mingw32_HOST_OS)
 import Network.Socket.Cbits
+#else
+# if defined(__IO_MANAGER_WINIO__)
+import GHC.IO.SubSystem ((<!>))
+# endif
 #endif
 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 +35,14 @@
 
 #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
@@ -46,12 +53,20 @@
 #endif
 
 -- | Get the nonblocking flag.
---   On Windows, this function always returns 'False'.
+--   On Windows, this function always returns 'False' when using MIO but
+--   returns `True` when using WinIO.  Technically on Windows whether the
+--   the socket blocks or not is not determined by the socket itself but
+--   by the operations used on the socket.  Becuase we will always use
+--   overlapping I/O when WinIO is enabled we return `True` here.
 --
 --   Since 2.7.0.0.
-getNonBlock :: CInt -> IO Bool
+getNonBlock :: CSocket -> IO Bool
 #if defined(mingw32_HOST_OS)
+# if defined(__IO_MANAGER_WINIO__)
+getNonBlock _ = return False <!> return True
+# else
 getNonBlock _ = return False
+# endif
 #else
 getNonBlock fd = do
     flags <- c_fcntl_read fd fGetFl 0

Network/Socket/Handle.hs

@@ -19,9 +19,18 @@ import Network.Socket.Types
 -- Haskell, e.g. merely performing 'hClose' on a TCP socket won't
 -- 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

@@ -549,6 +549,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/STM.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE CPP #-}
+
 module Network.Socket.STM where
 
 import Control.Concurrent
 import Control.Concurrent.STM
 import Network.Socket.Types
 import System.Posix.Types
 
 -- | STM action to wait until the socket is ready for reading.
 waitReadSocketSTM :: Socket -> IO (STM ())
@@ -12,7 +14,11 @@
 -- | STM action to wait until the socket is ready for reading and STM
 --   action to cancel the waiting.
 waitAndCancelReadSocketSTM :: Socket -> IO (STM (), IO ())
+#if !defined(mingw32_HOST_OS)
 waitAndCancelReadSocketSTM s = withFdSocket s $ threadWaitReadSTM . Fd
+#else
+waitAndCancelReadSocketSTM _ = undefined
+#endif
 
 -- | STM action to wait until the socket is ready for writing.
 waitWriteSocketSTM :: Socket -> IO (STM ())
@@ -21,4 +27,8 @@
 -- | STM action to wait until the socket is ready for writing and STM
 --   action to cancel the waiting.
 waitAndCancelWriteSocketSTM :: Socket -> IO (STM (), IO ())
+#if !defined(mingw32_HOST_OS)
 waitAndCancelWriteSocketSTM s = withFdSocket s $ threadWaitWriteSTM . Fd
+#else
+waitAndCancelWriteSocketSTM _ = undefined
+#endif

Network/Socket/Shutdown.hs

@@ -22,7 +22,7 @@
 import Network.Socket.Buffer
 import Network.Socket.Imports
 import Network.Socket.Internal
 import Network.Socket.STM
 import Network.Socket.Types
 
 data ShutdownCmd = ShutdownReceive
@@ -45,7 +45,7 @@
     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

@@ -12,7 +12,7 @@
 
 #if defined(mingw32_HOST_OS)
 import Control.Exception (bracket)
 import Foreign (FunPtr)
 import GHC.Conc (asyncDoProc)
 #else
 import Foreign.C.Error (getErrno, eINTR, eINPROGRESS)
@@ -224,31 +224,31 @@
 #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"