diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## Version 2.6.3.5 + * Reverting "Do not closeFd within sendFd" + [#271](https://github.com/haskell/network/pull/271) + ## Version 2.6.3.4 * Don't touch IPv6Only when running on OpenBSD diff --git a/Network/Socket.hsc b/Network/Socket.hsc --- a/Network/Socket.hsc +++ b/Network/Socket.hsc @@ -1094,8 +1094,11 @@ -- for transmitting file descriptors, mainly. sendFd :: Socket -> CInt -> IO () sendFd sock outfd = do - _ <- throwSocketErrorWaitWrite sock "Network.Socket.sendFd" $ c_sendFd (fdSocket sock) outfd - return () + _ <- ($) throwSocketErrorWaitWrite sock "Network.Socket.sendFd" $ + c_sendFd (fdSocket sock) outfd + -- Note: If Winsock supported FD-passing, thi would have been + -- incorrect (since socket FDs need to be closed via closesocket().) + closeFd outfd -- | Receive a file descriptor over a domain socket. Note that the resulting -- file descriptor may have to be put into non-blocking mode in order to be diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for Haskell network package 2.6.3.1. +# Generated by GNU Autoconf 2.69 for Haskell network package 2.6.3.5. # # Report bugs to . # @@ -580,8 +580,8 @@ # Identity of this package. PACKAGE_NAME='Haskell network package' PACKAGE_TARNAME='network' -PACKAGE_VERSION='2.6.3.1' -PACKAGE_STRING='Haskell network package 2.6.3.1' +PACKAGE_VERSION='2.6.3.5' +PACKAGE_STRING='Haskell network package 2.6.3.5' PACKAGE_BUGREPORT='libraries@haskell.org' PACKAGE_URL='' @@ -1249,7 +1249,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures Haskell network package 2.6.3.1 to adapt to many kinds of systems. +\`configure' configures Haskell network package 2.6.3.5 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1315,7 +1315,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of Haskell network package 2.6.3.1:";; + short | recursive ) echo "Configuration of Haskell network package 2.6.3.5:";; esac cat <<\_ACEOF @@ -1400,7 +1400,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -Haskell network package configure 2.6.3.1 +Haskell network package configure 2.6.3.5 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1872,7 +1872,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell network package $as_me 2.6.3.1, which was +It was created by Haskell network package $as_me 2.6.3.5, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -4621,7 +4621,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by Haskell network package $as_me 2.6.3.1, which was +This file was extended by Haskell network package $as_me 2.6.3.5, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -4683,7 +4683,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -Haskell network package config.status 2.6.3.1 +Haskell network package config.status 2.6.3.5 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell network package], [2.6.3.4], [libraries@haskell.org], [network]) +AC_INIT([Haskell network package], [2.6.3.5], [libraries@haskell.org], [network]) ac_includes_default="$ac_includes_default #ifdef HAVE_SYS_SOCKET_H diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,5 +1,5 @@ name: network -version: 2.6.3.4 +version: 2.6.3.5 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden @@ -74,34 +74,19 @@ c-sources: cbits/HsNet.c ghc-options: -Wall -fwarn-tabs -test-suite simple - hs-source-dirs: tests - main-is: Simple.hs - type: exitcode-stdio-1.0 - - build-depends: - base < 5, - bytestring, - directory, - HUnit, - network, - test-framework, - test-framework-hunit - -test-suite regression +test-suite spec hs-source-dirs: tests - main-is: Regression.hs + main-is: Spec.hs + other-modules: RegressionSpec + SimpleSpec type: exitcode-stdio-1.0 - + ghc-options: -Wall -threaded build-depends: base < 5, bytestring, HUnit, network, - test-framework, - test-framework-hunit - -- Some of the bugs only occur in the threaded RTS - ghc-options: -Wall -threaded + hspec test-suite doctest hs-source-dirs: tests diff --git a/tests/Regression.hs b/tests/Regression.hs deleted file mode 100644 --- a/tests/Regression.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | Tests for things that didn't work in the past. -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- for recv and send -module Main where - -import Network.Socket - -import Control.Exception - -import Test.Framework (Test, defaultMain) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (assertFailure) - ------------------------------------------------------------------------- --- Tests - --- Used to segfault on OS X 10.8.2 due to AI_NUMERICSERV being set --- without a service being set. This is a OS X bug. -testGetAddrInfo :: IO () -testGetAddrInfo = do - let hints = defaultHints { addrFlags = [AI_NUMERICSERV] } - _ <- getAddrInfo (Just hints) (Just "localhost") Nothing - return () - -mkBadSocketAndTry :: (Socket -> IO a) -> IO (Either IOException a) -mkBadSocketAndTry f = do - sock <- socket AF_INET Stream defaultProtocol - try $ f sock - --- Because of 64/32 bitness issues, -1 wasn't correctly checked for on Windows. --- See also GHC ticket #12010 -badRecvShouldThrow :: IO () -badRecvShouldThrow = do - res <- mkBadSocketAndTry $ flip recv 1024 - case res of - Left _ex -> return () - Right _ -> assertFailure "recv didn't throw an exception" - -badSendShouldThrow :: IO () -badSendShouldThrow = do - res <- mkBadSocketAndTry $ flip send "hello" - case res of - Left _ex -> return () - Right _ -> assertFailure "send didn't throw an exception" - ------------------------------------------------------------------------- --- List of all tests - -tests :: [Test] -tests = - [ testCase "testGetAddrInfo" testGetAddrInfo - , testCase "badRecvShouldThrow" badRecvShouldThrow - , testCase "badSendShouldThrow" badSendShouldThrow - ] - ------------------------------------------------------------------------- --- Test harness - -main :: IO () -main = withSocketsDo $ defaultMain tests diff --git a/tests/RegressionSpec.hs b/tests/RegressionSpec.hs new file mode 100644 --- /dev/null +++ b/tests/RegressionSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Tests for things that didn't work in the past. +module RegressionSpec (main, spec) where + +import Control.Monad +import Network.Socket hiding (send, sendTo, recv, recvFrom) +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/Simple.hs b/tests/Simple.hs deleted file mode 100644 --- a/tests/Simple.hs +++ /dev/null @@ -1,497 +0,0 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- for recv - -#if !defined(mingw32_HOST_OS) -# define DOMAIN_SOCKET_SUPPORT 1 -#endif - -module Main where - -import Control.Concurrent (ThreadId, forkIO, myThreadId) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, readMVar) -import qualified Control.Exception as E -import Control.Monad -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as C -#if defined(HAVE_LINUX_CAN_H) -import Data.Maybe (fromJust) -#endif -import Network.Socket hiding (recv, recvFrom, send, sendTo) -import qualified Network.Socket (recv) -import Network.Socket.ByteString -import System.Directory - ---- To tests for AF_CAN on Linux, you need to bring up a virtual (or real can ---- interface.). Run as root: ---- # modprobe can ---- # modprobe can_raw ---- # modprobe vcan ---- # sudo ip link add dev vcan0 type vcan ---- # ip link show vcan0 ---- 3: can0: mtu 16 qdisc noqueue state UNKNOWN link/can ---- Define HAVE_LINUX_CAN to run CAN tests as well. ---- #define HAVE_LINUX_CAN 1 --- #include "../include/HsNetworkConfig.h" -#if defined(HAVE_LINUX_CAN_H) -import Network.BSD (ifNameToIndex) -#endif -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit (Assertion, (@=?), assertBool, assertFailure) - ------------------------------------------------------------------------- - -serverAddr :: String -serverAddr = "127.0.0.1" - -testMsg :: S.ByteString -testMsg = C.pack "This is a test message." - ------------------------------------------------------------------------- --- Tests - ------------------------------------------------------------------------- --- Sending and receiving - -testSend :: Assertion -testSend = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = send sock testMsg - -testSendAll :: Assertion -testSendAll = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = sendAll sock testMsg - -testSendTo :: Assertion -testSendTo = udpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock serverPort = do - addr <- inet_addr serverAddr - sendTo sock testMsg (SockAddrInet serverPort addr) - -testSendAllTo :: Assertion -testSendAllTo = udpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock serverPort = do - addr <- inet_addr serverAddr - sendAllTo sock testMsg (SockAddrInet serverPort addr) - -testSendMany :: Assertion -testSendMany = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) (S.append seg1 seg2) - client sock = sendMany sock [seg1, seg2] - - seg1 = C.pack "This is a " - seg2 = C.pack "test message." - -testSendManyTo :: Assertion -testSendManyTo = udpTest client server - where - server sock = recv sock 1024 >>= (@=?) (S.append seg1 seg2) - client sock serverPort = do - addr <- inet_addr serverAddr - sendManyTo sock [seg1, seg2] (SockAddrInet serverPort addr) - - seg1 = C.pack "This is a " - seg2 = C.pack "test message." - -testRecv :: Assertion -testRecv = tcpTest client server - where - server sock = recv sock 1024 >>= (@=?) testMsg - client sock = send sock testMsg - -testOverFlowRecv :: Assertion -testOverFlowRecv = tcpTest client server - where - server sock = do seg1 <- recv sock (S.length testMsg - 3) - seg2 <- recv sock 1024 - let msg = S.append seg1 seg2 - testMsg @=? msg - - client sock = send sock testMsg - -testRecvFrom :: Assertion -testRecvFrom = tcpTest client server - where - server sock = do (msg, _) <- recvFrom sock 1024 - testMsg @=? msg - - client sock = do - serverPort <- getPeerPort sock - addr <- inet_addr serverAddr - sendTo sock testMsg (SockAddrInet serverPort addr) - -testOverFlowRecvFrom :: Assertion -testOverFlowRecvFrom = tcpTest client server - where - server sock = do (seg1, _) <- recvFrom sock (S.length testMsg - 3) - (seg2, _) <- recvFrom sock 1024 - let msg = S.append seg1 seg2 - testMsg @=? msg - - client sock = send sock testMsg - -testUserTimeout :: Assertion -testUserTimeout = do - when (isSupportedSocketOption UserTimeout) $ do - sock <- socket AF_INET Stream defaultProtocol - setSocketOption sock UserTimeout 1000 - getSocketOption sock UserTimeout >>= (@=?) 1000 - setSocketOption sock UserTimeout 2000 - getSocketOption sock UserTimeout >>= (@=?) 2000 - close sock - -{- -testGetPeerCred:: Assertion -testGetPeerCred = - test clientSetup clientAct serverSetup server - where - clientSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - connect sock $ SockAddrUnix addr - return sock - - serverSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - bind sock $ SockAddrUnix addr - listen sock 1 - return sock - - server sock = do - (clientSock, _) <- accept sock - _ <- serverAct clientSock - close clientSock - - addr = "/tmp/testAddr1" - clientAct sock = withSocketsDo $ do - sendAll sock testMsg - (pid,uid,gid) <- getPeerCred sock - putStrLn $ unwords ["pid=",show pid,"uid=",show uid, "gid=", show gid] - serverAct sock = withSocketsDo $ do - msg <- recv sock 1024 - putStrLn $ C.unpack msg - - -testGetPeerEid :: Assertion -testGetPeerEid = - test clientSetup clientAct serverSetup server - where - clientSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - connect sock $ SockAddrUnix addr - return sock - - serverSetup = do - sock <- socket AF_UNIX Stream defaultProtocol - bind sock $ SockAddrUnix addr - listen sock 1 - return sock - - server sock = do - (clientSock, _) <- accept sock - _ <- serverAct clientSock - close clientSock - - addr = "/tmp/testAddr2" - clientAct sock = withSocketsDo $ do - sendAll sock testMsg - (uid,gid) <- getPeerEid sock - putStrLn $ unwords ["uid=",show uid, "gid=", show gid] - serverAct sock = withSocketsDo $ do - msg <- recv sock 1024 - putStrLn $ C.unpack msg --} - -#if defined(HAVE_LINUX_CAN_H) -canTestMsg = S.pack [ 0,0,0,0 -- can ID = 0 - , 4,0,0,0 -- data length counter = 2 (bytes) - , 0x80,123,321,55 -- SYNC with some random extra bytes - , 0, 0, 0, 0 -- padding - ] - -testCanSend :: Assertion -testCanSend = canTest "vcan0" client server - where - server sock = recv sock 1024 >>= (@=?) canTestMsg - client sock = send sock canTestMsg - -canTest :: String -> (Socket -> IO a) -> (Socket -> IO b) -> IO () -canTest ifname clientAct serverAct = do - ifIndex <- liftM fromJust $ ifNameToIndex ifname - test (clientSetup ifIndex) clientAct (serverSetup ifIndex) serverAct - where - clientSetup ifIndex = do - sock <- socket AF_CAN Raw 1 -- protocol 1 = raw CAN - -- bind the socket to the interface - bind sock (SockAddrCan $ fromIntegral $ ifIndex) - return sock - - serverSetup = clientSetup -#endif - --- The String version of 'recv' should throw an exception when the remote end --- has closed the connection, the ByteString version should return an empty --- ByteString. -testStringEol :: Assertion -testStringEol = tcpTest client close - where client s = do - res <- E.try $ Network.Socket.recv s 4096 - case res of - Left (_ :: IOError) -> return () - Right _ -> assertFailure - "String recv didn't throw an exception on a closed socket" - -testByteStringEol :: Assertion -testByteStringEol = tcpTest client close - where client s = do - res :: Either IOError C.ByteString <- E.try $ recv s 4096 - res @=? Right S.empty - ------------------------------------------------------------------------- --- Conversions of IP addresses - -testHtonlNtohl :: Assertion -testHtonlNtohl = do - let addrl = 0xCafeBabe - addrl @=? (htonl . ntohl) addrl - addrl @=? (ntohl . htonl) addrl - assertBool "BE or LE byte order" $ - ntohl addrl `elem` [0xCafeBabe, 0xbebafeca] - -testHostAddressToTuple :: Assertion -testHostAddressToTuple = do - -- Look up a numeric IPv4 host - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_ADDRCONFIG] } - (AddrInfo{addrAddress = (SockAddrInet _ hostAddr)} : _) <- - getAddrInfo (Just hints) (Just "127.128.129.130") Nothing - -- and check that the decoded address matches the expected representation - (0x7f, 0x80, 0x81, 0x82) @=? hostAddressToTuple hostAddr - -testHostAddressToTupleInv :: Assertion -testHostAddressToTupleInv = do - let addr = (0x7f, 0x80, 0x81, 0x82) - addr @=? (hostAddressToTuple . tupleToHostAddress) addr - -#if defined(IPV6_SOCKET_SUPPORT) -testHostAddress6ToTuple :: Assertion -testHostAddress6ToTuple = do - -- Look up a numeric IPv6 host - 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 - -- and check that the decoded address matches the expected representation - (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334) - @=? hostAddress6ToTuple hostAddr - -testHostAddress6ToTupleInv :: Assertion -testHostAddress6ToTupleInv = do - let addr = (0x2001, 0x0db8, 0x85a3, 0x0000, 0x0000, 0x8a2e, 0x0370, 0x7334) - addr @=? (hostAddress6ToTuple . tupleToHostAddress6) addr -#endif - -#if defined(DOMAIN_SOCKET_SUPPORT) -testUnix :: Assertion -testUnix = do - let client sock = send sock testMsg - server (sock, addr) = do - msg <- recv sock 1024 - testMsg @=? msg - SockAddrUnix "" @=? addr - unixTest client server -#endif - ------------------------------------------------------------------------- --- Other - ------------------------------------------------------------------------- --- List of all tests - -basicTests :: Test -basicTests = testGroup "Basic socket operations" - [ - -- Sending and receiving - testCase "testSend" testSend - , testCase "testSendAll" testSendAll - , testCase "testSendTo" testSendTo - , testCase "testSendAllTo" testSendAllTo - , testCase "testSendMany" testSendMany - , testCase "testSendManyTo" testSendManyTo - , testCase "testRecv" testRecv - , testCase "testOverFlowRecv" testOverFlowRecv - , testCase "testRecvFrom" testRecvFrom - , testCase "testOverFlowRecvFrom" testOverFlowRecvFrom - , testCase "testUserTimeout" testUserTimeout -#if defined(DOMAIN_SOCKET_SUPPORT) - , testCase "testUnix" testUnix -#endif --- , testCase "testGetPeerCred" testGetPeerCred --- , testCase "testGetPeerEid" testGetPeerEid - , testCase "testStringEol" testStringEol - , testCase "testByteStringEol" testByteStringEol -#if defined(HAVE_LINUX_CAN_H) - , testCase "testCanSend" testCanSend -#endif - -- conversions of IP addresses - , testCase "testHtonlNtohl" testHtonlNtohl - , testCase "testHostAddressToTuple" testHostAddressToTuple - , testCase "testHostAddressToTupleInv" testHostAddressToTupleInv -#if defined(IPV6_SOCKET_SUPPORT) - , testCase "testHostAddress6ToTuple" testHostAddress6ToTuple - , testCase "testHostAddress6ToTupleInv" testHostAddress6ToTupleInv -#endif - -- other - ] - -tests :: [Test] -tests = [basicTests] - ------------------------------------------------------------------------- --- Test helpers - --- | Returns the 'PortNumber' of the peer. Will throw an 'error' if --- used on a non-IP socket. -getPeerPort :: Socket -> IO PortNumber -getPeerPort sock = do - sockAddr <- getPeerName sock - case sockAddr of - (SockAddrInet port _) -> return port - (SockAddrInet6 port _ _ _) -> return port - _ -> ioError $ userError "getPeerPort: only works with IP sockets" - --- | 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 - portVar <- newEmptyMVar - test (clientSetup portVar) clientAct (serverSetup portVar) server - where - clientSetup portVar = do - sock <- socket AF_INET Stream defaultProtocol - addr <- inet_addr serverAddr - serverPort <- readMVar portVar - connect sock $ SockAddrInet serverPort addr - return sock - - serverSetup portVar = do - sock <- socket AF_INET Stream defaultProtocol - setSocketOption sock ReuseAddr 1 - addr <- inet_addr serverAddr - bind sock (SockAddrInet aNY_PORT addr) - listen sock 1 - serverPort <- socketPort sock - putMVar portVar serverPort - return sock - - server sock = do - (clientSock, _) <- accept sock - _ <- 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 - sock <- socket AF_INET Datagram defaultProtocol - setSocketOption sock ReuseAddr 1 - addr <- inet_addr serverAddr - bind sock (SockAddrInet aNY_PORT addr) - serverPort <- socketPort sock - putMVar portVar serverPort - return sock - -#if defined(DOMAIN_SOCKET_SUPPORT) -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 = 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 -#endif - --- | 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 - _ <- 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 - _ <- 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 before after thing = - E.bracket before after thing - `E.catch` \ (e :: E.SomeException) -> E.throwTo tid e - ------------------------------------------------------------------------- --- Test harness - -main :: IO () -main = withSocketsDo $ defaultMain tests diff --git a/tests/SimpleSpec.hs b/tests/SimpleSpec.hs new file mode 100644 --- /dev/null +++ b/tests/SimpleSpec.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SimpleSpec (main, spec) where + +import Control.Concurrent (ThreadId, forkIO, myThreadId) +import Control.Concurrent.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 Network.Socket hiding (send, sendTo, recv, recvFrom) +import Network.Socket.ByteString +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 "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 + + 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 + +------------------------------------------------------------------------ + +serverAddr :: String +serverAddr = "127.0.0.1" + +testMsg :: ByteString +testMsg = "This is a test message." + +------------------------------------------------------------------------ +-- 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. '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 + portVar <- newEmptyMVar + test (clientSetup portVar) clientAct (serverSetup portVar) server + 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) + connect sock $ addrAddress addr + return sock + + 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) + setSocketOption sock ReuseAddr 1 + bind sock $ addrAddress addr + listen sock 1 + serverPort <- socketPort sock + putMVar portVar serverPort + return sock + + server sock = do + (clientSock, _) <- accept sock + _ <- 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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}