winio: load the msg extension functions from Haskell, and fix a spurious EOF

CHANGELOG.md

@@ -13,6 +13,11 @@
   [#621](https://github.com/haskell/network/pull/621)
 * Fixing the misspelled WSAEACCES error description on Windows.
   [#622](https://github.com/haskell/network/pull/622)
+* WINIO: loading WSASendMsg and WSARecvMsg from Haskell so that they can be
+  issued asynchronously.
+  [#626](https://github.com/haskell/network/pull/626)
+* WINIO: fixing a spurious EOF when a recv completes synchronously.
+  [#626](https://github.com/haskell/network/pull/626)
 
 ## Version 3.2.8.0
 

Network/Socket/Buffer.hsc

@@ -32,6 +32,7 @@ import System.IO.Error (mkIOError, ioeSetErrorString, catchIOError)
 #if defined(mingw32_HOST_OS)
 import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr)
 import Network.Socket.Win32.CmsgHdr
+import Network.Socket.Win32.Load
 import Network.Socket.Win32.MsgHdr
 import Network.Socket.Win32.WSABuf
 ## if __IO_MANAGER_WINIO__ >= 2
@@ -251,7 +252,12 @@ recvBufFromWinIO s ptr nbytes =
                 -- would hang forever).
                 err <- c_WSAGetLastError
                 if ret == 0
-                    then return $ Mgr.CbDone Nothing
+                    -- An overlapped socket queues a completion packet even when
+                    -- the call succeeds synchronously, so let the I/O manager
+                    -- resolve it.  CbDone Nothing makes it read an OVERLAPPED
+                    -- that may not be filled in yet, which surfaces as a
+                    -- spurious EOF.
+                    then return Mgr.CbPending
                     else if err == _ERROR_IO_PENDING
                         then return Mgr.CbPending
                         else return $ Mgr.CbError (fromIntegral err)
@@ -328,7 +334,12 @@ recvBufWinIO s ptr nbytes = withFdSocket s $ \sock ->
                 -- would hang forever).
                 err <- c_WSAGetLastError
                 if ret == 0
-                    then return $ Mgr.CbDone Nothing
+                    -- An overlapped socket queues a completion packet even when
+                    -- the call succeeds synchronously, so let the I/O manager
+                    -- resolve it.  CbDone Nothing makes it read an OVERLAPPED
+                    -- that may not be filled in yet, which surfaces as a
+                    -- spurious EOF.
+                    then return Mgr.CbPending
                     else if err == _ERROR_IO_PENDING
                         then return Mgr.CbPending
                         else return $ Mgr.CbError (fromIntegral err)
@@ -519,37 +530,40 @@ foreign import CALLCONV SAFE_ON_WIN "ioctlsocket"
   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 :: CSocket -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
 foreign import CALLCONV unsafe "WSASend"
   c_WSASend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
 foreign import CALLCONV unsafe "WSASendTo"
   c_WSASendTo :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr sa -> CInt -> Ptr () -> Ptr () -> IO CInt
-foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
-  c_recvmsg_mio :: 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
-## if __IO_MANAGER_WINIO__ >= 2
-foreign import CALLCONV unsafe "WSARecvMsg"
-  c_recvmsg_winio :: CSocket -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
-## endif
+
+-- Winsock can leave the control buffer pointing at garbage once the
+-- message was truncated, so clear it.  The C wrapper around WSARecvMsg
+-- used to do this.
+clearCtrlOnTruncation :: Ptr (MsgHdr sa) -> CInt -> IO ()
+clearCtrlOnTruncation msgHdrPtr ret = when (ret == -1) $ do
+    err <- c_WSAGetLastError
+    when (err == #{const WSAEMSGSIZE}) $ do
+        (#poke WSAMSG, Control.len) msgHdrPtr (0 :: Word32)
+        (#poke WSAMSG, Control.buf) msgHdrPtr (nullPtr :: Ptr Word8)
 
 sendBufMsgMIO :: Socket -> CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt
-sendBufMsgMIO s fd msgHdrPtr cflags =
+sendBufMsgMIO s fd msgHdrPtr cflags = do
+  sendMsg <- mkSendMsgSafe <$> getWSASendMsg fd
   throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $
     alloca $ \send_ptr ->
-      c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr
+      sendMsg fd (castPtr msgHdrPtr) (fromIntegral cflags) send_ptr nullPtr nullPtr
 
 ## if __IO_MANAGER_WINIO__ >= 2
 sendBufMsgWinIO :: CSocket -> Ptr (MsgHdr sa) -> CInt -> IO CInt
-sendBufMsgWinIO fd msgHdrPtr cflags =
+sendBufMsgWinIO fd msgHdrPtr cflags = do
+  sendMsg <- mkSendMsgUnsafe <$> getWSASendMsg fd
   fmap fromIntegral $ Mgr.withException "sendBufMsg" $
     Mgr.withOverlapped "sendBufMsg" (wordPtrToPtr $ fromIntegral fd) 0
       (\lpOverlapped -> do
-        ret <- c_sendmsg fd msgHdrPtr (fromIntegral cflags) nullPtr
+        ret <- sendMsg fd (castPtr msgHdrPtr) (fromIntegral cflags) nullPtr
                  (castPtr lpOverlapped) nullPtr
         if ret == 0
           then return Mgr.CbPending
@@ -564,30 +578,41 @@ sendBufMsgWinIO fd msgHdrPtr cflags =
 
 -- Helper functions for recvBufMsg on Windows
 recvBufMsgMIO :: Socket -> CSocket -> Ptr (MsgHdr sa) -> IO Int
-recvBufMsgMIO s fd msgHdrPtr = alloca $ \len_ptr -> do
-    _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmsg" $
-            c_recvmsg_mio fd msgHdrPtr len_ptr nullPtr nullPtr
-    fromIntegral <$> peek len_ptr
+recvBufMsgMIO s fd msgHdrPtr = do
+    recvMsg <- mkRecvMsgSafe <$> getWSARecvMsg fd
+    alloca $ \len_ptr -> do
+      _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmsg" $ do
+              ret <- recvMsg fd (castPtr msgHdrPtr) len_ptr nullPtr nullPtr
+              clearCtrlOnTruncation msgHdrPtr ret
+              return ret
+      fromIntegral <$> peek len_ptr
 
 ## if __IO_MANAGER_WINIO__ >= 2
 recvBufMsgWinIO :: CSocket -> Ptr (MsgHdr sa) -> IO Int
 recvBufMsgWinIO fd msgHdrPtr = do
     -- Perform async WSARecvMsg using withOverlapped
     -- (socket already associated in socket creation)
+    recvMsg <- mkRecvMsgUnsafe <$> getWSARecvMsg fd
     fmap fromIntegral $ Mgr.withException "recvMsg" $
-      Mgr.withOverlapped "recvMsg" (wordPtrToPtr $ fromIntegral fd) 0 startCB completionCB
+      Mgr.withOverlapped "recvMsg" (wordPtrToPtr $ fromIntegral fd) 0 (startCB recvMsg) completionCB
   where
-    startCB :: Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
-    startCB lpOverlapped = do
-        ret <- c_recvmsg_winio fd msgHdrPtr nullPtr (castPtr lpOverlapped) nullPtr
+    startCB :: WSARecvMsgFn -> Mgr.LPOVERLAPPED -> IO (Mgr.CbResult Int)
+    startCB recvMsg lpOverlapped = do
+        ret <- recvMsg fd (castPtr msgHdrPtr) nullPtr (castPtr lpOverlapped) nullPtr
+        clearCtrlOnTruncation msgHdrPtr ret
         -- 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
+            -- An overlapped socket queues a completion packet even when
+            -- the call succeeds synchronously, so let the I/O manager
+            -- resolve it.  CbDone Nothing makes it read an OVERLAPPED
+            -- that may not be filled in yet, which surfaces as a
+            -- spurious EOF.
+            then return Mgr.CbPending
             else if err == _ERROR_IO_PENDING
                 then return Mgr.CbPending
                 else return $ Mgr.CbError (fromIntegral err)

Network/Socket/ByteString/IO.hsc

@@ -58,6 +58,9 @@ import System.Posix.Types (Fd(..))
 
 import Network.Socket.Flag
 import Network.Socket.SockAddr (annotateWithSocket)
+#if defined(mingw32_HOST_OS)
+import Network.Socket.Win32.Load
+#endif
 
 #if !defined(mingw32_HOST_OS)
 import Network.Socket.Posix.Cmsg
@@ -216,11 +219,12 @@ sendManyTo s cs addr = sendManyTo' `annotateWithSocket` (s, Nothing)
                 , msgCtrlLen   = 0
                 , msgFlags     = 0
                 }
-          withFdSocket s $ \fd ->
+          withFdSocket s $ \fd -> do
+              sendMsg <- mkSendMsgSafe <$> getWSASendMsg fd
               with msgHdr $ \msgHdrPtr ->
                 alloca $ \send_ptr -> do
                   _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $
-                          c_sendmsg fd msgHdrPtr 0 send_ptr nullPtr nullPtr
+                          sendMsg fd (castPtr msgHdrPtr) 0 send_ptr nullPtr nullPtr
                   peek send_ptr
 #endif
 

Network/Socket/ByteString/Internal.hs

@@ -14,11 +14,11 @@ module Network.Socket.ByteString.Internal
       mkInvalidRecvArgError
 #if !defined(mingw32_HOST_OS)
     , c_writev
+    , c_sendmsg
+    , c_recvmsg
 #else
     , c_wsasend
 #endif
-    , c_sendmsg
-    , c_recvmsg
     ) where
 
 #include "HsNetDef.h"
@@ -39,7 +39,6 @@ import Foreign.C.Types
 import Foreign.Ptr
 
 import Network.Socket.Win32.WSABuf (WSABuf)
-import Network.Socket.Win32.MsgHdr (MsgHdr)
 import Network.Socket.Types
 
 type DWORD   = Word32
@@ -64,8 +63,6 @@ foreign import ccall unsafe "recvmsg"
   -- fixme Handle for SOCKET, see #426
 foreign import CALLCONV SAFE_ON_WIN "WSASend"
   c_wsasend :: CSocket -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt
-foreign import CALLCONV SAFE_ON_WIN "WSASendMsg"
-  c_sendmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr ()  -> IO CInt
-foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
-  c_recvmsg :: CSocket -> Ptr (MsgHdr SockAddr) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
+-- WSASendMsg and WSARecvMsg are extension functions and cannot be
+-- imported by name; see Network.Socket.Win32.Load.
 #endif

Network/Socket/Win32/Load.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE CPP #-}
+
+-- | Lazily loading Winsock extension functions.
+--
+-- Winsock does not export @WSASendMsg@ and @WSARecvMsg@ as ordinary
+-- symbols.  They have to be looked up at run time with @WSAIoctl@ and
+-- @SIO_GET_EXTENSION_FUNCTION_POINTER@, which needs a live socket.  The
+-- resulting pointer is process-wide, so it is fetched once and cached.
+--
+-- Doing the lookup here rather than in C is what lets the WinIO path
+-- issue the call itself and hand it to @withOverlapped@.
+module Network.Socket.Win32.Load (
+    -- * Generic loader
+    Loaded(..)
+  , loadExtensionFunction
+    -- * WSASendMsg and WSARecvMsg
+  , WSASendMsgFn
+  , WSARecvMsgFn
+  , getWSASendMsg
+  , getWSARecvMsg
+  , mkSendMsgSafe
+  , mkRecvMsgSafe
+#if __IO_MANAGER_WINIO__ >= 2
+  , mkSendMsgUnsafe
+  , mkRecvMsgUnsafe
+#endif
+  ) where
+
+#include "HsNetDef.h"
+
+import Control.Concurrent.STM
+import Control.Exception (onException)
+import System.IO.Unsafe (unsafePerformIO)
+
+import Network.Socket.Imports
+import Network.Socket.Internal (throwSocketError)
+import Network.Socket.Types (CSocket)
+
+type DWORD   = Word32
+type LPDWORD = Ptr DWORD
+
+-- | Cache state of a lazily loaded extension function.
+data Loaded a = Unloaded | Loading | Loaded a
+
+-- | Look an extension function up once and cache it.  A concurrent
+-- caller waits for the in-flight lookup instead of issuing a redundant
+-- @WSAIoctl@.  On failure the cache is reset so that a later call, which
+-- may have a usable socket, can try again.
+loadExtensionFunction
+    :: TVar (Loaded (FunPtr a))
+    -- ^ Cache shared by all sockets.
+    -> (CSocket -> IO (FunPtr a))
+    -- ^ The C side loader, returning a null pointer on failure.
+    -> String
+    -- ^ Function name, for the error message.
+    -> CSocket
+    -> IO (FunPtr a)
+loadExtensionFunction var load fname s = do
+    mfp <- atomically $ do
+        st <- readTVar var
+        case st of
+            Unloaded  -> do
+                writeTVar var Loading
+                return Nothing
+            Loading   -> retry
+            Loaded fp -> return $ Just fp
+    case mfp of
+        Just fp -> return fp
+        Nothing -> load' `onException` atomically (writeTVar var Unloaded)
+  where
+    load' = do
+        fp <- load s
+        when (fp == nullFunPtr) $
+            throwSocketError $ "Network.Socket: cannot load " ++ fname
+        atomically $ writeTVar var $ Loaded fp
+        return fp
+
+-- The message header is kept as @Ptr ()@ so that one cache serves every
+-- socket address type; callers cast it.
+type WSASendMsgFn = CSocket -> Ptr () -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
+type WSARecvMsgFn = CSocket -> Ptr () -> LPDWORD -> Ptr () -> Ptr () -> IO CInt
+
+foreign import ccall unsafe "loadWSASendMsg"
+  c_loadWSASendMsg :: CSocket -> IO (FunPtr WSASendMsgFn)
+foreign import ccall unsafe "loadWSARecvMsg"
+  c_loadWSARecvMsg :: CSocket -> IO (FunPtr WSARecvMsgFn)
+
+-- | MIO blocks inside the call and so needs a safe wrapper.
+foreign import CALLCONV SAFE_ON_WIN "dynamic"
+  mkSendMsgSafe :: FunPtr WSASendMsgFn -> WSASendMsgFn
+foreign import CALLCONV SAFE_ON_WIN "dynamic"
+  mkRecvMsgSafe :: FunPtr WSARecvMsgFn -> WSARecvMsgFn
+
+#if __IO_MANAGER_WINIO__ >= 2
+-- | WinIO returns immediately, so the unsafe wrapper is the right one.
+foreign import CALLCONV unsafe "dynamic"
+  mkSendMsgUnsafe :: FunPtr WSASendMsgFn -> WSASendMsgFn
+foreign import CALLCONV unsafe "dynamic"
+  mkRecvMsgUnsafe :: FunPtr WSARecvMsgFn -> WSARecvMsgFn
+#endif
+
+sendMsgCache :: TVar (Loaded (FunPtr WSASendMsgFn))
+sendMsgCache = unsafePerformIO $ newTVarIO Unloaded
+{-# NOINLINE sendMsgCache #-}
+
+recvMsgCache :: TVar (Loaded (FunPtr WSARecvMsgFn))
+recvMsgCache = unsafePerformIO $ newTVarIO Unloaded
+{-# NOINLINE recvMsgCache #-}
+
+getWSASendMsg :: CSocket -> IO (FunPtr WSASendMsgFn)
+getWSASendMsg = loadExtensionFunction sendMsgCache c_loadWSASendMsg "WSASendMsg"
+
+getWSARecvMsg :: CSocket -> IO (FunPtr WSARecvMsgFn)
+getWSARecvMsg = loadExtensionFunction recvMsgCache c_loadWSARecvMsg "WSARecvMsg"