network 2.6.3.4 → 2.6.3.5
raw patch · 10 files changed
+299/−590 lines, 10 filesdep +hspecdep −directorydep −test-frameworkdep −test-framework-hunitdep ~basedep ~bytestring
Dependencies added: hspec
Dependencies removed: directory, test-framework, test-framework-hunit
Dependency ranges changed: base, bytestring
Files
- CHANGELOG.md +4/−0
- Network/Socket.hsc +5/−2
- configure +9/−9
- configure.ac +1/−1
- network.cabal +7/−22
- tests/Regression.hs +0/−59
- tests/RegressionSpec.hs +29/−0
- tests/Simple.hs +0/−497
- tests/SimpleSpec.hs +243/−0
- tests/Spec.hs +1/−0
CHANGELOG.md view
@@ -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
Network/Socket.hsc view
@@ -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
configure view
@@ -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 <libraries@haskell.org>. #@@ -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\\"
configure.ac view
@@ -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
network.cabal view
@@ -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
− tests/Regression.hs
@@ -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
+ tests/RegressionSpec.hs view
@@ -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
− tests/Simple.hs
@@ -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: <NOARP,UP,LOWER_UP> 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
+ tests/SimpleSpec.hs view
@@ -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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}