diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,38 @@ +0.6.1.0 Lars Petersen 2016-08-11 + + * A potential race condition has been fixed (issue #18): `c_get_last_error` + was supposed to return the error code of the last operation (if any). + On Linux et.al. it just returned `errno` whereas on Windows it wrapped + a call to `WSAGetLastError`. + The problem was that the value of `errno` and `WSAGetLastError` is only + valid when sampled immediately after the failed call. This could not be + easily guaranteed the way it was implemented: GHC's RTS is potentially + allowed to interrupt the thread between the failed call and the call to + `c_get_last_error` (although this is very unlikely when no memory allocation + is necessary). The content of `errno` might have been reset of overridden + by another thread. + The solution for this is that all FFI calls now take a pointer with a reserved + memory location (allocated on the stack, so it's quite cheap) and the C + functions immediately save the errno (if necessary). The `unsafe ccall`s are + guaranteed to be uninterruptible. + + * All tests have been ported to `tasty` as previously proposed by + Roman Cheplyaka. + + * Fixed `connect` operation to use `getsockopt` with SO_ERROR to determine + socket connection status / error code instead of issuing a second connection + attempt (see issue #15). + On Windows, the solution is a bit more difficult: `getsockopt` return 0 + unless the operation has either succeeded or failed. + Unfortunately, there did not exist a mechanism to wait for this condition + (GHC's IO manager lacks this feature). This has been circumvented by + calling `select` for the socket with minimal timeout several times with + an exponential back-off. Tests have been added to validate different aspects + of this. + 0.6.0.1 Lars Petersen 2016-04-10 - * Adapted the `AddrInfo` test suite to not depend on specific nameresolution + * Adapted the `AddrInfo` test suite to not depend on specific name resolution features that aren't available in a `chroot()` environment (see issue #12). 0.6.0.0 Lars Petersen 2016-03-26 diff --git a/CONTRIBUTORS.txt b/CONTRIBUTORS.txt --- a/CONTRIBUTORS.txt +++ b/CONTRIBUTORS.txt @@ -1,3 +1,4 @@ +Mathieu Boespflug (issue #15) Ben Gamari (issue #10) Niklas Hambüchen (issue #9) Michael Fox (reported issue #7) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,20 +19,17 @@ - Absolutely no conditional exports. - No `#ifdef` madness in the Haskell sources. The Haskell binding code - uses the FFI to reference the platform's native networking functions. - If they are not POSIX compliant (i.e. on Windows) a level of - indirection is introduced to create a POSIX compliant equivalent in C - using whatever the platform specific building blocks are. + uses the FFI to reference platform dependant C functions for each operation. + If a platform is not POSIX compliant (i.e. Windows) equivalent functionality + is implemented by using whatever the platform specific building blocks are. ### Platform Support #### Linux -Working. - -#### MacOS - -Working. +Platform is fully supported. Each commit and release is automatically tested with +[Travis CI](https://travis-ci.org/lpeterse/haskell-socket) and several versions +of GHC. #### Windows @@ -54,6 +51,15 @@ This workaround may be removed if someone is willing to sacrifice to improve the IO manager on Windows. +Each release is manually tested on a Windows 10 virtual machine with the +latest Haskell Platform (64bit). + +#### MacOS + +Working, but not regularly tested. + +Please report when it is no longer working on MacOS. + ### Dependencies - base @@ -61,10 +67,17 @@ ### Tests -Run the default test suites: +The project uses [tasty](http://documentup.com/feuerbach/tasty) for testing. +There are two test suites: `default` and `threaded` which are using the same +code. Only difference is that one is compiled against GHC's single threaded RTS +and the other against the multi-threaded one. Run `cabal test` to run both +in sequence. + +In order to see details and colored output you may also want to try + ```bash -cabal test +ghc --make test/test.hs && ./test/test ``` [badge-travis]: https://img.shields.io/travis/lpeterse/haskell-socket.svg diff --git a/platform/linux/cbits/hs_socket.c b/platform/linux/cbits/hs_socket.c --- a/platform/linux/cbits/hs_socket.c +++ b/platform/linux/cbits/hs_socket.c @@ -1,14 +1,107 @@ #include -int hs_setnonblocking(int fd) { - int flags; +int hs_socket (int domain, int type, int protocol, int *err) { +#ifdef SOCK_NONBLOCK + // On Linux, there is an optimized way to set a socket non-blocking + int fd = socket(domain, type | SOCK_NONBLOCK, protocol); + if (fd >= 0) { + return fd; + } +#else + // This is the regular way via fcntl + int fd = socket(domain, type, protocol); + if (fd >= 0) { + int flags = fcntl(fd, F_GETFL, 0); + if (flags >= 0 && !fcntl(fd, F_SETFL, flags | O_NONBLOCK)) { + return fd; + } else { + close(fd); + } + } +#endif + *err = errno; + return -1; +} - if (-1 == (flags = fcntl(fd, F_GETFL, 0))) { - flags = 0; +int hs_connect (int sockfd, const struct sockaddr *name, int namelen, int *err) { + int i = connect(sockfd, name, namelen); + *err = errno; + return i; +} + +int hs_bind (int sockfd, const struct sockaddr *name, int namelen, int *err) { + int i = bind(sockfd, name, namelen); + *err = errno; + return i; +} + +int hs_listen (int sockfd, int backlog, int *err) { + int i = listen(sockfd, backlog); + *err = errno; + return i; +} + +int hs_accept (int sockfd, struct sockaddr *addr, int *addrlen, int *err) { +#ifdef SOCK_NONBLOCK + // On Linux, there is an optimized way to set a socket non-blocking + int fd = accept4(sockfd, addr, addrlen, SOCK_NONBLOCK); + if (fd >= 0) { + return fd; } - return fcntl(fd, F_SETFL, flags | O_NONBLOCK); +#else + // This is the canonical way in absence of accept4 + int fd = accept(sockfd, addr, addrlen); + if (fd >= 0) { + int flags = fcntl(fd, F_GETFL, 0); + if (flags >= 0 && !fcntl(fd, F_SETFL, flags | O_NONBLOCK)) { + return fd; + } else { + close(fd); + } + } +#endif + *err = errno; + return -1; } -int hs_get_last_socket_error(void) { - return errno; -}; +int hs_close (int fd, int *err) { + int i = close(fd); + *err = errno; + return i; +} + +int hs_send (int fd, const void *buf, size_t len, int flags, int *err) { + int i = send(fd, buf, len, flags); + *err = errno; + return i; +} + +int hs_recv (int fd, void *buf, size_t len, int flags, int *err) { + int i = recv(fd, buf, len, flags); + *err = errno; + return i; +} + +int hs_sendto (int fd, const void *buf, size_t len, int flags, const struct sockaddr *dest_addr, int addrlen, int *err) { + int i = sendto(fd, buf, len, flags, dest_addr, addrlen); + *err = errno; + return i; +} + +int hs_recvfrom (int fd, void *buf, size_t len, int flags, struct sockaddr *src_addr, int *addrlen, int *err) { + int i = recvfrom(fd, buf, len, flags, src_addr, addrlen); + *err = errno; + return i; +} + +int hs_getsockopt(int fd, int level, int optname, void *optval, int *optlen, int *err) { + int i = getsockopt(fd, level, optname, optval, optlen); + *err = errno; + return i; +} + +int hs_setsockopt(int fd, int level, int optname, const void *optval, int optlen, int *err) { + int i = setsockopt(fd, level, optname, optval, optlen); + *err = errno; + return i; +} diff --git a/platform/linux/include/hs_socket.h b/platform/linux/include/hs_socket.h --- a/platform/linux/include/hs_socket.h +++ b/platform/linux/include/hs_socket.h @@ -1,4 +1,5 @@ #include +#include #include #include @@ -8,10 +9,20 @@ #include "netinet/in.h" #include "netdb.h" -/* SocketException */ +int hs_socket (int domain, int type, int protocol, int *err); +int hs_connect (int fd, const struct sockaddr *name, int namelen, int *err); +int hs_bind (int fd, const struct sockaddr *name, int namelen, int *err); +int hs_listen (int fd, int backlog, int *err); +int hs_accept (int fd, struct sockaddr *addr, int *addrlen, int *err); +int hs_close (int fd, int *err); -int hs_setnonblocking(int fd); -int hs_get_last_socket_error(void); +int hs_send (int fd, const void *buf, size_t len, int flags, int *err); +int hs_recv (int fd, void *buf, size_t len, int flags, int *err); +int hs_sendto (int fd, const void *buf, size_t len, int flags, const struct sockaddr *dest_addr, int addrlen, int *err); +int hs_recvfrom(int fd, void *buf, size_t len, int flags, struct sockaddr *src_addr, int *addrlen, int *err); + +int hs_getsockopt(int fd, int level, int option_name, void *option_value, int *option_len, int *err); +int hs_setsockopt(int fd, int level, int option_name, const void *option_value, int option_len, int *err); #define SEOK 0 #define SEINTR EINTR diff --git a/platform/linux/src/System/Socket/Internal/Platform.hsc b/platform/linux/src/System/Socket/Internal/Platform.hsc --- a/platform/linux/src/System/Socket/Internal/Platform.hsc +++ b/platform/linux/src/System/Socket/Internal/Platform.hsc @@ -1,8 +1,14 @@ module System.Socket.Internal.Platform where +import Control.Applicative ((<$>)) +import Control.Exception +import Control.Monad (when, join) + import Foreign.Ptr import Foreign.C.Types import Foreign.C.String +import Foreign.Storable +import Foreign.Marshal.Alloc import GHC.Conc (threadWaitReadSTM, threadWaitWriteSTM, atomically) @@ -11,6 +17,8 @@ import System.Socket.Internal.Message import System.Socket.Internal.Exception +#include "hs_socket.h" + unsafeSocketWaitWrite :: Fd -> Int -> IO (IO ()) unsafeSocketWaitWrite fd _ = do threadWaitWriteSTM fd >>= return . atomically . fst @@ -20,7 +28,7 @@ -- > safeSocketWaitRead = do -- > wait <- withMVar msock $ \sock-> do -- > -- Register while holding a lock on the socket descriptor. --- > unsafeSocketWaitRead sock 0 +-- > unsafeSocketWaitRead sock 0 -- > -- Do the waiting without keeping the socket descriptor locked. -- > wait unsafeSocketWaitRead :: Fd -- ^ Socket descriptor @@ -29,50 +37,48 @@ unsafeSocketWaitRead fd _ = do threadWaitReadSTM fd >>= return . atomically . fst +unsafeSocketWaitConnected :: Fd -> IO () +unsafeSocketWaitConnected fd = do + join $ unsafeSocketWaitWrite fd 0 + type CSSize = CInt -foreign import ccall unsafe "socket" - c_socket :: CInt -> CInt -> CInt -> IO Fd - -foreign import ccall unsafe "close" - c_close :: Fd -> IO CInt - -foreign import ccall unsafe "bind" - c_bind :: Fd -> Ptr a -> CInt -> IO CInt +foreign import ccall unsafe "hs_socket" + c_socket :: CInt -> CInt -> CInt -> Ptr CInt -> IO Fd -foreign import ccall unsafe "connect" - c_connect :: Fd -> Ptr a -> CInt -> IO CInt +foreign import ccall unsafe "hs_close" + c_close :: Fd -> Ptr CInt -> IO CInt -foreign import ccall unsafe "accept" - c_accept :: Fd -> Ptr a -> Ptr CInt -> IO Fd +foreign import ccall unsafe "hs_bind" + c_bind :: Fd -> Ptr a -> CInt -> Ptr CInt -> IO CInt -foreign import ccall unsafe "listen" - c_listen :: Fd -> CInt -> IO CInt +foreign import ccall unsafe "hs_connect" + c_connect :: Fd -> Ptr a -> CInt -> Ptr CInt -> IO CInt -foreign import ccall unsafe "send" - c_send :: Fd -> Ptr a -> CSize -> MessageFlags -> IO CSSize +foreign import ccall unsafe "hs_accept" + c_accept :: Fd -> Ptr a -> Ptr CInt -> Ptr CInt -> IO Fd -foreign import ccall unsafe "sendto" - c_sendto :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> CInt -> IO CSSize +foreign import ccall unsafe "hs_listen" + c_listen :: Fd -> CInt -> Ptr CInt -> IO CInt -foreign import ccall unsafe "recv" - c_recv :: Fd -> Ptr a -> CSize -> MessageFlags -> IO CSSize +foreign import ccall unsafe "hs_send" + c_send :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr CInt -> IO CSSize -foreign import ccall unsafe "recvfrom" - c_recvfrom :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> Ptr CInt -> IO CSSize +foreign import ccall unsafe "hs_sendto" + c_sendto :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> CInt -> Ptr CInt -> IO CSSize -foreign import ccall unsafe "getsockopt" - c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt +foreign import ccall unsafe "hs_recv" + c_recv :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr CInt -> IO CSSize -foreign import ccall unsafe "setsockopt" - c_setsockopt :: Fd -> CInt -> CInt -> Ptr a -> CInt -> IO CInt +foreign import ccall unsafe "hs_recvfrom" + c_recvfrom :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> Ptr CInt -> Ptr CInt -> IO CSSize -foreign import ccall unsafe "hs_setnonblocking" - c_setnonblocking :: Fd -> IO CInt +foreign import ccall unsafe "hs_getsockopt" + c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> Ptr CInt -> Ptr CInt -> IO CInt -foreign import ccall unsafe "hs_get_last_socket_error" - c_get_last_socket_error :: IO SocketException +foreign import ccall unsafe "hs_setsockopt" + c_setsockopt :: Fd -> CInt -> CInt -> Ptr a -> CInt -> Ptr CInt -> IO CInt foreign import ccall unsafe "memset" c_memset :: Ptr a -> CInt -> CSize -> IO () diff --git a/platform/win32/cbits/hs_socket.c b/platform/win32/cbits/hs_socket.c --- a/platform/win32/cbits/hs_socket.c +++ b/platform/win32/cbits/hs_socket.c @@ -17,73 +17,154 @@ return 0; }; -int hs_socket(int domain, int type, int protocol) { - if (hs_socket_init() != 0) { - return -1; +int hs_socket(int domain, int type, int protocol, int *err) { + if (!hs_socket_init()) { + u_long iMode = 1; + int fd = socket(domain, type, protocol); + if (fd >= 0) { + if (!ioctlsocket(fd, FIONBIO, &iMode)) { + return fd; + } else { + closesocket(fd); + } + } } - - return socket(domain, type, protocol); + *err = WSAGetLastError(); + return -1; }; -int hs_bind(int sockfd, const struct sockaddr *name, int namelen) { - return bind(sockfd, name, namelen); +int hs_bind(int sockfd, const struct sockaddr *name, int namelen, int *err) { + int i = bind(sockfd, name, namelen); + if (i) { + *err = WSAGetLastError(); + } + return i; }; -int hs_connect(int sockfd, const struct sockaddr *name, int namelen) { - return connect(sockfd, name, namelen); +int hs_connect(int sockfd, const struct sockaddr *name, int namelen, int *err) { + int i = connect(sockfd, name, namelen); + if (i) { + *err = WSAGetLastError(); + } + return i; }; -int hs_listen (int sockfd, int backlog) { - return listen(sockfd, backlog); -}; +/** +* Determine a sockets connection status. +* +* Return values: +* 0: connection established +* 1: connection pending +* 2: connection failed +* 3: select or getsockopt failed +* +* The operation will block for the least possible time interval (1 micro second) +* and is not used as it is supposed to be used as we don't want to block. +* Haskell's RTS is used to wait and poll this operation from time to time. +*/ +int hs_connect_status (int sockfd, int *err) { + int errlen = sizeof(int); + struct timeval timeout = {0,1}; + fd_set writefds; + fd_set exceptfds; -int hs_accept(int sockfd, struct sockaddr *addr, int *addrlen) { - //printf("accepting"); - int x = accept(sockfd, addr, addrlen); - //printf("accepted"); - return x; + FD_ZERO(&writefds); + FD_ZERO(&exceptfds); + FD_SET(sockfd, &writefds); + FD_SET(sockfd, &exceptfds); + + switch (select(sockfd, NULL, &writefds, &exceptfds, &timeout)) { + case 0: + return 1; // Connection pending. + case 1: + if (FD_ISSET(sockfd, &writefds)) { + return 0; // Connection established. + } + if (FD_ISSET(sockfd, &exceptfds) && !getsockopt(sockfd, SOL_SOCKET, SO_ERROR, (char*) err, &errlen)) { + return 2; // Connection failed. + } + default: + *err = WSAGetLastError(); + return -1; // select or getsockopt failed. + } } -int hs_close(int sockfd) { - return closesocket(sockfd); +int hs_listen (int sockfd, int backlog, int *err) { + int i = listen(sockfd, backlog); + if (i) { + *err = WSAGetLastError(); + } + return i; }; -int hs_setnonblocking(int fd) { - // If iMode = 0, blocking is enabled; - // If iMode != 0, non-blocking mode is enabled. +int hs_accept(int fd, struct sockaddr *addr, int *addrlen, int *err) { u_long iMode = 1; - return ioctlsocket(fd, FIONBIO, &iMode); - //return 0; -}; + int ft = accept(fd, addr, addrlen); + if (ft >= 0) { + if (!ioctlsocket(ft, FIONBIO, &iMode)) { + return ft; + } else { + closesocket(ft); + } + } + *err = WSAGetLastError(); + return ft; +} -int hs_send (int sockfd, const void *buf, size_t len, int flags) { - return send(sockfd, buf, len, flags); +int hs_close(int sockfd, int *err) { + int i = closesocket(sockfd); + if (i) { + *err = WSAGetLastError(); + } + return i; }; -int hs_recv (int sockfd, void *buf, size_t len, int flags) { - return recv(sockfd, buf, len, flags); +int hs_send (int sockfd, const void *buf, size_t len, int flags, int *err) { + int i = send(sockfd, buf, len, flags); + if (i < 0) { + *err = WSAGetLastError(); + } + return i; }; -int hs_sendto (int sockfd, const void *buf, size_t len, int flags, - const struct sockaddr *dest_addr, int addrlen) { - return sendto(sockfd, buf, len, flags, dest_addr, addrlen); +int hs_recv (int sockfd, void *buf, size_t len, int flags, int *err) { + int i = recv(sockfd, buf, len, flags); + if (i < 0) { + *err = WSAGetLastError(); + } + return i; }; -int hs_recvfrom(int sockfd, void *buf, size_t len, int flags, - struct sockaddr *src_addr, int *addrlen) { - return recvfrom(sockfd, buf, len, flags, src_addr, addrlen); +int hs_sendto (int sockfd, const void *buf, size_t len, int flags, const struct sockaddr *dest_addr, int addrlen, int *err) { + int i = sendto(sockfd, buf, len, flags, dest_addr, addrlen); + if (i < 0) { + *err = WSAGetLastError(); + } + return i; }; -int hs_get_last_socket_error(void) { - return WSAGetLastError(); +int hs_recvfrom(int sockfd, void *buf, size_t len, int flags, struct sockaddr *src_addr, int *addrlen, int *err) { + int i = recvfrom(sockfd, buf, len, flags, src_addr, addrlen); + if (i < 0) { + *err = WSAGetLastError(); + } + return i; }; -int hs_getsockopt(int sockfd, int level, int option_name, void *option_value, int *option_len) { - return getsockopt(sockfd, level, option_name, option_value, option_len); +int hs_getsockopt(int sockfd, int level, int option_name, void *option_value, int *option_len, int *err) { + int i = getsockopt(sockfd, level, option_name, option_value, option_len); + if (i) { + *err = WSAGetLastError(); + } + return i; }; -int hs_setsockopt(int sockfd, int level, int option_name, const void *option_value, int option_len) { - return setsockopt(sockfd, level, option_name, option_value, option_len); +int hs_setsockopt(int sockfd, int level, int option_name, const void *option_value, int option_len, int *err) { + int i = setsockopt(sockfd, level, option_name, option_value, option_len); + if (i) { + *err = WSAGetLastError(); + } + return i; }; const char *hs_gai_strerror(int errcode) { diff --git a/platform/win32/include/hs_socket.h b/platform/win32/include/hs_socket.h --- a/platform/win32/include/hs_socket.h +++ b/platform/win32/include/hs_socket.h @@ -73,27 +73,25 @@ #define AI_RETURN_PREFERRED_NAMES 0x00010000 #endif - -int hs_setnonblocking(int fd); +int hs_get_last_socket_error(); int hs_socket_init(); -int hs_socket (int domain, int type, int protocol); -int hs_bind (int sockfd, const struct sockaddr *name, int namelen); -int hs_connect (int sockfd, const struct sockaddr *name, int namelen); -int hs_listen (int sockfd, int backlog); -int hs_accept (int sockfd, struct sockaddr *addr, int *addrlen); -int hs_close (int sockfd); +int hs_socket (int domain, int type, int protocol, int *err); +int hs_bind (int sockfd, const struct sockaddr *name, int namelen, int *err); +int hs_connect (int sockfd, const struct sockaddr *name, int namelen, int *err); +int hs_connect_status (int sockfd, int *err); +int hs_listen (int sockfd, int backlog, int *err); +int hs_accept (int sockfd, struct sockaddr *addr, int *addrlen, int *err); +int hs_close (int sockfd, int *err); -int hs_send (int sockfd, const void *buf, size_t len, int flags); -int hs_recv (int sockfd, void *buf, size_t len, int flags); -int hs_sendto (int sockfd, const void *buf, size_t len, int flags, - const struct sockaddr *dest_addr, int addrlen); -int hs_recvfrom(int sockfd, void *buf, size_t len, int flags, - struct sockaddr *src_addr, int *addrlen); +int hs_send (int sockfd, const void *buf, size_t len, int flags, int *err); +int hs_recv (int sockfd, void *buf, size_t len, int flags, int *err); +int hs_sendto (int sockfd, const void *buf, size_t len, int flags, const struct sockaddr *dest_addr, int addrlen, int *err); +int hs_recvfrom(int sockfd, void *buf, size_t len, int flags, struct sockaddr *src_addr, int *addrlen, int *err); -int hs_getsockopt(int sockfd, int level, int option_name, void *option_value, int *option_len); -int hs_setsockopt(int sockfd, int level, int option_name, const void *option_value, int option_len); +int hs_getsockopt(int sockfd, int level, int option_name, void *option_value, int *option_len, int *err); +int hs_setsockopt(int sockfd, int level, int option_name, const void *option_value, int option_len, int *err); int hs_getaddrinfo(const char *node, const char *service, const struct addrinfo *hints, @@ -106,10 +104,6 @@ void hs_freeaddrinfo(struct addrinfo *res); const char *hs_gai_strerror(int errcode); - -/* SocketException */ - -int hs_get_last_socket_error(void); #define SEOK 0 #define SEINTR WSAEINTR diff --git a/platform/win32/src/System/Socket/Internal/Platform.hsc b/platform/win32/src/System/Socket/Internal/Platform.hsc --- a/platform/win32/src/System/Socket/Internal/Platform.hsc +++ b/platform/win32/src/System/Socket/Internal/Platform.hsc @@ -1,12 +1,17 @@ module System.Socket.Internal.Platform where import Control.Concurrent ( threadDelay ) +import Control.Concurrent.MVar ( MVar, withMVar ) +import Control.Exception ( throwIO ) +import Control.Monad ( when ) import Data.Bits import Foreign.Ptr import Foreign.C.Types import Foreign.C.String +import Foreign.Storable +import Foreign.Marshal import System.Posix.Types ( Fd(..) ) @@ -21,50 +26,62 @@ unsafeSocketWaitRead _ iteration = do return (threadDelay $ 1 `shiftL` min iteration 20) +unsafeSocketWaitConnected :: Fd -> IO () +unsafeSocketWaitConnected fd = + alloca $ \errPtr-> loop errPtr 0 + where + loop errPtr iteration = do + i <- c_connect_status fd errPtr + when (i /= 0) $ case i of + 1 -> do + -- Wait with exponential backoff. + threadDelay $ 1 `shiftL` min iteration 20 + -- Try again. + loop errPtr $! iteration + 1 + _ -> do + SocketException <$> peek errPtr >>= throwIO + type CSSize = CInt foreign import ccall unsafe "hs_socket" - c_socket :: CInt -> CInt -> CInt -> IO Fd + c_socket :: CInt -> CInt -> CInt -> Ptr CInt -> IO Fd foreign import ccall unsafe "hs_close" - c_close :: Fd -> IO CInt + c_close :: Fd -> Ptr CInt -> IO CInt foreign import ccall unsafe "hs_bind" - c_bind :: Fd -> Ptr a -> CInt -> IO CInt + c_bind :: Fd -> Ptr a -> CInt -> Ptr CInt -> IO CInt foreign import ccall unsafe "hs_connect" - c_connect :: Fd -> Ptr a -> CInt -> IO CInt + c_connect :: Fd -> Ptr a -> CInt -> Ptr CInt -> IO CInt +foreign import ccall unsafe "hs_connect_status" + c_connect_status :: Fd -> Ptr CInt -> IO CInt + foreign import ccall unsafe "hs_accept" - c_accept :: Fd -> Ptr a -> Ptr CInt -> IO Fd + c_accept :: Fd -> Ptr a -> Ptr CInt -> Ptr CInt -> IO Fd foreign import ccall unsafe "hs_listen" - c_listen :: Fd -> CInt -> IO CInt + c_listen :: Fd -> CInt -> Ptr CInt -> IO CInt foreign import ccall unsafe "hs_send" - c_send :: Fd -> Ptr a -> CSize -> MessageFlags -> IO CSSize + c_send :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr CInt -> IO CSSize foreign import ccall unsafe "hs_sendto" - c_sendto :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> CInt -> IO CSSize + c_sendto :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> CInt -> Ptr CInt -> IO CSSize foreign import ccall unsafe "hs_recv" - c_recv :: Fd -> Ptr a -> CSize -> MessageFlags -> IO CSSize + c_recv :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr CInt -> IO CSSize foreign import ccall unsafe "hs_recvfrom" - c_recvfrom :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> Ptr CInt -> IO CSSize + c_recvfrom :: Fd -> Ptr a -> CSize -> MessageFlags -> Ptr b -> Ptr CInt -> Ptr CInt -> IO CSSize foreign import ccall unsafe "hs_getsockopt" - c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt + c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> Ptr CInt -> Ptr CInt -> IO CInt foreign import ccall unsafe "hs_setsockopt" - c_setsockopt :: Fd -> CInt -> CInt -> Ptr a -> CInt -> IO CInt - -foreign import ccall unsafe "hs_setnonblocking" - c_setnonblocking :: Fd -> IO CInt - -foreign import ccall unsafe "hs_get_last_socket_error" - c_get_last_socket_error :: IO SocketException + c_setsockopt :: Fd -> CInt -> CInt -> Ptr a -> CInt -> Ptr CInt -> IO CInt foreign import ccall unsafe "memset" c_memset :: Ptr a -> CInt -> CSize -> IO () diff --git a/socket.cabal b/socket.cabal --- a/socket.cabal +++ b/socket.cabal @@ -1,5 +1,5 @@ name: socket -version: 0.6.0.1 +version: 0.6.1.0 synopsis: An extensible socket library. description: This library is a minimal cross platform interface for @@ -14,7 +14,8 @@ cabal-version: >=1.10 homepage: https://github.com/lpeterse/haskell-socket bug-reports: https://github.com/lpeterse/haskell-socket/issues -tested-with: GHC==7.10.1, GHC==7.8.3 +tested-with: GHC==7.8.1, GHC==7.8.2, GHC==7.8.3, GHC==7.8.4, + GHC==7.10.1, GHC==7.10.2, GHC==7.10.3, GHC==8.0.1 extra-source-files: README.md CHANGELOG.md CONTRIBUTORS.txt @@ -58,105 +59,41 @@ hs-source-dirs: platform/linux/src c-sources: platform/linux/cbits/hs_socket.c -test-suite UDP - hs-source-dirs: tests - main-is: UDP.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite TCP - hs-source-dirs: tests - main-is: TCP.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite TCP-sendAndRecvAll - hs-source-dirs: tests - main-is: TCP-sendAndRecvAll.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite PingPong - hs-source-dirs: tests - main-is: PingPong.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite AddrInfo - hs-source-dirs: tests - main-is: AddrInfo.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - -test-suite NonBlockingIO - hs-source-dirs: tests - main-is: NonBlockingIO.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite NonBlockingIO-threaded - hs-source-dirs: tests - main-is: NonBlockingIO.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - ghc-options: -threaded - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite IPV6_V6ONLY - hs-source-dirs: tests - main-is: IPV6_V6ONLY.hs - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async - -test-suite EPIPE - hs-source-dirs: tests - default-language: Haskell2010 - main-is: EPIPE.hs - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async +test-suite default + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + test.hs + build-depends: + base >= 4.7 && < 5 + , tasty >= 0.11 + , tasty-hunit + , async + , bytestring + , socket -test-suite EOPNOTSUPP - hs-source-dirs: tests - default-language: Haskell2010 - main-is: EOPNOTSUPP.hs - type: exitcode-stdio-1.0 - build-depends: base >= 4.7 && < 5 - , bytestring < 0.11 - , socket - , async +test-suite threaded + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + test.hs + ghc-options: + -threaded + build-depends: + base >= 4.7 && < 5 + , tasty >= 0.11 + , tasty-hunit + , async + , bytestring + , socket source-repository head type: git diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc --- a/src/System/Socket.hsc +++ b/src/System/Socket.hsc @@ -185,109 +185,63 @@ socket = socket' where socket' :: forall f t p. (Family f, Type t, Protocol p) => IO (Socket f t p) - socket' = do + socket' = alloca $ \errPtr-> do bracketOnError -- Try to acquire the socket resource. This part has exceptions masked. - ( c_socket (familyNumber (undefined :: f)) (typeNumber (undefined :: t)) (protocolNumber (undefined :: p)) ) + ( c_socket (familyNumber (undefined :: f)) (typeNumber (undefined :: t)) (protocolNumber (undefined :: p)) errPtr ) -- On failure after the c_socket call we try to close the socket to not leak file descriptors. -- If closing fails we cannot really do something about it. We tried at least. - -- This part has exceptions masked as well. c_close is an unsafe FFI call. - ( \fd-> when (fd >= 0) (c_close fd >> return ()) ) - -- If an exception is raised, it is reraised after the socket has been closed. - -- This part has async exceptions unmasked (via restore). - ( \fd-> if fd < 0 then do - c_get_last_socket_error >>= throwIO - else do - -- setNonBlockingFD calls c_fcntl_write which is an unsafe FFI call. - i <- c_setnonblocking fd - if i < 0 then do - c_get_last_socket_error >>= throwIO - else do - mfd <- newMVar fd - let s = Socket mfd - _ <- mkWeakMVar mfd (close s) - return s + -- c_close is an unsafe FFI call. + ( \fd-> when (fd >= 0) $ alloca $ void . c_close fd ) + ( \fd-> do + when (fd < 0) (SocketException <$> peek errPtr >>= throwIO) + mfd <- newMVar fd + let s = Socket mfd + _ <- mkWeakMVar mfd (close s) + return s ) --- | Connects to an remote address. +-- | Connects to a remote address. -- --- - Calling `connect` on a `close`d socket throws `eBadFileDescriptor` even if the former file descriptor has been reassigned. -- - This operation returns as soon as a connection has been established (as -- if the socket were blocking). The connection attempt has either failed or -- succeeded after this operation threw an exception or returned. --- - The operation might throw `SocketException`s. Due to implementation quirks --- the socket should be considered in an undefined state when this operation --- failed. It should be closed then. --- - Also see [these considerations](http://cr.yp.to/docs/connect.html) on --- the problems with connecting non-blocking sockets. +-- - The socket is locked throughout the whole operation. +-- - The operation throws `SocketException`s. Calling `connect` on a `close`d +-- socket throws `eBadFileDescriptor` even if the former file descriptor has +-- been reassigned. connect :: (Family f, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO () -connect (Socket mfd) addr = do - alloca $ \addrPtr-> do - poke addrPtr addr - let addrLen = fromIntegral (sizeOf addr) - mwait <- withMVar mfd $ \fd-> do - when (fd < 0) (throwIO eBadFileDescriptor) +connect (Socket mfd) addr = + withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + alloca $ \addrPtr-> alloca $ \errPtr-> do + poke addrPtr addr + let addrLen = fromIntegral (sizeOf addr) -- The actual connection attempt. - i <- c_connect fd addrPtr addrLen + i <- c_connect fd addrPtr addrLen errPtr -- On non-blocking sockets we expect to get EINPROGRESS or EWOULDBLOCK. - if i < 0 then do - e <- c_get_last_socket_error - if e == eInProgress || e == eWouldBlock || e == eInterrupted then do - -- The manpage says that in this case the connection - -- shall be established asynchronously and one is - -- supposed to wait. - wait <- unsafeSocketWaitWrite fd 0 - return (Just wait) - else do - throwIO e - else do - -- This should not be the case on non-blocking socket, but better safe than sorry. - return Nothing - case mwait of - Nothing -> do - -- The connection could be established synchronously. Nothing else to do. - return () - Just wait -> do - -- This either waits or does nothing. - wait - -- By here we don't know anything about the current connection status. - -- It might either have succeeded, failed or is still undecided. - -- The approach is to try a second connection attempt, because its error - -- codes allow us to distinguish all three potential states. - ( fix $ \again iteration-> do - mwait' <- withMVar mfd $ \fd-> do - i <- c_connect fd addrPtr addrLen - if i < 0 then do - e <- c_get_last_socket_error - if e == eIsConnected then do - -- This is what we want. The connection is established. - return Nothing - else if e == eAlready then do - -- The previous connection attempt is still pending. - Just Control.Applicative.<$> unsafeSocketWaitWrite fd iteration - else do - -- The previous connection failed (results in EINPROGRESS or - -- EWOULBLOCK here) or something else is wrong. - -- We throw eTimedOut here as we don't know and will never - -- know the exact reason (better suggestions appreciated). - throwIO eTimedOut - else do - -- This means the last connection attempt succeeded immediately. - -- Linux does this when connecting to the same address when the - -- unsafeSocketWaitWrite call signals writeability. - return Nothing - case mwait' of - Nothing -> do - return () - Just wait' -> do - wait' - again $! iteration + 1 - ) 1 + when (i /= 0) $ do + err <- SocketException <$> peek errPtr + if err == eInProgress || err == eWouldBlock + then do + -- The manpage says that in this case the connection + -- shall be established asynchronously and one is + -- supposed to wait. + unsafeSocketWaitConnected fd + -- At least on Linux a second connect after signaled writeability + -- will not fail (the next one would). + i' <- c_connect fd addrPtr addrLen errPtr + when (i' /= 0) $ do + err' <- SocketException <$> peek errPtr + -- On Windows, the second connect fails with `eIsConnected`. + -- In our case this is not an error condition - other errors are. + when (err' /= eIsConnected) (throwIO err') + else throwIO err -- | Bind a socket to an address. -- -- - Calling `bind` on a `close`d socket throws `eBadFileDescriptor` even if the former file descriptor has been reassigned. --- - It is assumed that `c_bind` never blocks and therefore `eInProgress`, `eAlready` and `eInterrupted` don't occur. +-- - It is assumed that `bind` never blocks and therefore `eInProgress`, `eAlready` and `eInterrupted` don't occur. -- This assumption is supported by the fact that the Linux manpage doesn't mention any of these errors, -- the Posix manpage doesn't mention the last one and even MacOS' implementation will never -- fail with any of these when the socket is configured non-blocking as @@ -295,14 +249,12 @@ -- - This operation throws `SocketException`s. Consult your @man@ page for -- details and specific @errno@s. bind :: (Family f, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO () -bind (Socket mfd) addr = do - alloca $ \addrPtr-> do +bind (Socket mfd) addr = + alloca $ \addrPtr-> alloca $ \errPtr-> do poke addrPtr addr withMVar mfd $ \fd-> do - i <- c_bind fd addrPtr (fromIntegral $ sizeOf addr) - if i < 0 - then c_get_last_socket_error >>= throwIO - else return () + i <- c_bind fd addrPtr (fromIntegral $ sizeOf addr) errPtr + when (i /= 0) (SocketException <$> peek errPtr >>= throwIO) -- | Starts listening and queueing connection requests on a connection-mode -- socket. @@ -315,13 +267,10 @@ -- - This operation throws `SocketException`s. Consult your @man@ page for -- details and specific @errno@s. listen :: Socket f t p -> Int -> IO () -listen (Socket ms) backlog = do - i <- withMVar ms $ \s-> do - c_listen s (fromIntegral backlog) - if i < 0 then do - c_get_last_socket_error >>= throwIO - else do - return () +listen (Socket ms) backlog = + withMVar ms $ \s-> alloca $ \errPtr-> do + i <- c_listen s (fromIntegral backlog) errPtr + when (i /= 0) (SocketException <$> peek errPtr >>= throwIO) -- | Accept a new connection. -- @@ -344,40 +293,34 @@ accept' = do -- Allocate local (!) memory for the address. alloca $ \addrPtr-> do - alloca $ \addrPtrLen-> do + alloca $ \addrPtrLen-> alloca $ \errPtr-> do poke addrPtrLen (fromIntegral $ sizeOf (undefined :: SocketAddress f)) ( fix $ \again iteration-> do -- We mask asynchronous exceptions during this critical section. - ews <- withMVarMasked mfd $ \fd-> do - fix $ \retry-> do - ft <- c_accept fd addrPtr addrPtrLen - if ft < 0 then do - e <- c_get_last_socket_error - if e == eWouldBlock || e == eAgain - then do - unsafeSocketWaitRead fd iteration >>= return . Left - else if e == eInterrupted - -- On EINTR it is good practice to just retry. - then retry - else throwIO e - -- This is the critical section: We got a valid descriptor we have not yet returned. - else do - i <- c_setnonblocking ft - if i < 0 then do - c_get_last_socket_error >>= throwIO + ews <- withMVar mfd $ \fd-> do + when (fd < 0) (throwIO eBadFileDescriptor) + bracketOnError + ( c_accept fd addrPtr addrPtrLen errPtr ) + ( \ft-> when (ft >= 0) $ alloca $ void . c_close ft ) + ( \ft-> if ft < 0 + then do + err <- SocketException <$> peek errPtr + unless (err == eWouldBlock || err == eAgain) (throwIO err) + wait <- unsafeSocketWaitRead fd iteration + return $ Left wait else do - -- This peek operation might be a little expensive, but I don't see an alternative. addr <- peek addrPtr :: IO (SocketAddress f) -- newMVar is guaranteed to be not interruptible. mft <- newMVar ft -- Register a finalizer on the new socket. _ <- mkWeakMVar mft (close (Socket mft `asTypeOf` s)) - return (Right (Socket mft, addr)) + return $ Right (Socket mft, addr) + ) -- If ews is Left we got EAGAIN or EWOULDBLOCK and retry after the next event. case ews of Left wait -> wait >> (again $! iteration + 1) Right sock -> return sock - ) 0 -- This is the initial iteration value. + ) 0 -- This is the initial iteration value. -- | Send a message on a connected socket. -- @@ -473,14 +416,12 @@ -- EINTR: It is best practice to just retry the operation what we do here. -- EIO: Only occurs when filesystem is involved (?). -- Conclusion: Our close should never fail. If it does, something is horribly wrong. - ( const $ fix $ \retry-> do - i <- c_close fd - if i < 0 then do - e <- c_get_last_socket_error - if e == eInterrupted - then retry - else throwIO e - else return () + ( const $ alloca $ \errPtr-> fix $ \retry-> do + i <- c_close fd errPtr + when (i /= 0) $ do + err <- SocketException <$> peek errPtr + when (err /= eInterrupted) (throwIO err) + retry ) fd -- When we arrive here, no exception has been thrown and the descriptor has been closed. -- We put an invalid file descriptor into the MVar. diff --git a/src/System/Socket/Internal/Socket.hsc b/src/System/Socket/Internal/Socket.hsc --- a/src/System/Socket/Internal/Socket.hsc +++ b/src/System/Socket/Internal/Socket.hsc @@ -24,7 +24,7 @@ import Control.Concurrent.MVar import Control.Exception import Control.Monad -import Control.Applicative +import Control.Applicative ((<$>)) import Foreign.Ptr import Foreign.Storable @@ -111,26 +111,18 @@ ------------------------------------------------------------------------------- unsafeSetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> a -> IO () -unsafeSetSocketOption (Socket mfd) level name value = do - withMVar mfd $ \fd-> - alloca $ \vPtr-> do - poke vPtr value - i <- c_setsockopt fd level name - vPtr - (fromIntegral $ sizeOf value) - when (i < 0) $ do - c_get_last_socket_error >>= throwIO +unsafeSetSocketOption (Socket mfd) level name value = + withMVar mfd $ \fd-> alloca $ \vPtr-> alloca $ \errPtr-> do + poke vPtr value + i <- c_setsockopt fd level name vPtr (fromIntegral $ sizeOf value) errPtr + when (i < 0) (SocketException <$> peek errPtr >>= throwIO) unsafeGetSocketOption :: Storable a => Socket f t p -> CInt -> CInt -> IO a -unsafeGetSocketOption (Socket mfd) level name = do - u <- return undefined - withMVar mfd $ \fd-> - alloca $ \vPtr-> do - alloca $ \lPtr-> do - poke lPtr (fromIntegral $ sizeOf u) - i <- c_getsockopt fd level name vPtr (lPtr :: Ptr CInt) - if i < 0 then do - c_get_last_socket_error >>= throwIO - else do - x <- peek vPtr - return (x `asTypeOf` u) +unsafeGetSocketOption (Socket mfd) level name = + withMVar mfd $ \fd-> alloca $ \vPtr-> alloca $ \lPtr-> alloca $ \errPtr-> do + u <- return undefined + poke lPtr (fromIntegral $ sizeOf u) + i <- c_getsockopt fd level name vPtr (lPtr :: Ptr CInt) errPtr + when (i < 0) (SocketException <$> peek errPtr >>= throwIO) + x <- peek vPtr + return (x `asTypeOf` u) diff --git a/src/System/Socket/Unsafe.hsc b/src/System/Socket/Unsafe.hsc --- a/src/System/Socket/Unsafe.hsc +++ b/src/System/Socket/Unsafe.hsc @@ -36,12 +36,15 @@ import Data.Function +import Control.Applicative ((<$>)) import Control.Monad import Control.Exception import Control.Concurrent.MVar import Foreign.C.Types import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc import System.Socket.Internal.Socket import System.Socket.Internal.Platform @@ -68,26 +71,21 @@ unsafeReceiveFrom s bufPtr bufSize flags addrPtr addrSizePtr = do tryWaitRetryLoop s unsafeSocketWaitRead (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr) -tryWaitRetryLoop :: Socket f t p -> (Fd -> Int-> IO (IO ())) -> (Fd -> IO CInt) -> IO CInt +tryWaitRetryLoop :: Socket f t p -> (Fd -> Int-> IO (IO ())) -> (Fd -> Ptr CInt -> IO CInt) -> IO CInt tryWaitRetryLoop (Socket mfd) getWaitAction action = loop 0 where loop iteration = do - ewr <- withMVar mfd $ \fd-> do - when (fd < 0) $ do - throwIO eBadFileDescriptor - fix $ \retry-> do - i <- action fd - if (i < 0) then do - e <- c_get_last_socket_error - if e == eWouldBlock || e == eAgain then do - getWaitAction fd iteration >>= return . Left - else if e == eInterrupted - then retry - else throwIO e - else do - -- The following is quite interesting for debugging: - -- when (iteration /= 0) (print iteration) - return (Right i) + ewr <- withMVar mfd $ \fd-> alloca $ \errPtr-> do + when (fd < 0) (throwIO eBadFileDescriptor) + i <- action fd errPtr + if (i < 0) then do + err <- SocketException <$> peek errPtr + unless (err == eWouldBlock || err == eAgain) (throwIO err) + Left <$> getWaitAction fd iteration + else + -- The following is quite interesting for debugging: + -- when (iteration /= 0) (print iteration) + return (Right i) case ewr of Left wait -> do wait diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Concurrent ( threadDelay ) +import Control.Concurrent.Async ( async, race, poll, cancel, concurrently, wait ) +import Control.Exception ( try, bracket, throwIO, catch ) +import Control.Monad ( when, unless, void ) + +import Prelude hiding ( head ) + +import Data.Maybe ( isJust ) +import Data.Monoid ( mempty ) +import Data.Int ( Int64 ) +import qualified Data.ByteString.Lazy as LBS + +import Test.Tasty +import Test.Tasty.HUnit + +import System.Socket +import System.Socket.Family.Inet +import System.Socket.Family.Inet6 +import System.Socket.Type.Stream +import System.Socket.Type.Datagram +import System.Socket.Protocol.TCP +import System.Socket.Protocol.UDP + +main :: IO () +main = defaultMain $ testGroup "System.Socket" + [ group00 + , group01 + , group02 + , group03 + , group07 + , group80 + , group99 ] + +port :: InetPort +port = 39000 + +port6 :: Inet6Port +port6 = 39000 + +group00 :: TestTree +group00 = testGroup "accept" + [ testGroup "Inet/Strem/TCP" + [ testCase "cancel operation" $ + -- | This is to test interruptability of (blocking) calls like + -- accept. The implementation may either run the call "safe" + -- in another thread if it is really blocking or wait on events + -- in which case the control is at the RTS's IO manager. + -- In both cases this test should be able to cancel the accept + -- async and therefore terminate. + -- If the test hangs, this means the runtime system got sedated + -- possibly due to a blocking system call in a non-threaded + -- environment. + bracket (socket :: IO (Socket Inet Stream TCP)) close $ \s-> do + setSocketOption s (ReuseAddress True) + bind s (SocketAddressInet inetLoopback port) + listen s 5 + a <- async (accept s) + threadDelay 1000000 -- make sure the async call really got enough time to start + p <- poll a + case p of + Just (Left ex) -> assertFailure "unexpected exception" + Just (Right _) -> assertFailure "unexpected connect" + Nothing -> void $ cancel a + ] + ] + +group01 :: TestTree +group01 = testGroup "connect" [ testGroup "Inet/Stream/TCP" t1 ] + where + t1 = + [ testCase "connect to closed port on inetLoopback" $ bracket + ( socket :: IO (Socket Inet Stream TCP)) + close + ( \s-> do + r <- try $ connect s (SocketAddressInet inetLoopback port) + case r of + Left e | e == eConnectionRefused -> return () + | otherwise -> throwIO e + Right () -> assertFailure "connection should have failed" + ) + + , testCase "connect to closed port on inetNone" $ bracket + ( socket :: IO (Socket Inet Stream TCP)) + close + ( \s-> do + r <- try $ connect s (SocketAddressInet inetNone port) + case r of + Left e | e == eNetworkUnreachable -> return () + | e == eAddressNotAvailable -> return () + | otherwise -> throwIO e + Right () -> assertFailure "connection should have failed" + ) + + , testCase "connect to open socket on localhost" $ bracket + ( do server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + (\(server,client)-> do + close server + close client + ) + (\(server,client)-> do + setSocketOption server (ReuseAddress True) + bind server (SocketAddressInet inetLoopback port) + listen server 5 + connect client (SocketAddressInet inetLoopback port) + ) + + , testCase "connect closed socket" $ bracket + ( do server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + (\(server,client)-> do + close server + close client + ) + (\(server,client)-> do + setSocketOption server (ReuseAddress True) + bind server (SocketAddressInet inetLoopback port) + listen server 5 + close client + connect client (SocketAddressInet inetLoopback port) + ) `catch` \e-> case e of + _ | e == eBadFileDescriptor -> return () + | otherwise -> assertFailure "expected eBadFileDescriptor" + + , testCase "connect already connected socket" $ bracket + ( do server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + (\(server,client)-> do + close server + close client + ) + (\(server,client)-> do + setSocketOption server (ReuseAddress True) + bind server (SocketAddressInet inetLoopback port) + listen server 5 + connect client (SocketAddressInet inetLoopback port) + connect client (SocketAddressInet inetLoopback port) + assertFailure "should have thrown eIsConnected" + ) `catch` \e-> case e of + _ | e == eIsConnected -> return () + | otherwise -> assertFailure "expected eIsConnected" + ] + +group02 :: TestTree +group02 = testGroup "listen" + [ testGroup "Inet/Datagram/UDP" + [ testCase "listen on bound socket" $ bracket + ( socket :: IO (Socket Inet Datagram UDP) ) close $ \sock-> do + bind sock (SocketAddressInet inetLoopback port) + setSocketOption sock (ReuseAddress True) + listen sock 5 `catch` \e-> case e of + _ | e == eOperationNotSupported -> return () + _ -> assertFailure "expected eOperationNotSupported" + ] + , testGroup "Inet/Stream/TCP" + [ testCase "listen on bound socket" $ bracket + ( socket :: IO (Socket Inet Stream TCP) ) close $ \sock-> do + bind sock (SocketAddressInet inetLoopback port) + setSocketOption sock (ReuseAddress True) + listen sock 5 + ] + ] + +group03 :: TestTree +group03 = testGroup "send/receive" + [ testGroup "Inet/Stream/TCP" + [ testCase "send and receive a chunk" $ bracket + ( do + server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + let addr = SocketAddressInet inetLoopback port + let helloWorld = "Hello world!" + setSocketOption server (ReuseAddress True) + bind server addr + listen server 5 + serverRecv <- async $ do + (peerSock, peerAddr) <- accept server + receive peerSock 4096 mempty + connect client addr + send client helloWorld mempty + msg <- wait serverRecv + when (msg /= helloWorld) (assertFailure "Received message was bogus.") + ) + , testCase "trigger ePipe exception" $ bracket + ( do + server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + let addr = SocketAddressInet inetLoopback port + setSocketOption server (ReuseAddress True) + bind server addr + listen server 5 + connect client addr + (peerSock, _) <- accept server + _ <- send client "This should be received." mempty + _ <- receive peerSock 4096 mempty + close peerSock + threadDelay 1000000 + e1 <- try $ send client "This might fail." mempty + case e1 of + Right _ -> return () + Left e -> unless (e == ePipe) (throwIO e) + threadDelay 1000000 + e2 <- try $ send client "This should fail." mempty + case e2 of + Right _ -> assertFailure "expected ePipe" + Left e -> unless (e == ePipe) (throwIO e) + ) + ] + , testGroup "Inet/Datagram/UDP" + [ testCase "send and receive a datagram" $ bracket + ( do + server <- socket :: IO (Socket Inet Datagram UDP) + client <- socket :: IO (Socket Inet Datagram UDP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + let addr = SocketAddressInet inetLoopback port + let helloWorld = "Hello world!" + bind server addr + ((msg,peeraddr),_) <- concurrently (receiveFrom server 4096 mempty) $ do + -- This is a race condition: + -- The server must listen before the client sends his msg or the packt goes + -- to nirvana. Still, a second here should be enough. If not, there's + -- something wrong worth investigating. + threadDelay 1000000 + sendTo client helloWorld mempty addr + when (msg /= helloWorld) $ assertFailure "messages not equal" + ) + ] + ] + +group07 :: TestTree +group07 = testGroup "sendAll/receiveAll" + [ testGroup "Inet/Stream/TCP" + [ testCase "send and receive a 128MB chunk" $ bracket + ( do + server <- socket :: IO (Socket Inet Stream TCP) + client <- socket :: IO (Socket Inet Stream TCP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + let addr = SocketAddressInet inetLoopback port + let msgSize = 128*1024*1024 + 1 :: Int64 + let msg = LBS.replicate msgSize 23 + setSocketOption server (ReuseAddress True) + bind server addr + listen server 5 + serverRecv <- async $ do + (peerSock, peerAddr) <- accept server + receiveAll peerSock msgSize mempty + threadDelay 100000 + connect client addr + sendAll client msg mempty + close client + msgReceived <- wait serverRecv + when (msgReceived /= msg) (assertFailure "Received message was bogus.") + ) + ] + ] + +group80 :: TestTree +group80 = testGroup "setSocketOption" [ testGroup "V6Only" + [ testCase "present" $ bracket + ( do + server <- socket :: IO (Socket Inet6 Datagram UDP) + client <- socket :: IO (Socket Inet Datagram UDP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + setSocketOption server (V6Only True) + bind server (SocketAddressInet6 inet6Any port6 0 0) + threadDelay 1000000 -- wait for the listening socket being set up + sendTo client "PING" mempty (SocketAddressInet inetLoopback port) + eith <- race + ( void $ receiveFrom server 4096 mempty ) + ( threadDelay 1000000 ) + case eith of + Left () -> assertFailure "expected timeout" + Right () -> return () -- timeout is the expected behaviour + ) + , testCase "absent" $ bracket + ( do + server <- socket :: IO (Socket Inet6 Datagram UDP) + client <- socket :: IO (Socket Inet Datagram UDP) + return (server, client) + ) + ( \(server,client)-> do + close server + close client + ) + ( \(server,client)-> do + setSocketOption server (V6Only False) + bind server (SocketAddressInet6 inet6Any port6 0 0) + threadDelay 1000000 -- wait for the listening socket being set up + sendTo client "PING" mempty (SocketAddressInet inetLoopback port) + eith <- race + ( void $ receiveFrom server 4096 mempty ) + ( threadDelay 1000000 ) + case eith of + Left () -> return () + Right () -> assertFailure "expected packet" + ) + ] + ] + +group99 :: TestTree +group99 = testGroup "getAddrInfo" [ + + testCase "getAddrInfo \"127.0.0.1\" \"80\"" $ do + ais <- getAddressInfo + (Just "127.0.0.1") + (Just "80") + aiNumericHost :: IO [AddressInfo Inet Stream TCP] + when (length ais /= 1) $ assertFailure "expected 1 result" + let [ai] = ais + when (isJust $ canonicalName ai) $ assertFailure "expected no canonical name" + let sa = socketAddress ai + when (inetAddress sa /= inetLoopback) $ assertFailure "expected loopback address" + when (inetPort sa /= 80) $ assertFailure "expected port 80" + + , testCase "getAddrInfo \"\" \"\"" $ + void (getAddressInfo Nothing Nothing mempty :: IO [AddressInfo Inet Stream TCP]) `catch` \e-> case e of + _ | e == eaiNoName -> return () + _ -> assertFailure "expected eaiNoName" + + ] diff --git a/tests/AddrInfo.hs b/tests/AddrInfo.hs deleted file mode 100644 --- a/tests/AddrInfo.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-} -module Main where - -import Data.Bits -import Data.Monoid -import Control.Monad -import Control.Exception -import System.Socket -import System.Socket.Family.Inet as Inet -import System.Socket.Type.Stream -import System.Socket.Protocol.TCP - -main :: IO () -main = do - t0001 - t0002 - -t0001 :: IO () -t0001 = do - ais <- getAddressInfo - (Just "127.0.0.1") - (Just "80") - aiNumericHost - `onException` p 0 :: IO [AddressInfo Inet Stream TCP] - when (length ais /= 1) (e 1) - let [ai] = ais - when (canonicalName ai /= Nothing) (e 2) - let sa = socketAddress ai - when (inetPort sa /= 80) (e 3) - when (inetAddress sa /= inetLoopback) (e 4) - where - p i = print ("t0001." ++ show i) - e i = error ("t0001." ++ show i) - -t0002 :: IO () -t0002 = do - let x = getAddressInfo - Nothing - Nothing - mempty :: IO [AddressInfo Inet Stream TCP] - eui <- tryJust (\ex@(AddressInfoException _)-> if ex == eaiNoName then Just () else Nothing) - (x `onException` p 0) - when (eui /= Left ()) (e 1) - where - p i = print ("t0002." ++ show i) - e i = error ("t0002." ++ show i) - --- | This tests the correct funtionality of the flags --- AI_V4MAPPEND and AI_ALL. Asking for localhost should --- yield an additional v4-mappend IPV6-Address in the second case, --- but not in the first one. -{- --- TODO: Commented out due to issue #12 until a solution has been found. -t0003 :: IO () -t0003 = do - x <- getAddressInfo - (Just "localhost") - Nothing - mempty - `onException` p 0:: IO [AddressInfo Inet6 Stream TCP] - y <- getAddressInfo - (Just "localhost") - Nothing - (aiAll `mappend` aiV4Mapped) - `onException` p 1 :: IO [AddressInfo Inet6 Stream TCP] - when (length x == length y) (e 2) - where - p i = print ("t0003." ++ show i) - e i = error ("t0003." ++ show i) --} diff --git a/tests/EOPNOTSUPP.hs b/tests/EOPNOTSUPP.hs deleted file mode 100644 --- a/tests/EOPNOTSUPP.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async - -import qualified Data.ByteString.Lazy as LBS - -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Type.Datagram -import System.Socket.Protocol.UDP - -main :: IO () -main = do - bracket - ( socket `onException` print "E01" :: IO (Socket Inet Datagram UDP) - ) - (\server-> do - close server `onException` print "E03" - ) - (\server-> do - bind server addr `onException` print "E06" - e1 <- try (listen server 5) - case e1 of - Right _ -> error "E08" - Left e -> if e == eOperationNotSupported - then return () - else throwIO e `onException` print "E09" - ) - where - addr = SocketAddressInet inetLoopback 7777 diff --git a/tests/EPIPE.hs b/tests/EPIPE.hs deleted file mode 100644 --- a/tests/EPIPE.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async - -import Data.Int -import Data.Monoid -import qualified Data.ByteString.Lazy as LBS - -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Type.Stream -import System.Socket.Protocol.TCP - -main :: IO () -main = do - bracket - ( do server <- socket `onException` print "E01" :: IO (Socket Inet Stream TCP) - client <- socket `onException` print "E02" :: IO (Socket Inet Stream TCP) - return (server, client) - ) - (\(server,client)-> do - close server `onException` print "E03" - close client `onException` print "E04" - ) - (\(server,client)-> do - bind server addr `onException` print "E06" - listen server 5 `onException` print "E07" - - connect client addr `onException` print "E08" - (peerSock, _) <- accept server `onException` print "E09" - _ <- send client "This should be received." mempty `onException` print "E10" - _ <- receive peerSock 4096 mempty `onException` print "E11" - close peerSock `onException` print "E12" - - threadDelay 1000000 - - e1 <- try $ send client "This might fail." mempty `onException` print "E13" - case e1 of - Right _ -> return () - Left e -> if e == ePipe - then return () - else throwIO e `onException` print "E14" - - threadDelay 1000000 - - e2 <- try $ send client "This should fail." mempty `onException` print "E15" - case e2 of - Right _ -> error "E16" - Left e -> if e == ePipe - then return () - else throwIO e `onException` print "E17" - ) - where - addr = SocketAddressInet inetLoopback 7777 diff --git a/tests/IPV6_V6ONLY.hs b/tests/IPV6_V6ONLY.hs deleted file mode 100644 --- a/tests/IPV6_V6ONLY.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Data.Bits -import Data.Monoid -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Family.Inet6 -import System.Socket.Type.Datagram -import System.Socket.Protocol.UDP -import System.Exit - -main :: IO () -main = do - t0001 - t0002 - -t0001 :: IO () -t0001 = - bracket - ( do - server <- socket `onException` p 0 :: IO (Socket Inet6 Datagram UDP) - client <- socket `onException` p 1 :: IO (Socket Inet Datagram UDP) - return (server, client) - ) - (\(server,client)-> do - close server `onException` p 2 - close client `onException` p 3 - ) - (\(server,client)-> do - setSocketOption server (V6Only True) `onException` p 4 - bind server (SocketAddressInet6 inet6Any 7777 0 0) `onException` p 5 - - threadDelay 1000000 -- wait for the listening socket being set up - sendTo client "PING" mempty (SocketAddressInet inetLoopback 7777) - `onException` p 6 - eith <- race - ( receiveFrom server 4096 mempty `onException` p 7 >> return () ) - ( threadDelay 1000000 ) - case eith of - Left () -> e 8 -- we didn't expect receiving a msg - Right () -> return () -- timeout is the expected behaviour - ) - where - e i = error ("t0001." ++ show i) - p i = print ("t0001." ++ show i) - -t0002 :: IO () -t0002 = - bracket - ( do - server <- socket `onException` p 0 :: IO (Socket Inet6 Datagram UDP) - client <- socket `onException` p 1 :: IO (Socket Inet Datagram UDP) - return (server, client) - ) - (\(server,client)-> do - close server `onException` p 2 - close client `onException` p 3 - ) - (\(server,client)-> do - setSocketOption server (V6Only False) `onException` p 4 - bind server (SocketAddressInet6 inet6Any 7778 0 0) `onException` p 5 - - threadDelay 1000000 -- wait for the listening socket being set up - sendTo client "PING" mempty (SocketAddressInet inetLoopback 7778) `onException` p 6 - eith <- race - ( receiveFrom server 4096 mempty `onException` p 7 >> return ()) - ( threadDelay 1000000 ) - case eith of - Left () -> return () -- we received the expected msg - Right () -> e 8 -- timeout occured - ) - where - e i = error ("t0002." ++ show i) - p i = print ("t0002." ++ show i) diff --git a/tests/NonBlockingIO.hs b/tests/NonBlockingIO.hs deleted file mode 100644 --- a/tests/NonBlockingIO.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-} -module Main where - -import Data.Bits -import Data.Monoid -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Type.Stream -import System.Socket.Protocol.TCP -import System.Exit - -main :: IO () -main = do - t0001 - --- | This is to test interruptability of (blocking) calls like --- accept. The implementation may either run the call "safe" --- in another thread if it is really blocking or wait on events --- in which case the control is at the RTS's IO manager. --- In both cases this test should be able to cancel the accept --- async and therefore terminate. --- If the test hangs, this means the runtime system got sedated --- possibly due to a blocking system call in a non-threaded --- environment. -t0001 :: IO () -t0001 = do - s <- socket `onException` e 0 :: IO (Socket Inet Stream TCP) - setSocketOption s (ReuseAddress True) `onException` e 1 - bind s (SocketAddressInet inetLoopback 8080) `onException` e 2 - listen s 5 `onException` e 3 - a <- async (accept s) `onException` e 4 - threadDelay 1000000 -- make sure the async call really got enough time to start - p <- poll a `onException` e 5 - case p of - Just (Left ex) -> do - throwIO ex `onException` e 6 - Just (Right _) -> do - throwIO (AssertionFailed "") `onException` e 7 - Nothing -> do - cancel a `onException` e 8 - return () - where - e i = print ("t0001." ++ show i) diff --git a/tests/PingPong.hs b/tests/PingPong.hs deleted file mode 100644 --- a/tests/PingPong.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Data.Bits -import Data.Monoid -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Type.Stream -import System.Socket.Protocol.TCP -import System.Exit - -main :: IO () -main = do - t0001 - -t0001 :: IO () -t0001 = do - server <- socket `onException` e 0 :: IO (Socket Inet Stream TCP) - client <- socket `onException` e 1 :: IO (Socket Inet Stream TCP) - setSocketOption server (ReuseAddress True) `onException` e 2 - bind server addr `onException` e 3 - listen server 5 `onException` e 4 - connect client addr `onException` e 5 - (peer,_) <- accept server `onException` e 6 - - x <- async (loop client 0) - y <- async (loop peer 0) - - send peer "Ping!" mempty - - threadDelay 2000000 -- let's see how much we get through in 2s - cancel x - cancel y - - i <- wait x - print (show i ++ "/2s") - when (i < 10000) (e 16) - - where - addr = SocketAddressInet inetLoopback 8080 - e i = print ("t0001." ++ show i) - loop sock index = ( do - ping <- receive sock 4096 mempty - when (ping /= "Ping!") (e 14) - send sock ping mempty - loop sock (index + 1) - ) `catch` (\ThreadKilled-> return index) `onException` e 15 diff --git a/tests/TCP-sendAndRecvAll.hs b/tests/TCP-sendAndRecvAll.hs deleted file mode 100644 --- a/tests/TCP-sendAndRecvAll.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Main where - -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async - -import Data.Int -import Data.Monoid -import qualified Data.ByteString.Lazy as LBS - -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Type.Stream -import System.Socket.Protocol.TCP - --- | This tries to send and receive an extremely huge message (currently 128MB). -main :: IO () -main = - bracket - ( do server <- socket `onException` print "E01" :: IO (Socket Inet Stream TCP) - client <- socket `onException` print "E02" :: IO (Socket Inet Stream TCP) - return (server, client) - ) - (\(server,client)-> do - close server `onException` print "E03" - close client `onException` print "E04" - ) - (\(server,client)-> do - bind server addr `onException` print "E06" - listen server 5 `onException` print "E07" - serverRecv <- async $ do - (peerSock, peerAddr) <- accept server `onException` print "E08" - receiveAll peerSock msgSize mempty `onException` print "E09" - - threadDelay 100000 - connect client addr `onException` print "E11" - sendAll client msg mempty `onException` print "E12" - close client - - msgReceived <- wait serverRecv `onException` print "E13" - when (msgReceived /= msg) $ error "E14" - ) - where - msgSize = 128*1024*1024 + 1 :: Int64 - msg = LBS.replicate msgSize 23 - addr = SocketAddressInet inetLoopback 7777 diff --git a/tests/TCP.hs b/tests/TCP.hs deleted file mode 100644 --- a/tests/TCP.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} -module Main where - -import Data.Monoid -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async -import Foreign.Storable -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Family.Inet6 -import System.Socket.Type.Stream -import System.Socket.Protocol.TCP -import System.Exit - -main :: IO () -main = do - test "test0001.01" $ test0001 (undefined :: Socket Inet Stream TCP) localhost - test "test0001.02" $ test0001 (undefined :: Socket Inet6 Stream TCP) localhost6 - --- Test send and receive on connection oriented sockets (i.e. TCP). -test0001 :: (Family f, Type t, Protocol p, Storable (SocketAddress f)) => Socket f t p -> SocketAddress f -> IO (Either String String) -test0001 dummy addr = - bracket - ( do server <- socket `asTypeOf` return dummy `onException` print "E01" - client <- socket `asTypeOf` return dummy `onException` print "E02" - return (server, client) - ) - (\(server,client)-> do - close server `onException` print "E03" - close client `onException` print "E04" - ) - (\(server,client)-> do - setSocketOption server (ReuseAddress True) `onException` print "E05" - bind server addr `onException` print "E06" - listen server 5 `onException` print "E07" - serverRecv <- async $ do - (peerSock, peerAddr) <- accept server `onException` print "E08" - receive peerSock 4096 mempty `onException` print "E09" - connect client addr `onException` print "E11" - send client helloWorld mempty `onException` print "E12" - msg <- wait serverRecv `onException` print "E13" - close server `onException` print "E14" - close client `onException` print "E15" - if (msg /= helloWorld) - then return (Left "Received message was bogus.") - else return (Right "") - ) - where - helloWorld = "Hello world!" - -localhost :: SocketAddress Inet -localhost = SocketAddressInet inetLoopback 7777 - -localhost6 :: SocketAddress Inet6 -localhost6 = SocketAddressInet6 inet6Loopback 7777 0 0 - - -test :: String -> IO (Either String String) -> IO () -test n t = do - putStr ("Test " ++ show n ++ ": ") - catch - ( do r <- t - case r of - Left x -> putStr "FAIL " >> putStrLn x >> exitFailure - Right x -> putStr "OK " >> putStrLn x - ) - (\e-> putStr "EXCP " >> putStrLn (show (e :: SomeException)) >> exitFailure) diff --git a/tests/UDP.hs b/tests/UDP.hs deleted file mode 100644 --- a/tests/UDP.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} -module Main where - -import Data.Monoid -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.Async -import Foreign.Storable -import System.Socket -import System.Socket.Family.Inet -import System.Socket.Family.Inet6 -import System.Socket.Type.Datagram -import System.Socket.Protocol.UDP -import System.Exit - -main :: IO () -main = do - test "Inet" (undefined :: Socket Inet Datagram UDP) localhost - test "Inet6" (undefined :: Socket Inet6 Datagram UDP) localhost6 - --- Test stateless sockets (i.e. UDP). -test :: (Family f, Type t, Protocol p, Storable (SocketAddress f)) => String -> Socket f t p -> SocketAddress f -> IO () -test inet dummy addr = do - server <- socket `asTypeOf` return dummy `onException` p 1 - client <- socket `asTypeOf` return dummy `onException` p 2 - - bind server addr `onException` p 4 - - ((msg,peeraddr),_) <- concurrently - ( do - receiveFrom server 4096 mempty `onException` p 5 - ) - ( do - -- This is a race condition: - -- The server must listen before the client sends his msg or the packt goes - -- to nirvana. Still, a second here should be enough. If not, there's - -- something wrong worth investigating. - threadDelay 1000000 - sendTo client helloWorld mempty addr `onException` p 6 - ) - - when (msg /= helloWorld) $ e 8 - - close client `onException` p 10 - close server `onException` p 11 - - where - helloWorld = "Hello world!" - e i = error (inet ++ ": " ++ show i) - p i = print (inet ++ ": " ++ show i) - -localhost :: SocketAddress Inet -localhost = SocketAddressInet inetLoopback 7777 - -localhost6 :: SocketAddress Inet6 -localhost6 = SocketAddressInet6 inet6Loopback 7777 0 0