Hello community, here is the log from the commit of package ghc-network for openSUSE:Factory checked in at 2019-05-09 10:10:15 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-network (Old) and /work/SRC/openSUSE:Factory/.ghc-network.new.5148 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-network" Thu May 9 10:10:15 2019 rev:19 rq:700203 version:2.8.0.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-network/ghc-network.changes 2018-12-06 12:16:34.301567817 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-network.new.5148/ghc-network.changes 2019-05-09 10:10:20.993189498 +0200 @@ -1,0 +2,9 @@ +Tue Apr 30 09:23:15 UTC 2019 - [email protected] + +- Update network to version 2.8.0.1. + Upstream has edited the change log file since the last release in + a non-trivial way, i.e. they did more than just add a new entry + at the top. You can review the file at: + http://hackage.haskell.org/package/network-2.8.0.1/src/CHANGELOG.md + +------------------------------------------------------------------- Old: ---- network-2.8.0.0.tar.gz New: ---- network-2.8.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-network.spec ++++++ --- /var/tmp/diff_new_pack.KcCDqI/_old 2019-05-09 10:10:24.801200402 +0200 +++ /var/tmp/diff_new_pack.KcCDqI/_new 2019-05-09 10:10:24.805200413 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-network # -# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2019 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,7 +19,7 @@ %global pkg_name network %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.8.0.0 +Version: 2.8.0.1 Release: 0 Summary: Low-level networking interface License: BSD-3-Clause ++++++ network-2.8.0.0.tar.gz -> network-2.8.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/CHANGELOG.md new/network-2.8.0.1/CHANGELOG.md --- old/network-2.8.0.0/CHANGELOG.md 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -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. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/Network/Socket/ByteString/Lazy.hs new/network-2.8.0.1/Network/Socket/ByteString/Lazy.hs --- old/network-2.8.0.0/Network/Socket/ByteString/Lazy.hs 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/Network/Socket/ByteString/Lazy.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/Network/Socket/Types.hsc new/network-2.8.0.1/Network/Socket/Types.hsc --- old/network-2.8.0.0/Network/Socket/Types.hsc 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/Network/Socket/Types.hsc 2001-09-09 03:46:40.000000000 +0200 @@ -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) = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/Network/Socket.hsc new/network-2.8.0.1/Network/Socket.hsc --- old/network-2.8.0.0/Network/Socket.hsc 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/Network/Socket.hsc 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/configure new/network-2.8.0.1/configure --- old/network-2.8.0.0/configure 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/configure 2001-09-09 03:46:40.000000000 +0200 @@ -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 <[email protected]>. # @@ -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='[email protected]' 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\\" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/configure.ac new/network-2.8.0.1/configure.ac --- old/network-2.8.0.0/configure.ac 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/configure.ac 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,4 @@ -AC_INIT([Haskell network package], [2.8.0.0], [[email protected]], [network]) +AC_INIT([Haskell network package], [2.8.0.1], [[email protected]], [network]) ac_includes_default="$ac_includes_default #ifdef HAVE_SYS_SOCKET_H diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/network.cabal new/network-2.8.0.1/network.cabal --- old/network-2.8.0.0/network.cabal 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/network.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/tests/Network/Socket/ByteString/LazySpec.hs new/network-2.8.0.1/tests/Network/Socket/ByteString/LazySpec.hs --- old/network-2.8.0.0/tests/Network/Socket/ByteString/LazySpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/network-2.8.0.1/tests/Network/Socket/ByteString/LazySpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/tests/Network/Socket/ByteStringSpec.hs new/network-2.8.0.1/tests/Network/Socket/ByteStringSpec.hs --- old/network-2.8.0.0/tests/Network/Socket/ByteStringSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/network-2.8.0.1/tests/Network/Socket/ByteStringSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/tests/Network/SocketSpec.hs new/network-2.8.0.1/tests/Network/SocketSpec.hs --- old/network-2.8.0.0/tests/Network/SocketSpec.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/network-2.8.0.1/tests/Network/SocketSpec.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/tests/Network/Test/Common.hs new/network-2.8.0.1/tests/Network/Test/Common.hs --- old/network-2.8.0.0/tests/Network/Test/Common.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/network-2.8.0.1/tests/Network/Test/Common.hs 2001-09-09 03:46:40.000000000 +0200 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/tests/RegressionSpec.hs new/network-2.8.0.1/tests/RegressionSpec.hs --- old/network-2.8.0.0/tests/RegressionSpec.hs 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/tests/RegressionSpec.hs 1970-01-01 01:00:00.000000000 +0100 @@ -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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/network-2.8.0.0/tests/SimpleSpec.hs new/network-2.8.0.1/tests/SimpleSpec.hs --- old/network-2.8.0.0/tests/SimpleSpec.hs 2018-09-05 00:14:52.000000000 +0200 +++ new/network-2.8.0.1/tests/SimpleSpec.hs 1970-01-01 01:00:00.000000000 +0100 @@ -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
