diff --git a/Network/Socket/Cbits.hsc b/Network/Socket/Cbits.hsc index 91a60cad..c1195db5 100644 --- a/Network/Socket/Cbits.hsc +++ b/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 diff --git a/Network/Socket/Internal.hs b/Network/Socket/Internal.hs index 2959463c..ace6a38b 100644 --- a/Network/Socket/Internal.hs +++ b/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 = diff --git a/Network/Socket/Wait.hs b/Network/Socket/Wait.hs index c2bd9866..fb9d6382 100644 --- a/Network/Socket/Wait.hs +++ b/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 diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs index 813f08aa..82228beb 100644 --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -19,7 +19,8 @@ import Foreign.C.Types () 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 @@ spec = do 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