Use the correct return type for Windows' send()/recv() (Fix #12010)

Summary:
They return signed 32 bit ints on Windows, even on a 64 bit OS, rather than
Linux's 64 bit ssize_t. This means when recv() returned -1 to signal an error we
thought it was 4294967295. It was converted to an int, -1 and the buffer was
memcpy'd which caused a segfault. Other bad stuff happened with send()s.

See also note CSsize in System.Posix.Internals.

Add a test for #12010

Test Plan:
- GHC testsuite (T12010)
- http-conduit test (https://github.com/snoyberg/http-client/issues/191)

Reviewers: austin, hvr, bgamari, Phyx

Reviewed By: Phyx

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2170

GHC Trac Issues: #12010

7 files changed, 131 insertions, 29 deletions

diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs
index fb8a1d5b65..18148ecee1 100644
--- a/libraries/base/GHC/IO/FD.hs
+++ b/libraries/base/GHC/IO/FD.hs
@@ -606,18 +606,18 @@ asyncWriteRawBufferPtr loc !fd buf off len = do
 
 blockingReadRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
 blockingReadRawBufferPtr loc fd buf off len
-  = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
+  = throwErrnoIfMinus1Retry loc $
         if fdIsSocket fd
-           then c_safe_recv (fdFD fd) (buf `plusPtr` off) len 0
-           else c_safe_read (fdFD fd) (buf `plusPtr` off) len
+           then c_safe_recv (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
+           else c_safe_read (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
 
 blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
 blockingWriteRawBufferPtr loc fd buf off len
-  = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
+  = throwErrnoIfMinus1Retry loc $
         if fdIsSocket fd
-           then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0
+           then c_safe_send  (fdFD fd) (buf `plusPtr` off) (fromIntegral len) 0
            else do
-             r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
+             r <- c_safe_write (fdFD fd) (buf `plusPtr` off) (fromIntegral len)
              when (r == -1) c_maperrno
              return r
       -- we don't trust write() to give us the correct errno, and
@@ -631,10 +631,10 @@ blockingWriteRawBufferPtr loc fd buf off len
 -- These calls may block, but that's ok.
 
 foreign import WINDOWS_CCONV safe "recv"
-   c_safe_recv :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
+   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt
 
 foreign import WINDOWS_CCONV safe "send"
-   c_safe_send :: CInt -> Ptr Word8 -> CSize -> CInt{-flags-} -> IO CSsize
+   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt
 
 #endif
 
diff --git a/libraries/base/System/Posix/Internals.hs b/libraries/base/System/Posix/Internals.hs
index 66e9304d56..630f251669 100644
--- a/libraries/base/System/Posix/Internals.hs
+++ b/libraries/base/System/Posix/Internals.hs
@@ -404,24 +404,24 @@ foreign import ccall unsafe "HsBase.h _dup2"
 foreign import ccall unsafe "HsBase.h _isatty"
    c_isatty :: CInt -> IO CInt
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi unsafe "HsBase.h _read"
-   c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
+   c_read :: CInt -> Ptr Word8 -> CUInt -> IO CInt
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi safe "HsBase.h _read"
-   c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
+   c_safe_read :: CInt -> Ptr Word8 -> CUInt -> IO CInt
 
 foreign import ccall unsafe "HsBase.h _umask"
    c_umask :: CMode -> IO CMode
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi unsafe "HsBase.h _write"
-   c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
+   c_write :: CInt -> Ptr Word8 -> CUInt -> IO CInt
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi safe "HsBase.h _write"
-   c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
+   c_safe_write :: CInt -> Ptr Word8 -> CUInt -> IO CInt
 
 foreign import ccall unsafe "HsBase.h _unlink"
    c_unlink :: CString -> IO CInt
@@ -462,22 +462,22 @@ foreign import ccall unsafe "HsBase.h dup2"
 foreign import ccall unsafe "HsBase.h isatty"
    c_isatty :: CInt -> IO CInt
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi unsafe "HsBase.h read"
    c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi safe "HsBase.h read"
    c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
 foreign import ccall unsafe "HsBase.h umask"
    c_umask :: CMode -> IO CMode
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi unsafe "HsBase.h write"
    c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
--- See Note: CSsize
+-- See Note: Windows types
 foreign import capi safe "HsBase.h write"
    c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize
 
@@ -619,14 +619,13 @@ foreign import capi  unsafe "stdio.h value SEEK_SET" sEEK_SET :: CInt
 foreign import capi  unsafe "stdio.h value SEEK_END" sEEK_END :: CInt
 
 {-
-Note: CSsize
-
-On Win64, ssize_t is 64 bit, but functions like read return 32 bit
-ints. The CAPI wrapper means the C compiler takes care of doing all
-the necessary casting.
-
-When using ccall instead, when the functions failed with -1, we thought
-they were returning with 4294967295, and so didn't throw an exception.
-This lead to a segfault in echo001(ghci).
+Note: Windows types
+
+Windows' _read and _write have types that differ from POSIX. They take an
+unsigned int for lengh and return a signed int where POSIX uses size_t and
+ssize_t. Those are different on x86_64 and equivalent on x86. We import them
+with the types in Microsoft's documentation which means that c_read,
+c_safe_read, c_write and c_safe_write have different Haskell types depending on
+the OS.
 -}
 
diff --git a/libraries/base/tests/IO/T12010/Makefile b/libraries/base/tests/IO/T12010/Makefile
new file mode 100644
index 0000000000..112e1f19fc
--- /dev/null
+++ b/libraries/base/tests/IO/T12010/Makefile
@@ -0,0 +1,10 @@
+TOP=../../../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: T12010
+T12010:
+	'$(HSC2HS)' -I ../../../include/ -I ../../../../../includes/ T12010.hsc
+	'$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -c cbits/initWinSock.c
+	'$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -fno-warn-unsupported-calling-conventions cbits/initWinSock.o T12010.hs
+	./T12010
diff --git a/libraries/base/tests/IO/T12010/T12010.hsc b/libraries/base/tests/IO/T12010/T12010.hsc
new file mode 100644
index 0000000000..fa566e0025
--- /dev/null
+++ b/libraries/base/tests/IO/T12010/T12010.hsc
@@ -0,0 +1,40 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Main where
+import Control.Exception
+import Control.Monad
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import GHC.IO.FD
+import System.Exit
+
+-- HsBase includes WinSock on Windows, on POSIX we need to explicitly ask for
+-- sockets.
+#include "HsBase.h"
+#ifndef _WIN32
+#include <sys/socket.h>
+#endif
+
+aF_INET :: CInt
+aF_INET = #const AF_INET
+
+sOCK_STREAM :: CInt
+sOCK_STREAM = #const SOCK_STREAM
+
+main :: IO ()
+main = do
+#ifdef _WIN32
+  void $ initWinSock
+#endif
+  sock <- c_socket aF_INET sOCK_STREAM 0
+  let fd = FD sock 1
+  res <- try $ allocaBytes 1024 (\ptr -> readRawBufferPtr "T12010" fd ptr 0 1024)
+  case res of
+    Left (_ex :: IOException) -> exitSuccess
+    Right res'                -> print res' >> exitFailure
+
+foreign import stdcall unsafe "socket"
+  c_socket :: CInt -> CInt -> CInt -> IO CInt
+
+#ifdef _WIN32
+foreign import ccall unsafe "initWinSock" initWinSock :: IO Int
+#endif
diff --git a/libraries/base/tests/IO/T12010/T12010.stdout b/libraries/base/tests/IO/T12010/T12010.stdout
new file mode 100644
index 0000000000..dec7b86bee
--- /dev/null
+++ b/libraries/base/tests/IO/T12010/T12010.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling Main             ( T12010.hs, T12010.o )
+Linking T12010 ...
diff --git a/libraries/base/tests/IO/T12010/cbits/initWinSock.c b/libraries/base/tests/IO/T12010/cbits/initWinSock.c
new file mode 100644
index 0000000000..be517edc35
--- /dev/null
+++ b/libraries/base/tests/IO/T12010/cbits/initWinSock.c
@@ -0,0 +1,43 @@
+#include "HsBase.h"
+#include "HsFFI.h"
+
+#if defined(HAVE_WINSOCK_H) && !defined(__CYGWIN__)
+
+static int winsock_inited = 0;
+
+static void
+shutdownHandler(void)
+{
+  WSACleanup();
+}
+
+/* Initialising WinSock... */
+int
+initWinSock ()
+{
+  WORD wVersionRequested;
+  WSADATA wsaData;
+  int err;
+
+  if (!winsock_inited) {
+    wVersionRequested = MAKEWORD( 2, 2 );
+
+    err = WSAStartup ( wVersionRequested, &wsaData );
+
+    if ( err != 0 ) {
+       return err;
+    }
+
+    if ( LOBYTE( wsaData.wVersion ) != 2 ||
+       HIBYTE( wsaData.wVersion ) != 2 ) {
+      WSACleanup();
+      return (-1);
+    }
+
+    atexit(shutdownHandler);
+    winsock_inited = 1;
+  }
+  return 0;
+}
+
+#endif
diff --git a/libraries/base/tests/IO/T12010/test.T b/libraries/base/tests/IO/T12010/test.T
new file mode 100644
index 0000000000..178814fff3
--- /dev/null
+++ b/libraries/base/tests/IO/T12010/test.T
@@ -0,0 +1,8 @@
+test('T12010',
+     [
+        extra_clean(['cbits/initWinSock.o', 'T12010.hi', 'T12010.hs']),
+        only_ways(['threaded1']),
+        extra_ways(['threaded1']),
+        cmd_prefix('WAY_FLAGS="' + ' '.join(config.way_flags('T12010')['threaded1']) + '"')],
+     run_command,
+     ['$MAKE -s --no-print-directory T12010'])