network 2.8.0.0 → 2.8.0.1
raw patch · 13 files changed
+541/−408 lines, 13 filesdep ~hspecPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: hspec
API changes (from Hackage documentation)
- Network.Socket: MkSocket :: CInt -> Family -> SocketType -> ProtocolNumber -> (MVar SocketStatus) -> Socket
+ Network.Socket: MkSocket :: CInt -> Family -> SocketType -> ProtocolNumber -> MVar SocketStatus -> Socket
Files
- CHANGELOG.md +9/−2
- Network/Socket.hsc +1/−0
- Network/Socket/ByteString/Lazy.hs +4/−1
- Network/Socket/Types.hsc +14/−13
- configure +12/−14
- configure.ac +1/−1
- network.cabal +11/−4
- tests/Network/Socket/ByteString/LazySpec.hs +54/−0
- tests/Network/Socket/ByteStringSpec.hs +109/−0
- tests/Network/SocketSpec.hs +126/−0
- tests/Network/Test/Common.hs +200/−0
- tests/RegressionSpec.hs +0/−29
- tests/SimpleSpec.hs +0/−344
CHANGELOG.md view
@@ -1,8 +1,15 @@+## Version 2.8.0.1++* Eensuring that accept returns a correct sockaddr for unix domain.+ [#400](https://github.com/haskell/network/pull/400)+* Avoid out of bounds writes in pokeSockAddr.+ [#400](https://github.com/haskell/network/pull/400)+ ## Version 2.8.0.0 -* Breaking change: PortNumber originally contained Word32 in network+* Breaking change: PortNumber originally contained Word16 in network byte order and used "deriving Ord". This results in strange behavior- on the Ord instance. Now PortNumber holds Word32 in host byte order.+ on the Ord instance. Now PortNumber holds Word16 in host byte order. [#347](https://github.com/haskell/network/pull/347) * Breaking change: stopping the export of the PortNum constructor in PortNumber.
Network/Socket.hsc view
@@ -641,6 +641,7 @@ else do let sz = sizeOfSockAddrByFamily family allocaBytes sz $ \ sockaddr -> do+ zeroMemory sockaddr $ fromIntegral sz #if defined(mingw32_HOST_OS) new_sock <- if threaded
Network/Socket/ByteString/Lazy.hs view
@@ -39,6 +39,7 @@ import Network.Socket (Socket(..), ShutdownCmd(..), shutdown) import Prelude hiding (getContents) import System.IO.Unsafe (unsafeInterleaveIO)+import System.IO.Error (catchIOError) import qualified Data.ByteString as S import qualified Network.Socket.ByteString as N@@ -67,7 +68,9 @@ loop = unsafeInterleaveIO $ do s <- N.recv sock defaultChunkSize if S.null s- then shutdown sock ShutdownReceive >> return Empty+ then do+ shutdown sock ShutdownReceive `catchIOError` const (return ())+ return Empty else Chunk s `liftM` loop -- | Receive data from the socket. The socket must be in a connected
Network/Socket/Types.hsc view
@@ -801,10 +801,8 @@ -- families. Currently only UNIX-domain sockets and the Internet -- families are supported. -#if defined(IPV6_SOCKET_SUPPORT) type FlowInfo = Word32 type ScopeID = Word32-#endif -- | The existence of a constructor does not necessarily imply that -- that socket address type is supported on your system: see@@ -906,6 +904,15 @@ let sz = sizeOfSockAddrByFamily family allocaBytes sz $ \ptr -> f ptr sz +-- We cannot bind sun_paths longer than than the space in the sockaddr_un+-- structure, and attempting to do so could overflow the allocated storage+-- space. This constant holds the maximum allowable path length.+--+#if defined(DOMAIN_SOCKET_SUPPORT)+unixPathMax :: Int+unixPathMax = #const sizeof(((struct sockaddr_un *)NULL)->sun_path)+#endif+ -- We can't write an instance of 'Storable' for 'SockAddr' because -- @sockaddr@ is a sum type of variable size but -- 'Foreign.Storable.sizeOf' is required to be constant.@@ -916,21 +923,15 @@ -- | Write the given 'SockAddr' to the given memory location. pokeSockAddr :: Ptr a -> SockAddr -> IO () #if defined(DOMAIN_SOCKET_SUPPORT)-pokeSockAddr p (SockAddrUnix path) = do-#if defined(darwin_HOST_OS)- zeroMemory p (#const sizeof(struct sockaddr_un))-#else- case path of- ('\0':_) -> zeroMemory p (#const sizeof(struct sockaddr_un))- _ -> return ()-#endif+pokeSockAddr p sa@(SockAddrUnix path) = do+ when (length path > unixPathMax) $ error "pokeSockAddr: path is too long"+ zeroMemory p $ fromIntegral $ sizeOfSockAddr sa #if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8) #endif (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily) let pathC = map castCharToCChar path- poker = case path of ('\0':_) -> pokeArray; _ -> pokeArray0 0- poker ((#ptr struct sockaddr_un, sun_path) p) pathC+ pokeArray ((#ptr struct sockaddr_un, sun_path) p) pathC #endif pokeSockAddr p (SockAddrInet port addr) = do #if defined(darwin_HOST_OS)@@ -1025,13 +1026,13 @@ let x `sl` i = fromIntegral x `shiftL` i :: Word32 in ntohl $ (b3 `sl` 24) .|. (b2 `sl` 16) .|. (b1 `sl` 8) .|. (b0 `sl` 0) -#if defined(IPV6_SOCKET_SUPPORT) -- | Independent of endianness. For example @::1@ is stored as @(0, 0, 0, 1)@. -- -- For direct manipulation prefer 'hostAddress6ToTuple' and -- 'tupleToHostAddress6'. type HostAddress6 = (Word32, Word32, Word32, Word32) +#if defined(IPV6_SOCKET_SUPPORT) hostAddress6ToTuple :: HostAddress6 -> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) hostAddress6ToTuple (w3, w2, w1, w0) =
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.8.0.1. # # 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.8.0.1'+PACKAGE_STRING='Haskell network package 2.8.0.1' PACKAGE_BUGREPORT='libraries@haskell.org' PACKAGE_URL='' @@ -627,7 +627,6 @@ EXTRA_SRCS EXTRA_LIBS EXTRA_CPPFLAGS-CALLCONV EGREP GREP CPP@@ -1249,7 +1248,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.8.0.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1315,7 +1314,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.8.0.1:";; esac cat <<\_ACEOF @@ -1400,7 +1399,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.8.0.1 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc.@@ -1872,7 +1871,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.8.0.1, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@@@ -4097,21 +4096,20 @@ *-mingw* | *-msys*) EXTRA_SRCS="cbits/initWinSock.c, cbits/winSockErr.c, cbits/asyncAccept.c" EXTRA_LIBS=ws2_32- CALLCONV=stdcall ;;+ ;; *-solaris2*) EXTRA_SRCS="cbits/ancilData.c" EXTRA_LIBS="nsl, socket"- CALLCONV=ccall ;;+ ;; *) EXTRA_SRCS="cbits/ancilData.c" EXTRA_LIBS=- CALLCONV=ccall ;;+ ;; esac - ac_config_files="$ac_config_files network.buildinfo" @@ -4621,7 +4619,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.8.0.1, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES@@ -4683,7 +4681,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.8.0.1 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.8.0.0], [libraries@haskell.org], [network])+AC_INIT([Haskell network package], [2.8.0.1], [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.8.0.0+version: 2.8.0.1 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Evan Borden@@ -76,17 +76,24 @@ test-suite spec 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+ -- that work together; easiest way is to constraint+ -- both packages to a small enough version range.+ build-tools: hspec-discover >= 2.6 build-depends: base >= 4.7 && < 5, bytestring, directory, HUnit, network,- hspec+ hspec >= 2.6 test-suite doctest hs-source-dirs: tests
+ tests/Network/Socket/ByteString/LazySpec.hs view
@@ -0,0 +1,54 @@+{-# 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 hiding (recv, recvFrom, send, sendTo)+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++ describe "sendAll" $ do+ it "works well" $ do+ let server sock = recv sock 1024 `shouldReturn` lazyTestMsg+ client sock = sendAll sock lazyTestMsg+ 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++ describe "recv" $ do+ it "works well" $ do+ let server sock = recv sock 1024 `shouldReturn` lazyTestMsg+ 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
+ tests/Network/Socket/ByteStringSpec.hs view
@@ -0,0 +1,109 @@+{-# 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 hiding (recv, recvFrom, send, sendTo)+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 "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++ 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 "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 "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
+ tests/Network/SocketSpec.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.SocketSpec (main, spec) where++import Control.Concurrent.MVar (readMVar)+import Control.Monad+import Network.Socket hiding (recv, send)+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+#ifdef linux_HOST_OS+ it "can end-to-end with an abstract socket" $ do+ when isUnixDomainSocketAvailable $ do+ let+ abstractAddress = toEnum 0:"/haskell/network/abstract"+ clientAct sock = send sock testMsg+ server (sock, addr) = do+ recv sock 1024 `shouldReturn` testMsg+ addr `shouldBe` (SockAddrUnix "")+ unixTestWith abstractAddress (const $ return ()) clientAct server+ it "safely throws an exception" $ do+ when isUnixDomainSocketAvailable $ do+ let abstractAddress = toEnum 0:"/haskell/network/abstract-longlonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglonglong"+ sock <- socket AF_UNIX Stream defaultProtocol+ bind sock (SockAddrUnix abstractAddress) `shouldThrow` anyErrorCall+#endif
+ tests/Network/Test/Common.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Test.Common+ ( serverAddr+ , testMsg+ , lazyTestMsg+ , tcpTest+ , tcpTestUsingClient+ , unixTest+ , unixTestWith+ , udpTest+ ) 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 = unixTestWith unixAddr unlink+ where+ unlink file = do+ exist <- doesFileExist file+ when exist $ removeFile file++unixTestWith+ :: String -- ^ address+ -> (String -> IO ()) -- ^ clean up action+ -> (Socket -> IO a) -- ^ client action+ -> ((Socket, SockAddr) -> IO b) -- ^ server action+ -> IO ()+unixTestWith address cleanupAct clientAct serverAct =+ test clientSetup clientAct serverSetup server+ where+ clientSetup = do+ sock <- socket AF_UNIX Stream defaultProtocol+ connect sock (SockAddrUnix address)+ return sock++ serverSetup = do+ sock <- socket AF_UNIX Stream defaultProtocol+ cleanupAct address -- just in case+ bind sock (SockAddrUnix address)+ listen sock 1+ return sock++ server sock = E.bracket (accept sock) (killClientSock . fst) serverAct++ killClientSock sock = do+ shutdown sock ShutdownBoth+ close sock+ cleanupAct address++-- | 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)+ let 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)+ let 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)+ let 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+ -- Release MVar if server setup fails+ `E.catch` \(e :: E.SomeException) -> putMVar barrier $ Just e+ client tid barrier+ where+ server barrier =+ E.bracket serverSetup close $ \sock -> do+ serverReady+ Just _ <- timeout 1000000 $ serverAct sock+ putMVar barrier Nothing+ where+ -- | Signal to the client that it can proceed.+ serverReady = putMVar barrier Nothing++ client tid barrier = do+ maybe (return ()) E.throwIO =<< takeMVar barrier+ -- Transfer exceptions to the main thread.+ bracketWithReraise tid clientSetup close $ \res -> do+ Just _ <- timeout 1000000 $ clientAct res+ maybe (return ()) E.throwIO =<< 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/RegressionSpec.hs
@@ -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 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/SimpleSpec.hs
@@ -1,344 +0,0 @@-{-# 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 qualified Data.ByteString.Lazy as L-import Network.Socket hiding (send, sendTo, recv, recvFrom)-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 "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-- 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-- -- 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----------------------------------------------------------------------------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- 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)-#if !defined(mingw32_HOST_OS)- let fd = fdSocket sock- getNonBlock fd `shouldReturn` True- getCloseOnExec fd `shouldReturn` False-#endif- 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)- let 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)- let 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