Finish windows implementation

Author: Mistuke

Network/Socket.hs

@@ -140,6 +140,7 @@ module Network.Socket
                   ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo
                   ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo)
     , isSupportedSocketOption
+    , whenSupported
     , getSocketOption
     , setSocketOption
     , getSockOpt

Network/Socket/Buffer.hsc

@@ -267,9 +267,17 @@ recvBufMsg s bufsizs clen flags = do
               , msgBuffer    = wsaBPtr
               , msgBufferLen = fromIntegral wsaBLen
 #endif
+#if !defined(mingw32_HOST_OS)
               , msgCtrl    = castPtr ctrlPtr
+#else
+              , msgCtrl    = if clen == 0 then nullPtr else castPtr ctrlPtr
+#endif
               , msgCtrlLen = fromIntegral clen
+#if !defined(mingw32_HOST_OS)
               , msgFlags   = 0
+#else
+              , msgFlags   = fromIntegral $ fromMsgFlag flags
+#endif
               }
             _cflags = fromMsgFlag flags
         withFdSocket s $ \fd -> do
@@ -280,7 +288,7 @@ recvBufMsg s bufsizs clen flags = do
                       c_recvmsg fd msgHdrPtr _cflags
 #else
                 alloca $ \len_ptr -> do
-                    _ <- throwSocketErrorWaitRead s "Network.Socket.Buffer.recvmg" $
+                    _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmg" $
                             c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr
                     peek len_ptr
 #endif

Network/Socket/Internal.hs

@@ -34,12 +34,14 @@ module Network.Socket.Internal
     , throwSocketErrorIfMinus1Retry
     , throwSocketErrorIfMinus1Retry_
     , throwSocketErrorIfMinus1RetryMayBlock
+    , throwSocketErrorIfMinus1ButRetry
 
     -- ** Guards that wait and retry if the operation would block
     -- | These guards are based on 'throwSocketErrorIfMinus1RetryMayBlock'.
     -- They wait for socket readiness if the action fails with @EWOULDBLOCK@
     -- or similar.
     , throwSocketErrorWaitRead
+    , throwSocketErrorWaitReadBut
     , throwSocketErrorWaitWrite
 
     -- * Initialization
