Work around GHC bug #12020

Network/Socket.hsc

@@ -654,7 +654,11 @@ sendBuf :: Socket     -- Bound/Connected Socket
 sendBuf sock@(MkSocket s _family _stype _protocol _status) str len = do
    liftM fromIntegral $
 #if defined(mingw32_HOST_OS)
-    writeRawBufferPtr
+-- writeRawBufferPtr is supposed to handle checking for errors, but it's broken
+-- on x86_64 because of GHC bug #12010 so we duplicate the check here. The call
+-- to throwSocketErrorIfMinus1Retry can be removed when no GHC version with the
+-- bug is supported.
+    throwSocketErrorIfMinus1Retry "Network.Socket.sendBuf" $ writeRawBufferPtr
       "Network.Socket.sendBuf"
       (socket2FD sock)
       (castPtr str)
@@ -704,8 +708,10 @@ recvBuf sock@(MkSocket s _family _stype _protocol _status) ptr nbytes
  | otherwise   = do
         len <-
 #if defined(mingw32_HOST_OS)
-          readRawBufferPtr "Network.Socket.recvBuf" (socket2FD sock) ptr 0
-                 (fromIntegral nbytes)
+-- see comment in sendBuf above.
+            throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $
+                readRawBufferPtr "Network.Socket.recvBuf"
+                (socket2FD sock) ptr 0 (fromIntegral nbytes)
 #else
                throwSocketErrorWaitRead sock "recvBuf" $
                    c_recv s (castPtr ptr) (fromIntegral nbytes) 0{-flags-}

network.cabal

@@ -105,8 +105,8 @@ test-suite regression
     network,
     test-framework,
     test-framework-hunit
-
-  ghc-options: -Wall
+  -- Some of the bugs only occur in the threaded RTS
+  ghc-options: -Wall -threaded
 
 test-suite doctest
   hs-source-dirs: tests

tests/Regression.hs

@@ -2,8 +2,13 @@
 module Main where
 
 import Network.Socket
+import qualified Network.Socket.ByteString as BS
+
+import Control.Exception
+
 import Test.Framework (Test, defaultMain)
 import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit (assertFailure)
 
 ------------------------------------------------------------------------
 -- Tests
@@ -16,12 +21,35 @@ testGetAddrInfo = do
     _ <- getAddrInfo (Just hints) (Just "localhost") Nothing
     return ()
 
+mkBadSocketAndTry :: (Socket -> IO a) -> IO (Either IOException a)
+mkBadSocketAndTry f = do
+    sock <- socket AF_INET Stream defaultProtocol
+    try $ f sock
+
+-- Because of 64/32 bitness issues, -1 wasn't correctly checked for on Windows.
+-- See also GHC ticket #12010
+badRecvShouldThrow :: IO ()
+badRecvShouldThrow = do
+    res <- mkBadSocketAndTry $ flip recv 1024
+    case res of
+        Left _ex -> return ()
+        Right _  -> assertFailure "recv didn't throw an exception"
+
+badSendShouldThrow :: IO ()
+badSendShouldThrow = do
+    res <- mkBadSocketAndTry $ flip send "hello"
+    case res of
+        Left _ex -> return ()
+        Right _  -> assertFailure "send didn't throw an exception"
+
 ------------------------------------------------------------------------
 -- List of all tests
 
 tests :: [Test]
 tests =
-    [ testCase "testGetAddrInfo" testGetAddrInfo
+    [ testCase "testGetAddrInfo" testGetAddrInfo,
+      testCase "badRecvShouldThrow" badRecvShouldThrow,
+      testCase "badSendShouldThrow" badSendShouldThrow
     ]
 
 ------------------------------------------------------------------------