socket 0.6.0.1 → 0.6.1.0
raw patch · 23 files changed
+877/−912 lines, 23 filesdep +tastydep +tasty-hunitdep ~bytestringPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: tasty, tasty-hunit
Dependency ranges changed: bytestring
API changes (from Hackage documentation)
- System.Socket.Unsafe: tryWaitRetryLoop :: Socket f t p -> (Fd -> Int -> IO (IO ())) -> (Fd -> IO CInt) -> IO CInt
+ System.Socket.Unsafe: tryWaitRetryLoop :: Socket f t p -> (Fd -> Int -> IO (IO ())) -> (Fd -> Ptr CInt -> IO CInt) -> IO CInt
Files
- CHANGELOG.md +33/−1
- CONTRIBUTORS.txt +1/−0
- README.md +24/−11
- platform/linux/cbits/hs_socket.c +101/−8
- platform/linux/include/hs_socket.h +14/−3
- platform/linux/src/System/Socket/Internal/Platform.hsc +37/−31
- platform/win32/cbits/hs_socket.c +122/−41
- platform/win32/include/hs_socket.h +14/−20
- platform/win32/src/System/Socket/Internal/Platform.hsc +35/−18
- socket.cabal +37/−100
- src/System/Socket.hsc +69/−128
- src/System/Socket/Internal/Socket.hsc +14/−22
- src/System/Socket/Unsafe.hsc +15/−17
- test/test.hs +361/−0
- tests/AddrInfo.hs +0/−70
- tests/EOPNOTSUPP.hs +0/−34
- tests/EPIPE.hs +0/−58
- tests/IPV6_V6ONLY.hs +0/−79
- tests/NonBlockingIO.hs +0/−47
- tests/PingPong.hs +0/−51
- tests/TCP-sendAndRecvAll.hs +0/−47
- tests/TCP.hs +0/−69
- tests/UDP.hs +0/−57
CHANGELOG.md view
@@ -1,6 +1,38 @@+0.6.1.0 Lars Petersen <info@lars-petersen.net> 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 <info@lars-petersen.net> 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 <info@lars-petersen.net> 2016-03-26
CONTRIBUTORS.txt view
@@ -1,3 +1,4 @@+Mathieu Boespflug (issue #15) Ben Gamari (issue #10) Niklas Hambüchen (issue #9) Michael Fox (reported issue #7)
README.md view
@@ -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
platform/linux/cbits/hs_socket.c view
@@ -1,14 +1,107 @@ #include <hs_socket.h> -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;+}
platform/linux/include/hs_socket.h view
@@ -1,4 +1,5 @@ #include <stdint.h>+#include <unistd.h> #include <fcntl.h> #include <errno.h> @@ -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
platform/linux/src/System/Socket/Internal/Platform.hsc view
@@ -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 ()
platform/win32/cbits/hs_socket.c view
@@ -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) {
platform/win32/include/hs_socket.h view
@@ -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
platform/win32/src/System/Socket/Internal/Platform.hsc view
@@ -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 ()
socket.cabal view
@@ -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
src/System/Socket.hsc view
@@ -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.
src/System/Socket/Internal/Socket.hsc view
@@ -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)
src/System/Socket/Unsafe.hsc view
@@ -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
+ test/test.hs view
@@ -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"++ ]
− tests/AddrInfo.hs
@@ -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)--}
− tests/EOPNOTSUPP.hs
@@ -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
− tests/EPIPE.hs
@@ -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
− tests/IPV6_V6ONLY.hs
@@ -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)
− tests/NonBlockingIO.hs
@@ -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)
− tests/PingPong.hs
@@ -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
− tests/TCP-sendAndRecvAll.hs
@@ -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
− tests/TCP.hs
@@ -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)
− tests/UDP.hs
@@ -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