Give Winsock errors the IOErrorType of their errno

Network/Socket/Cbits.hsc

@@ -3,6 +3,9 @@ module Network.Socket.Cbits where
 #include "HsNet.h"
 
 import Network.Socket.Imports
+#if defined(mingw32_HOST_OS)
+import GHC.IO.Exception (IOErrorType (..))
+#endif
 
 -- | This is the value of SOMAXCONN, typically 128.
 -- 128 is good enough for normal network servers but
@@ -41,6 +44,51 @@ wsaEHOSTUNREACH :: CInt
 wsaEHOSTUNREACH = #const WSAEHOSTUNREACH
 wsaENOPROTOOPT :: CInt
 wsaENOPROTOOPT = #const WSAENOPROTOOPT
+-- | The 'IOErrorType' which 'Foreign.C.Error.errnoToIOError' gives the
+--   errno of the same name.  WSAEINTR stays 'OtherError': on Windows it
+--   is what closesocket gives a blocked call, not an interrupt.
+winsockErrorType :: CInt -> IOErrorType
+winsockErrorType rc = case rc of
+    #{const WSAEACCES} -> PermissionDenied
+    #{const WSAEADDRINUSE} -> ResourceBusy
+    #{const WSAEADDRNOTAVAIL} -> UnsupportedOperation
+    #{const WSAEAFNOSUPPORT} -> UnsupportedOperation
+    #{const WSAEALREADY} -> AlreadyExists
+    #{const WSAEBADF} -> InvalidArgument
+    #{const WSAECONNREFUSED} -> NoSuchThing
+    #{const WSAECONNRESET} -> ResourceVanished
+    #{const WSAEDESTADDRREQ} -> InvalidArgument
+    #{const WSAEDQUOT} -> PermissionDenied
+    #{const WSAEHOSTDOWN} -> NoSuchThing
+    #{const WSAEHOSTUNREACH} -> NoSuchThing
+    #{const WSAEINPROGRESS} -> AlreadyExists
+    #{const WSAEINVAL} -> InvalidArgument
+    #{const WSAEISCONN} -> AlreadyExists
+    #{const WSAELOOP} -> InvalidArgument
+    #{const WSAEMFILE} -> ResourceExhausted
+    #{const WSAEMSGSIZE} -> ResourceExhausted
+    #{const WSAENAMETOOLONG} -> InvalidArgument
+    #{const WSAENETDOWN} -> ResourceVanished
+    #{const WSAENETRESET} -> ResourceVanished
+    #{const WSAENETUNREACH} -> NoSuchThing
+    #{const WSAENOBUFS} -> ResourceExhausted
+    #{const WSAENOPROTOOPT} -> UnsupportedOperation
+    #{const WSAENOTCONN} -> InvalidArgument
+    #{const WSAENOTEMPTY} -> UnsatisfiedConstraints
+    #{const WSAENOTSOCK} -> InvalidArgument
+    #{const WSAEOPNOTSUPP} -> UnsupportedOperation
+    #{const WSAEPFNOSUPPORT} -> UnsupportedOperation
+    #{const WSAEPROCLIM} -> PermissionDenied
+    #{const WSAEPROTONOSUPPORT} -> ProtocolError
+    #{const WSAEPROTOTYPE} -> ProtocolError
+    #{const WSAEREMOTE} -> IllegalOperation
+    #{const WSAESHUTDOWN} -> IllegalOperation
+    #{const WSAESOCKTNOSUPPORT} -> UnsupportedOperation
+    #{const WSAESTALE} -> ResourceVanished
+    #{const WSAETIMEDOUT} -> TimeExpired
+    #{const WSAETOOMANYREFS} -> ResourceExhausted
+    #{const WSAEUSERS} -> ResourceExhausted
+    _ -> OtherError
 #else
 fGetFd :: CInt
 fGetFd = #const F_GETFD

Network/Socket/Internal.hs

