diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +## Version 3.0.1.0 + +* Added `getSocketType :: Socket -> IO SocketType`. + [#372](https://github.com/haskell/network/pull/372) +* Correcting manual and brushing up test cases + [#375](https://github.com/haskell/network/pull/375) +* Fixed longstanded bug in `getContents` on mac + [#375](https://github.com/haskell/network/pull/375) +* Fixing regression: set correct sockaddr length for abstract addresses + for Linux. + [#374](https://github.com/haskell/network/pull/374) + ## Version 3.0.0.1 * Fixed a bug in `connect` where exceptions were not thrown diff --git a/Network/Socket.hs b/Network/Socket.hs --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -141,6 +141,7 @@ -- ** Types of Socket , SocketType(..) , isSupportedSocketType + , getSocketType -- ** Family , Family(..) , isSupportedFamily diff --git a/Network/Socket/Buffer.hs b/Network/Socket/Buffer.hs --- a/Network/Socket/Buffer.hs +++ b/Network/Socket/Buffer.hs @@ -53,8 +53,6 @@ -- | 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. --- --- Sending data to closed socket may lead to undefined behaviour. sendBuf :: Socket -- Bound/Connected Socket -> Ptr Word8 -- Pointer to the data to send -> Int -- Length of the buffer @@ -115,8 +113,6 @@ -- 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. --- --- Receiving data from closed socket may lead to undefined behaviour. recvBuf :: Socket -> Ptr Word8 -> Int -> IO Int recvBuf s ptr nbytes | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvBuf") diff --git a/Network/Socket/ByteString.hs b/Network/Socket/ByteString.hs --- a/Network/Socket/ByteString.hs +++ b/Network/Socket/ByteString.hs @@ -68,8 +68,6 @@ -- 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. --- --- Sending data to closed socket may lead to undefined behaviour. sendTo :: Socket -> ByteString -> SockAddr -> IO Int sendTo = G.sendTo @@ -79,8 +77,6 @@ -- data has been sent or an error occurs. On error, an exception is -- raised, and there is no way to determine how much data, if any, was -- successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. sendAllTo :: Socket -> ByteString -> SockAddr -> IO () sendAllTo = G.sendAllTo @@ -88,8 +84,6 @@ -- connected state. Returns @(bytes, address)@ where @bytes@ is a -- 'ByteString' representing the data received and @address@ is a -- 'SockAddr' representing the address of the sending socket. --- --- Receiving data from closed socket may lead to undefined behaviour. recvFrom :: Socket -> Int -> IO (ByteString, SockAddr) recvFrom = G.recvFrom diff --git a/Network/Socket/ByteString/IO.hsc b/Network/Socket/ByteString/IO.hsc --- a/Network/Socket/ByteString/IO.hsc +++ b/Network/Socket/ByteString/IO.hsc @@ -73,8 +73,6 @@ -- | 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. --- --- Sending data to closed socket may lead to undefined behaviour. send :: Socket -- ^ Connected socket -> ByteString -- ^ Data to send -> IO Int -- ^ Number of bytes sent @@ -92,8 +90,6 @@ -- until either all data has been sent or an error occurs. On error, -- an exception is raised, and there is no way to determine how much -- data, if any, was successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. sendAll :: Socket -- ^ Connected socket -> ByteString -- ^ Data to send -> IO () @@ -107,8 +103,6 @@ -- 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. --- --- Sending data to closed socket may lead to undefined behaviour. sendTo :: SocketAddress sa => Socket -- ^ Socket -> ByteString -- ^ Data to send @@ -123,8 +117,6 @@ -- data has been sent or an error occurs. On error, an exception is -- raised, and there is no way to determine how much data, if any, was -- successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. sendAllTo :: SocketAddress sa => Socket -- ^ Socket -> ByteString -- ^ Data to send @@ -142,8 +134,6 @@ -- sent or an error occurs. On error, an exception is raised, and -- there is no way to determine how much data, if any, was -- successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. sendMany :: Socket -- ^ Connected socket -> [ByteString] -- ^ Data to send -> IO () @@ -170,8 +160,6 @@ -- continues to send data until either all data has been sent or an -- error occurs. On error, an exception is raised, and there is no -- way to determine how much data, if any, was successfully sent. --- --- Sending data to closed socket may lead to undefined behaviour. sendManyTo :: Socket -- ^ Socket -> [ByteString] -- ^ Data to send -> SockAddr -- ^ Recipient address @@ -211,8 +199,6 @@ -- -- For TCP sockets, a zero length return value means the peer has -- closed its half side of the connection. --- --- Receiving data from closed socket may lead to undefined behaviour. recv :: Socket -- ^ Connected socket -> Int -- ^ Maximum number of bytes to receive -> IO ByteString -- ^ Data received @@ -226,8 +212,6 @@ -- 'SockAddr' representing the address of the sending socket. -- -- If the first return value is zero, it means EOF. --- --- Receiving data from closed socket may lead to undefined behaviour. recvFrom :: SocketAddress sa => Socket -- ^ Socket -> Int -- ^ Maximum number of bytes to receive diff --git a/Network/Socket/ByteString/Lazy.hs b/Network/Socket/ByteString/Lazy.hs --- a/Network/Socket/ByteString/Lazy.hs +++ b/Network/Socket/ByteString/Lazy.hs @@ -33,6 +33,7 @@ import Network.Socket (ShutdownCmd (..), shutdown) import Prelude hiding (getContents) import System.IO.Unsafe (unsafeInterleaveIO) +import System.IO.Error (catchIOError) #if defined(mingw32_HOST_OS) import Network.Socket.ByteString.Lazy.Windows (send, sendAll) @@ -64,7 +65,9 @@ loop = unsafeInterleaveIO $ do sbs <- N.recv s defaultChunkSize if S.null sbs - then shutdown s ShutdownReceive >> return Empty + then do + shutdown s ShutdownReceive `catchIOError` const (return ()) + return Empty else Chunk sbs <$> loop -- | Receive data from the socket. The socket must be in a connected @@ -74,8 +77,6 @@ -- until a message arrives. -- -- If there is no more data to be received, returns an empty 'ByteString'. --- --- Receiving data from closed socket may lead to undefined behaviour. recv :: Socket -- ^ Connected socket -> Int64 -- ^ Maximum number of bytes to receive diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc --- a/Network/Socket/Options.hsc +++ b/Network/Socket/Options.hsc @@ -8,6 +8,7 @@ module Network.Socket.Options ( SocketOption(..) , isSupportedSocketOption + , getSocketType , getSocketOption , setSocketOption , c_getsockopt @@ -58,6 +59,13 @@ -- | Does the 'SocketOption' exist on this system? isSupportedSocketOption :: SocketOption -> Bool isSupportedSocketOption = isJust . packSocketOption + +-- | Get the 'SocketType' of an active socket. +-- +-- Since: 3.0.1.0 +getSocketType :: Socket -> IO SocketType +getSocketType s = (fromMaybe NoSocketType . unpackSocketType . fromIntegral) + <$> getSocketOption s Type -- | For a socket option, return Just (level, value) where level is the -- corresponding C option level constant (e.g. SOL_SOCKET) and value is diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -136,9 +136,6 @@ -- | Close the socket. This function does not throw exceptions even if -- the underlying system call returns errors. -- --- Sending data to or receiving data from closed socket --- may lead to undefined behaviour. --- -- If multiple threads use the same socket and one uses 'fdSocket' and -- the other use 'close', unexpected behavior may happen. -- For more information, please refer to the documentation of 'fdSocket'. @@ -156,9 +153,6 @@ -- | Close the socket. This function throws exceptions if -- the underlying system call returns errors. --- --- Sending data to or receiving data from closed socket --- may lead to undefined behaviour. close' :: Socket -> IO () close' s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do -- closeFdWith avoids the deadlock of IO manager. @@ -941,7 +935,25 @@ -- in that the value of the argument /is/ used. sizeOfSockAddr :: SockAddr -> Int #if defined(DOMAIN_SOCKET_SUPPORT) +# ifdef linux_HOST_OS +-- http://man7.org/linux/man-pages/man7/unix.7.html says: +-- "an abstract socket address is distinguished (from a +-- pathname socket) by the fact that sun_path[0] is a null byte +-- ('\0'). The socket's address in this namespace is given by the +-- additional bytes in sun_path that are covered by the specified +-- length of the address structure. (Null bytes in the name have no +-- special significance.) The name has no connection with filesystem +-- pathnames. When the address of an abstract socket is returned, +-- the returned addrlen is greater than sizeof(sa_family_t) (i.e., +-- greater than 2), and the name of the socket is contained in the +-- first (addrlen - sizeof(sa_family_t)) bytes of sun_path." +sizeOfSockAddr (SockAddrUnix path) = + case path of + '\0':_ -> (#const sizeof(sa_family_t)) + length path + _ -> #const sizeof(struct sockaddr_un) +# else sizeOfSockAddr SockAddrUnix{} = #const sizeof(struct sockaddr_un) +# endif #else sizeOfSockAddr SockAddrUnix{} = error "sizeOfSockAddr: not supported" #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.0.0.1], + [3.0.1.0], [libraries@haskell.org], [network]) 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.0.0.1 +version: 3.0.1.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden @@ -115,8 +115,11 @@ default-language: Haskell2010 hs-source-dirs: tests main-is: Spec.hs - other-modules: RegressionSpec - SimpleSpec + other-modules: + Network.Test.Common + Network.SocketSpec + Network.Socket.ByteStringSpec + Network.Socket.ByteString.LazySpec type: exitcode-stdio-1.0 ghc-options: -Wall -threaded -- NB: make sure to versions of hspec and hspec-discover diff --git a/tests/Network/Socket/ByteString/LazySpec.hs b/tests/Network/Socket/ByteString/LazySpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Socket/ByteString/LazySpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Socket.ByteString.LazySpec (main, spec) where + +import Prelude hiding (getContents) + +import qualified Data.ByteString.Lazy as L +import Network.Socket +import Network.Socket.ByteString.Lazy +import Network.Test.Common +import Control.Monad + +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "send" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` lazyTestMsg + client sock = send sock lazyTestMsg + tcpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock = do + close sock + send sock lazyTestMsg `shouldThrow` anyException + tcpTest client server + + describe "sendAll" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` lazyTestMsg + client sock = sendAll sock lazyTestMsg + tcpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock = do + close sock + sendAll sock lazyTestMsg `shouldThrow` anyException + tcpTest client server + + describe "getContents" $ do + it "works well" $ do + let server sock = getContents sock `shouldReturn` lazyTestMsg + client sock = do + void $ send sock lazyTestMsg + shutdown sock ShutdownSend + tcpTest client server + + it "returns empty string at EOF" $ do + let client s = getContents s `shouldReturn` L.empty + server s = shutdown s ShutdownSend + tcpTest client server + + describe "recv" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` lazyTestMsg + client sock = send sock lazyTestMsg + tcpTest client server + + it "throws when closed" $ do + let server sock = do + close sock + recv sock 1024 `shouldThrow` anyException + client sock = send sock lazyTestMsg + tcpTest client server + + it "can treat overflow" $ do + let server sock = do + seg1 <- recv sock (L.length lazyTestMsg - 3) + seg2 <- recv sock 1024 + let msg = L.append seg1 seg2 + msg `shouldBe` lazyTestMsg + client sock = send sock lazyTestMsg + tcpTest client server + + it "returns empty string at EOF" $ do + let client s = recv s 4096 `shouldReturn` L.empty + server s = shutdown s ShutdownSend + tcpTest client server diff --git a/tests/Network/Socket/ByteStringSpec.hs b/tests/Network/Socket/ByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Socket/ByteStringSpec.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Socket.ByteStringSpec (main, spec) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import Network.Socket +import Network.Socket.ByteString +import Network.Test.Common + +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "send" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = send sock testMsg + tcpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock = do + close sock + send sock testMsg `shouldThrow` anyException + tcpTest client server + + it "checks -1 correctly on Windows" $ do + sock <- socket AF_INET Stream defaultProtocol + send sock "hello world" `shouldThrow` anyException + + describe "sendAll" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = sendAll sock testMsg + tcpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock = do + close sock + sendAll sock testMsg `shouldThrow` anyException + tcpTest client server + + describe "sendTo" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock serverPort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + sendTo sock testMsg $ addrAddress addr + udpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock serverPort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + close sock + sendTo sock testMsg (addrAddress addr) `shouldThrow` anyException + udpTest client server + + describe "sendAllTo" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock serverPort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + sendAllTo sock testMsg $ addrAddress addr + udpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock serverPort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + close sock + sendAllTo sock testMsg (addrAddress addr) `shouldThrow` anyException + udpTest client server + + describe "sendMany" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` S.append seg1 seg2 + client sock = sendMany sock [seg1, seg2] + + seg1 = C.pack "This is a " + seg2 = C.pack "test message." + tcpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock = do + close sock + sendMany sock [seg1, seg2] `shouldThrow` anyException + + seg1 = C.pack "This is a " + seg2 = C.pack "test message." + tcpTest client server + + describe "sendManyTo" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` S.append seg1 seg2 + client sock serverPort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + sendManyTo sock [seg1, seg2] $ addrAddress addr + + seg1 = C.pack "This is a " + seg2 = C.pack "test message." + udpTest client server + + it "throws when closed" $ do + let server _ = return () + client sock serverPort = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + close sock + sendManyTo sock [seg1, seg2] (addrAddress addr) `shouldThrow` anyException + + seg1 = C.pack "This is a " + seg2 = C.pack "test message." + udpTest client server + + describe "recv" $ do + it "works well" $ do + let server sock = recv sock 1024 `shouldReturn` testMsg + client sock = send sock testMsg + tcpTest client server + + it "throws when closed" $ do + let server sock = do + close sock + recv sock 1024 `shouldThrow` anyException + client sock = send sock testMsg + tcpTest client server + + it "can treat overflow" $ do + let server sock = do + seg1 <- recv sock (S.length testMsg - 3) + seg2 <- recv sock 1024 + let msg = S.append seg1 seg2 + msg `shouldBe` testMsg + client sock = send sock testMsg + tcpTest client server + + it "returns empty string at EOF" $ do + let client s = recv s 4096 `shouldReturn` S.empty + server s = shutdown s ShutdownSend + tcpTest client server + + it "checks -1 correctly on Windows" $ do + sock <- socket AF_INET Stream defaultProtocol + recv sock 1024 `shouldThrow` anyException + + describe "recvFrom" $ do + it "works well" $ do + let server sock = do + (msg, _) <- recvFrom sock 1024 + testMsg `shouldBe` msg + client sock = do + addr <- getPeerName sock + sendTo sock testMsg addr + tcpTest client server + + it "throws when closed" $ do + let server sock = do + close sock + recvFrom sock 1024 `shouldThrow` anyException + client sock = do + addr <- getPeerName sock + sendTo sock testMsg addr + tcpTest client server + + it "can treat overflow" $ do + let server sock = do + (seg1, _) <- recvFrom sock (S.length testMsg - 3) + (seg2, _) <- recvFrom sock 1024 + let msg = S.append seg1 seg2 + testMsg `shouldBe` msg + client sock = send sock testMsg + tcpTest client server + + it "returns empty string at EOF" $ do + let server sock = do + (seg1, _) <- recvFrom sock (S.length testMsg - 3) + seg1 `shouldBe` S.empty + client sock = shutdown sock ShutdownSend + tcpTest client server diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Network/SocketSpec.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.SocketSpec (main, spec) where + +import Control.Concurrent.MVar (readMVar) +import Control.Monad +import Network.Socket +import Network.Socket.ByteString +import Network.Test.Common + +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "connect" $ do + let + hints = defaultHints { addrSocketType = Stream } + connect' serverPort = do + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + connect sock (addrAddress addr) + return sock + + it "fails to connect and throws an IOException" $ do + connect' (8080 :: Int) `shouldThrow` anyIOException + + it "successfully connects to a socket with no exception" $ do + tcpTestUsingClient return return $ readMVar >=> connect' + + describe "UserTimeout" $ do + it "can be set" $ do + when (isSupportedSocketOption UserTimeout) $ do + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock UserTimeout 1000 + getSocketOption sock UserTimeout `shouldReturn` 1000 + setSocketOption sock UserTimeout 2000 + getSocketOption sock UserTimeout `shouldReturn` 2000 + close sock + + -- On various BSD systems the peer credentials are exchanged during + -- connect(), and this does not happen with `socketpair()`. Therefore, + -- we must actually set up a listener and connect, rather than use a + -- socketpair(). + -- + describe "getPeerCredential" $ do + it "can return something" $ do + when isUnixDomainSocketAvailable $ do + -- It would be useful to check that we did not get garbage + -- back, but rather the actual uid of the test program. For + -- that we'd need System.Posix.User, but that is not available + -- under Windows. For now, accept the risk that we did not get + -- the right answer. + -- + let client sock = do + (_, uid, _) <- getPeerCredential sock + uid `shouldNotBe` Nothing + server (sock, _) = do + (_, uid, _) <- getPeerCredential sock + uid `shouldNotBe` Nothing + unixTest client server + {- The below test fails on many *BSD systems, because the getsockopt() + call that underlies getpeereid() does not have the same meaning for + all address families, but the C-library was not checking that the + provided sock is an AF_UNIX socket. This will fixed some day, but + we should not fail on those systems in the mean-time. The upstream + C-library fix is to call getsockname() and check the address family + before calling `getpeereid()`. We could duplicate that in our own + code, and then this test would work on those platforms that have + `getpeereid()` and not the SO_PEERCRED socket option. + + it "return nothing for non-UNIX-domain socket" $ do + when isUnixDomainSocketAvailable $ do + s <- socket AF_INET Stream defaultProtocol + cred1 <- getPeerCredential s + cred1 `shouldBe` (Nothing,Nothing,Nothing) + -} + + describe "getAddrInfo" $ do + it "works for IPv4 address" $ do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } + AddrInfo{addrAddress = (SockAddrInet _ hostAddr)}:_ <- + getAddrInfo (Just hints) (Just "127.128.129.130") Nothing + hostAddressToTuple hostAddr `shouldBe` (0x7f, 0x80, 0x81, 0x82) + +#if defined(IPV6_SOCKET_SUPPORT) + it "works for IPv6 address" $ do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } + host = "2001:0db8:85a3:0000:0000:8a2e:0370:7334" + AddrInfo{addrAddress = (SockAddrInet6 _ _ hostAddr _)}:_ <- + getAddrInfo (Just hints) (Just host) Nothing + hostAddress6ToTuple hostAddr + `shouldBe` (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334) +#endif + + it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do + let hints = defaultHints { addrFlags = [AI_NUMERICSERV] } + void $ getAddrInfo (Just hints) (Just "localhost") Nothing + + describe "unix sockets" $ do + it "basic unix sockets end-to-end" $ do + when isUnixDomainSocketAvailable $ do + let client sock = send sock testMsg + server (sock, addr) = do + recv sock 1024 `shouldReturn` testMsg + addr `shouldBe` (SockAddrUnix "") + unixTest client server diff --git a/tests/Network/Test/Common.hs b/tests/Network/Test/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Network/Test/Common.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Network.Test.Common + ( serverAddr + , testMsg + , lazyTestMsg + , tcpTest + , unixTest + , udpTest + , tcpTestUsingClient + ) where + +import Control.Concurrent (ThreadId, forkIO, myThreadId) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar) +import qualified Control.Exception as E +import Control.Monad +import Data.ByteString (ByteString) +import Network.Socket +import System.Directory +import qualified Data.ByteString.Lazy as L +import System.Timeout (timeout) + +import Test.Hspec + +serverAddr :: String +serverAddr = "127.0.0.1" + +testMsg :: ByteString +testMsg = "This is a test message." + +lazyTestMsg :: L.ByteString +lazyTestMsg = L.fromStrict "This is a test message." + +unixAddr :: String +unixAddr = "/tmp/network-test" + +-- | Establish a connection between client and server and then run +-- 'clientAct' and 'serverAct', in different threads. Both actions +-- get passed a connected 'Socket', used for communicating between +-- client and server. 'unixTest' makes sure that the 'Socket' is +-- closed after the actions have run. +unixTest :: (Socket -> IO a) -> ((Socket, SockAddr) -> IO b) -> IO () +unixTest clientAct serverAct = + test clientSetup clientAct serverSetup server + where + clientSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + connect sock (SockAddrUnix unixAddr) + return sock + + serverSetup = do + sock <- socket AF_UNIX Stream defaultProtocol + unlink unixAddr -- just in case + bind sock (SockAddrUnix unixAddr) + listen sock 1 + return sock + + server sock = E.bracket (accept sock) (killClientSock . fst) serverAct + + unlink file = do + exist <- doesFileExist file + when exist $ removeFile file + + killClientSock sock = do + shutdown sock ShutdownBoth + close sock + unlink unixAddr + +-- | Establish a connection between client and server and then run +-- 'clientAct' and 'serverAct', in different threads. Both actions +-- get passed a connected 'Socket', used for communicating between +-- client and server. 'tcpTest' makes sure that the 'Socket' is +-- closed after the actions have run. +tcpTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO () +tcpTest clientAct serverAct = + tcpTestUsingClient serverAct clientAct clientSetup + where + clientSetup portVar = do + let hints = defaultHints { addrSocketType = Stream } + serverPort <- readMVar portVar + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) +#if !defined(mingw32_HOST_OS) + fd <- fdSocket sock + getNonBlock fd `shouldReturn` True + getCloseOnExec fd `shouldReturn` False +#endif + connect sock $ addrAddress addr + return sock + +tcpTestUsingClient + :: (Socket -> IO a) -> (Socket -> IO b) -> (MVar PortNumber -> IO Socket) -> IO () +tcpTestUsingClient serverAct clientAct clientSetup = do + portVar <- newEmptyMVar + test (clientSetup portVar) clientAct (serverSetup portVar) server + where + serverSetup portVar = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + fd <- fdSocket sock +#if !defined(mingw32_HOST_OS) + getNonBlock fd `shouldReturn` True + getCloseOnExec fd `shouldReturn` False +#endif + setSocketOption sock ReuseAddr 1 + setCloseOnExecIfNeeded fd +#if !defined(mingw32_HOST_OS) + getCloseOnExec fd `shouldReturn` True +#endif + bind sock $ addrAddress addr + listen sock 1 + serverPort <- socketPort sock + putMVar portVar serverPort + return sock + + server sock = do + (clientSock, _) <- accept sock +#if !defined(mingw32_HOST_OS) + fd <- fdSocket clientSock + getNonBlock fd `shouldReturn` True + getCloseOnExec fd `shouldReturn` True +#endif + _ <- serverAct clientSock + close clientSock + +-- | Create an unconnected 'Socket' for sending UDP and receiving +-- datagrams and then run 'clientAct' and 'serverAct'. +udpTest :: (Socket -> PortNumber -> IO a) -> (Socket -> IO b) -> IO () +udpTest clientAct serverAct = do + portVar <- newEmptyMVar + test clientSetup (client portVar) (serverSetup portVar) serverAct + where + clientSetup = socket AF_INET Datagram defaultProtocol + + client portVar sock = do + serverPort <- readMVar portVar + clientAct sock serverPort + + serverSetup portVar = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Datagram + } + addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing + sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + setSocketOption sock ReuseAddr 1 + bind sock $ addrAddress addr + serverPort <- socketPort sock + putMVar portVar serverPort + return sock + +-- | Run a client/server pair and synchronize them so that the server +-- is started before the client and the specified server action is +-- finished before the client closes the 'Socket'. +test :: IO Socket -> (Socket -> IO b) -> IO Socket -> (Socket -> IO c) -> IO () +test clientSetup clientAct serverSetup serverAct = do + tid <- myThreadId + barrier <- newEmptyMVar + _ <- forkIO $ server barrier + client tid barrier + where + server barrier = + E.bracket serverSetup close $ \sock -> do + serverReady + Just _ <- timeout 1000000 $ serverAct sock + putMVar barrier () + where + -- | Signal to the client that it can proceed. + serverReady = putMVar barrier () + + client tid barrier = do + takeMVar barrier + -- Transfer exceptions to the main thread. + bracketWithReraise tid clientSetup close $ \res -> do + Just _ <- timeout 1000000 $ clientAct res + takeMVar barrier + +-- | Like 'bracket' but catches and reraises the exception in another +-- thread, specified by the first argument. +bracketWithReraise :: ThreadId -> IO a -> (a -> IO b) -> (a -> IO ()) -> IO () +bracketWithReraise tid setup teardown thing = + E.bracket setup teardown thing + `E.catch` \ (e :: E.SomeException) -> E.throwTo tid e diff --git a/tests/RegressionSpec.hs b/tests/RegressionSpec.hs deleted file mode 100644 --- a/tests/RegressionSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Tests for things that didn't work in the past. -module RegressionSpec (main, spec) where - -import Control.Monad -import Network.Socket -import Network.Socket.ByteString - -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "getAddrInfo" $ do - it "does not cause segfault on macOS 10.8.2 due to AI_NUMERICSERV" $ do - let hints = defaultHints { addrFlags = [AI_NUMERICSERV] } - void $ getAddrInfo (Just hints) (Just "localhost") Nothing - - describe "Network.Socket.ByteString.recv" $ do - it "checks -1 correctly on Windows" $ do - sock <- socket AF_INET Stream defaultProtocol - recv sock 1024 `shouldThrow` anyException - - describe "Network.Socket.ByteString.send" $ do - it "checks -1 correctly on Windows" $ do - sock <- socket AF_INET Stream defaultProtocol - send sock "hello world" `shouldThrow` anyException diff --git a/tests/SimpleSpec.hs b/tests/SimpleSpec.hs deleted file mode 100644 --- a/tests/SimpleSpec.hs +++ /dev/null @@ -1,370 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module SimpleSpec (main, spec) where - -import Control.Concurrent (ThreadId, forkIO, myThreadId) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, readMVar) -import qualified Control.Exception as E -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as L -import Network.Socket -import Network.Socket.ByteString -import qualified Network.Socket.ByteString.Lazy as Lazy -import System.Directory -import System.Timeout (timeout) - -import Test.Hspec - -main :: IO () -main = hspec spec - -spec :: Spec -spec = do - describe "send" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = send sock testMsg - tcpTest client server - - describe "sendAll" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = sendAll sock testMsg - tcpTest client server - - describe "sendTo" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock serverPort = do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) - sendTo sock testMsg $ addrAddress addr - udpTest client server - - describe "sendAllTo" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock serverPort = do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) - sendAllTo sock testMsg $ addrAddress addr - udpTest client server - - describe "sendMany" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` (S.append seg1 seg2) - client sock = sendMany sock [seg1, seg2] - - seg1 = C.pack "This is a " - seg2 = C.pack "test message." - tcpTest client server - - describe "sendManyTo" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` (S.append seg1 seg2) - client sock serverPort = do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) - sendManyTo sock [seg1, seg2] $ addrAddress addr - - seg1 = C.pack "This is a " - seg2 = C.pack "test message." - udpTest client server - - describe "recv" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = send sock testMsg - tcpTest client server - - it "can treat overflow" $ do - let server sock = do seg1 <- recv sock (S.length testMsg - 3) - seg2 <- recv sock 1024 - let msg = S.append seg1 seg2 - msg `shouldBe` testMsg - client sock = send sock testMsg - tcpTest client server - - it "returns empty string at EOF" $ do - let client s = recv s 4096 `shouldReturn` S.empty - server s = shutdown s ShutdownSend - tcpTest client server - - describe "recvFrom" $ do - it "works well" $ do - let server sock = do (msg, _) <- recvFrom sock 1024 - testMsg `shouldBe` msg - client sock = do - addr <- getPeerName sock - sendTo sock testMsg addr - tcpTest client server - it "can treat overflow" $ do - let server sock = do (seg1, _) <- recvFrom sock (S.length testMsg - 3) - (seg2, _) <- recvFrom sock 1024 - let msg = S.append seg1 seg2 - testMsg `shouldBe` msg - - client sock = send sock testMsg - tcpTest client server - describe "connect" $ do - let - hints = defaultHints { addrSocketType = Stream } - connect' serverPort = do - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - connect sock (addrAddress addr) - return sock - it "fails to connect and throws an IOException" $ do - connect' (8080 :: Int) `shouldThrow` anyIOException - it "successfully connects to a socket with no exception" $ do - tcpTestUsingClient return return $ readMVar >=> connect' - - describe "UserTimeout" $ do - it "can be set" $ do - when (isSupportedSocketOption UserTimeout) $ do - sock <- socket AF_INET Stream defaultProtocol - setSocketOption sock UserTimeout 1000 - getSocketOption sock UserTimeout `shouldReturn` 1000 - setSocketOption sock UserTimeout 2000 - getSocketOption sock UserTimeout `shouldReturn` 2000 - close sock - - -- On various BSD systems the peer credentials are exchanged during - -- connect(), and this does not happen with `socketpair()`. Therefore, - -- we must actually set up a listener and connect, rather than use a - -- socketpair(). - -- - describe "getPeerCredential" $ do - it "can return something" $ do - when isUnixDomainSocketAvailable $ do - -- It would be useful to check that we did not get garbage - -- back, but rather the actual uid of the test program. For - -- that we'd need System.Posix.User, but that is not available - -- under Windows. For now, accept the risk that we did not get - -- the right answer. - -- - let client sock = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - server (sock, _) = do - (_, uid, _) <- getPeerCredential sock - uid `shouldNotBe` Nothing - unixTest client server - {- The below test fails on many *BSD systems, because the getsockopt() - call that underlies getpeereid() does not have the same meaning for - all address families, but the C-library was not checking that the - provided sock is an AF_UNIX socket. This will fixed some day, but - we should not fail on those systems in the mean-time. The upstream - C-library fix is to call getsockname() and check the address family - before calling `getpeereid()`. We could duplicate that in our own - code, and then this test would work on those platforms that have - `getpeereid()` and not the SO_PEERCRED socket option. - - it "return nothing for non-UNIX-domain socket" $ do - when isUnixDomainSocketAvailable $ do - s <- socket AF_INET Stream defaultProtocol - cred1 <- getPeerCredential s - cred1 `shouldBe` (Nothing,Nothing,Nothing) - -} - - describe "getAddrInfo" $ do - it "works for IPv4 address" $ do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } - AddrInfo{addrAddress = (SockAddrInet _ hostAddr)}:_ <- - getAddrInfo (Just hints) (Just "127.128.129.130") Nothing - hostAddressToTuple hostAddr `shouldBe` (0x7f, 0x80, 0x81, 0x82) -#if defined(IPV6_SOCKET_SUPPORT) - it "works for IPv6 address" $ do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } - host = "2001:0db8:85a3:0000:0000:8a2e:0370:7334" - AddrInfo{addrAddress = (SockAddrInet6 _ _ hostAddr _)}:_ <- - getAddrInfo (Just hints) (Just host) Nothing - hostAddress6ToTuple hostAddr - `shouldBe` (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334) -#endif - - describe "unix sockets" $ do - it "basic unix sockets end-to-end" $ do - when isUnixDomainSocketAvailable $ do - let client sock = send sock testMsg - server (sock, addr) = do - recv sock 1024 `shouldReturn` testMsg - addr `shouldBe` (SockAddrUnix "") - unixTest client server - - describe "Lazy.sendAll" $ do - it "works well" $ do - let server sock = recv sock 1024 `shouldReturn` testMsg - client sock = Lazy.sendAll sock $ L.fromChunks [testMsg] - tcpTest client server - ------------------------------------------------------------------------- - -serverAddr :: String -serverAddr = "127.0.0.1" - -testMsg :: ByteString -testMsg = "This is a test message." - -unixAddr :: String -unixAddr = "/tmp/network-test" - ------------------------------------------------------------------------- --- Test helpers - --- | Establish a connection between client and server and then run --- 'clientAct' and 'serverAct', in different threads. Both actions --- get passed a connected 'Socket', used for communicating between --- client and server. 'unixTest' makes sure that the 'Socket' is --- closed after the actions have run. -unixTest :: (Socket -> IO a) -> ((Socket, SockAddr) -> IO b) -> IO () -unixTest clientAct serverAct = do - test clientSetup clientAct serverSetup server - where - clientSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - connect sock (SockAddrUnix unixAddr) - return sock - - serverSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - unlink unixAddr -- just in case - bind sock (SockAddrUnix unixAddr) - listen sock 1 - return sock - - server sock = E.bracket (accept sock) (killClientSock . fst) serverAct - - unlink file = do - exist <- doesFileExist file - when exist $ removeFile file - - killClientSock sock = do - shutdown sock ShutdownBoth - close sock - unlink unixAddr - --- | Establish a connection between client and server and then run --- 'clientAct' and 'serverAct', in different threads. Both actions --- get passed a connected 'Socket', used for communicating between --- client and server. 'tcpTest' makes sure that the 'Socket' is --- closed after the actions have run. -tcpTest :: (Socket -> IO a) -> (Socket -> IO b) -> IO () -tcpTest clientAct serverAct = do - tcpTestUsingClient serverAct clientAct clientSetup - where - clientSetup portVar = do - let hints = defaultHints { addrSocketType = Stream } - serverPort <- readMVar portVar - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) (Just $ show serverPort) - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) -#if !defined(mingw32_HOST_OS) - fd <- fdSocket sock - getNonBlock fd `shouldReturn` True - getCloseOnExec fd `shouldReturn` False -#endif - connect sock $ addrAddress addr - return sock - -tcpTestUsingClient - :: (Socket -> IO a) -> (Socket -> IO b) -> (MVar PortNumber -> IO Socket) -> IO () -tcpTestUsingClient serverAct clientAct clientSetup = do - portVar <- newEmptyMVar - test (clientSetup portVar) clientAct (serverSetup portVar) server - where - serverSetup portVar = do - let hints = defaultHints { - addrFlags = [AI_PASSIVE] - , addrSocketType = Stream - } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - fd <- fdSocket sock -#if !defined(mingw32_HOST_OS) - getNonBlock fd `shouldReturn` True - getCloseOnExec fd `shouldReturn` False -#endif - setSocketOption sock ReuseAddr 1 - setCloseOnExecIfNeeded fd -#if !defined(mingw32_HOST_OS) - getCloseOnExec fd `shouldReturn` True -#endif - bind sock $ addrAddress addr - listen sock 1 - serverPort <- socketPort sock - putMVar portVar serverPort - return sock - - server sock = do - (clientSock, _) <- accept sock -#if !defined(mingw32_HOST_OS) - fd <- fdSocket clientSock - getNonBlock fd `shouldReturn` True - getCloseOnExec fd `shouldReturn` True -#endif - _ <- serverAct clientSock - close clientSock - --- | Create an unconnected 'Socket' for sending UDP and receiving --- datagrams and then run 'clientAct' and 'serverAct'. -udpTest :: (Socket -> PortNumber -> IO a) -> (Socket -> IO b) -> IO () -udpTest clientAct serverAct = do - portVar <- newEmptyMVar - test clientSetup (client portVar) (serverSetup portVar) serverAct - where - clientSetup = socket AF_INET Datagram defaultProtocol - - client portVar sock = do - serverPort <- readMVar portVar - clientAct sock serverPort - - serverSetup portVar = do - let hints = defaultHints { - addrFlags = [AI_PASSIVE] - , addrSocketType = Datagram - } - addr:_ <- getAddrInfo (Just hints) (Just serverAddr) Nothing - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - setSocketOption sock ReuseAddr 1 - bind sock $ addrAddress addr - serverPort <- socketPort sock - putMVar portVar serverPort - return sock - --- | Run a client/server pair and synchronize them so that the server --- is started before the client and the specified server action is --- finished before the client closes the 'Socket'. -test :: IO Socket -> (Socket -> IO b) -> IO Socket -> (Socket -> IO c) -> IO () -test clientSetup clientAct serverSetup serverAct = do - tid <- myThreadId - barrier <- newEmptyMVar - _ <- forkIO $ server barrier - client tid barrier - where - server barrier = do - E.bracket serverSetup close $ \sock -> do - serverReady - Just _ <- timeout 1000000 $ serverAct sock - putMVar barrier () - where - -- | Signal to the client that it can proceed. - serverReady = putMVar barrier () - - client tid barrier = do - takeMVar barrier - -- Transfer exceptions to the main thread. - bracketWithReraise tid clientSetup close $ \res -> do - Just _ <- timeout 1000000 $ clientAct res - takeMVar barrier - --- | Like 'bracket' but catches and reraises the exception in another --- thread, specified by the first argument. -bracketWithReraise :: ThreadId -> IO a -> (a -> IO b) -> (a -> IO ()) -> IO () -bracketWithReraise tid setup teardown thing = - E.bracket setup teardown thing - `E.catch` \ (e :: E.SomeException) -> E.throwTo tid e