network 3.1.0.1 → 3.1.1.0
raw patch · 12 files changed
+480/−226 lines, 12 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.Socket: gracefulClose :: Socket -> Int -> IO ()
+ Network.Socket: socketToFd :: Socket -> IO CInt
+ Network.Socket: touchSocket :: Socket -> IO ()
+ Network.Socket: unsafeFdSocket :: Socket -> IO CInt
Files
- CHANGELOG.md +13/−0
- Network/Socket.hs +40/−32
- Network/Socket/Buffer.hs +0/−146
- Network/Socket/Buffer.hsc +195/−0
- Network/Socket/Shutdown.hs +89/−0
- Network/Socket/Types.hsc +72/−18
- cbits/initWinSock.c +15/−0
- configure.ac +1/−1
- examples/EchoClient.hs +13/−11
- examples/EchoServer.hs +18/−17
- network.cabal +1/−1
- tests/Network/SocketSpec.hs +23/−0
CHANGELOG.md view
@@ -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.
Network/Socket.hs view
@@ -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
− Network/Socket/Buffer.hs
@@ -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
+ Network/Socket/Buffer.hsc view
@@ -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
Network/Socket/Shutdown.hs view
@@ -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
Network/Socket/Types.hsc view
@@ -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.
cbits/initWinSock.c view
@@ -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
configure.ac view
@@ -1,5 +1,5 @@ AC_INIT([Haskell network package],- [3.1.0.1],+ [3.1.1.0], [libraries@haskell.org], [network])
examples/EchoClient.hs view
@@ -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
examples/EchoServer.hs view
@@ -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)
network.cabal view
@@ -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
tests/Network/SocketSpec.hs view
@@ -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