@@ -61,11 +61,6 @@ import GHC.Conc (threadWaitRead, threadWaitWrite)
 #if defined(mingw32_HOST_OS)
 import qualified Control.Exception as E
 import System.IO.Unsafe (unsafePerformIO)
-# if __GLASGOW_HASKELL__ >= 707
-import GHC.IO.Exception (IOErrorType(..))
-# else
-import GHC.IOBase (IOErrorType(..))
-# endif
 import System.IO.Error (ioeSetErrorString, mkIOError)
 #else
 import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry,
@@ -154,14 +149,15 @@ throwSocketError = throwErrno
 -- | Like 'throwSocketError', but the error code is supplied as an argument.
 --
 -- On Windows the code is a Winsock error code rather than an errno.  It
--- is kept in 'ioe_errno' all the same: Winsock reports every error as
--- 'OtherError', so the code is the only thing which tells them apart.
+-- is kept in 'ioe_errno' all the same, and the error type is the one
+-- the errno of the same name has elsewhere.
 throwSocketErrorCode :: String -> CInt -> IO a
 #if defined(mingw32_HOST_OS)
 throwSocketErrorCode name rc = do
     pstr <- c_getWSError rc
     str  <- peekCString pstr
-    let ioe = (mkIOError OtherError name Nothing Nothing){ioe_errno = Just rc}
+    let typ = winsockErrorType rc
+        ioe = (mkIOError typ name Nothing Nothing){ioe_errno = Just rc}
     ioError (ioeSetErrorString ioe str)
 #else
 throwSocketErrorCode loc errno =

Network/Socket/Wait.hs

@@ -363,8 +363,9 @@ isTransientAcceptError e =
 --   earlier send of its own came back as an ICMP port unreachable.
 --
 --   POSIX gives it as @ECONNREFUSED@ and Winsock as @WSAECONNRESET@, so
---   the error type differs (@NoSuchThing@ and @OtherError@); this reads
---   the code instead.  Only a connected socket hears it on any platform.
+--   the error type differs (@NoSuchThing@ and @ResourceVanished@); this
+--   reads the code instead.  Only a connected socket hears it on any
+--   platform.
 --
 --   @since 3.2.12.0
 isPortUnreachableError :: E.IOException -> Bool

tests/Network/SocketSpec.hs

@@ -19,7 +19,8 @@
 import Network.Socket
 import Network.Socket.ByteString
 import Network.Test.Common
-import System.IO.Error (tryIOError)
+import GHC.IO.Exception (IOErrorType (ResourceVanished))
+import System.IO.Error (ioeGetErrorType, tryIOError)
 import System.IO.Temp (withSystemTempDirectory)
 import System.Mem (performGC)
 import System.Posix.Types (Fd(..))
@@ -378,6 +379,21 @@
         it "is heard by a connected one through recvMsg" $
             bounceWith recvMsg' connectSend `shouldThrow` isPortUnreachableError
 
+    describe "a connection the peer resets" $ do
+        it "is reported as ResourceVanished" $ do
+            -- The byte makes the reset follow the connect: an RST which
+            -- beat it would fail the connect itself on Linux.
+            let server sock = do
+                    void $ recv sock 1
+                    setSockOpt sock Linger (StructLinger 1 0)
+                -- Plain recv on Windows reads through GHC's IO manager,
+                -- which does not go by the Winsock code.
+                client sock = do
+                    sendAll sock "x"
+                    recvWith sock 1024 retry `shouldThrow` isVanished
+                isVanished e = ioeGetErrorType e == ResourceVanished
+            tcpTest client server
+
     describe "gracefulClose" $ do
         it "does not send TCP RST back" $ do
             let server sock = do
@@ -635,7 +651,7 @@
 cmsgidGen = biasedGen (\g -> CmsgId <$> g <*> g) cmsgidPatterns arbitrary
 
 genFds :: Gen [Fd]
 genFds = listOf (Fd <$> arbitrary)
 
 -- pruned lists of pattern synonym values for each type to generate values from