@@ -134,16 +136,37 @@ throwSocketErrorIfMinus1RetryMayBlock
 {-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
         :: String -> IO b -> IO CInt -> IO CInt #-}
 
+
+-- | Throw an 'IOError' corresponding to the current socket error if
+-- the IO action returns a result of @-1@, but retries in case of an
+-- interrupted operation.  Checks for operations that would block and
+-- executes an alternative action before retrying in that case.  If the error
+-- is one handled by the exempt filter then ignore it and return the errorcode.
+throwSocketErrorIfMinus1RetryMayBlockBut
+    :: (Eq a, Num a)
+    => (CInt -> Bool) -- ^ exception exempt filter
+    -> String         -- ^ textual description of the location
+    -> IO b           -- ^ action to execute before retrying if an
+                      --   immediate retry would block
+    -> IO a           -- ^ the 'IO' operation to be executed
+    -> IO a
+
+{-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock
+        :: String -> IO b -> IO CInt -> IO CInt #-}
+
 #if defined(mingw32_HOST_OS)
 
 throwSocketErrorIfMinus1RetryMayBlock name _ act
   = throwSocketErrorIfMinus1Retry name act
 
+throwSocketErrorIfMinus1RetryMayBlockBut exempt name _ act
+  = throwSocketErrorIfMinus1ButRetry exempt name act
+
 throwSocketErrorIfMinus1_ name act = do
   _ <- throwSocketErrorIfMinus1Retry name act
   return ()
 
-throwSocketErrorIfMinus1Retry name act = do
+throwSocketErrorIfMinus1ButRetry exempt name act = do
   r <- act
   if (r == -1)
    then do
@@ -155,7 +178,9 @@ throwSocketErrorIfMinus1Retry name act = do
            then throwSocketError name
            else return r'
       else
-        throwSocketError name
+        if (exempt rc)
+          then return r
+          else throwSocketError name
    else return r
 
 throwSocketErrorCode name rc = do
@@ -177,6 +202,9 @@ foreign import ccall unsafe "getWSErrorDescr"
 throwSocketErrorIfMinus1RetryMayBlock name on_block act =
     throwErrnoIfMinus1RetryMayBlock name act on_block
 
+throwSocketErrorIfMinus1RetryMayBlockBut _exempt name on_block act =
+    throwErrnoIfMinus1RetryMayBlock name act on_block
+
 throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry
 
 throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_
@@ -188,6 +216,9 @@ throwSocketErrorCode loc errno =
 
 #endif
 
+throwSocketErrorIfMinus1Retry
+  = throwSocketErrorIfMinus1ButRetry (const False)
+
 -- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
 -- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready,
 -- and try again.
@@ -196,6 +227,15 @@ throwSocketErrorWaitRead s name io = withFdSocket s $ \fd ->
     throwSocketErrorIfMinus1RetryMayBlock name
       (threadWaitRead $ fromIntegral fd) io
 
+-- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
+-- @EWOULDBLOCK@ or similar, wait for the socket to be read-ready,
+-- and try again.  If it fails with the error the user was expecting then
+-- ignore the error
+throwSocketErrorWaitReadBut :: (Eq a, Num a) => (CInt -> Bool) -> Socket -> String -> IO a -> IO a
+throwSocketErrorWaitReadBut exempt s name io = withFdSocket s $ \fd ->
+    throwSocketErrorIfMinus1RetryMayBlockBut exempt name
+      (threadWaitRead $ fromIntegral fd) io
+
 -- | Like 'throwSocketErrorIfMinus1Retry', but if the action fails with
 -- @EWOULDBLOCK@ or similar, wait for the socket to be write-ready,
 -- and try again.

Network/Socket/Options.hsc

@@ -16,6 +16,7 @@ module Network.Socket.Options (
                 ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo
                 ,RecvIPv6HopLimit,RecvIPv6TClass,RecvIPv6PktInfo)
   , isSupportedSocketOption
+  , whenSupported
   , getSocketType
   , getSocketOption
   , setSocketOption
@@ -289,6 +290,13 @@ instance Storable StructLinger where
         (#poke struct linger, l_linger) p linger
 #endif
 
+-- | Executes the given action and ignoring the result only when the specified
+-- socket option is valid.
+whenSupported :: SocketOption -> IO a -> IO ()
+whenSupported s action
+  | isSupportedSocketOption s = action >> return ()
+  | otherwise                 = return ()
+
 -- | Set a socket option that expects an Int value.
 -- There is currently no API to set e.g. the timeval socket options
 setSocketOption :: Socket

Network/Socket/Win32/Cmsg.hsc

@@ -41,11 +41,11 @@ pattern CmsgIdIPv6HopLimit = CmsgId (#const IPPROTO_IPV6) (#const IPV6_HOPLIMIT)
 
 -- | The identifier for 'IPv4TOS'.
 pattern CmsgIdIPv4TOS :: CmsgId
-pattern CmsgIdIPv4TOS = CmsgId (#const IPPROTO_IP) (#const IP_RECVTOS)
+pattern CmsgIdIPv4TOS = CmsgId (#const IPPROTO_IP) (#const IP_TOS)
 
 -- | The identifier for 'IPv6TClass'.
 pattern CmsgIdIPv6TClass :: CmsgId
-pattern CmsgIdIPv6TClass = CmsgId (#const IPPROTO_IPV6) (#const IPV6_RECVTCLASS)
+pattern CmsgIdIPv6TClass = CmsgId (#const IPPROTO_IPV6) (#const IPV6_TCLASS)
 
 -- | The identifier for 'IPv4PktInfo'.
 pattern CmsgIdIPv4PktInfo :: CmsgId

Network/Socket/Win32/CmsgHdr.hsc

@@ -72,16 +72,21 @@ parseCmsgs msgptr = do
     loop ptr build
       | ptr == nullPtr = return $ build []
       | otherwise = do
-            cmsg <- fromCmsgHdr ptr
-            nextPtr <- c_cmsg_nxthdr msgptr ptr
-            loop nextPtr (build . (cmsg :))
-
-fromCmsgHdr :: Ptr CmsgHdr -> IO Cmsg
+            val <- fromCmsgHdr ptr
+            case val of
+              Nothing -> return $ build []
+              Just cmsg -> do
+                nextPtr <- c_cmsg_nxthdr msgptr ptr
+                loop nextPtr (build . (cmsg :))
+
+fromCmsgHdr :: Ptr CmsgHdr -> IO (Maybe Cmsg)
 fromCmsgHdr ptr = do
     CmsgHdr len lvl typ <- peek ptr
     src <- c_cmsg_data ptr
     let siz = fromIntegral len - (src `minusPtr` ptr)
-    Cmsg (CmsgId lvl typ) <$> create (fromIntegral siz) (\dst -> memcpy dst src siz)
+    if siz < 0
+      then return Nothing
+      else Just . Cmsg (CmsgId lvl typ) <$> create (fromIntegral siz) (\dst -> memcpy dst src siz)
 
 foreign import ccall unsafe "cmsg_firsthdr"
   c_cmsg_firsthdr :: Ptr (MsgHdr sa) -> IO (Ptr CmsgHdr)

Network/Socket/Win32/MsgHdr.hsc

@@ -25,7 +25,7 @@ data MsgHdr sa = MsgHdr
     , msgCtrl      :: !(Ptr Word8)
     , msgCtrlLen   :: !ULONG
     , msgFlags     :: !DWORD
-    }
+    } deriving Show
 
 instance Storable (MsgHdr sa) where
   sizeOf      = const #{size WSAMSG}

cbits/cmsg.c

@@ -62,8 +62,17 @@ WSARecvMsg (SOCKET s, LPWSAMSG lpMsg, LPDWORD lpdwNumberOfBytesRecvd,
       return -1;
   }
 
-  return ptr_RecvMsg (s, lpMsg, lpdwNumberOfBytesRecvd, lpOverlapped,
-                      lpCompletionRoutine);
+  int res = ptr_RecvMsg (s, lpMsg, lpdwNumberOfBytesRecvd, lpOverlapped,
+                         lpCompletionRoutine);
+
+  /*  If the msg was truncated then this pointer can be garbage.  */
+  if (res == SOCKET_ERROR && GetLastError () == WSAEMSGSIZE)
+     {
+        lpMsg->Control.len = 0;
+        lpMsg->Control.buf = NULL;
+     }
+
+  return res;
 }
 #else
 struct cmsghdr *cmsg_firsthdr(struct msghdr *mhdr) {

include/win32defs.h

@@ -114,4 +114,7 @@
 #endif
 #ifndef IP_RECVERR
 #define IP_RECVERR                75 // Receive ICMP errors.
+#endif
+#ifndef IPV6_TCLASS
+#define IPV6_TCLASS 39
 #endif

tests/Network/Socket/ByteStringSpec.hs

@@ -229,39 +229,46 @@ spec = do
 
         it "receives control messages for IPv4" $ do
             let server sock = do
-                    setSocketOption sock RecvIPv4TTL 1
-                    setSocketOption sock RecvIPv4TOS 1
-                    setSocketOption sock RecvIPv4PktInfo 1
+                    whenSupported RecvIPv4TTL     $ setSocketOption sock RecvIPv4TTL 1
+                    whenSupported RecvIPv4TOS     $ setSocketOption sock RecvIPv4TOS 1
+                    whenSupported RecvIPv4PktInfo $ setSocketOption sock RecvIPv4PktInfo 1
                     (_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty
 
-                    ((lookupCmsg CmsgIdIPv4TTL cmsgs >>= decodeCmsg) :: Maybe IPv4TTL) `shouldNotBe` Nothing
-                    ((lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS) `shouldNotBe` Nothing
-                    ((lookupCmsg CmsgIdIPv4PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv4PktInfo) `shouldNotBe` Nothing
+                    whenSupported RecvIPv4TTL $
+                      ((lookupCmsg CmsgIdIPv4TTL cmsgs >>= decodeCmsg) :: Maybe IPv4TTL) `shouldNotBe` Nothing
+                    whenSupported RecvIPv4TOS $
+                      ((lookupCmsg CmsgIdIPv4TOS cmsgs >>= decodeCmsg) :: Maybe IPv4TOS) `shouldNotBe` Nothing
+                    whenSupported RecvIPv4PktInfo $
+                      ((lookupCmsg CmsgIdIPv4PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv4PktInfo) `shouldNotBe` Nothing
                 client sock addr = sendTo sock seg addr
 
                 seg = C.pack "This is a test message"
             udpTest client server
 
         it "receives control messages for IPv6" $ do
             let server sock = do
-                    setSocketOption sock RecvIPv6HopLimit 1
-                    setSocketOption sock RecvIPv6TClass 1
-                    setSocketOption sock RecvIPv6PktInfo 1
+                    whenSupported RecvIPv6HopLimit $ setSocketOption sock RecvIPv6HopLimit 1
+                    whenSupported RecvIPv6TClass   $ setSocketOption sock RecvIPv6TClass 1
+                    whenSupported RecvIPv6PktInfo  $ setSocketOption sock RecvIPv6PktInfo 1
                     (_, _, cmsgs, _) <- recvMsg sock 1024 128 mempty
 
-                    ((lookupCmsg CmsgIdIPv6HopLimit cmsgs >>= decodeCmsg) :: Maybe IPv6HopLimit) `shouldNotBe` Nothing
-                    ((lookupCmsg CmsgIdIPv6TClass cmsgs >>= decodeCmsg) :: Maybe IPv6TClass) `shouldNotBe` Nothing
-                    ((lookupCmsg CmsgIdIPv6PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv6PktInfo) `shouldNotBe` Nothing
+
+                    whenSupported RecvIPv6HopLimit $
+                      ((lookupCmsg CmsgIdIPv6HopLimit cmsgs >>= decodeCmsg) :: Maybe IPv6HopLimit) `shouldNotBe` Nothing
+                    whenSupported RecvIPv6TClass $
+                      ((lookupCmsg CmsgIdIPv6TClass cmsgs >>= decodeCmsg) :: Maybe IPv6TClass) `shouldNotBe` Nothing
+                    whenSupported RecvIPv6PktInfo $
+                      ((lookupCmsg CmsgIdIPv6PktInfo cmsgs >>= decodeCmsg) :: Maybe IPv6PktInfo) `shouldNotBe` Nothing
                 client sock addr = sendTo sock seg addr
 
                 seg = C.pack "This is a test message"
             udpTest6 client server
 
         it "receives truncated control messages" $ do
             let server sock = do
-                    setSocketOption sock RecvIPv4TTL 1
-                    setSocketOption sock RecvIPv4TOS 1
-                    setSocketOption sock RecvIPv4PktInfo 1
+                    whenSupported RecvIPv4TTL     $ setSocketOption sock RecvIPv4TTL 1
+                    whenSupported RecvIPv4TOS     $ setSocketOption sock RecvIPv4TOS 1
+                    whenSupported RecvIPv4PktInfo $ setSocketOption sock RecvIPv4PktInfo 1
                     (_, _, _, flags) <- recvMsg sock 1024 10 mempty
                     flags .&. MSG_CTRUNC `shouldBe` MSG_CTRUNC