From b4e4181be238cef721ff59747a5ae5416dd1d8aa Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 3 Oct 2025 16:48:41 -0700
Subject: [PATCH 1/4] All WinIO work

---
 CHANGELOG.md                          |   5 +
 Network/Socket/Buffer.hsc             | 235 +++++++++++++++++++++++---
 Network/Socket/ByteString/Internal.hs |  12 +-
 Network/Socket/Fcntl.hs               |  29 +++-
 Network/Socket/Handle.hs              |  11 +-
 Network/Socket/Name.hs                |   4 +-
 Network/Socket/Options.hsc            |   4 +-
 Network/Socket/STM.hs                 |  10 ++
 Network/Socket/Shutdown.hs            |   2 +-
 Network/Socket/Syscall.hs             |  40 +++--
 Network/Socket/Types.hsc              |  37 ++--
 cbits/cmsg.c                          |   6 +
 include/HsNetDef.h                    |   6 +-
 network.cabal                         |  14 +-
 stack.yaml                            |   4 +-
 tests/Network/SocketSpec.hs           |   6 +-
 16 files changed, 339 insertions(+), 86 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index fe1d7bcb..8ad383d5 100644
--- a/CHANGELOG.md
+++ b/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.
diff --git a/Network/Socket/Buffer.hsc b/Network/Socket/Buffer.hsc
index 81759e4a..dcf49a1d 100644
--- a/Network/Socket/Buffer.hsc
+++ b/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
diff --git a/Network/Socket/ByteString/Internal.hs b/Network/Socket/ByteString/Internal.hs
index 3d789d97..59c8104f 100644
--- a/Network/Socket/ByteString/Internal.hs
+++ b/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
diff --git a/Network/Socket/Fcntl.hs b/Network/Socket/Fcntl.hs
index 81442cab..e6a3f21e 100644
--- a/Network/Socket/Fcntl.hs
+++ b/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(HAS_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 @@ 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
@@ -46,12 +53,20 @@ getCloseOnExec fd = do
 #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(HAS_WINIO)
+getNonBlock _ = return False <!> return True
+# else
 getNonBlock _ = return False
+# endif
 #else
 getNonBlock fd = do
     flags <- c_fcntl_read fd fGetFl 0
diff --git a/Network/Socket/Handle.hs b/Network/Socket/Handle.hs
index 8b46dea1..683a8d4b 100644
--- a/Network/Socket/Handle.hs
+++ b/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
diff --git a/Network/Socket/Name.hs b/Network/Socket/Name.hs
index ae6cd6e8..3160a145 100644
--- a/Network/Socket/Name.hs
+++ b/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
diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc
index 44288e6b..1805fc10 100644
--- a/Network/Socket/Options.hsc
+++ b/Network/Socket/Options.hsc
@@ -559,6 +559,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
diff --git a/Network/Socket/STM.hs b/Network/Socket/STM.hs
index fb368eec..0bfd6711 100644
--- a/Network/Socket/STM.hs
+++ b/Network/Socket/STM.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 module Network.Socket.STM where
 
 import Control.Concurrent
@@ -12,7 +14,11 @@ waitReadSocketSTM s = fst <$> waitAndCancelReadSocketSTM s
 -- | 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 @@ waitWriteSocketSTM s = fst <$> waitAndCancelWriteSocketSTM s
 -- | 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
diff --git a/Network/Socket/Shutdown.hs b/Network/Socket/Shutdown.hs
index 0479e319..f8494585 100644
--- a/Network/Socket/Shutdown.hs
+++ b/Network/Socket/Shutdown.hs
@@ -45,7 +45,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.
diff --git a/Network/Socket/Syscall.hs b/Network/Socket/Syscall.hs
index c7494b49..2e730cfb 100644
--- a/Network/Socket/Syscall.hs
+++ b/Network/Socket/Syscall.hs
@@ -4,16 +4,19 @@
 
 module Network.Socket.Syscall where
 
-import Foreign.Marshal.Utils (with)
 import qualified Control.Exception as E
-# if defined(mingw32_HOST_OS)
-import System.IO.Error (catchIOError)
-#endif
+import Foreign.Marshal.Utils (with)
 
 #if defined(mingw32_HOST_OS)
 import Control.Exception (bracket)
 import Foreign (FunPtr)
 import GHC.Conc (asyncDoProc)
+import System.IO.Error (catchIOError)
+# if defined(HAS_WINIO)
+import qualified GHC.Event.Windows as Mgr
+import Foreign.Ptr (wordPtrToPtr)
+import GHC.IO.SubSystem ((<!>))
+# endif
 #else
 import Foreign.C.Error (getErrno, eINTR, eINPROGRESS)
 import GHC.Conc (threadWaitWrite)
@@ -79,6 +82,10 @@ socket family stype protocol = E.bracketOnError create c_close $ \fd -> do
     -- Let's ensure that the socket (file descriptor) is closed even on
     -- asynchronous exceptions.
     setNonBlock fd
+#if defined(mingw32_HOST_OS) && defined(HAS_WINIO)
+    -- Associate socket with I/O manager immediately if using WinIO
+    (return () <!> Mgr.associateHandle' (wordPtrToPtr $ fromIntegral fd))
+#endif
     s <- mkSocket fd
     -- This socket is not managed by the IO manager yet.
     -- So, we don't have to call "close" which uses "closeFdWith".
@@ -203,7 +210,12 @@ listen s backlog = withFdSocket s $ \fd -> do
 accept :: SocketAddress sa => Socket -> IO (Socket, sa)
 accept listing_sock = withNewSocketAddress $ \new_sa sz ->
     withFdSocket listing_sock $ \listing_fd -> do
- new_sock <- E.bracketOnError (callAccept listing_fd new_sa sz) c_close mkSocket
+ new_sock <- E.bracketOnError (callAccept listing_fd new_sa sz) c_close $ \fd -> do
+#if defined(HAS_WINIO)
+     -- Associate accepted socket with I/O manager if using WinIO
+     (return () <!> Mgr.associateHandle' (wordPtrToPtr $ fromIntegral fd))
+#endif
+     mkSocket fd
  new_addr <- peekSocketAddress new_sa
  return (new_sock, new_addr)
   where
@@ -234,31 +246,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"
diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc
index a0efb968..8bd419da 100644
--- a/Network/Socket/Types.hsc
+++ b/Network/Socket/Types.hsc
@@ -14,6 +14,7 @@
 module Network.Socket.Types (
     -- * Socket type
       Socket
+    , CSocket
     , withFdSocket
     , unsafeFdSocket
     , touchSocket
@@ -107,8 +108,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 ++ ">"
@@ -118,7 +125,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.
@@ -143,7 +150,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)
@@ -175,7 +182,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?
@@ -191,7 +198,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
@@ -201,7 +208,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
@@ -210,18 +217,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
@@ -230,8 +237,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)
@@ -250,7 +257,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
@@ -264,7 +271,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
@@ -273,10 +280,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
 
 -----------------------------------------------------------------------------
diff --git a/cbits/cmsg.c b/cbits/cmsg.c
index 105dd197..15b17cd8 100644
--- a/cbits/cmsg.c
+++ b/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;
   }
diff --git a/include/HsNetDef.h b/include/HsNetDef.h
index d84640de..0d732625 100644
--- a/include/HsNetDef.h
+++ b/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 */
diff --git a/network.cabal b/network.cabal
index 981ff6a5..0727550f 100644
--- a/network.cabal
+++ b/network.cabal
@@ -4,7 +4,6 @@ version:            3.2.8.0
 license:            BSD3
 license-file:       LICENSE
 maintainer:         Kazu Yamamoto, Tamar Christina
-
 tested-with:
     GHC == 9.8.2
     GHC == 9.6.4
@@ -169,12 +168,16 @@ library
             iphlpapi
             mswsock
 
-        if impl(ghc >=7.10)
+        build-depends:   temporary
+
+        if impl(ghc >=7.10 && <9.0)
             cpp-options: -D_WIN32_WINNT=0x0600
             cc-options:  -D_WIN32_WINNT=0x0600
 
-        build-depends:
-            temporary
+        if impl(ghc >=9.0)
+            cpp-options:   -D_WIN32_WINNT=0x0601 -DHAS_WINIO
+            cc-options:    -D_WIN32_WINNT=0x0601
+            build-depends: Win32 >=2.12.0.1
 
     if impl(ghc >=8)
         default-extensions: Strict StrictData
@@ -202,6 +205,9 @@ test-suite spec
         hspec >=2.6,
         QuickCheck
 
+    if os(windows) && impl(ghc >=9.0)
+        ghc-options: -with-rtsopts=--io-manager=native
+
     if flag(devel)
         cpp-options: -DDEVELOPMENT
 
diff --git a/stack.yaml b/stack.yaml
index 23cee2d9..1ea11ac8 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,6 +1,8 @@
-resolver: lts-21.25
+resolver: nightly-2025-10-01
+
 packages:
 - '.'
+
 nix:
   packages: [ ncurses ]
 
diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs
index d056c9de..3d57bafc 100644
--- a/tests/Network/SocketSpec.hs
+++ b/tests/Network/SocketSpec.hs
@@ -6,16 +6,16 @@ module Network.SocketSpec (main, spec) where
 import Control.Concurrent (threadDelay, forkIO)
 import Control.Concurrent.MVar (readMVar)
 import Control.Monad
-import Data.Maybe (fromJust)
 import Data.List (nub)
+import Data.Maybe (fromJust)
+import Foreign.C.Types ()
 import Network.Socket
 import Network.Socket.ByteString
 import Network.Test.Common
-import System.Mem (performGC)
 import System.IO.Error (tryIOError)
 import System.IO.Temp (withSystemTempDirectory)
+import System.Mem (performGC)
 import System.Posix.Types (Fd(..))
-import Foreign.C.Types ()
 
 import Test.Hspec
 import Test.QuickCheck

From 147d2fd0158b39c6f3c86de51740be23df6b3b90 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 6 Apr 2026 10:19:01 -0700
Subject: [PATCH 2/4] Fix socketToHandle

---
 Network/Socket/Handle.hs | 35 +++++++++++++++++++++++++++++------
 1 file changed, 29 insertions(+), 6 deletions(-)

diff --git a/Network/Socket/Handle.hs b/Network/Socket/Handle.hs
index 683a8d4b..00ad60a1 100644
--- a/Network/Socket/Handle.hs
+++ b/Network/Socket/Handle.hs
@@ -1,9 +1,19 @@
+{-# LANGUAGE CPP #-}
+
 module Network.Socket.Handle where
 
 import qualified GHC.IO.Device (IODeviceType (Stream))
 import GHC.IO.Handle.FD (fdToHandle')
 import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering)
 
+#if defined(mingw32_HOST_OS) && defined(HAS_WINIO)
+import Foreign.Ptr (wordPtrToPtr)
+import GHC.IO.SubSystem ((<!>))
+import qualified GHC.Event.Windows as Mgr
+import GHC.IO.Windows.Handle (fromHANDLE, Io, NativeHandle)
+import GHC.IO.Handle.Windows (mkHandleFromHANDLE)
+#endif
+
 import Network.Socket.Types
 
 -- | Turns a Socket into an 'Handle'. By default, the new handle is
@@ -19,11 +29,20 @@ 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 <-
+#if defined(mingw32_HOST_OS) && defined(HAS_WINIO)
+        socketToHandleMIO oldfd <!> socketToHandleWinIO oldfd
+#else
+        socketToHandleMIO oldfd
+#endif
+    hSetBuffering h NoBuffering
+    return h
+  where
+    err _ = ioError $ userError $ "socketToHandle: socket is no longer valid"
+
+    socketToHandleMIO oldfd =
         fdToHandle'
             (fromIntegral oldfd)
             (Just GHC.IO.Device.Stream)
@@ -31,7 +50,11 @@ socketToHandle s mode = invalidateSocket s err $ \oldfd -> do
             (show s)
             mode
             True {-bin-}
-    hSetBuffering h NoBuffering
-    return h
-  where
-    err _ = ioError $ userError $ "socketToHandle: socket is no longer valid"
+
+#if defined(mingw32_HOST_OS) && defined(HAS_WINIO)
+    socketToHandleWinIO oldfd = do
+        let hwnd = wordPtrToPtr $ fromIntegral oldfd
+        Mgr.associateHandle' hwnd
+        let nativeHwnd = fromHANDLE hwnd :: Io NativeHandle
+        mkHandleFromHANDLE nativeHwnd GHC.IO.Device.Stream (show s) mode Nothing
+#endif

From 47e1fdb5e831e5314773b7f697605637447db1b9 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 6 Apr 2026 10:35:09 -0700
Subject: [PATCH 3/4] Don't try to implement
 waitAndCancelReadSocketSTM/waitAndCancelWriteSocketSTM on Windows

---
 Network/Socket/STM.hs | 10 ----------
 1 file changed, 10 deletions(-)

diff --git a/Network/Socket/STM.hs b/Network/Socket/STM.hs
index 0bfd6711..fb368eec 100644
--- a/Network/Socket/STM.hs
+++ b/Network/Socket/STM.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
 module Network.Socket.STM where
 
 import Control.Concurrent
@@ -14,11 +12,7 @@ waitReadSocketSTM s = fst <$> waitAndCancelReadSocketSTM s
 -- | 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 ())
@@ -27,8 +21,4 @@ waitWriteSocketSTM s = fst <$> waitAndCancelWriteSocketSTM s
 -- | 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

From 634b3374e3a50581bda16e13e9635d3c32e3a8a8 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 6 Apr 2026 10:49:23 -0700
Subject: [PATCH 4/4] More on socketToHandle, waitAndCancelReadSocketSTM,
 waitAndCancelWriteSocketSTM

---
 Network/Socket/Handle.hs | 28 ++++++++--------------------
 Network/Socket/STM.hs    |  4 ++--
 2 files changed, 10 insertions(+), 22 deletions(-)

diff --git a/Network/Socket/Handle.hs b/Network/Socket/Handle.hs
index 00ad60a1..c63a5d53 100644
--- a/Network/Socket/Handle.hs
+++ b/Network/Socket/Handle.hs
@@ -31,30 +31,18 @@ import Network.Socket.Types
 -- sequence with appropriate handshakes specified by the protocol.
 socketToHandle :: Socket -> IOMode -> IO Handle
 socketToHandle s mode = invalidateSocket s err $ \oldfd -> do
-    h <-
+    let posix = fdToHandle' (fromIntegral oldfd) (Just GHC.IO.Device.Stream) True (show s) mode True {-bin-}
 #if defined(mingw32_HOST_OS) && defined(HAS_WINIO)
-        socketToHandleMIO oldfd <!> socketToHandleWinIO oldfd
+        native = do
+            let hwnd = wordPtrToPtr $ fromIntegral oldfd
+            Mgr.associateHandle' hwnd
+            let nativeHwnd = fromHANDLE hwnd :: Io NativeHandle
+            mkHandleFromHANDLE nativeHwnd GHC.IO.Device.Stream (show s) mode Nothing
+    h <- posix <!> native
 #else
-        socketToHandleMIO oldfd
+    h <- posix
 #endif
     hSetBuffering h NoBuffering
     return h
   where
     err _ = ioError $ userError $ "socketToHandle: socket is no longer valid"
-
-    socketToHandleMIO oldfd =
-        fdToHandle'
-            (fromIntegral oldfd)
-            (Just GHC.IO.Device.Stream)
-            True
-            (show s)
-            mode
-            True {-bin-}
-
-#if defined(mingw32_HOST_OS) && defined(HAS_WINIO)
-    socketToHandleWinIO oldfd = do
-        let hwnd = wordPtrToPtr $ fromIntegral oldfd
-        Mgr.associateHandle' hwnd
-        let nativeHwnd = fromHANDLE hwnd :: Io NativeHandle
-        mkHandleFromHANDLE nativeHwnd GHC.IO.Device.Stream (show s) mode Nothing
-#endif
diff --git a/Network/Socket/STM.hs b/Network/Socket/STM.hs
index fb368eec..6f2419b4 100644
--- a/Network/Socket/STM.hs
+++ b/Network/Socket/STM.hs
@@ -12,7 +12,7 @@ waitReadSocketSTM s = fst <$> waitAndCancelReadSocketSTM s
 -- | STM action to wait until the socket is ready for reading and STM
 --   action to cancel the waiting.
 waitAndCancelReadSocketSTM :: Socket -> IO (STM (), IO ())
-waitAndCancelReadSocketSTM s = withFdSocket s $ threadWaitReadSTM . Fd
+waitAndCancelReadSocketSTM s = withFdSocket s $ threadWaitReadSTM . Fd . fromIntegral
 
 -- | STM action to wait until the socket is ready for writing.
 waitWriteSocketSTM :: Socket -> IO (STM ())
@@ -21,4 +21,4 @@ waitWriteSocketSTM s = fst <$> waitAndCancelWriteSocketSTM s
 -- | STM action to wait until the socket is ready for writing and STM
 --   action to cancel the waiting.
 waitAndCancelWriteSocketSTM :: Socket -> IO (STM (), IO ())
-waitAndCancelWriteSocketSTM s = withFdSocket s $ threadWaitWriteSTM . Fd
+waitAndCancelWriteSocketSTM s = withFdSocket s $ threadWaitWriteSTM . Fd . fromIntegral