network 3.2.11.0 → 3.2.12.0
raw patch · 21 files changed
+1133/−106 lines, 21 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Network.Socket: connectWith :: Socket -> SockAddr -> STM a -> IO (Either a ())
+ Network.Socket: isPortUnreachableError :: IOException -> Bool
+ Network.Socket: recvBufMsgWith :: Socket -> [(Ptr Word8, Int)] -> Int -> MsgFlag -> STM a -> IO (Either a (SockAddr, Int, [Cmsg], MsgFlag))
+ Network.Socket: sendBufMsgWith :: Socket -> SockAddr -> [(Ptr Word8, Int)] -> [Cmsg] -> MsgFlag -> STM a -> IO (Either a Int)
+ Network.Socket: sendBufToWith :: Socket -> Ptr a -> Int -> SockAddr -> STM b -> IO (Either b Int)
+ Network.Socket: sendBufWith :: Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a Int)
+ Network.Socket: unsafeGracefulClose :: Socket -> Int -> IO ()
+ Network.Socket: withWritable :: Socket -> STM a -> IO b -> IO (Either a b)
+ Network.Socket.Address: connectWith :: SocketAddress sa => Socket -> sa -> STM a -> IO (Either a ())
+ Network.Socket.Address: recvBufFromWith :: SocketAddress sa => Socket -> Ptr a -> Int -> STM b -> IO (Either b (Int, sa))
+ Network.Socket.Address: recvBufMsgWith :: SocketAddress sa => Socket -> [(Ptr Word8, Int)] -> Int -> MsgFlag -> STM a -> IO (Either a (sa, Int, [Cmsg], MsgFlag))
+ Network.Socket.Address: sendBufMsgWith :: SocketAddress sa => Socket -> sa -> [(Ptr Word8, Int)] -> [Cmsg] -> MsgFlag -> STM a -> IO (Either a Int)
+ Network.Socket.Address: sendBufToWith :: SocketAddress sa => Socket -> Ptr a -> Int -> sa -> STM b -> IO (Either b Int)
+ Network.Socket.Address: sendToWith :: SocketAddress sa => Socket -> ByteString -> sa -> STM a -> IO (Either a Int)
+ Network.Socket.ByteString: recvMsgWith :: Socket -> Int -> Int -> MsgFlag -> STM a -> IO (Either a (SockAddr, ByteString, [Cmsg], MsgFlag))
+ Network.Socket.ByteString: sendAllWith :: Socket -> ByteString -> STM a -> IO (Either a ())
+ Network.Socket.ByteString: sendManyWith :: Socket -> [ByteString] -> STM a -> IO (Either a ())
+ Network.Socket.ByteString: sendMsgWith :: Socket -> SockAddr -> [ByteString] -> [Cmsg] -> MsgFlag -> STM a -> IO (Either a Int)
+ Network.Socket.ByteString: sendToWith :: Socket -> ByteString -> SockAddr -> STM a -> IO (Either a Int)
+ Network.Socket.ByteString: sendWith :: Socket -> ByteString -> STM a -> IO (Either a Int)
+ Network.Socket.ByteString.Lazy: recvWith :: Socket -> Int64 -> STM a -> IO (Either a ByteString)
+ Network.Socket.ByteString.Lazy: sendAllWith :: Socket -> ByteString -> STM a -> IO (Either a ())
+ Network.Socket.ByteString.Lazy: sendWith :: Socket -> ByteString -> STM a -> IO (Either a Int64)
- Network.Socket: recvBufFromWith :: SocketAddress sa => Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a (Int, sa))
+ Network.Socket: recvBufFromWith :: SocketAddress sa => Socket -> Ptr a -> Int -> STM b -> IO (Either b (Int, sa))
Files
- CHANGELOG.md +13/−0
- Network/Socket.hs +20/−2
- Network/Socket/Address.hs +6/−0
- Network/Socket/Buffer.hsc +109/−23
- Network/Socket/ByteString.hs +13/−0
- Network/Socket/ByteString/IO.hsc +125/−22
- Network/Socket/ByteString/Internal.hs +4/−0
- Network/Socket/ByteString/Lazy.hs +43/−0
- Network/Socket/Shutdown.hs +13/−1
- Network/Socket/SockAddr.hs +34/−0
- Network/Socket/Syscall.hs +33/−10
- Network/Socket/Unix.hsc +27/−18
- Network/Socket/Wait.hs +160/−10
- Network/Socket/Win32/Cancel.hs +23/−4
- cbits/overlapped.c +164/−0
- configure +61/−0
- include/HsNet.h +15/−0
- network.cabal +3/−2
- tests/Network/Socket/ByteString/LazySpec.hs +30/−0
- tests/Network/Socket/ByteStringSpec.hs +125/−1
- tests/Network/SocketSpec.hs +112/−13
CHANGELOG.md view
@@ -1,5 +1,18 @@ # CHANGELOG for network +## Version 3.2.12.0++* Add unsafeGracefulClose and recvMsgWith+* Return the bytes sent from sendMsg on Windows+* Add withWritable, connectWith and the send functions which the caller can give up on+* Raise the error which the first read of recvWith meets, rather than dropping it and waiting+* Add recvBufMsgWith, sendBufMsgWith, the give-up functions of Network.Socket.Address and of Network.Socket.ByteString.Lazy+* On Windows, giving up on an operation no longer cancels other threads' operations on the socket+* recvBufFromWith takes Ptr a, as recvBufFrom does+* Emulate socketPair with TCP over loopback on Windows+ [#630](https://github.com/haskell/network/pull/630)+* Add isPortUnreachableError+ ## Version 3.2.11.0 * Add unsafeClose
Network/Socket.hs view
@@ -131,6 +131,7 @@ close', unsafeClose, gracefulClose,+ unsafeGracefulClose, shutdown, ShutdownCmd (..), @@ -405,13 +406,20 @@ -- ** Giving up on a blocked operation withReadable,+ withWritable, acceptWith,+ connectWith, recvBufWith, recvBufFromWith,+ sendBufWith,+ sendBufToWith,+ sendBufMsgWith,+ recvBufMsgWith, -- ** What a given-up operation can fail with isClosedSocketError, isTransientAcceptError,+ isPortUnreachableError, -- ** Waiting for readiness (POSIX only) waitReadSocketSTM,@@ -457,8 +465,11 @@ recvBufFromWith, isClosedSocketError, isTransientAcceptError,+ isPortUnreachableError, recvBufWith,+ sendBufWith, withReadable,+ withWritable, ) #if !defined(mingw32_HOST_OS) import Network.Socket.Posix.Cmsg@@ -476,6 +487,9 @@ -- caller gave up and 'Right' when the operation completed, and an -- operation which has completed wins a tie. They are for one reader at -- a time, and 'withReadable' says what else they ask of the caller.+-- 'withWritable', 'connectWith', 'sendBufWith' and 'sendBufToWith' do the+-- same for writing, one writer at a time; a stream given up on in the+-- middle of a send is to be closed. -- -- The other two ways are going away or gone. A close ends a wait only -- because the event manager tells the waiter so, which 'GHC.Conc.closeFdWith'@@ -506,5 +520,9 @@ -- one could be started. The four readiness functions say so rather than -- blocking for good, and what runs there instead is the operation itself, -- on a thread of its own, cancelled with @CancelIoEx@ when the caller--- gives up. "Network.Socket.ByteString" has @recvWith@ and--- @recvFromWith@ for 'Data.ByteString.ByteString'.+-- gives up. Those for particular operations cancel their own alone,+-- and another thread's operation on the socket carries on; the action+-- given to 'withReadable' or 'withWritable' cannot be told apart, so its+-- cancel ends every operation pending on the socket.+-- "Network.Socket.ByteString" has @recvWith@ and @recvFromWith@ for+-- 'Data.ByteString.ByteString'.
Network/Socket/Address.hs view
@@ -7,6 +7,7 @@ -- * Socket operations connect,+ connectWith, bind, accept, acceptWith,@@ -14,17 +15,22 @@ -- * Sending and receiving ByteString sendTo, sendAllTo,+ sendToWith, recvFrom, recvWith, recvFromWith, -- * Sending and receiving data from a buffer sendBufTo,+ sendBufToWith, recvBufFrom,+ recvBufFromWith, -- * Advanced IO sendBufMsg,+ sendBufMsgWith, recvBufMsg,+ recvBufMsgWith, ) where import Network.Socket.Buffer
Network/Socket/Buffer.hsc view
@@ -11,14 +11,19 @@ , recvBufFrom , recvBuf , recvBufNoWait+ , recvBufNoWaitOr , sendBufMsg , recvBufMsg+ , sendBufToOv+ , sendBufOv+ , recvBufFromOv+ , recvBufOv+ , sendBufMsgOv+ , recvBufMsgOv ) where #if !defined(mingw32_HOST_OS) import Foreign.C.Error (getErrno, eAGAIN, eWOULDBLOCK)-#else-import Foreign.Ptr (nullPtr) #endif import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Marshal.Utils (with)@@ -57,14 +62,25 @@ -> Int -- Data to send -> sa -> IO Int -- Number of Bytes sent-sendBufTo s ptr nbytes sa =+sendBufTo = sendBufToOv nullPtr++-- | 'sendBufTo' issued with an OVERLAPPED on Windows, unless it is+-- 'nullPtr', so that cancelling it reaches nothing else. The+-- OVERLAPPED is ignored elsewhere. So are the others ending in @Ov@.+sendBufToOv :: SocketAddress sa => Ptr () -> Socket -> Ptr a -> Int -> sa -> IO Int+sendBufToOv _ov s ptr nbytes sa = withSocketAddress sa $ \p_sa siz -> fromIntegral <$> do withFdSocket s $ \fd -> do let sz = fromIntegral siz n = fromIntegral nbytes flags = 0 throwSocketErrorWaitWrite s "Network.Socket.sendBufTo" $- c_sendto fd ptr n flags p_sa sz+#if defined(mingw32_HOST_OS)+ if _ov /= nullPtr+ then c_ovl_sendto fd (castPtr ptr) (fromIntegral nbytes) (castPtr p_sa) sz _ov+ else+#endif+ c_sendto fd ptr n flags p_sa sz #if defined(mingw32_HOST_OS) socket2FD :: Socket -> IO FD@@ -81,8 +97,17 @@ -> Ptr Word8 -- Pointer to the data to send -> Int -- Length of the buffer -> IO Int -- Number of Bytes sent-sendBuf s str len = fromIntegral <$> do+sendBuf = sendBufOv nullPtr++-- | 'sendBuf' issued with an OVERLAPPED: see 'sendBufToOv'.+sendBufOv :: Ptr () -> Socket -> Ptr Word8 -> Int -> IO Int+sendBufOv _ov s str len = fromIntegral <$> do #if defined(mingw32_HOST_OS)+ if _ov /= nullPtr then+ withFdSocket s $ \fd ->+ throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $+ c_ovl_send fd (castPtr str) (fromIntegral len) _ov+ else do -- 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@@ -112,7 +137,11 @@ -- NOTE: blocking on Windows unless you compile with -threaded (see -- GHC ticket #1129) recvBufFrom :: SocketAddress sa => Socket -> Ptr a -> Int -> IO (Int, sa)-recvBufFrom s ptr nbytes+recvBufFrom = recvBufFromOv nullPtr++-- | 'recvBufFrom' issued with an OVERLAPPED: see 'sendBufToOv'.+recvBufFromOv :: SocketAddress sa => Ptr () -> Socket -> Ptr a -> Int -> IO (Int, sa)+recvBufFromOv _ov s ptr nbytes | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") | otherwise = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> withFdSocket s $ \fd -> do@@ -120,6 +149,11 @@ let cnbytes = fromIntegral nbytes flags = 0 len <- throwSocketErrorWaitRead s "Network.Socket.recvBufFrom" $+#if defined(mingw32_HOST_OS)+ if _ov /= nullPtr+ then c_ovl_recvfrom fd (castPtr ptr) (fromIntegral nbytes) (castPtr ptr_sa) ptr_len _ov+ else+#endif c_recvfrom fd ptr cnbytes flags ptr_sa ptr_len sockaddr <- peekSocketAddress ptr_sa `catchIOError` \_ -> getPeerName s@@ -138,8 +172,17 @@ -- EOF. Historical note: Version 2.8.x.y or earlier, -- an EOF error was thrown. This was changed in version 3.0. recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int-recvBuf s ptr nbytes+recvBuf = recvBufOv nullPtr++-- | 'recvBuf' issued with an OVERLAPPED: see 'sendBufToOv'.+recvBufOv :: Ptr () -> Socket -> Ptr Word8 -> Int -> IO Int+recvBufOv _ov s ptr nbytes | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf")+#if defined(mingw32_HOST_OS)+ | _ov /= nullPtr = withFdSocket s $ \fd -> fromIntegral <$>+ throwSocketErrorWaitRead s "Network.Socket.recvBuf"+ (c_ovl_recv fd (castPtr ptr) (fromIntegral nbytes) _ov)+#endif | otherwise = do #if defined(mingw32_HOST_OS) -- see comment in sendBuf above.@@ -162,23 +205,34 @@ -- -- @since 3.2.9.0 recvBufNoWait :: Socket -> Ptr Word8 -> Int -> IO Int-recvBufNoWait s ptr nbytes = withFdSocket s $ \fd -> do+recvBufNoWait = recvBufNoWaitOr $ return (-2)++-- | 'recvBufNoWait' which runs the action on an error, in place of+-- answering -2. The error is gone from the socket once read, so this+-- is where to raise it.+recvBufNoWaitOr :: IO CInt -> Socket -> Ptr Word8 -> Int -> IO Int+recvBufNoWaitOr onError s ptr nbytes = withFdSocket s $ \fd -> do #if defined(mingw32_HOST_OS) alloca $ \ptr_bytes -> do res <- c_ioctlsocket fd #{const FIONREAD} ptr_bytes avail <- peek ptr_bytes- r <- if res == #{const NO_ERROR} && avail > 0 then- c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-}+ let failed = do+ err <- c_WSAGetLastError+ if err == #{const WSAEWOULDBLOCK}+ || err == #{const WSAEINPROGRESS} then+ return (-1)+ else+ onError+ r <- if res == #{const NO_ERROR} && avail > 0 then do+ -- A pending error, such as an ICMP unreachable, counts as+ -- something to read, and recv takes it.+ n <- c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-}+ if n == -1 then failed else return n else if avail == 0 then -- Socket would block, could also mean socket is closed but -- can't distinguish return (-1)- else do err <- c_WSAGetLastError- if err == #{const WSAEWOULDBLOCK}- || err == #{const WSAEINPROGRESS} then- return (-1)- else- return (-2)+ else failed return $ fromIntegral r #else@@ -190,7 +244,7 @@ if err == eAGAIN || err == eWOULDBLOCK then return (-1) else- return (-2)+ fromIntegral <$> onError #endif mkInvalidRecvArgError :: String -> IOError@@ -206,7 +260,12 @@ -> [Cmsg] -- ^ Control messages -> MsgFlag -- ^ Message flags -> IO Int -- ^ The length actually sent-sendBufMsg s sa bufsizs cmsgs flags = do+sendBufMsg = sendBufMsgOv nullPtr++-- | 'sendBufMsg' issued with an OVERLAPPED: see 'sendBufToOv'.+sendBufMsgOv :: SocketAddress sa+ => Ptr () -> Socket -> sa -> [(Ptr Word8,Int)] -> [Cmsg] -> MsgFlag -> IO Int+sendBufMsgOv _ov s sa bufsizs cmsgs flags = do sz <- withSocketAddress sa $ \addrPtr addrSize -> #if !defined(mingw32_HOST_OS) withIOVec bufsizs $ \(iovsPtr, iovsLen) -> do@@ -231,12 +290,17 @@ cflags = fromMsgFlag flags withFdSocket s $ \fd -> with msgHdr $ \msgHdrPtr ->- throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $ #if !defined(mingw32_HOST_OS)+ throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $ c_sendmsg fd msgHdrPtr cflags #else- alloca $ \send_ptr ->- c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr+ -- WSASendMsg returns 0 and puts the bytes sent here.+ alloca $ \send_ptr -> do+ _ <- throwSocketErrorWaitWrite s "Network.Socket.Buffer.sendMsg" $+ if _ov /= nullPtr+ then c_ovl_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr _ov+ else c_sendmsg fd msgHdrPtr (fromIntegral cflags) send_ptr nullPtr nullPtr+ peek send_ptr #endif return $ fromIntegral sz @@ -254,7 +318,12 @@ -- 'MSG_CTRUNC' is returned -> MsgFlag -- ^ Message flags -> IO (sa,Int,[Cmsg],MsgFlag) -- ^ Source address, total bytes received, control messages and message flags-recvBufMsg s bufsizs clen flags = do+recvBufMsg = recvBufMsgOv nullPtr++-- | 'recvBufMsg' issued with an OVERLAPPED: see 'sendBufToOv'.+recvBufMsgOv :: SocketAddress sa+ => Ptr () -> Socket -> [(Ptr Word8,Int)] -> Int -> MsgFlag -> IO (sa,Int,[Cmsg],MsgFlag)+recvBufMsgOv _ov s bufsizs clen flags = do withNewSocketAddress $ \addrPtr addrSize -> allocaBytes clen $ \ctrlPtr -> #if !defined(mingw32_HOST_OS)@@ -289,7 +358,9 @@ #else alloca $ \len_ptr -> do _ <- throwSocketErrorWaitReadBut (== #{const WSAEMSGSIZE}) s "Network.Socket.Buffer.recvmsg" $- c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr+ if _ov /= nullPtr+ then c_ovl_recvmsg fd msgHdrPtr len_ptr _ov+ else c_recvmsg fd msgHdrPtr len_ptr nullPtr nullPtr peek len_ptr #endif sockaddr <- peekSocketAddress addrPtr `catchIOError` \_ -> getPeerName s@@ -315,6 +386,21 @@ c_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg" c_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> Ptr () -> IO CInt++-- Each waits for the operation it issues with the OVERLAPPED given, so+-- they are safe calls, and are run where the wait can be given up on.+foreign import ccall safe "hsnet_ovl_recv"+ c_ovl_recv :: CInt -> Ptr CChar -> CInt -> Ptr () -> IO CInt+foreign import ccall safe "hsnet_ovl_send"+ c_ovl_send :: CInt -> Ptr CChar -> CInt -> Ptr () -> IO CInt+foreign import ccall safe "hsnet_ovl_recvfrom"+ c_ovl_recvfrom :: CInt -> Ptr CChar -> CInt -> Ptr () -> Ptr CInt -> Ptr () -> IO CInt+foreign import ccall safe "hsnet_ovl_sendto"+ c_ovl_sendto :: CInt -> Ptr CChar -> CInt -> Ptr () -> CInt -> Ptr () -> IO CInt+foreign import ccall safe "hsnet_ovl_sendmsg"+ c_ovl_sendmsg :: CInt -> Ptr (MsgHdr sa) -> DWORD -> LPDWORD -> Ptr () -> IO CInt+foreign import ccall safe "hsnet_ovl_recvmsg"+ c_ovl_recvmsg :: CInt -> Ptr (MsgHdr sa) -> LPDWORD -> Ptr () -> IO CInt #endif foreign import ccall unsafe "recv"
Network/Socket/ByteString.hs view
@@ -22,12 +22,16 @@ sendAll, sendTo, sendAllTo,+ sendWith,+ sendAllWith,+ sendToWith, -- ** Vectored I/O -- $vectored sendMany, sendManyTo, sendManyWithFds,+ sendManyWith, -- * Receive data from a socket recv,@@ -37,7 +41,9 @@ -- * Advanced send and recv sendMsg,+ sendMsgWith, recvMsg,+ recvMsgWith, ) where import Control.Concurrent.STM (STM)@@ -48,6 +54,7 @@ recvFromWith, sendAllTo, sendTo,+ sendToWith, ) import qualified Network.Socket.ByteString.IO as G import Network.Socket.Types@@ -104,3 +111,9 @@ recvFromWith :: Socket -> Int -> STM a -> IO (Either a (ByteString, SockAddr)) recvFromWith = G.recvFromWith++-- | 'sendTo' which the caller can give up on.+--+-- @since 3.2.12.0+sendToWith :: Socket -> ByteString -> SockAddr -> STM a -> IO (Either a Int)+sendToWith = G.sendToWith
Network/Socket/ByteString/IO.hsc view
@@ -19,22 +19,28 @@ , sendAll , sendTo , sendAllTo+ , sendWith+ , sendAllWith+ , sendToWith -- ** Vectored I/O -- $vectored , sendMany , sendManyTo , sendManyWithFds+ , sendManyWith -- * Receive data from a socket , recv , recvFrom , recvWith , recvFromWith+ , recvMsgWith , waitWhen0 -- * Advanced send and recv , sendMsg+ , sendMsgWith , recvMsg , MsgFlag(..) , Cmsg(..)@@ -83,9 +89,14 @@ send :: Socket -- ^ Connected socket -> ByteString -- ^ Data to send -> IO Int -- ^ Number of bytes sent-send s xs = unsafeUseAsCStringLen xs $ \(str, len) ->- sendBuf s (castPtr str) len+send = sendOv nullPtr +-- The give-ups below issue their operations with an OVERLAPPED of their+-- own on Windows, through these: see 'Network.Socket.Buffer.sendBufToOv'.+sendOv :: Ptr () -> Socket -> ByteString -> IO Int+sendOv ov s xs = unsafeUseAsCStringLen xs $ \(str, len) ->+ sendBufOv ov s (castPtr str) len+ waitWhen0 :: Int -> Socket -> IO () waitWhen0 0 s = when rtsSupportsBoundThreads $ withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd@@ -108,6 +119,35 @@ waitWhen0 sent s when (sent /= B.length bs) $ loop $ B.drop sent bs +-- | 'send' which the caller can give up on. See+-- 'Network.Socket.withWritable' for what is left of the stream after+-- giving up.+--+-- @since 3.2.12.0+sendWith :: Socket -> ByteString -> STM a -> IO (Either a Int)+sendWith s xs giveUp = withWritableOv s giveUp $ \ov -> sendOv ov s xs++-- | 'sendAll' which the caller can give up on. Part of the data may+-- have been sent before it gives up, so a stream given up on is to be+-- closed.+--+-- @since 3.2.12.0+sendAllWith :: Socket -> ByteString -> STM a -> IO (Either a ())+sendAllWith _ "" _ = return $ Right ()+sendAllWith s bs giveUp = do+ r <- sendWith s bs giveUp+ case r of+ Left a -> return $ Left a+ Right sent -> sendAllWith s (B.drop sent bs) giveUp++-- | 'sendTo' which the caller can give up on.+--+-- @since 3.2.12.0+sendToWith+ :: SocketAddress sa+ => Socket -> ByteString -> sa -> STM a -> IO (Either a Int)+sendToWith s xs sa giveUp = withWritableOv s giveUp $ \ov -> sendToOv ov s xs sa+ -- | Send data to the socket. The recipient can be specified -- explicitly, so the socket need not be in a connected state. -- Returns the number of bytes sent. Applications are responsible for@@ -117,9 +157,12 @@ -> ByteString -- ^ Data to send -> sa -- ^ Recipient address -> IO Int -- ^ Number of bytes sent-sendTo s xs sa =- unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo s str len sa+sendTo = sendToOv nullPtr +sendToOv :: SocketAddress sa => Ptr () -> Socket -> ByteString -> sa -> IO Int+sendToOv ov s xs sa =+ unsafeUseAsCStringLen xs $ \(str, len) -> sendBufToOv ov s str len sa+ -- | Send data to the socket. The recipient can be specified -- explicitly, so the socket need not be in a connected state. Unlike -- 'sendTo', this function continues to send data until either all@@ -151,11 +194,16 @@ -> IO () sendMany _ [] = return () sendMany s cs = do- sent <- sendManyInner+ sent <- sendManyOnce s cs waitWhen0 sent s when (sent >= 0) $ sendMany s $ remainingChunks sent cs- where- sendManyInner =++-- One gathering write, which may send only part of the data.+sendManyOnce :: Socket -> [ByteString] -> IO Int+sendManyOnce = sendManyOnceOv nullPtr++sendManyOnceOv :: Ptr () -> Socket -> [ByteString] -> IO Int+sendManyOnceOv _ov s cs = #if !defined(mingw32_HOST_OS) fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> withFdSocket s $ \fd -> do@@ -166,12 +214,27 @@ fmap fromIntegral . withWSABuffromBS cs $ \(wsabsPtr, wsabsLen) -> withFdSocket s $ \fd -> do let len = fromIntegral wsabsLen- alloca $ \send_ptr -> do- _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $- c_wsasend fd wsabsPtr len send_ptr 0 nullPtr nullPtr- peek send_ptr+ if _ov /= nullPtr+ then throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $+ c_ovl_sendv fd wsabsPtr len _ov+ else alloca $ \send_ptr -> do+ _ <- throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $+ c_wsasend fd wsabsPtr len send_ptr 0 nullPtr nullPtr+ fromIntegral <$> peek send_ptr #endif +-- | 'sendMany' which the caller can give up on. Parts may have been+-- sent before it gives up, so a stream given up on is to be closed.+--+-- @since 3.2.12.0+sendManyWith :: Socket -> [ByteString] -> STM a -> IO (Either a ())+sendManyWith _ [] _ = return $ Right ()+sendManyWith s cs giveUp = do+ r <- withWritableOv s giveUp $ \ov -> sendManyOnceOv ov s cs+ case r of+ Left a -> return $ Left a+ Right sent -> sendManyWith s (remainingChunks sent cs) giveUp+ -- | Send data to the socket. The recipient can be specified -- explicitly, so the socket need not be in a connected state. The -- data is sent as if the parts have been concatenated. This function@@ -263,8 +326,11 @@ -> IO ByteString -- ^ Data received recv s nbytes | nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv")- | otherwise = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes+ | otherwise = recvOv nullPtr s nbytes +recvOv :: Ptr () -> Socket -> Int -> IO ByteString+recvOv ov s nbytes = createAndTrim nbytes $ \ptr -> recvBufOv ov s ptr nbytes+ -- | Receive data from the socket. The socket need not be in a -- connected state. Returns @(bytes, address)@ where @bytes@ is a -- 'ByteString' representing the data received and @address@ is a@@ -275,9 +341,12 @@ Socket -- ^ Socket -> Int -- ^ Maximum number of bytes to receive -> IO (ByteString, sa) -- ^ Data received and sender address-recvFrom sock nbytes =+recvFrom = recvFromOv nullPtr++recvFromOv :: SocketAddress sa => Ptr () -> Socket -> Int -> IO (ByteString, sa)+recvFromOv ov sock nbytes = allocaBytes nbytes $ \ptr -> do- (len, sockaddr) <- recvBufFrom sock ptr nbytes+ (len, sockaddr) <- recvBufFromOv ov sock ptr nbytes str <- B.packCStringLen (ptr, len) return (str, sockaddr) @@ -294,10 +363,11 @@ | nbytes < 0 = ioError $ mkInvalidRecvArgError "Network.Socket.ByteString.recvWith" | otherwise = do- bs <- createAndTrim' nbytes $ \ptr -> recvBufNoWait s ptr nbytes+ bs <- createAndTrim' nbytes $ \ptr ->+ recvBufNoWaitOr (throwSocketError "Network.Socket.ByteString.recvWith") s ptr nbytes case bs of Just b -> return $ Right b- Nothing -> withReadable s giveUp $ recv s nbytes+ Nothing -> withReadableOv s giveUp $ \ov -> recvOv ov s nbytes -- | 'recvFrom' which the caller can give up on. --@@ -308,7 +378,7 @@ -> Int -> STM a -> IO (Either a (ByteString, sa))-recvFromWith s nbytes giveUp = withReadable s giveUp $ recvFrom s nbytes+recvFromWith s nbytes giveUp = withReadableOv s giveUp $ \ov -> recvFromOv ov s nbytes -- A read which never waits: 'Nothing' when nothing is there yet. createAndTrim' :: Int -> (Ptr Word8 -> IO Int) -> IO (Maybe ByteString)@@ -368,10 +438,27 @@ -> [Cmsg] -- ^ Control messages -> MsgFlag -- ^ Message flags -> IO Int -- ^ The length actually sent-sendMsg _ _ [] _ _ = return 0-sendMsg s addr bss cmsgs flags = withBufSizs bss $ \bufsizs ->- sendBufMsg s addr bufsizs cmsgs flags+sendMsg = sendMsgOv nullPtr +sendMsgOv :: Ptr () -> Socket -> SockAddr -> [ByteString] -> [Cmsg] -> MsgFlag -> IO Int+sendMsgOv _ _ _ [] _ _ = return 0+sendMsgOv ov s addr bss cmsgs flags = withBufSizs bss $ \bufsizs ->+ sendBufMsgOv ov s addr bufsizs cmsgs flags++-- | 'sendMsg' which the caller can give up on.+--+-- @since 3.2.12.0+sendMsgWith+ :: Socket+ -> SockAddr+ -> [ByteString]+ -> [Cmsg]+ -> MsgFlag+ -> STM a+ -> IO (Either a Int)+sendMsgWith s addr bss cmsgs flags giveUp =+ withWritableOv s giveUp $ \ov -> sendMsgOv ov s addr bss cmsgs flags+ -- | Receive data from the socket using recvmsg(2). recvMsg :: Socket -- ^ Socket -> Int -- ^ The maximum length of data to be received@@ -382,11 +469,27 @@ -- 'MSG_CTRUNC' is returned -> MsgFlag -- ^ Message flags -> IO (SockAddr, ByteString, [Cmsg], MsgFlag) -- ^ Source address, received data, control messages and message flags-recvMsg s siz clen flags = do+recvMsg = recvMsgOv nullPtr++recvMsgOv :: Ptr () -> Socket -> Int -> Int -> MsgFlag -> IO (SockAddr, ByteString, [Cmsg], MsgFlag)+recvMsgOv ov s siz clen flags = do bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz) withForeignPtr fptr $ \ptr -> do- (addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags+ (addr,len,cmsgs,flags') <- recvBufMsgOv ov s [(ptr,siz)] clen flags let bs' | len < siz = PS fptr 0 len | otherwise = bs return (addr, bs', cmsgs, flags')++-- | 'recvMsg' which the caller can give up on.+--+-- @since 3.2.12.0+recvMsgWith+ :: Socket+ -> Int+ -> Int+ -> MsgFlag+ -> STM a+ -> IO (Either a (SockAddr, ByteString, [Cmsg], MsgFlag))+recvMsgWith s siz clen flags giveUp =+ withReadableOv s giveUp $ \ov -> recvMsgOv ov s siz clen flags
Network/Socket/ByteString/Internal.hs view
@@ -16,6 +16,7 @@ , c_writev #else , c_wsasend+ , c_ovl_sendv #endif , c_sendmsg , c_recvmsg@@ -64,6 +65,9 @@ -- fixme Handle for SOCKET, see #426 foreign import CALLCONV SAFE_ON_WIN "WSASend" c_wsasend :: CInt -> Ptr WSABuf -> DWORD -> LPDWORD -> DWORD -> Ptr () -> Ptr () -> IO CInt+-- WSASend with an OVERLAPPED of the caller's, waited for in the call.+foreign import ccall safe "hsnet_ovl_sendv"+ c_ovl_sendv :: CInt -> Ptr WSABuf -> DWORD -> Ptr () -> IO CInt foreign import CALLCONV SAFE_ON_WIN "WSASendMsg" c_sendmsg :: CInt -> Ptr (MsgHdr SockAddr) -> DWORD -> LPDWORD -> Ptr () -> Ptr () -> IO CInt foreign import CALLCONV SAFE_ON_WIN "WSARecvMsg"
Network/Socket/ByteString/Lazy.hs view
@@ -24,12 +24,16 @@ send, sendAll, sendWithFds,+ sendWith,+ sendAllWith, -- * Receive data from a socket getContents, recv,+ recvWith, ) where +import Control.Concurrent.STM (STM) import Data.ByteString.Lazy.Internal ( ByteString (..), defaultChunkSize,@@ -51,6 +55,9 @@ import qualified Network.Socket.ByteString as N import Network.Socket.Imports import Network.Socket.Types+#if !defined(mingw32_HOST_OS)+import Network.Socket.Wait (withWritable)+#endif -- | Send data and file descriptors over a UNIX-domain socket in -- a single system call. This function does not work on Windows.@@ -64,6 +71,32 @@ -> IO () sendWithFds s lbs fds = N.sendManyWithFds s (L.toChunks lbs) fds +-- | 'send' which the caller can give up on. See+-- 'Network.Socket.withWritable' for what is left of the stream after+-- giving up.+--+-- @since 3.2.12.0+sendWith :: Socket -> ByteString -> STM a -> IO (Either a Int64)+#if defined(mingw32_HOST_OS)+-- 'send' sends the first chunk here, and so does this, through the+-- strict one, whose give-up cancels its own operation alone.+sendWith s lbs giveUp = fmap fromIntegral <$> N.sendWith s chunk giveUp+ where+ chunk = case L.toChunks lbs of+ [] -> S.empty+ x : _ -> x+#else+sendWith s lbs giveUp = withWritable s giveUp $ send s lbs+#endif++-- | 'sendAll' which the caller can give up on. Part of the data may+-- have been sent before it gives up, so a stream given up on is to be+-- closed.+--+-- @since 3.2.12.0+sendAllWith :: Socket -> ByteString -> STM a -> IO (Either a ())+sendAllWith s lbs = N.sendManyWith s (L.toChunks lbs)+ -- ----------------------------------------------------------------------------- -- Receiving @@ -106,6 +139,16 @@ -> IO ByteString -- ^ Data received recv s nbytes = chunk <$> N.recv s (fromIntegral nbytes)+ where+ chunk k+ | S.null k = Empty+ | otherwise = Chunk k Empty++-- | 'recv' which the caller can give up on.+--+-- @since 3.2.12.0+recvWith :: Socket -> Int64 -> STM a -> IO (Either a ByteString)+recvWith s nbytes giveUp = fmap chunk <$> N.recvWith s (fromIntegral nbytes) giveUp where chunk k | S.null k = Empty
Network/Socket/Shutdown.hs view
@@ -7,6 +7,7 @@ ShutdownCmd(..) , shutdown , gracefulClose+ , unsafeGracefulClose ) where import Control.Concurrent (rtsSupportsBoundThreads, yield)@@ -50,7 +51,18 @@ -- -- Since: 3.1.1.0 gracefulClose :: Socket -> Int -> IO ()-gracefulClose s tmout0 = sendRecvFIN `E.finally` close s+gracefulClose = gracefulCloseWith close++-- | 'gracefulClose' which ends with 'unsafeClose' rather than 'close',+-- for a caller which knows that no other thread is waiting on the+-- socket. The wait for the peer's FIN is this thread's own.+--+-- @since 3.2.12.0+unsafeGracefulClose :: Socket -> Int -> IO ()+unsafeGracefulClose = gracefulCloseWith unsafeClose++gracefulCloseWith :: (Socket -> IO ()) -> Socket -> Int -> IO ()+gracefulCloseWith closer s tmout0 = sendRecvFIN `E.finally` closer s where sendRecvFIN = do -- Sending TCP FIN.
Network/Socket/SockAddr.hs view
@@ -4,13 +4,17 @@ getPeerName, getSocketName, connect,+ connectWith, bind, accept, acceptWith, sendBufTo,+ sendBufToWith, recvBufFrom, sendBufMsg, recvBufMsg,+ sendBufMsgWith,+ recvBufMsgWith, ) where import Control.Concurrent.STM (STM)@@ -43,6 +47,14 @@ connect :: Socket -> SockAddr -> IO () connect = G.connect +-- | 'connect' which the caller can give up on. Whichever settles+-- first decides: 'Left' when the 'STM' action fires, 'Right' when the+-- connection is made. A socket given up on is to be closed.+--+-- @since 3.2.12.0+connectWith :: Socket -> SockAddr -> STM a -> IO (Either a ())+connectWith = G.connectWith+ -- | Bind the socket to an address. The socket must not already be -- bound. The 'Family' passed to @bind@ must be the -- same as that passed to 'socket'. If the special port number@@ -93,6 +105,12 @@ sendBufTo :: Socket -> Ptr a -> Int -> SockAddr -> IO Int sendBufTo = G.sendBufTo +-- | 'sendBufTo' which the caller can give up on.+--+-- @since 3.2.12.0+sendBufToWith :: Socket -> Ptr a -> Int -> SockAddr -> STM b -> IO (Either b Int)+sendBufToWith = G.sendBufToWith+ -- | Receive data from the socket, writing it into buffer instead of -- creating a new string. The socket need not be in a connected -- state. Returns @(nbytes, address)@ where @nbytes@ is the number of@@ -141,3 +159,19 @@ -> IO (SockAddr, Int, [Cmsg], MsgFlag) -- ^ Source address, received data, control messages and message flags recvBufMsg = G.recvBufMsg++-- | 'sendBufMsg' which the caller can give up on.+--+-- @since 3.2.12.0+sendBufMsgWith+ :: Socket -> SockAddr -> [(Ptr Word8, Int)] -> [Cmsg] -> MsgFlag -> STM a+ -> IO (Either a Int)+sendBufMsgWith = G.sendBufMsgWith++-- | 'recvBufMsg' which the caller can give up on.+--+-- @since 3.2.12.0+recvBufMsgWith+ :: Socket -> [(Ptr Word8, Int)] -> Int -> MsgFlag -> STM a+ -> IO (Either a (SockAddr, Int, [Cmsg], MsgFlag))+recvBufMsgWith = G.recvBufMsgWith
Network/Socket/Syscall.hs view
@@ -4,6 +4,7 @@ module Network.Socket.Syscall where +import Data.Either (isRight) import Foreign.Marshal.Utils (with) import qualified Control.Exception as E # if defined(mingw32_HOST_OS)@@ -172,29 +173,51 @@ -- | Connect to a remote socket at address. connect :: SocketAddress sa => Socket -> sa -> IO ()-connect s sa = withSocketsDo $ withSocketAddress sa $ \p_sa sz -> do- connectLoop s p_sa (fromIntegral sz)- reportConnReset s True+connect s sa = void (connectWhenWritable s sa waitWrite :: IO (Either () ()))+ where+#if defined(mingw32_HOST_OS)+ waitWrite act = Right <$> act+#else+ waitWrite act = do+ withFdSocket s $ threadWaitWrite . fromIntegral+ Right <$> act+#endif -connectLoop :: SocketAddress sa => Socket -> Ptr sa -> CInt -> IO ()-connectLoop s p_sa sz = withFdSocket s $ \fd -> loop fd+-- | 'connect' which leaves the wait for a connection in progress to+-- the caller: the argument runs the action once the socket is writable.+connectWhenWritable+ :: SocketAddress sa+ => Socket -> sa -> (IO () -> IO (Either a ())) -> IO (Either a ())+connectWhenWritable s sa whenWritable =+ withSocketsDo $ withSocketAddress sa $ \p_sa sz -> do+ r <- connectLoop s p_sa (fromIntegral sz) whenWritable+ when (isRight r) $ reportConnReset s True+ return r++connectLoop+ :: SocketAddress sa+ => Socket -> Ptr sa -> CInt -> (IO () -> IO (Either a ())) -> IO (Either a ())+#if defined(mingw32_HOST_OS)+connectLoop s p_sa sz _ = withFdSocket s $ \fd -> loop fd+#else+connectLoop s p_sa sz whenWritable = withFdSocket s $ \fd -> loop fd+#endif where errLoc = "Network.Socket.connect: " ++ show s loop fd = do r <- c_connect fd p_sa sz- when (r == -1) $ do+ if r /= -1 then return (Right ()) else do #if defined(mingw32_HOST_OS) throwSocketError errLoc #else err <- getErrno case () of _ | err == eINTR -> loop fd- _ | err == eINPROGRESS -> connectBlocked--- _ | err == eAGAIN -> connectBlocked+ _ | err == eINPROGRESS -> whenWritable connected+-- _ | err == eAGAIN -> whenWritable connected _otherwise -> throwSocketError errLoc - connectBlocked = do- withFdSocket s $ threadWaitWrite . fromIntegral+ connected = do err <- getSocketOption s SoError when (err /= 0) $ throwSocketErrorCode errLoc (fromIntegral err) #endif
Network/Socket/Unix.hsc view
@@ -22,11 +22,11 @@ import System.Posix.Types (Fd(..)) #if defined(mingw32_HOST_OS)+import qualified Control.Exception as E+import Network.Socket.Name (getSocketName)+import Network.Socket.Options import Network.Socket.Syscall import Network.Socket.Win32.Cmsg-import System.Directory-import System.IO-import System.IO.Temp #else import Foreign.Marshal.Array (peekArray) import Network.Socket.Internal@@ -156,26 +156,35 @@ dummyBufSize = 16 -- | Build a pair of connected socket objects.--- On Windows, this function emulates socketpair() using--- 'AF_UNIX' and a temporary file will remain.+-- On Windows, this function emulates socketpair() with a TCP connection+-- over the loopback interface, whatever the arguments are: there an+-- 'AF_UNIX' recv may miss the peer's close and wait for ever. socketPair :: Family -- Family Name (usually AF_UNIX) -> SocketType -- Socket Type (usually Stream) -> ProtocolNumber -- Protocol Number -> IO (Socket, Socket) -- unnamed and connected. #if defined(mingw32_HOST_OS)-socketPair _ _ _ = withSystemTempFile "temp-for-pair" $ \file hdl -> do- hClose hdl- removeFile file- listenSock <- socket AF_UNIX Stream defaultProtocol- bind listenSock $ SockAddrUnix file- listen listenSock 10- clientSock <- socket AF_UNIX Stream defaultProtocol- connect clientSock $ SockAddrUnix file- (serverSock, _ :: SockAddr) <- accept listenSock- close listenSock- withFdSocket clientSock setNonBlockIfNeeded- withFdSocket serverSock setNonBlockIfNeeded- return (clientSock, serverSock)+socketPair _ _ _ =+ E.bracket (socket AF_INET Stream defaultProtocol) close $ \listenSock -> do+ bind listenSock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1)+ listen listenSock 10+ addr :: SockAddr <- getSocketName listenSock+ E.bracketOnError (socket AF_INET Stream defaultProtocol) close $ \clientSock -> do+ connect clientSock addr+ me :: SockAddr <- getSocketName clientSock+ serverSock <- acceptFrom listenSock me+ mapM_ prepare [clientSock, serverSock]+ return (clientSock, serverSock)+ where+ -- Another process may connect to the port first; it is not our peer.+ acceptFrom listenSock me = do+ (sock, peer) <- accept listenSock+ if peer == me+ then return sock+ else close sock >> acceptFrom listenSock me+ prepare sock = do+ setSocketOption sock NoDelay 1+ withFdSocket sock setNonBlockIfNeeded #else socketPair family stype protocol = allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do
Network/Socket/Wait.hs view
@@ -18,11 +18,20 @@ -- the one which would have given up, and nothing returns at all. module Network.Socket.Wait ( withReadable,+ withWritable,+ withReadableOv,+ withWritableOv, acceptWith, recvBufWith, recvBufFromWith,+ sendBufWith,+ sendBufToWith,+ recvBufMsgWith,+ sendBufMsgWith,+ connectWith, isClosedSocketError, isTransientAcceptError,+ isPortUnreachableError, ) where import Control.Concurrent.STM@@ -30,6 +39,9 @@ import Foreign.C.Error ( Errno (..), eCONNABORTED,+#if !defined(mingw32_HOST_OS)+ eCONNREFUSED,+#endif eHOSTDOWN, eHOSTUNREACH, eNETDOWN,@@ -48,9 +60,15 @@ #else import Network.Socket.STM #endif+import Network.Socket.Flag import Network.Socket.Imports import Network.Socket.Syscall import Network.Socket.Types+#if !defined(mingw32_HOST_OS)+import Network.Socket.Posix.Cmsg+#else+import Network.Socket.Win32.Cmsg+#endif -- | Running an action once the socket is readable, unless the 'STM' -- action fires first. The 'STM' action is also looked at before@@ -66,7 +84,11 @@ -- readiness to wait for, so the action is started at once on a thread -- of its own and the give-up cancels it with @CancelIoEx@ on this -- socket, which reaches nothing else -- an action blocked on anything--- else would never end.+-- else would never end. The cancel cannot tell the action from other+-- operations pending on the socket, so it ends those too, whichever+-- thread issued them. The give-ups for particular operations, such as+-- 'recvBufWith' and 'Network.Socket.ByteString.sendAllWith', cancel+-- their own and leave the rest alone. -- -- __One reader at a time__ is what keeps that condition. A second -- thread taking the data between the readiness and the action leaves@@ -79,7 +101,35 @@ -- looks at it once more before a read which would not block. Reading -- a 'TVar' is what it is for. withReadable :: Socket -> STM a -> IO b -> IO (Either a b)-withReadable s giveUp act = do+withReadable s giveUp act = withReady Read False s giveUp $ const act++-- | 'withReadable' for writing: running an action once the socket is+-- writable, unless the 'STM' action fires first. The same conditions+-- hold, with one writer at a time in place of one reader.+--+-- A send which is given up on may have sent part of its data on+-- Windows, where it is cancelled rather than never started, and the+-- socket cannot be sent on after that. So a stream given up on in+-- the middle of a send is to be closed.+--+-- @since 3.2.12.0+withWritable :: Socket -> STM a -> IO b -> IO (Either a b)+withWritable s giveUp act = withReady Write False s giveUp $ const act++-- | 'withReadable' for an operation which takes an OVERLAPPED: on+-- Windows it is issued with one of its own and the give-up cancels it+-- alone. 'nullPtr' is passed elsewhere.+withReadableOv :: Socket -> STM a -> (Ptr () -> IO b) -> IO (Either a b)+withReadableOv = withReady Read True++-- | 'withWritable' for an operation which takes an OVERLAPPED.+withWritableOv :: Socket -> STM a -> (Ptr () -> IO b) -> IO (Either a b)+withWritableOv = withReady Write True++data Ready = Read | Write++withReady :: Ready -> Bool -> Socket -> STM a -> (Ptr () -> IO b) -> IO (Either a b)+withReady _ready _own s giveUp act = do -- Looking at the give-up first: on Windows 'wait' starts the -- operation before it looks at any STM, and on POSIX this keeps a -- caller which has given up off a descriptor close may have freed.@@ -89,12 +139,23 @@ Nothing -> wait where #if !defined(mingw32_HOST_OS)+ -- A socket which is ready already skips the IO manager, whose round+ -- trip costs several times the operation: a send usually finds room. wait = do- (readable, cancelWait) <- waitAndCancelReadSocketSTM s+ now <- withFdSocket s $ \fd ->+ c_ready_now fd $ case _ready of+ Read -> 0+ Write -> 1+ if now /= 0 then Right <$> act nullPtr else waitIO++ waitIO = do+ (ready, cancelWait) <- case _ready of+ Read -> waitAndCancelReadSocketSTM s+ Write -> waitAndCancelWriteSocketSTM s ev <-- atomically ((Left <$> giveUp) `orElse` (Right <$> readable))+ atomically ((Left <$> giveUp) `orElse` (Right <$> ready)) `E.finally` (cancelWait `E.catch` gone)- either (return . Left) (const $ Right <$> act) ev+ either (return . Left) (const $ Right <$> act nullPtr) ev -- The cancel can throw, and from a finally that would replace the -- exception which ended the wait -- the timeout the caller is waiting@@ -103,8 +164,13 @@ gone :: E.IOException -> IO () gone _ = return () #else- wait = do- (completed, cancelAct) <- windowsViaSTM s act+ -- Only an operation issued with an OVERLAPPED of its own can be+ -- cancelled alone; any other cancel reaches the whole socket.+ wait+ | _own = withOverlapped waitOn+ | otherwise = waitOn nullPtr+ waitOn ov = do+ (completed, cancelAct) <- windowsViaSTM s ov (act ov) -- The operation wins a tie. It has already read into the -- caller's buffer by then, and answering Left would throw those -- bytes away -- which for a stream loses them for good.@@ -123,6 +189,11 @@ return $ Left a #endif +#if !defined(mingw32_HOST_OS)+foreign import ccall unsafe "hsnet_ready_now"+ c_ready_now :: CInt -> CInt -> IO CInt+#endif+ -- | 'accept' which the caller can give up on. -- -- @since 3.2.10.0@@ -133,17 +204,79 @@ -- -- @since 3.2.10.0 recvBufWith :: Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a Int)-recvBufWith s ptr nbytes giveUp = withReadable s giveUp $ recvBuf s ptr nbytes+recvBufWith s ptr nbytes giveUp =+ withReadableOv s giveUp $ \ov -> recvBufOv ov s ptr nbytes -- | 'recvBufFrom' which the caller can give up on. -- -- @since 3.2.10.0 recvBufFromWith :: SocketAddress sa- => Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a (Int, sa))+ => Socket -> Ptr a -> Int -> STM b -> IO (Either b (Int, sa)) recvBufFromWith s ptr nbytes giveUp =- withReadable s giveUp $ recvBufFrom s ptr nbytes+ withReadableOv s giveUp $ \ov -> recvBufFromOv ov s ptr nbytes +-- | 'sendBuf' which the caller can give up on. See 'withWritable' for+-- what is left of the stream after giving up.+--+-- @since 3.2.12.0+sendBufWith :: Socket -> Ptr Word8 -> Int -> STM a -> IO (Either a Int)+sendBufWith s ptr nbytes giveUp =+ withWritableOv s giveUp $ \ov -> sendBufOv ov s ptr nbytes++-- | 'sendBufTo' which the caller can give up on.+--+-- @since 3.2.12.0+sendBufToWith+ :: SocketAddress sa+ => Socket -> Ptr a -> Int -> sa -> STM b -> IO (Either b Int)+sendBufToWith s ptr nbytes sa giveUp =+ withWritableOv s giveUp $ \ov -> sendBufToOv ov s ptr nbytes sa++-- | 'recvBufMsg' which the caller can give up on.+--+-- @since 3.2.12.0+recvBufMsgWith+ :: SocketAddress sa+ => Socket+ -> [(Ptr Word8, Int)]+ -> Int+ -> MsgFlag+ -> STM a+ -> IO (Either a (sa, Int, [Cmsg], MsgFlag))+recvBufMsgWith s bufsizs clen flags giveUp =+ withReadableOv s giveUp $ \ov -> recvBufMsgOv ov s bufsizs clen flags++-- | 'sendBufMsg' which the caller can give up on.+--+-- @since 3.2.12.0+sendBufMsgWith+ :: SocketAddress sa+ => Socket+ -> sa+ -> [(Ptr Word8, Int)]+ -> [Cmsg]+ -> MsgFlag+ -> STM a+ -> IO (Either a Int)+sendBufMsgWith s sa bufsizs cmsgs flags giveUp =+ withWritableOv s giveUp $ \ov -> sendBufMsgOv ov s sa bufsizs cmsgs flags++-- | 'connect' which the caller can give up on. A socket given up on+-- may still be connecting, so it is to be closed.+--+-- @since 3.2.12.0+connectWith :: SocketAddress sa => Socket -> sa -> STM a -> IO (Either a ())+#if !defined(mingw32_HOST_OS)+connectWith s sa giveUp = do+ gaveUp <- atomically $ (Just <$> giveUp) `orElse` return Nothing+ case gaveUp of+ Just a -> return $ Left a+ Nothing -> connectWhenWritable s sa $ withWritable s giveUp+#else+connectWith s sa giveUp = withWritable s giveUp $ connect s sa+#endif+ -- | Whether this is the error a socket operation gives once the socket has -- been closed under it. --@@ -224,4 +357,21 @@ ] #else isWinsock _ = False+#endif++-- | Whether a receive on a connected datagram socket failed because an+-- 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.+--+-- @since 3.2.12.0+isPortUnreachableError :: E.IOException -> Bool+isPortUnreachableError e = ioe_errno e == Just code+ where+#if defined(mingw32_HOST_OS)+ code = wsaECONNRESET+#else+ Errno code = eCONNREFUSED #endif
Network/Socket/Win32/Cancel.hs view
@@ -17,12 +17,14 @@ module Network.Socket.Win32.Cancel ( windowsViaSTM, windowsCancelPendingIo,+ withOverlapped, ) where import Control.Concurrent (forkIO) import Control.Concurrent.STM import qualified Control.Exception as E-import Foreign.Ptr (nullPtr)+import Foreign.Marshal.Alloc (allocaBytes)+import System.IO.Unsafe (unsafePerformIO) import System.IO (hPutStrLn, stderr) import Network.Socket.Imports@@ -36,8 +38,12 @@ -- Cancelling waits for the operation to end, so a buffer it reads -- into has to stay alive until either the 'STM' action completes or -- the cancel returns.-windowsViaSTM :: Socket -> IO a -> IO (STM a, IO ())-windowsViaSTM s act = do+--+-- The cancel reaches the operation issued with the given OVERLAPPED+-- (see 'withOverlapped') and nothing else. With 'nullPtr' it reaches+-- every operation pending on the socket, whichever thread issued it.+windowsViaSTM :: Socket -> Ptr () -> IO a -> IO (STM a, IO ())+windowsViaSTM s ov act = do var <- newTVarIO Nothing -- Masked so that the var is written whatever happens: a thread -- which died between the call returning and the write would leave@@ -65,7 +71,7 @@ cancel sock ended _tid = E.uninterruptibleMask_ $ loop sayAfter where loop n = do- windowsCancelPendingIo sock+ void $ withFdSocket sock $ \fd -> c_CancelIoEx fd ov over <- endedWithin 1000 unless over $ do when (n == 1) say@@ -101,6 +107,19 @@ -- again. windowsCancelPendingIo :: Socket -> IO () windowsCancelPendingIo s = void $ withFdSocket s $ \fd -> c_CancelIoEx fd nullPtr++-- | Running an action with an OVERLAPPED of its own, to issue an+-- operation which 'windowsViaSTM' can then cancel alone. It stays+-- alive until the action returns, so the operation must end first.+withOverlapped :: (Ptr () -> IO a) -> IO a+withOverlapped = allocaBytes overlappedSize++overlappedSize :: Int+overlappedSize = fromIntegral $ unsafePerformIO c_ovl_size+{-# NOINLINE overlappedSize #-}++foreign import ccall unsafe "hsnet_ovl_size"+ c_ovl_size :: IO CInt -- BOOL CancelIoEx(HANDLE hFile, LPOVERLAPPED lpOverlapped) -- A SOCKET is a kernel HANDLE. A NULL lpOverlapped cancels all
+ cbits/overlapped.c view
@@ -0,0 +1,164 @@+/* Socket operations with an OVERLAPPED of the caller's, waited for here, so+ that CancelIoEx(s, ov) cancels this one alone. Each answers like the+ call it wraps, leaving the error for WSAGetLastError. */++#include <string.h>+#include "HsNet.h"++int+hsnet_ovl_size(void)+{+ return sizeof(OVERLAPPED);+}++/* The low bit of hEvent keeps the completion off a completion port the+ socket may be associated with. */+static int+ovl_begin(LPOVERLAPPED ov, HANDLE *ev)+{+ memset(ov, 0, sizeof(*ov));+ *ev = CreateEventW(NULL, TRUE, FALSE, NULL);+ if (*ev == NULL) {+ WSASetLastError(GetLastError());+ return SOCKET_ERROR;+ }+ ov->hEvent = (HANDLE)((ULONG_PTR)*ev | 1);+ return 0;+}++/* r is what the call answered. A pending operation is waited for, and+ then *n and *flags are what it completed with. */+static int+ovl_end(SOCKET s, LPOVERLAPPED ov, HANDLE ev, int r,+ DWORD *n, DWORD *flags, int *waited)+{+ int err = 0;+ *waited = 0;+ if (r == SOCKET_ERROR) {+ err = WSAGetLastError();+ if (err == WSA_IO_PENDING) {+ err = 0;+ *waited = 1;+ if (!WSAGetOverlappedResult(s, ov, n, TRUE, flags))+ err = WSAGetLastError();+ }+ }+ CloseHandle(ev);+ if (err != 0) {+ WSASetLastError(err);+ return SOCKET_ERROR;+ }+ return 0;+}++int+hsnet_ovl_recv(SOCKET s, char *buf, int len, LPOVERLAPPED ov)+{+ WSABUF b;+ DWORD n = 0, flags = 0;+ HANDLE ev;+ int r, waited;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ b.buf = buf;+ b.len = len;+ r = WSARecv(s, &b, 1, &n, &flags, ov, NULL);+ if (ovl_end(s, ov, ev, r, &n, &flags, &waited) != 0) return SOCKET_ERROR;+ return (int)n;+}++int+hsnet_ovl_recvfrom(SOCKET s, char *buf, int len,+ struct sockaddr *from, int *fromlen, LPOVERLAPPED ov)+{+ WSABUF b;+ DWORD n = 0, flags = 0;+ HANDLE ev;+ int r, waited;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ b.buf = buf;+ b.len = len;+ r = WSARecvFrom(s, &b, 1, &n, &flags, from, fromlen, ov, NULL);+ if (ovl_end(s, ov, ev, r, &n, &flags, &waited) != 0) return SOCKET_ERROR;+ return (int)n;+}++int+hsnet_ovl_send(SOCKET s, char *buf, int len, LPOVERLAPPED ov)+{+ WSABUF b;+ DWORD n = 0, flags = 0;+ HANDLE ev;+ int r, waited;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ b.buf = buf;+ b.len = len;+ r = WSASend(s, &b, 1, &n, 0, ov, NULL);+ if (ovl_end(s, ov, ev, r, &n, &flags, &waited) != 0) return SOCKET_ERROR;+ return (int)n;+}++int+hsnet_ovl_sendv(SOCKET s, LPWSABUF bufs, DWORD count, LPOVERLAPPED ov)+{+ DWORD n = 0, flags = 0;+ HANDLE ev;+ int r, waited;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ r = WSASend(s, bufs, count, &n, 0, ov, NULL);+ if (ovl_end(s, ov, ev, r, &n, &flags, &waited) != 0) return SOCKET_ERROR;+ return (int)n;+}++int+hsnet_ovl_sendto(SOCKET s, char *buf, int len,+ const struct sockaddr *to, int tolen, LPOVERLAPPED ov)+{+ WSABUF b;+ DWORD n = 0, flags = 0;+ HANDLE ev;+ int r, waited;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ b.buf = buf;+ b.len = len;+ r = WSASendTo(s, &b, 1, &n, 0, to, tolen, ov, NULL);+ if (ovl_end(s, ov, ev, r, &n, &flags, &waited) != 0) return SOCKET_ERROR;+ return (int)n;+}++/* Answers 0 and puts the bytes sent in *sent, as WSASendMsg does. */+int+hsnet_ovl_sendmsg(SOCKET s, LPWSAMSG msg, DWORD flags, LPDWORD sent,+ LPOVERLAPPED ov)+{+ DWORD oflags = 0;+ HANDLE ev;+ int r, waited;+ *sent = 0;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ r = WSASendMsg(s, msg, flags, sent, ov, NULL);+ return ovl_end(s, ov, ev, r, sent, &oflags, &waited);+}++/* Answers 0 and puts the bytes received in *got, as WSARecvMsg does,+ and SOCKET_ERROR with WSAEMSGSIZE for a message cut short. */+int+hsnet_ovl_recvmsg(SOCKET s, LPWSAMSG msg, LPDWORD got, LPOVERLAPPED ov)+{+ DWORD flags = 0;+ HANDLE ev;+ int r, waited;+ *got = 0;+ if (ovl_begin(ov, &ev) != 0) return SOCKET_ERROR;+ r = WSARecvMsg(s, msg, got, ov, NULL);+ r = ovl_end(s, ov, ev, r, got, &flags, &waited);+ if (waited) {+ /* Completed later: the flags come from here, not from msg. */+ msg->dwFlags = flags;+ if (r == SOCKET_ERROR && WSAGetLastError() == WSAEMSGSIZE) {+ msg->dwFlags |= MSG_TRUNC;+ msg->Control.len = 0;+ msg->Control.buf = NULL;+ }+ }+ return r;+}
configure view
@@ -685,6 +685,8 @@ ac_user_opts=' enable_option_checking with_cc+with_compiler+with_hc ' ac_precious_vars='build_alias host_alias@@ -1316,6 +1318,7 @@ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) C compiler+Haskell compiler Some influential environment variables: CC C compiler command@@ -3927,6 +3930,25 @@ +# Check whether --with-compiler was given.+if test ${with_compiler+y}+then :+ withval=$with_compiler; HC=$withval+fi+++# Check whether --with-hc was given.+if test ${with_hc+y}+then :+ withval=$with_hc; HC=$withval+fi++if test -z "$HC"+then :+ HC=ghc+fi++ { printf '%s\n' "$as_me:${as_lineno-$LINENO}: checking for an ANSI C-conforming const" >&5 printf %s "checking for an ANSI C-conforming const... " >&6; } if test ${ac_cv_c_const+y}@@ -4427,6 +4449,45 @@ { printf '%s\n' "$as_me:${as_lineno-$LINENO}: creating ./network.buildinfo" >&5 printf '%s\n' "$as_me: creating ./network.buildinfo" >&6;} echo "install-includes: HsNetworkConfig.h" > network.buildinfo++WINIO_GHC_OPTIONS=+{ printf '%s\n' "$as_me:${as_lineno-$LINENO}: checking whether to use native Windows I/O manager RTS option" >&5+printf %s "checking whether to use native Windows I/O manager RTS option... " >&6; }+case "$host_os" in+mingw*)+ cat > conftest_ghc_cpp.hs <<EOF+#if !defined(__IO_MANAGER_WINIO__) || __IO_MANAGER_WINIO__ < 2+#error __IO_MANAGER_WINIO__ < 2+#endif+module Main where+main :: IO ()+main = return ()+EOF+ if "$HC" -c -cpp -fforce-recomp conftest_ghc_cpp.hs >/dev/null 2>&1; then+ { printf '%s\n' "$as_me:${as_lineno-$LINENO}: result: yes" >&5+printf '%s\n' "yes" >&6; }+ WINIO_GHC_OPTIONS="-with-rtsopts=--io-manager=native"+ else+ { printf '%s\n' "$as_me:${as_lineno-$LINENO}: result: no, $HC does not define __IO_MANAGER_WINIO__ >= 2" >&5+printf '%s\n' "no, $HC does not define __IO_MANAGER_WINIO__ >= 2" >&6; }+ fi+ rm -f conftest_ghc_cpp.hi conftest_ghc_cpp.hs conftest_ghc_cpp.o+ ;;+*)+ { printf '%s\n' "$as_me:${as_lineno-$LINENO}: result: no, not Windows" >&5+printf '%s\n' "no, not Windows" >&6; }+ ;;+esac++if test -n "$WINIO_GHC_OPTIONS"+then :+ cat >> network.buildinfo <<EOF++test-suite spec+ ghc-options: $WINIO_GHC_OPTIONS+EOF++fi cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure
include/HsNet.h view
@@ -160,6 +160,21 @@ freeaddrinfo(ai); } +#ifndef _WIN32+#include <poll.h>++/* Whether the socket is readable (or writable) now, without waiting. */+INLINE int+hsnet_ready_now(int fd, int write)+{+ struct pollfd p;+ p.fd = fd;+ p.events = write ? POLLOUT : POLLIN;+ p.revents = 0;+ return poll(&p, 1, 0) > 0;+}+#endif+ #ifndef IOV_MAX # define IOV_MAX 1024 #endif
network.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: network-version: 3.2.11.0+version: 3.2.12.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Tamar Christina@@ -69,6 +69,7 @@ include/HsNetDef.h include/afunix_compat.h cbits/asyncAccept.c+ cbits/overlapped.c cbits/initWinSock.c cbits/winSockErr.c cbits/cmsg.c@@ -158,6 +159,7 @@ cbits/initWinSock.c cbits/winSockErr.c cbits/asyncAccept.c+ cbits/overlapped.c other-modules: Network.Socket.ByteString.Lazy.Windows@@ -178,7 +180,6 @@ cc-options: -D_WIN32_WINNT=0x0600 build-depends:- temporary, Win32 >=2.12.0.1 if impl(ghc >=8)
tests/Network/Socket/ByteString/LazySpec.hs view
@@ -5,6 +5,8 @@ import Prelude hiding (getContents) +import Control.Concurrent (threadDelay)+import Control.Concurrent.STM (STM, check, readTVar, registerDelay, retry) import Control.Monad import qualified Data.ByteString.Lazy as L import Network.Socket@@ -44,6 +46,31 @@ sendAll sock lazyTestMsg `shouldThrow` anyException tcpTest client server + describe "sendWith" $ do+ it "sends as send does" $ do+ let server sock = recv sock 1024 `shouldReturn` lazyTestMsg+ client sock = sendWith sock lazyTestMsg never `shouldReturn` Right (L.length lazyTestMsg)+ tcpTest client server++ describe "sendAllWith" $ do+ it "sends as sendAll does" $ do+ let server sock = recv sock 1024 `shouldReturn` lazyTestMsg+ client sock = sendAllWith sock lazyTestMsg never `shouldReturn` Right ()+ tcpTest client server++ describe "recvWith" $ do+ it "receives as recv does" $ do+ let server sock = recvWith sock 1024 never `shouldReturn` Right lazyTestMsg+ client sock = sendAll sock lazyTestMsg+ tcpTest client server++ it "gives up when told to, with nothing to receive" $ do+ let server sock = do+ late <- registerDelay 100000+ recvWith sock 1024 (check =<< readTVar late) `shouldReturn` Left ()+ client _ = threadDelay 500000+ tcpTest client server+ describe "getContents" $ do it "works well" $ do let server sock = getContents sock `shouldReturn` lazyTestMsg@@ -83,3 +110,6 @@ let client s = recv s 4096 `shouldReturn` L.empty server s = shutdown s ShutdownSend tcpTest client server++never :: STM ()+never = retry
tests/Network/Socket/ByteStringSpec.hs view
@@ -2,7 +2,10 @@ module Network.Socket.ByteStringSpec (main, spec) where -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryReadMVar)+import Control.Concurrent.STM (STM, check, readTVar, registerDelay, retry)+import Control.Exception (SomeException, finally, try) import Control.Monad import Data.Bits import qualified Data.ByteString as S@@ -200,6 +203,98 @@ seg2 = C.pack "test message." udpTest client server + describe "recvMsgWith" $ do+ it "receives as recvMsg does" $ do+ let server sock = do+ r <- recvMsgWith sock 1024 0 mempty retry+ case r of+ Right (_, msg, _, _) -> msg `shouldBe` seg+ Left () -> expectationFailure "gave up without being told"+ client sock addr = sendTo sock seg addr++ seg = C.pack "This is a test message"+ udpTest client server++ it "gives up when told to, with nothing to receive" $ do+ sock <- socket AF_INET Datagram defaultProtocol+ bind sock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1)+ late <- registerDelay 100000+ r <- recvMsgWith sock 1024 0 mempty $ check =<< readTVar late+ close sock+ either (const True) (const False) r `shouldBe` True++ describe "sendWith" $ do+ it "sends as send does" $ do+ let server sock = recv sock 1024 `shouldReturn` testMsg+ client sock = sendWith sock testMsg never `shouldReturn` Right (S.length testMsg)+ tcpTest client server++ describe "sendAllWith" $ do+ it "sends as sendAll does" $ do+ let server sock = recv sock 1024 `shouldReturn` testMsg+ client sock = sendAllWith sock testMsg never `shouldReturn` Right ()+ tcpTest client server++ it "gives up when the peer does not read" $ withStalledPeer $ \sock -> do+ late <- registerDelay 200000+ gaveUp (sendAllWith sock chunk $ check =<< readTVar late)+ `shouldReturn` True++ describe "giving up" $ do+ -- On Windows a give-up cancels the operation; that must not+ -- reach another thread's operation on the same socket.+ it "leaves another thread's send alone" $ withStalledPeer $ \sock -> do+ ended <- newEmptyMVar+ _ <- forkIO $ do+ r <- try $ forever $ sendAll sock chunk+ putMVar ended (r :: Either SomeException ())+ threadDelay 300000+ late <- registerDelay 200000+ r <- recvWith sock 4096 $ check =<< readTVar late+ either (const True) (const False) r `shouldBe` True+ threadDelay 300000+ isNothing <$> tryReadMVar ended `shouldReturn` True++ it "leaves another thread's recv alone" $ withStalledPeer $ \sock -> do+ ended <- newEmptyMVar+ _ <- forkIO $ do+ r <- try $ recv sock 4096+ putMVar ended (r :: Either SomeException S.ByteString)+ threadDelay 100000+ late <- registerDelay 200000+ gaveUp (sendAllWith sock chunk $ check =<< readTVar late)+ `shouldReturn` True+ threadDelay 300000+ isNothing <$> tryReadMVar ended `shouldReturn` True++ describe "sendManyWith" $ do+ it "sends as sendMany does" $ do+ let server sock = recv sock 1024 `shouldReturn` S.append seg1 seg2+ client sock = sendManyWith sock [seg1, seg2] never `shouldReturn` Right ()+ seg1 = C.pack "This is a "+ seg2 = C.pack "test message."+ tcpTest client server++ it "gives up when the peer does not read" $ withStalledPeer $ \sock -> do+ late <- registerDelay 200000+ gaveUp (sendManyWith sock [chunk, chunk] $ check =<< readTVar late)+ `shouldReturn` True++ describe "sendToWith" $ do+ it "sends as sendTo does" $ do+ let server sock = recv sock 1024 `shouldReturn` testMsg+ client sock addr =+ sendToWith sock testMsg addr never `shouldReturn` Right (S.length testMsg)+ udpTest client server++ describe "sendMsgWith" $ do+ it "sends as sendMsg does" $ do+ let server sock = recv sock 1024 `shouldReturn` testMsg+ client sock addr =+ sendMsgWith sock addr [testMsg] [] mempty never+ `shouldReturn` Right (S.length testMsg)+ udpTest client server+ describe "recvMsg" $ do it "works well" $ do let server sock = do@@ -312,3 +407,32 @@ seg = C.pack "This is a test message" udpTest client server++-- A connection whose other end never reads, with small buffers, so that+-- sending blocks once they are full.+withStalledPeer :: (Socket -> IO a) -> IO a+withStalledPeer body = do+ let localhost = tupleToHostAddress (127, 0, 0, 1)+ listener <- socket AF_INET Stream defaultProtocol+ setSocketOption listener RecvBuffer 4096+ bind listener $ SockAddrInet 0 localhost+ listen listener 1+ port <- socketPort listener+ sock <- socket AF_INET Stream defaultProtocol+ setSocketOption sock SendBuffer 4096+ connect sock $ SockAddrInet port localhost+ (peer, _) <- accept listener+ body sock `finally` mapM_ close [sock, peer, listener]++-- Sending until the action gives up, and whether it did within 1 GiB.+gaveUp :: IO (Either () ()) -> IO Bool+gaveUp send1 = loop (1024 :: Int)+ where+ loop 0 = return False+ loop n = send1 >>= either (const $ return True) (const $ loop (n - 1))++chunk :: S.ByteString+chunk = S.replicate (1024 * 1024) 0x41++never :: STM ()+never = retry
tests/Network/SocketSpec.hs view
@@ -9,6 +9,10 @@ import Control.Concurrent.STM import Control.Monad import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BU+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (castPtr) import Data.Maybe (fromJust) import Data.List (nub) import Network.Socket@@ -19,6 +23,7 @@ import System.IO.Temp (withSystemTempDirectory) import System.Posix.Types (Fd(..)) import Foreign.C.Types ()+import System.Timeout (timeout) import Test.Hspec import Test.QuickCheck@@ -29,7 +34,13 @@ -- Send through the given action to a port nobody has bound, then receive -- on the same socket. 'Nothing' if the receive heard nothing in time. bounce :: (Socket -> SockAddr -> IO ()) -> IO (Maybe ByteString)-bounce send' = do+bounce = bounceWith $ \sock giveUp -> fmap fst <$> recvFromWith sock 2048 giveUp++bounceWith+ :: (Socket -> STM () -> IO (Either () ByteString))+ -> (Socket -> SockAddr -> IO ())+ -> IO (Maybe ByteString)+bounceWith receive send' = do dead <- deadPort sock <- socket AF_INET Datagram defaultProtocol bind sock $ SockAddrInet 0 localhost@@ -37,9 +48,9 @@ -- Long enough for the unreachable to come back before the receive. waitFor 300000 late <- registerDelay 300000- r <- recvFromWith sock 2048 $ check =<< readTVar late+ r <- receive sock $ check =<< readTVar late close sock- return $ either (const Nothing) (Just . fst) r+ return $ either (const Nothing) Just r where localhost = tupleToHostAddress (127, 0, 0, 1) waitFor us = do@@ -72,6 +83,63 @@ { clientSetup = readMVar portVar >>= connect' } + describe "connectWith" $ do+ let+ hints = defaultHints { addrSocketType = Stream }+ connectWith' serverPort giveUp = do+ addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort)+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ r <- connectWith sock (addrAddress addr) giveUp+ return (sock, r)++ it "connects as connect does" $ do+ withPort $ \portVar -> test (tcp serverAddr return portVar)+ { clientSetup = do+ (sock, r) <- readMVar portVar >>= \p -> connectWith' p (retry :: STM ())+ r `shouldBe` Right ()+ return sock+ }++ it "throws as connect does" $ do+ connectWith' (8003 :: Int) (retry :: STM ()) `shouldThrow` anyIOException++ it "gives up when already told to" $ do+ (sock, r) <- connectWith' (8003 :: Int) (return ())+ close sock+ r `shouldBe` Left ()++ it "gives up on a connection which does not come" $ do+ -- Nothing answers here, unless the network says it is+ -- unreachable at once, which is not giving up but is fine.+ sock <- socket AF_INET Stream defaultProtocol+ late <- registerDelay 300000+ r <- tryIOError $ connectWith sock (SockAddrInet 9 $ tupleToHostAddress (10, 255, 255, 1)) $+ check =<< readTVar late+ close sock+ r `shouldSatisfy` either (const True) (== Left ())++ describe "sendBufMsgWith and recvBufMsgWith" $ do+ it "send and receive as sendBufMsg and recvBufMsg do" $ do+ let server sock = allocaBytes 1024 $ \buf -> do+ r <- recvBufMsgWith sock [(buf, 1024)] 0 mempty (retry :: STM ())+ case r of+ Right (_, n, _, _) ->+ BS.packCStringLen (castPtr buf, n) `shouldReturn` testMsg+ Left () -> expectationFailure "gave up without being told"+ client sock addr = BU.unsafeUseAsCStringLen testMsg $ \(p, n) ->+ sendBufMsgWith sock addr [(castPtr p, n)] [] mempty (retry :: STM ())+ `shouldReturn` Right n+ udpTest client server++ it "recvBufMsgWith gives up when told to" $ do+ sock <- socket AF_INET Datagram defaultProtocol+ bind sock $ SockAddrInet 0 $ tupleToHostAddress (127, 0, 0, 1)+ late <- registerDelay 100000+ r <- allocaBytes 1024 $ \buf ->+ recvBufMsgWith sock [(buf, 1024)] 0 mempty $ check =<< readTVar late+ close sock+ either (const True) (const False) r `shouldBe` True+ describe "bind" $ do let hints = defaultHints { addrFlags = [AI_PASSIVE]@@ -191,6 +259,25 @@ -- check if an exception is not thrown. isSupportedSockAddr addr `shouldBe` True + describe "socketPair" $ do+ it "can send and recieve bi-directionally" $ do+ (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol+ void $ send s1 testMsg+ recv s2 1024 `shouldReturn` testMsg+ void $ send s2 testMsg+ recv s1 1024 `shouldReturn` testMsg++ -- Windows' AF_UNIX pair now and then missed a close racing the+ -- recv (seen in C and the non-threaded RTS, rarely here).+ it "tells a waiting recv that the peer has closed" $+ replicateM_ 100 $ do+ (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol+ got <- newEmptyMVar+ _ <- forkIO $ recv s2 1024 >>= putMVar got+ _ <- forkIO $ close s1+ timeout 5000000 (takeMVar got) `shouldReturn` Just ""+ close s2+ #if !defined(mingw32_HOST_OS) when isUnixDomainSocketAvailable $ do context "unix sockets" $ do@@ -222,14 +309,6 @@ #endif #if !defined(mingw32_HOST_OS)- describe "socketPair" $ do- it "can send and recieve bi-directionally" $ do- (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol- void $ send s1 testMsg- recv s2 1024 `shouldReturn` testMsg- void $ send s2 testMsg- recv s1 1024 `shouldReturn` testMsg- describe "sendFd/recvFd" $ do it "can send and recieve a file descriptor" $ do (s1, s2) <- socketPair AF_UNIX Stream defaultProtocol@@ -285,18 +364,38 @@ -- Winsock hands it to every datagram socket; a reply bouncing off a -- client which has gone would then end a server's receive loop. describe "an ICMP unreachable from a send of one's own" $ do+ let connectSend sock dead = connect sock dead >> void (send sock "bounce")+ recvMsg' sock giveUp =+ fmap (\(_, bs, _, _) -> bs) <$> recvMsgWith sock 2048 0 mempty giveUp it "is not heard by a socket which was never connected" $ bounce (\sock dead -> void $ sendTo sock "bounce" dead) `shouldReturn` Nothing it "is heard by a connected one" $- bounce (\sock dead -> connect sock dead >> void (send sock "bounce"))- `shouldThrow` anyIOException+ bounce connectSend `shouldThrow` isPortUnreachableError+ it "is heard by a connected one through recv" $+ bounceWith (\sock -> recvWith sock 2048) connectSend+ `shouldThrow` isPortUnreachableError+ it "is heard by a connected one through recvMsg" $+ bounceWith recvMsg' connectSend `shouldThrow` isPortUnreachableError describe "gracefulClose" $ do it "does not send TCP RST back" $ do let server sock = do void $ recv sock 1024 -- receiving "GOAWAY" gracefulClose sock 300+ client sock = do+ sendAll sock "GOAWAY"+ threadDelay 10000+ sendAll sock "PING"+ threadDelay 10000+ void $ recv sock 1024+ tcpTest client server++ describe "unsafeGracefulClose" $ do+ it "does not send TCP RST back" $ do+ let server sock = do+ void $ recv sock 1024 -- receiving "GOAWAY"+ unsafeGracefulClose sock 300 client sock = do sendAll sock "GOAWAY" threadDelay 10000