diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,16 @@ +## Version 3.1.1.0 + +* A new API: `gracefulClose`. + [#417](https://github.com/haskell/network/pull/417) +* `touchSocket`, `unsafeFdSocket`: Allow direct access to a socket's file + descriptor while providing tools to prevent it from being garbage collected. + This also deprecated `fdSocket` in favor of `unsafeFdSocket` and + `withFdSocket`. + [#423](https://github.com/haskell/network/pull/423) +* `socketToFd`: Duplicates a socket as a file desriptor and closes the source + socket. + [#424](https://github.com/haskell/network/pull/424) + ## Version 3.1.0.1 * getAddrInfo: raise exception if no AddrInfo returned. diff --git a/Network/Socket.hs b/Network/Socket.hs --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -16,10 +16,11 @@ -- used with either "Network.Socket.ByteString" or -- "Network.Socket.ByteString.Lazy" for sending/receiving. -- --- Here are two minimal example programs using the TCP/IP protocol: a --- server that echoes all data that it receives back (servicing only --- one client) and a client using it. +-- Here are two minimal example programs using the TCP/IP protocol: -- +-- * a server that echoes all data that it receives back +-- * a client using it +-- -- > -- Echo server program -- > module Main (main) where -- > @@ -31,35 +32,36 @@ -- > import Network.Socket.ByteString (recv, sendAll) -- > -- > main :: IO () --- > main = withSocketsDo $ do --- > addr <- resolve "3000" +-- > main = runTCPServer Nothing "3000" talk +-- > where +-- > talk s = do +-- > msg <- recv s 1024 +-- > unless (S.null msg) $ do +-- > sendAll s msg +-- > talk s +-- > +-- > -- from the "network-run" package. +-- > runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a +-- > runTCPServer mhost port server = withSocketsDo $ do +-- > addr <- resolve -- > E.bracket (open addr) close loop -- > where --- > resolve port = do +-- > resolve = do -- > let hints = defaultHints { -- > addrFlags = [AI_PASSIVE] -- > , addrSocketType = Stream -- > } --- > addr:_ <- getAddrInfo (Just hints) Nothing (Just port) --- > return addr +-- > head <$> getAddrInfo (Just hints) mhost (Just port) -- > open addr = do -- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) -- > setSocketOption sock ReuseAddr 1 --- > -- If the prefork technique is not used, --- > -- set CloseOnExec for the security reasons. -- > withFdSocket sock $ setCloseOnExecIfNeeded --- > bind sock (addrAddress addr) --- > listen sock 10 +-- > bind sock $ addrAddress addr +-- > listen sock 1024 -- > return sock -- > loop sock = forever $ do --- > (conn, peer) <- accept sock --- > putStrLn $ "Connection from " ++ show peer --- > void $ forkFinally (talk conn) (\_ -> close conn) --- > talk conn = do --- > msg <- recv conn 1024 --- > unless (S.null msg) $ do --- > sendAll conn msg --- > talk conn +-- > (conn, _peer) <- accept sock +-- > void $ forkFinally (server conn) (const $ gracefulClose conn 5000) -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- Echo client program @@ -71,23 +73,25 @@ -- > import Network.Socket.ByteString (recv, sendAll) -- > -- > main :: IO () --- > main = withSocketsDo $ do --- > addr <- resolve "127.0.0.1" "3000" --- > E.bracket (open addr) close talk +-- > main = runTCPClient "127.0.0.1" "3000" $ \s -> do +-- > sendAll s "Hello, world!" +-- > msg <- recv s 1024 +-- > putStr "Received: " +-- > C.putStrLn msg +-- > +-- > -- from the "network-run" package. +-- > runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a +-- > runTCPClient host port client = withSocketsDo $ do +-- > addr <- resolve +-- > E.bracket (open addr) close client -- > where --- > resolve host port = do +-- > resolve = do -- > let hints = defaultHints { addrSocketType = Stream } --- > addr:_ <- getAddrInfo (Just hints) (Just host) (Just port) --- > return addr +-- > head <$> getAddrInfo (Just hints) (Just host) (Just port) -- > open addr = do -- > sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) -- > connect sock $ addrAddress addr -- > return sock --- > talk sock = do --- > sendAll sock "Hello, world!" --- > msg <- recv sock 1024 --- > putStr "Received: " --- > C.putStrLn msg -- -- The proper programming model is that one 'Socket' is handled by -- a single thread. If multiple threads use one 'Socket' concurrently, @@ -122,6 +126,7 @@ -- ** Closing , close , close' + , gracefulClose , shutdown , ShutdownCmd(..) @@ -134,8 +139,11 @@ -- * Socket , Socket , socket - , fdSocket , withFdSocket + , unsafeFdSocket + , touchSocket + , socketToFd + , fdSocket , mkSocket , socketToHandle -- ** Types of Socket diff --git a/Network/Socket/Buffer.hs b/Network/Socket/Buffer.hs deleted file mode 100644 --- a/Network/Socket/Buffer.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE CPP #-} - -#include "HsNetDef.h" - -module Network.Socket.Buffer ( - sendBufTo - , sendBuf - , recvBufFrom - , recvBuf - ) where - -import Foreign.Marshal.Alloc (alloca) -import GHC.IO.Exception (IOErrorType(InvalidArgument)) -import System.IO.Error (mkIOError, ioeSetErrorString, catchIOError) - -#if defined(mingw32_HOST_OS) -import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr) -#endif - -import Network.Socket.Imports -import Network.Socket.Internal -import Network.Socket.Name -import Network.Socket.Types - --- | 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 --- ensuring that all data has been sent. -sendBufTo :: SocketAddress sa => - Socket -- (possibly) bound/connected Socket - -> Ptr a - -> Int -- Data to send - -> sa - -> IO Int -- Number of Bytes sent -sendBufTo 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) -socket2FD :: Socket -> IO FD -socket2FD s = do - fd <- fdSocket s - -- HACK, 1 means True - return $ FD{ fdFD = fd, fdIsSocket_ = 1 } -#endif - --- | Send data to the socket. The socket must be connected to a remote --- socket. Returns the number of bytes sent. Applications are --- responsible for ensuring that all data has been sent. -sendBuf :: Socket -- Bound/Connected Socket - -> 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 -#if defined(mingw32_HOST_OS) --- writeRawBufferPtr is supposed to handle checking for errors, but it's broken --- on x86_64 because of GHC bug #12010 so we duplicate the check here. The call --- to throwSocketErrorIfMinus1Retry can be removed when no GHC version with the --- bug is supported. - fd <- socket2FD s - let clen = fromIntegral len - throwSocketErrorIfMinus1Retry "Network.Socket.sendBuf" $ - writeRawBufferPtr "Network.Socket.sendBuf" fd (castPtr str) 0 clen -#else - withFdSocket s $ \fd -> do - let flags = 0 - clen = fromIntegral len - throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $ - c_send fd str clen flags -#endif - --- | 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 --- bytes received and @address@ is a 'SockAddr' representing the --- address of the sending socket. --- --- If the first return value is zero, it means EOF. --- --- For 'Stream' sockets, the second return value would be invalid. --- --- 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 - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") - | otherwise = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> - withFdSocket s $ \fd -> do - poke ptr_len (fromIntegral sz) - let cnbytes = fromIntegral nbytes - flags = 0 - len <- throwSocketErrorWaitRead s "Network.Socket.recvBufFrom" $ - c_recvfrom fd ptr cnbytes flags ptr_sa ptr_len - sockaddr <- peekSocketAddress ptr_sa - `catchIOError` \_ -> getPeerName s - return (fromIntegral len, sockaddr) - --- | Receive data from the socket. The socket must be in a connected --- state. This function may return fewer bytes than specified. If the --- message is longer than the specified length, it may be discarded --- depending on the type of socket. This function may block until a --- message arrives. --- --- Considering hardware and network realities, the maximum number of --- bytes to receive should be a small power of 2, e.g., 4096. --- --- The return value is the length of received data. Zero means --- 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 - | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") - | otherwise = do -#if defined(mingw32_HOST_OS) --- see comment in sendBuf above. - fd <- socket2FD s - let cnbytes = fromIntegral nbytes - len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $ - readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes -#else - len <- withFdSocket s $ \fd -> - throwSocketErrorWaitRead s "Network.Socket.recvBuf" $ - c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} -#endif - return $ fromIntegral len - -mkInvalidRecvArgError :: String -> IOError -mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError - InvalidArgument - loc Nothing Nothing) "non-positive length" - -#if !defined(mingw32_HOST_OS) -foreign import ccall unsafe "send" - c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt -foreign import ccall unsafe "recv" - c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt -#endif -foreign import CALLCONV SAFE_ON_WIN "sendto" - c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt -foreign import CALLCONV SAFE_ON_WIN "recvfrom" - c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt diff --git a/Network/Socket/Buffer.hsc b/Network/Socket/Buffer.hsc new file mode 100644 --- /dev/null +++ b/Network/Socket/Buffer.hsc @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} + +##include "HsNetDef.h" +#if defined(mingw32_HOST_OS) +# include "windows.h" +#endif + +module Network.Socket.Buffer ( + sendBufTo + , sendBuf + , recvBufFrom + , recvBuf + , recvBufNoWait + ) where + +#if !defined(mingw32_HOST_OS) +import Foreign.C.Error (getErrno, eAGAIN, eWOULDBLOCK) +#endif +import Foreign.Marshal.Alloc (alloca) +import GHC.IO.Exception (IOErrorType(InvalidArgument)) +import System.IO.Error (mkIOError, ioeSetErrorString, catchIOError) + +#if defined(mingw32_HOST_OS) +import GHC.IO.FD (FD(..), readRawBufferPtr, writeRawBufferPtr) +#endif + +import Network.Socket.Imports +import Network.Socket.Internal +import Network.Socket.Name +import Network.Socket.Types + +-- | 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 +-- ensuring that all data has been sent. +sendBufTo :: SocketAddress sa => + Socket -- (possibly) bound/connected Socket + -> Ptr a + -> Int -- Data to send + -> sa + -> IO Int -- Number of Bytes sent +sendBufTo 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) +socket2FD :: Socket -> IO FD +socket2FD s = do + fd <- unsafeFdSocket s + -- HACK, 1 means True + return $ FD{ fdFD = fd, fdIsSocket_ = 1 } +#endif + +-- | Send data to the socket. The socket must be connected to a remote +-- socket. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +sendBuf :: Socket -- Bound/Connected Socket + -> 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 +#if defined(mingw32_HOST_OS) +-- writeRawBufferPtr is supposed to handle checking for errors, but it's broken +-- on x86_64 because of GHC bug #12010 so we duplicate the check here. The call +-- to throwSocketErrorIfMinus1Retry can be removed when no GHC version with the +-- bug is supported. + fd <- socket2FD s + let clen = fromIntegral len + throwSocketErrorIfMinus1Retry "Network.Socket.sendBuf" $ + writeRawBufferPtr "Network.Socket.sendBuf" fd (castPtr str) 0 clen +#else + withFdSocket s $ \fd -> do + let flags = 0 + clen = fromIntegral len + throwSocketErrorWaitWrite s "Network.Socket.sendBuf" $ + c_send fd str clen flags +#endif + +-- | 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 +-- bytes received and @address@ is a 'SockAddr' representing the +-- address of the sending socket. +-- +-- If the first return value is zero, it means EOF. +-- +-- For 'Stream' sockets, the second return value would be invalid. +-- +-- 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 + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBufFrom") + | otherwise = withNewSocketAddress $ \ptr_sa sz -> alloca $ \ptr_len -> + withFdSocket s $ \fd -> do + poke ptr_len (fromIntegral sz) + let cnbytes = fromIntegral nbytes + flags = 0 + len <- throwSocketErrorWaitRead s "Network.Socket.recvBufFrom" $ + c_recvfrom fd ptr cnbytes flags ptr_sa ptr_len + sockaddr <- peekSocketAddress ptr_sa + `catchIOError` \_ -> getPeerName s + return (fromIntegral len, sockaddr) + +-- | Receive data from the socket. The socket must be in a connected +-- state. This function may return fewer bytes than specified. If the +-- message is longer than the specified length, it may be discarded +-- depending on the type of socket. This function may block until a +-- message arrives. +-- +-- Considering hardware and network realities, the maximum number of +-- bytes to receive should be a small power of 2, e.g., 4096. +-- +-- The return value is the length of received data. Zero means +-- 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 + | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") + | otherwise = do +#if defined(mingw32_HOST_OS) +-- see comment in sendBuf above. + fd <- socket2FD s + let cnbytes = fromIntegral nbytes + len <- throwSocketErrorIfMinus1Retry "Network.Socket.recvBuf" $ + readRawBufferPtr "Network.Socket.recvBuf" fd ptr 0 cnbytes +#else + len <- withFdSocket s $ \fd -> + throwSocketErrorWaitRead s "Network.Socket.recvBuf" $ + c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} +#endif + return $ fromIntegral len + +-- | Receive data from the socket. This function returns immediately +-- even if data is not available. In other words, IO manager is NOT +-- involved. The length of data is returned if received. +-- -1 is returned in the case of EAGAIN or EWOULDBLOCK. +-- -2 is returned in other error cases. +recvBufNoWait :: Socket -> Ptr Word8 -> Int -> IO Int +recvBufNoWait 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-} + 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) + return $ fromIntegral r + +#else + r <- c_recv fd (castPtr ptr) (fromIntegral nbytes) 0{-flags-} + if r >= 0 then + return $ fromIntegral r + else do + err <- getErrno + if err == eAGAIN || err == eWOULDBLOCK then + return (-1) + else + return (-2) +#endif + +mkInvalidRecvArgError :: String -> IOError +mkInvalidRecvArgError loc = ioeSetErrorString (mkIOError + InvalidArgument + loc Nothing Nothing) "non-positive length" + +#if !defined(mingw32_HOST_OS) +foreign import ccall unsafe "send" + c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt +#else +foreign import CALLCONV SAFE_ON_WIN "ioctlsocket" + c_ioctlsocket :: CInt -> CLong -> Ptr CULong -> IO CInt +foreign import CALLCONV SAFE_ON_WIN "WSAGetLastError" + c_WSAGetLastError :: IO CInt +#endif +foreign import ccall unsafe "recv" + c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt +foreign import CALLCONV SAFE_ON_WIN "sendto" + c_sendto :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> CInt -> IO CInt +foreign import CALLCONV SAFE_ON_WIN "recvfrom" + c_recvfrom :: CInt -> Ptr a -> CSize -> CInt -> Ptr sa -> Ptr CInt -> IO CInt diff --git a/Network/Socket/Shutdown.hs b/Network/Socket/Shutdown.hs --- a/Network/Socket/Shutdown.hs +++ b/Network/Socket/Shutdown.hs @@ -6,8 +6,20 @@ module Network.Socket.Shutdown ( ShutdownCmd(..) , shutdown + , gracefulClose ) where +import qualified Control.Exception as E +import Foreign.Marshal.Alloc (mallocBytes, free) + +import Control.Concurrent (threadDelay) +#if !defined(mingw32_HOST_OS) +import Control.Concurrent (putMVar, takeMVar, newEmptyMVar) +import qualified GHC.Event as Ev +import System.Posix.Types (Fd(..)) +#endif + +import Network.Socket.Buffer import Network.Socket.Imports import Network.Socket.Internal import Network.Socket.Types @@ -34,3 +46,80 @@ foreign import CALLCONV unsafe "shutdown" c_shutdown :: CInt -> CInt -> IO CInt + +#if !defined(mingw32_HOST_OS) +data Wait = MoreData | TimeoutTripped +#endif + +-- | Closing a socket gracefully. +-- This sends TCP FIN and check if TCP FIN is received from the peer. +-- The second argument is time out to receive TCP FIN in millisecond. +-- In both normal cases and error cases, socket is deallocated finally. +-- +-- Since: 3.1.1.0 +gracefulClose :: Socket -> Int -> IO () +gracefulClose s tmout = sendRecvFIN `E.finally` close s + where + sendRecvFIN = do + -- Sending TCP FIN. + shutdown s ShutdownSend + -- Waiting TCP FIN. +#if defined(mingw32_HOST_OS) + recvEOFloop +#else + mevmgr <- Ev.getSystemEventManager + case mevmgr of + Nothing -> recvEOFloop -- non-threaded RTS + Just evmgr -> recvEOFev evmgr +#endif + -- milliseconds. Taken from BSD fast clock value. + clock = 200 + recvEOFloop = E.bracket (mallocBytes bufSize) free $ loop 0 + where + loop delay buf = do + -- We don't check the (positive) length. + -- In normal case, it's 0. That is, only FIN is received. + -- In error cases, data is available. But there is no + -- application which can read it. So, let's stop receiving + -- to prevent attacks. + r <- recvBufNoWait s buf bufSize + let delay' = delay + clock + when (r == -1 && delay' < tmout) $ do + threadDelay (clock * 1000) + loop delay' buf +#if !defined(mingw32_HOST_OS) + recvEOFev evmgr = do + tmmgr <- Ev.getSystemTimerManager + mvar <- newEmptyMVar + E.bracket (register evmgr tmmgr mvar) (unregister evmgr tmmgr) $ \_ -> do + wait <- takeMVar mvar + case wait of + TimeoutTripped -> return () + -- We don't check the (positive) length. + -- In normal case, it's 0. That is, only FIN is received. + -- In error cases, data is available. But there is no + -- application which can read it. So, let's stop receiving + -- to prevent attacks. + MoreData -> E.bracket (mallocBytes bufSize) + free + (\buf -> void $ recvBufNoWait s buf bufSize) + register evmgr tmmgr mvar = do + -- millisecond to microsecond + key1 <- Ev.registerTimeout tmmgr (tmout * 1000) $ + putMVar mvar TimeoutTripped + key2 <- withFdSocket s $ \fd' -> do + let callback _ _ = putMVar mvar MoreData + fd = Fd fd' +#if __GLASGOW_HASKELL__ < 709 + Ev.registerFd evmgr callback fd Ev.evtRead +#else + Ev.registerFd evmgr callback fd Ev.evtRead Ev.OneShot +#endif + return (key1, key2) + unregister evmgr tmmgr (key1,key2) = do + Ev.unregisterTimeout tmmgr key1 + Ev.unregisterFd evmgr key2 +#endif + -- Don't use 4092 here. The GHC runtime takes the global lock + -- if the length is over 3276 bytes in 32bit or 3272 bytes in 64bit. + bufSize = 1024 diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -11,8 +11,11 @@ module Network.Socket.Types ( -- * Socket type Socket - , fdSocket , withFdSocket + , unsafeFdSocket + , touchSocket + , socketToFd + , fdSocket , mkSocket , invalidateSocket , close @@ -94,13 +97,18 @@ instance Eq Socket where Socket ref1 _ == Socket ref2 _ = ref1 == ref2 +{-# DEPRECATED fdSocket "Use withFdSocket or unsafeFdSocket instead" #-} +-- | Currently, this is an alias of `unsafeFdSocket`. +fdSocket :: Socket -> IO CInt +fdSocket = unsafeFdSocket + -- | Getting a file descriptor from a socket. -- -- If a 'Socket' is shared with multiple threads and --- one uses 'fdSocket', unexpected issues may happen. +-- one uses 'unsafeFdSocket', unexpected issues may happen. -- Consider the following scenario: -- --- 1) Thread A acquires a 'Fd' from 'Socket' by 'fdSocket'. +-- 1) Thread A acquires a 'Fd' from 'Socket' by 'unsafeFdSocket'. -- -- 2) Thread B close the 'Socket'. -- @@ -109,37 +117,83 @@ -- -- In this case, it is safer for Thread A to clone 'Fd' by -- 'System.Posix.IO.dup'. But this would still suffer from --- a race condition between 'fdSocket' and 'close'. +-- a race condition between 'unsafeFdSocket' and 'close'. -- +-- If you use this function, you need to guarantee that the 'Socket' does not +-- get garbage-collected until after you finish using the file descriptor. +-- 'touchSocket' can be used for this purpose. +-- -- A safer option is to use 'withFdSocket' instead. -{-# DEPRECATED fdSocket "Use withFdSocket instead" #-} -fdSocket :: Socket -> IO CInt -fdSocket (Socket ref _) = readIORef ref +unsafeFdSocket :: Socket -> IO CInt +unsafeFdSocket (Socket ref _) = readIORef ref +-- | Ensure that the given 'Socket' stays alive (i.e. not garbage-collected) +-- at the given place in the sequence of IO actions. This function can be +-- used in conjunction with 'unsafeFdSocket' to guarantee that the file +-- descriptor is not prematurely freed. +-- +-- > fd <- unsafeFdSocket sock +-- > -- using fd with blocking operations such as accept(2) +-- > touchSocket sock +touchSocket :: Socket -> IO () +touchSocket (Socket ref _) = touch ref + +touch :: IORef a -> IO () +touch (IORef (STRef mutVar)) = + -- Thanks to a GHC issue, this touch# may not be quite guaranteed + -- to work. There's talk of replacing the touch# primop with one + -- that works better with the optimizer. But this seems to be the + -- "right" way to do it for now. + IO $ \s -> (## touch## mutVar s, () ##) + -- | Get a file descriptor from a 'Socket'. The socket will never -- be closed automatically before @withFdSocket@ completes, but -- it may still be closed by an explicit call to 'close' or `close'`, -- either before or during the call. -- --- The file descriptor must not be used after @withFdSocket@ returns; --- see the documentation for 'fdSocket' to see why that is. +-- The file descriptor must not be used after @withFdSocket@ returns, because +-- the 'Socket' may have been garbage-collected, invalidating the file +-- descriptor. +-- +-- Since: 3.1.0.0 withFdSocket :: Socket -> (CInt -> IO r) -> IO r -withFdSocket (Socket ref@(IORef (STRef ref##)) _) f = do +withFdSocket (Socket ref _) f = do fd <- readIORef ref -- Should we throw an exception if the socket is already invalid? -- That will catch some mistakes but certainly not all. r <- f fd - -- Thanks to a GHC issue, this touch# may not be quite guaranteed - -- to work. There's talk of replacing the touch# primop with one - -- that works better with the optimizer. But this seems to be the - -- "right" way to do it for now. - - IO $ \s -> (## touch## ref## s, () ##) + touch ref return r +-- | Socket is closed and a duplicated file descriptor is returned. +-- The duplicated descriptor is no longer subject to the possibility +-- of unexpectedly being closed if the socket is finalized. It is +-- now the caller's responsibility to ultimately close the +-- duplicated file descriptor. +socketToFd :: Socket -> IO CInt +socketToFd s = do +#if defined(mingw32_HOST_OS) + fd <- unsafeFdSocket s + fd2 <- c_wsaDuplicate fd + -- FIXME: throw error no if -1 + close s + return fd2 +foreign import ccall unsafe "wsaDuplicate" + c_wsaDuplicate :: CInt -> IO CInt +#else + fd <- unsafeFdSocket s + -- FIXME: throw error no if -1 + fd2 <- c_dup fd + close s + return fd2 + +foreign import ccall unsafe "dup" + c_dup :: CInt -> IO CInt +#endif + -- | Creating a socket from a file descriptor. mkSocket :: CInt -> IO Socket mkSocket fd = do @@ -169,9 +223,9 @@ -- | Close the socket. This function does not throw exceptions even if -- the underlying system call returns errors. -- --- If multiple threads use the same socket and one uses 'fdSocket' and +-- If multiple threads use the same socket and one uses 'unsafeFdSocket' and -- the other use 'close', unexpected behavior may happen. --- For more information, please refer to the documentation of 'fdSocket'. +-- For more information, please refer to the documentation of 'unsafeFdSocket'. close :: Socket -> IO () close s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do -- closeFdWith avoids the deadlock of IO manager. diff --git a/cbits/initWinSock.c b/cbits/initWinSock.c --- a/cbits/initWinSock.c +++ b/cbits/initWinSock.c @@ -40,4 +40,19 @@ return 0; } +SOCKET +wsaDuplicate (SOCKET s) +{ + WSAPROTOCOL_INFOW protocolInfo; + if (WSADuplicateSocketW (s, GetCurrentProcessId (), &protocolInfo) != 0) + return -1; + + SOCKET res = WSASocketW(FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, + FROM_PROTOCOL_INFO, &protocolInfo, 0, 0); + if (res == SOCKET_ERROR) + return -1; + + return res; +} + #endif diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([Haskell network package], - [3.1.0.1], + [3.1.1.0], [libraries@haskell.org], [network]) diff --git a/examples/EchoClient.hs b/examples/EchoClient.hs --- a/examples/EchoClient.hs +++ b/examples/EchoClient.hs @@ -8,20 +8,22 @@ import Network.Socket.ByteString (recv, sendAll) main :: IO () -main = withSocketsDo $ do - addr <- resolve "127.0.0.1" "3000" - E.bracket (open addr) close talk +main = runTCPClient "127.0.0.1" "3000" $ \s -> do + sendAll s "Hello, world!" + msg <- recv s 1024 + putStr "Received: " + C.putStrLn msg + +-- from the "network-run" package. +runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a +runTCPClient host port client = withSocketsDo $ do + addr <- resolve + E.bracket (open addr) close client where - resolve host port = do + resolve = do let hints = defaultHints { addrSocketType = Stream } - addr:_ <- getAddrInfo (Just hints) (Just host) (Just port) - return addr + head <$> getAddrInfo (Just hints) (Just host) (Just port) open addr = do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) connect sock $ addrAddress addr return sock - talk sock = do - sendAll sock "Hello, world!" - msg <- recv sock 1024 - putStr "Received: " - C.putStrLn msg diff --git a/examples/EchoServer.hs b/examples/EchoServer.hs --- a/examples/EchoServer.hs +++ b/examples/EchoServer.hs @@ -9,32 +9,33 @@ import Network.Socket.ByteString (recv, sendAll) main :: IO () -main = withSocketsDo $ do - addr <- resolve "3000" +main = runTCPServer Nothing "3000" talk + where + talk s = do + msg <- recv s 1024 + unless (S.null msg) $ do + sendAll s msg + talk s + +-- from the "network-run" package. +runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a +runTCPServer mhost port server = withSocketsDo $ do + addr <- resolve E.bracket (open addr) close loop where - resolve port = do + resolve = do let hints = defaultHints { addrFlags = [AI_PASSIVE] , addrSocketType = Stream } - addr:_ <- getAddrInfo (Just hints) Nothing (Just port) - return addr + head <$> getAddrInfo (Just hints) mhost (Just port) open addr = do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 - -- If the prefork technique is not used, - -- set CloseOnExec for the security reasons. withFdSocket sock $ setCloseOnExecIfNeeded - bind sock (addrAddress addr) - listen sock 10 + bind sock $ addrAddress addr + listen sock 1024 return sock loop sock = forever $ do - (conn, peer) <- accept sock - putStrLn $ "Connection from " ++ show peer - void $ forkFinally (talk conn) (\_ -> close conn) - talk conn = do - msg <- recv conn 1024 - unless (S.null msg) $ do - sendAll conn msg - talk conn + (conn, _peer) <- accept sock + void $ forkFinally (server conn) (const $ gracefulClose conn 5000) diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: network -version: 3.1.0.1 +version: 3.1.1.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -196,3 +196,26 @@ cred1 <- getPeerCredential s cred1 `shouldBe` (Nothing,Nothing,Nothing) -} + + describe "gracefulClose" $ do + it "does not send TCP RST back" $ do + let server sock = do + void $ recv sock 1024 -- receiving "GOAWAY" + gracefulClose sock 3000 + client sock = do + sendAll sock "GOAWAY" + threadDelay 10000 + sendAll sock "PING" + threadDelay 10000 + void $ recv sock 1024 + tcpTest client server + + describe "socketToFd" $ do + it "socketToFd can send using fd" $ do + let server sock = do + void $ recv sock 1024 + client sock = do + fd <- socketToFd sock + s <- mkSocket fd + sendAll s "HELLO WORLD" + tcpTest client server