socket 0.3.0.1 → 0.4.0.0
raw patch · 30 files changed
+1206/−784 lines, 30 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +17/−0
- README.md +16/−7
- cbits/hs_socket_posix.c +0/−14
- cbits/hs_socket_win32.c +0/−126
- include/hs_socket.h +0/−65
- include/hs_socket_posix.h +0/−24
- include/hs_socket_win32.h +0/−60
- platform/linux/cbits/hs_socket.c +14/−0
- platform/win32/cbits/hs_socket.c +114/−0
- platform/win32/include/hs_socket.h +127/−0
- platform/win32/src/System/Socket/Internal/Platform.hsc +82/−0
- socket.cabal +96/−108
- src/System/Socket.hsc +207/−111
- src/System/Socket/Family/INET.hsc +1/−1
- src/System/Socket/Family/INET6.hsc +22/−1
- src/System/Socket/Internal/AddrInfo.hsc +7/−18
- src/System/Socket/Internal/Event.hs +0/−19
- src/System/Socket/Internal/Exception.hsc +32/−13
- src/System/Socket/Internal/FFI.hs +0/−61
- src/System/Socket/Internal/Msg.hsc +1/−17
- src/System/Socket/Internal/Socket.hsc +59/−6
- src/System/Socket/Unsafe.hsc +32/−25
- tests/AddrInfo.hs +22/−0
- tests/Basic.hs +0/−108
- tests/IPV6_V6ONLY.hs +78/−0
- tests/NonBlockingIO.hs +45/−0
- tests/PingPong.hs +49/−0
- tests/TCP-sendAndRecvAll.hs +45/−0
- tests/TCP.hs +76/−0
- tests/UDP.hs +64/−0
CHANGELOG.md view
@@ -1,3 +1,20 @@+0.4.0.0 Lars Petersen <info@lars-petersen.net> 2015-06-16++ * Changed semantics of `connect` operation. It now+ blocks until a connection has either has been established or failed.+ * Added `SO_ERROR` socket option.+ * Added `eALREADY` exception constant.+ * Added `eISCONN` exception constant.+ * Added `eNOTCONN` exception constant.+ * Added convenience operation `withConnectedSocket`.+ * Added `eNETUNREACH` exception constant.+ * Added new operation `recvAll` and changed `sendAll` to lazy `ByteString`.+ * Added new socket option IPV6_V6ONLY.+ * Removed untested socket option SO_ACCEPTCONN.+ * Correctly defining AI_ flags on Windows (MinGW doesn't although+ they are all well support on Vista or higher).+ * Got all tests passing on Windows 7.+ 0.3.0.1 Lars Petersen <info@lars-petersen.net> 2015-06-07 * Fixed documentation of eaiNONAME.
README.md view
@@ -45,14 +45,23 @@ #### Windows -Unfinished (problem with non-blocking IO).--Aim: Support Windows7 or higher. Don't have dependencies on autotools, just-Haskell Platform with MinGW should suffice.+Fully supported on Windows7 (maybe Vista) or higher :-) -#### Android+GHCs runtime system on Windows does not offer an event notification mechanism for sockets.+The original [network](https://hackage.haskell.org/package/network) library+suffers from this, too. For example, connection attempts are uninterruptible etc.+The approach taken to circumvent this in this library is to poll the+non-blocking sockets with increasing delay. This guarantees interruptability+and fairness between different threads. It allows for decent throughput+while also keeping CPU consumption on a moderate level if a socket has not seen+events for a longer period of time (maximum of 1 second delay after 20+polling iterations). The only drawback is potentially reduced response time+of your application. The good part: Heavy load (e.g. connection requests or+incoming traffic) will reduce this problem. Eventually your accepting thread+won't wait at all if there are several connection requests queued. -Unknown. Should be supported. Please get in touch if you plan to use it.+This workaround may be removed if someone is willing to sacrifice to improve+the IO manager on Windows. ### Dependencies @@ -61,7 +70,7 @@ ### Tests -Run the default test suite:+Run the default test suites: ```bash cabal test
− cbits/hs_socket_posix.c
@@ -1,14 +0,0 @@-#include <hs_socket.h>--int hs_setnonblocking(int fd) {- int flags;-- if (-1 == (flags = fcntl(fd, F_GETFL, 0))) {- flags = 0;- }- return fcntl(fd, F_SETFL, flags | O_NONBLOCK);-}--int hs_get_last_socket_error(void) {- return errno;-};
− cbits/hs_socket_win32.c
@@ -1,126 +0,0 @@-#include <hs_socket.h>--int hs_socket_init() {- static int has_already_been_initialised = 0;-- if (!has_already_been_initialised) {- WSADATA wsaData;-- int ini = WSAStartup(MAKEWORD(2,2), &wsaData);- if (ini != NO_ERROR) {- WSACleanup();- return -1;- } else {- has_already_been_initialised = 1;- }- }- return 0;-};--int hs_socket(int domain, int type, int protocol) {- if (hs_socket_init() != 0) {- return -1;- }-- return socket(domain, type, protocol);-};--int hs_bind(int sockfd, const struct sockaddr *name, int namelen) {- return bind(sockfd, name, namelen);-};--int hs_connect(int sockfd, const struct sockaddr *name, int namelen) {- int i = connect(sockfd, name, namelen);- if (i != 0) {- switch (WSAGetLastError()) {- case WSAEWOULDBLOCK:- return 0;- break;- // TODO: remap other error codes that don't behave the posix way.- default:- break;- }- }- return i;-};--int hs_listen (int sockfd, int backlog) {- return listen(sockfd, backlog);-};--int hs_accept(int sockfd, struct sockaddr *addr, int *addrlen) {- return accept(sockfd, addr, addrlen);-}--int hs_close(int sockfd) {- return closesocket(sockfd);-};--int hs_setnonblocking(int fd) {- // If iMode = 0, blocking is enabled; - // If iMode != 0, non-blocking mode is enabled.- u_long iMode = 1;- //return ioctlsocket(fd, FIONBIO, &iMode);- return 0;-};--int hs_send (int sockfd, const void *buf, size_t len, int flags) {- printf("send1");- int x = send(sockfd, buf, len, flags);- printf("send2\n");- printf("%ld\n", x);- return x;-};--int hs_recv (int sockfd, void *buf, size_t len, int flags) {- return -1;-};--int hs_sendto (int sockfd, const void *buf, size_t len, int flags,- const struct sockaddr *dest_addr, int addrlen) {- return -1;-};--int hs_recvfrom(int sockfd, void *buf, size_t len, int flags,- struct sockaddr *src_addr, int *addrlen) {- return -1;-};--int hs_get_last_socket_error(void) {- return WSAGetLastError();-};--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_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);-};--const char *hs_gai_strerror(int errcode) {- return gai_strerror(errcode);-};--int hs_getaddrinfo(const char *node, const char *service,- const struct addrinfo *hints,- struct addrinfo **res) {- if (hs_socket_init() != 0) {- return -1;- }- return getaddrinfo(node, service, hints, res);-};--int hs_getnameinfo(const struct sockaddr *sa, int salen,- char *host, int hostlen,- char *serv, int servlen, int flags) {- if (hs_socket_init() != 0) {- return -1;- }- return getnameinfo(sa, salen, host, hostlen, serv, servlen, flags);-};--void hs_freeaddrinfo(struct addrinfo *res) {- freeaddrinfo(res);- return;-};
− include/hs_socket.h
@@ -1,65 +0,0 @@-#ifndef _HS_SOCKET-#define _HS_SOCKET--#if defined(_WIN32)--#include <hs_socket_win32.h>--#else--#include <hs_socket_posix.h>--#endif /* defined(_WIN32) */--/* Flags (by convention) get defined 0 if they are not defined- on the system. This has to be checked for in the application.- This is the price to pay for not having conditionally defined- symbols on different systems.-*/--#ifndef MSG_EOR-#define MSG_EOR 0-#endif--#ifndef MSG_NOSIGNAL-#define MSG_NOSIGNAL 0-#endif--#ifndef MSG_WAITALL-#define MSG_WAITALL 0-#endif--#ifndef MSG_MORE-#define MSG_MORE 0-#endif--#ifndef MSG_TRUNC-#define MSG_TRUNC 0-#endif--#ifndef MSG_DONTWAIT-#define MSG_DONTWAIT 0-#endif--#ifndef EAI_SYSTEM-#define EAI_SYSTEM 0-#endif--#ifndef AI_ADDRCONFIG-#define AI_ADDRCONFIG 0-#endif--#ifndef AI_ALL-#define AI_ALL 0-#endif--#ifndef AI_NUMERICSERV-#define AI_NUMERICSERV 0-#endif--#ifndef AI_V4MAPPED-#define AI_V4MAPPED 0-#endif--#endif /* _HS_SOCKET */-
− include/hs_socket_posix.h
@@ -1,24 +0,0 @@-#include <stdint.h>-#include <fcntl.h>-#include <errno.h>--#include "sys/types.h"-#include "sys/socket.h"-#include "sys/un.h"-#include "netinet/in.h"-#include "netdb.h"--/* SocketException */--int hs_setnonblocking(int fd);-int hs_get_last_socket_error(void);--#define SEOK 0-#define SEINTR EINTR-#define SEAGAIN EAGAIN-#define SEWOULDBLOCK EWOULDBLOCK-#define SEBADF EBADF-#define SEINVAL EINVAL-#define SEINPROGRESS EINPROGRESS-#define SEPROTONOSUPPORT EPROTONOSUPPORT-#define SECONNREFUSED ECONNREFUSED
− include/hs_socket_win32.h
@@ -1,60 +0,0 @@-#include <stdint.h>-#include <stdio.h>-#include <winsock2.h>--#ifndef _WIN32_WINNT-#define _WIN32_WINNT 0x0501-#endif-#if (_WIN32_WINNT < 0x0501)-#undef _WIN32_WINNT-#define _WIN32_WINNT 0x0501-#endif--#include <ws2tcpip.h>--int hs_setnonblocking(int fd);--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_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_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_getaddrinfo(const char *node, const char *service,- const struct addrinfo *hints,- struct addrinfo **res);--int hs_getnameinfo(const struct sockaddr *sa, int salen,- char *host, int hostlen,- char *serv, int servlen, int flags);--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-#define SEAGAIN WSATRY_AGAIN-#define SEWOULDBLOCK WSAEWOULDBLOCK-#define SEBADF WSAEBADF-#define SEINVAL WSAEINVAL-#define SEINPROGRESS WSAEINPROGRESS-#define SEPROTONOSUPPORT WSAEPROTONOSUPPORT-#define SECONNREFUSED WSAECONNREFUSED
+ platform/linux/cbits/hs_socket.c view
@@ -0,0 +1,14 @@+#include <hs_socket.h>++int hs_setnonblocking(int fd) {+ int flags;++ if (-1 == (flags = fcntl(fd, F_GETFL, 0))) {+ flags = 0;+ }+ return fcntl(fd, F_SETFL, flags | O_NONBLOCK);+}++int hs_get_last_socket_error(void) {+ return errno;+};
+ platform/win32/cbits/hs_socket.c view
@@ -0,0 +1,114 @@+#include <hs_socket.h>++int hs_socket_init() {+ static int has_already_been_initialised = 0;++ if (!has_already_been_initialised) {+ WSADATA wsaData;++ int ini = WSAStartup(MAKEWORD(2,2), &wsaData);+ if (ini != NO_ERROR) {+ WSACleanup();+ return -1;+ } else {+ has_already_been_initialised = 1;+ }+ }+ return 0;+};++int hs_socket(int domain, int type, int protocol) {+ if (hs_socket_init() != 0) {+ return -1;+ }++ return socket(domain, type, protocol);+};++int hs_bind(int sockfd, const struct sockaddr *name, int namelen) {+ return bind(sockfd, name, namelen);+};++int hs_connect(int sockfd, const struct sockaddr *name, int namelen) {+ return connect(sockfd, name, namelen);+};++int hs_listen (int sockfd, int backlog) {+ return listen(sockfd, backlog);+};++int hs_accept(int sockfd, struct sockaddr *addr, int *addrlen) {+ //printf("accepting");+ int x = accept(sockfd, addr, addrlen);+ //printf("accepted");+ return x;+}++int hs_close(int sockfd) {+ return closesocket(sockfd);+};++int hs_setnonblocking(int fd) {+ // If iMode = 0, blocking is enabled; + // If iMode != 0, non-blocking mode is enabled.+ u_long iMode = 1;+ return ioctlsocket(fd, FIONBIO, &iMode);+ //return 0;+};++int hs_send (int sockfd, const void *buf, size_t len, int flags) {+ return send(sockfd, buf, len, flags);+};++int hs_recv (int sockfd, void *buf, size_t len, int flags) {+ return recv(sockfd, buf, len, flags);+};++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_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_get_last_socket_error(void) {+ return WSAGetLastError();+};++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_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);+};++const char *hs_gai_strerror(int errcode) {+ return gai_strerror(errcode);+};++int hs_getaddrinfo(const char *node, const char *service,+ const struct addrinfo *hints,+ struct addrinfo **res) {+ if (hs_socket_init() != 0) {+ return -1;+ }+ return getaddrinfo(node, service, hints, res);+};++int hs_getnameinfo(const struct sockaddr *sa, int salen,+ char *host, int hostlen,+ char *serv, int servlen, int flags) {+ if (hs_socket_init() != 0) {+ return -1;+ }+ return getnameinfo(sa, salen, host, hostlen, serv, servlen, flags);+};++void hs_freeaddrinfo(struct addrinfo *res) {+ freeaddrinfo(res);+ return;+};
+ platform/win32/include/hs_socket.h view
@@ -0,0 +1,127 @@+#include <stdint.h>+#include <stdio.h>+#include <winsock2.h>++#ifndef _WIN32_WINNT+#define _WIN32_WINNT 0x0501+#endif+#if (_WIN32_WINNT < 0x0501)+#undef _WIN32_WINNT+#define _WIN32_WINNT 0x0501+#endif++#include <ws2tcpip.h>++#ifndef MSG_EOR+#define MSG_EOR 0+#endif++#ifndef MSG_NOSIGNAL+#define MSG_NOSIGNAL 0+#endif++#ifndef MSG_WAITALL+#define MSG_WAITALL 0+#endif++#ifndef EAI_SYSTEM+#define EAI_SYSTEM 0+#endif++/* Value for this flag taken from the former Haskell network+ library. Remove if MinGW fixed this.+*/+#ifndef IPV6_V6ONLY+#define IPV6_V6ONLY 27+#endif++/* Values for this flags taken from+ http://sourceforge.net/p/mingw-w64/mailman/message/33056995/.+ According to MSDN documentation they are supported on+ Windows Vista or higher. This definitions may be removed+ when MinGW finally ships them.+*/++#ifndef AI_PASSIVE+#define AI_PASSIVE 0x00000001+#endif+#ifndef AI_CANONNAME+#define AI_CANONNAME 0x00000002+#endif+#ifndef AI_NUMERICHOST+#define AI_NUMERICHOST 0x00000004+#endif+#ifndef AI_NUMERICSERV+#define AI_NUMERICSERV 0x00000008+#endif+#ifndef AI_ALL+#define AI_ALL 0x00000100+#endif+#ifndef AI_ADDRCONFIG+#define AI_ADDRCONFIG 0x00000400+#endif+#ifndef AI_V4MAPPED+#define AI_V4MAPPED 0x00000800+#endif+#ifndef AI_NON_AUTHORITATIVE+#define AI_NON_AUTHORITATIVE 0x00004000+#endif+#ifndef AI_SECURE+#define AI_SECURE 0x00008000+#endif+#ifndef AI_RETURN_PREFERRED_NAMES+#define AI_RETURN_PREFERRED_NAMES 0x00010000+#endif+++int hs_setnonblocking(int fd);++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_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_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_getaddrinfo(const char *node, const char *service,+ const struct addrinfo *hints,+ struct addrinfo **res);++int hs_getnameinfo(const struct sockaddr *sa, int salen,+ char *host, int hostlen,+ char *serv, int servlen, int flags);++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+#define SEAGAIN WSATRY_AGAIN+#define SEWOULDBLOCK WSAEWOULDBLOCK+#define SEBADF WSAEBADF+#define SEINVAL WSAEINVAL+#define SEINPROGRESS WSAEINPROGRESS+#define SEPROTONOSUPPORT WSAEPROTONOSUPPORT+#define SECONNREFUSED WSAECONNREFUSED+#define SENETUNREACH WSAENETUNREACH+#define SENOTCONN WSAENOTCONN+#define SEALREADY WSAEALREADY+#define SEISCONN WSAEISCONN+#define SETIMEDOUT WSAETIMEDOUT
+ platform/win32/src/System/Socket/Internal/Platform.hsc view
@@ -0,0 +1,82 @@+module System.Socket.Internal.Platform where++import Control.Concurrent ( threadDelay )++import Data.Bits++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++import System.Posix.Types ( Fd(..) )++import System.Socket.Internal.Msg+import System.Socket.Internal.Exception++socketWaitWrite' :: Fd -> Int -> IO (IO ())+socketWaitWrite' _ iteration = do+ return (threadDelay $ 1 `shiftL` min iteration 20)++socketWaitRead' :: Fd -> Int -> IO (IO ())+socketWaitRead' _ iteration = do+ return (threadDelay $ 1 `shiftL` min iteration 20)++type CSSize+ = CInt++foreign import ccall unsafe "hs_socket"+ c_socket :: CInt -> CInt -> CInt -> IO Fd++foreign import ccall unsafe "hs_close"+ c_close :: Fd -> IO CInt++foreign import ccall unsafe "hs_bind"+ c_bind :: Fd -> Ptr a -> CInt -> IO CInt++foreign import ccall unsafe "hs_connect"+ c_connect :: Fd -> Ptr a -> CInt -> IO CInt++foreign import ccall unsafe "hs_accept"+ c_accept :: Fd -> Ptr a -> Ptr CInt -> IO Fd++foreign import ccall unsafe "hs_listen"+ c_listen :: Fd -> CInt -> IO CInt++foreign import ccall unsafe "hs_send"+ c_send :: Fd -> Ptr a -> CSize -> MsgFlags -> IO CSSize++foreign import ccall unsafe "hs_sendto"+ c_sendto :: Fd -> Ptr a -> CSize -> MsgFlags -> Ptr b -> CInt -> IO CSSize++foreign import ccall unsafe "hs_recv"+ c_recv :: Fd -> Ptr a -> CSize -> MsgFlags -> IO CSSize++foreign import ccall unsafe "hs_recvfrom"+ c_recvfrom :: Fd -> Ptr a -> CSize -> MsgFlags -> Ptr b -> Ptr CInt -> IO CSSize++foreign import ccall unsafe "hs_getsockopt"+ c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> 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++foreign import ccall unsafe "memset"+ c_memset :: Ptr a -> CInt -> CSize -> IO ()++foreign import ccall safe "hs_getaddrinfo"+ c_getaddrinfo :: CString -> CString -> Ptr a -> Ptr (Ptr a) -> IO CInt++foreign import ccall unsafe "hs_freeaddrinfo"+ c_freeaddrinfo :: Ptr a -> IO ()++foreign import ccall safe "hs_getnameinfo"+ c_getnameinfo :: Ptr a -> CInt -> CString -> CInt -> CString -> CInt -> CInt -> IO CInt++foreign import ccall unsafe "hs_gai_strerror"+ c_gai_strerror :: CInt -> IO CString
socket.cabal view
@@ -1,13 +1,13 @@ name: socket-version: 0.3.0.1+version: 0.4.0.0 synopsis: A portable and extensible sockets library. description:- __Motivation__+ /Motivation/ . This library aims to expose a minimal and platform-independant interface for POSIX compliant networking code. .- __Implementation Philosophy__+ /Implementation Philosophy/ . - Every operation and every flag exposed should be supported with same semantics on every platform. If this cannot be guaranteed it should@@ -23,30 +23,32 @@ indirection is introduced to write an Posix compliant equivalent in C using whatever the plaform specific building blocks are. .- __Platform Support__- .- /Linux/- .- Working.- .- /BSD/- .- Unknown. Should work. Please report if not.- .- /MacOS/+ /Platform Support/ .- Unknown. Please report if you have a Mac.+ /Linux/: Working. .- /Windows/+ /BSD/: Unknown. Should work. Please report if not. .- Unfinished (problem with non-blocking IO).+ /OS X/: Unknown. Please report if you have a Mac. .- Aim: Support Windows7 or higher. Don't have dependencies on autotools, just- Haskell Platform with MinGW should suffice.+ /Windows/: Fully supported on Windows7 (maybe Vista) or higher :-) .- /Android/+ GHCs runtime system on Windows does not offer an event notification mechanism for sockets.+ The original [network](https://hackage.haskell.org/package/network) library+ suffers from this, too. For example, connection attempts are uninterruptible etc.+ The approach taken to circumvent this in this library is to poll the+ non-blocking sockets with increasing delay. This guarantees interruptability+ and fairness between different threads. It allows for decent throughput+ while also keeping CPU consumption on a moderate level if a socket has not seen+ events for a longer period of time (maximum of 1 second delay after 20+ polling iterations). The only drawback is potentially reduced response time+ of your application. The good part: Heavy load (e.g. connection requests or+ incoming traffic) will reduce this problem. Eventually your accepting thread+ won't wait at all if there are several connection requests queued. .- Unknown. Should be supported. Please get in touch if you plan to use it.+ This workaround may be removed if someone is willing to sacrifice to improve+ the IO manager on Windows.+ license: MIT license-file: LICENSE author: Lars Petersen@@ -59,11 +61,6 @@ tested-with: GHC==7.10.1, GHC==7.8.3 extra-source-files: README.md CHANGELOG.md- include/hs_socket.h- include/hs_socket_win32.h- include/hs_socket_posix.h- cbits/hs_socket_win32.c- cbits/hs_socket_posix.c library exposed-modules: System.Socket@@ -79,102 +76,32 @@ , System.Socket.Protocol.UDP , System.Socket.Protocol.TCP , System.Socket.Unsafe- other-modules: System.Socket.Internal.FFI- , System.Socket.Internal.Event- , System.Socket.Internal.Socket+ other-modules: System.Socket.Internal.Socket , System.Socket.Internal.Exception , System.Socket.Internal.Msg , System.Socket.Internal.AddrInfo+ , System.Socket.Internal.Platform build-depends: base >= 4.7 && < 5 , bytestring < 0.11 hs-source-dirs: src build-tools: hsc2hs default-language: Haskell2010- ghc-options: -Wall-- include-dirs: include install-includes: hs_socket.h+ ghc-options: -Wall if os(windows)- c-sources: cbits/hs_socket_win32.c+ include-dirs: platform/win32/include+ hs-source-dirs: platform/win32/src+ c-sources: platform/win32/cbits/hs_socket.c extra-libraries: ws2_32- cpp-options: -DFFI_SOCKET="hs_socket"- -DFFI_SOCKET_SAFETY=safe- -DFFI_BIND="hs_bind"- -DFFI_BIND_SAFETY=safe- -DFFI_LISTEN="hs_listen"- -DFFI_LISTEN_SAFETY=safe- -DFFI_CLOSE="hs_close"- -DFFI_CLOSE_SAFETY=safe- -DFFI_ACCEPT="hs_accept"- -DFFI_ACCEPT_SAFETY=safe- -DFFI_CONNECT="hs_connect"- -DFFI_CONNECT_SAFETY=safe- -DFFI_SEND="hs_send"- -DFFI_SEND_SAFETY=safe- -DFFI_SENDTO="hs_sendto"- -DFFI_SENDTO_SAFETY=safe- -DFFI_SENDMSG="hs_sendmsg"- -DFFI_SENDMSG_SAFETY=safe- -DFFI_RECV="hs_recv"- -DFFI_RECV_SAFETY=safe- -DFFI_RECVFROM="hs_recvfrom"- -DFFI_RECVFROM_SAFETY=safe- -DFFI_RECVMSG="hs_recvmsg"- -DFFI_RECVMSG_SAFETY=safe- -DFFI_GETSOCKOPT="hs_getsockopt"- -DFFI_GETSOCKOPT_SAFETY=safe- -DFFI_SETSOCKOPT="hs_setsockopt"- -DFFI_SETSOCKOPT_SAFETY=safe- -DFFI_GETADDRINFO="hs_getaddrinfo"- -DFFI_GETADDRINFO_SAFETY=safe- -DFFI_FREEADDRINFO="hs_freeaddrinfo"- -DFFI_FREEADDRINFO_SAFETY=unsafe- -DFFI_GETNAMEINFO="hs_getnameinfo"- -DFFI_GETNAMEINFO_SAFETY=safe- -DFFI_GAI_STRERROR="hs_gai_strerror"- -DFFI_GAI_STRERROR_SAFETY=unsafe else- c-sources: cbits/hs_socket_posix.c- cpp-options: -DFFI_SOCKET="socket"- -DFFI_SOCKET_SAFETY=unsafe- -DFFI_BIND="bind"- -DFFI_BIND_SAFETY=unsafe- -DFFI_LISTEN="listen"- -DFFI_LISTEN_SAFETY=unsafe- -DFFI_CLOSE="close"- -DFFI_CLOSE_SAFETY=unsafe- -DFFI_ACCEPT="accept"- -DFFI_ACCEPT_SAFETY=unsafe- -DFFI_CONNECT="connect"- -DFFI_CONNECT_SAFETY=unsafe- -DFFI_SEND="send"- -DFFI_SEND_SAFETY=unsafe- -DFFI_SENDTO="sendto"- -DFFI_SENDTO_SAFETY=unsafe- -DFFI_SENDMSG="sendmsg"- -DFFI_SENDMSG_SAFETY=unsafe- -DFFI_RECV="recv"- -DFFI_RECV_SAFETY=unsafe- -DFFI_RECVFROM="recvfrom"- -DFFI_RECVFROM_SAFETY=unsafe- -DFFI_RECVMSG="recvmsg"- -DFFI_RECVMSG_SAFETY=unsafe- -DFFI_GETSOCKOPT="getsockopt"- -DFFI_GETSOCKOPT_SAFETY=unsafe- -DFFI_SETSOCKOPT="setsockopt"- -DFFI_SETSOCKOPT_SAFETY=unsafe- -DFFI_GETADDRINFO="getaddrinfo"- -DFFI_GETADDRINFO_SAFETY=safe- -DFFI_FREEADDRINFO="freeaddrinfo"- -DFFI_FREEADDRINFO_SAFETY=unsafe- -DFFI_GETNAMEINFO="getnameinfo"- -DFFI_GETNAMEINFO_SAFETY=safe- -DFFI_GAI_STRERROR="gai_strerror"- -DFFI_GAI_STRERROR_SAFETY=unsafe+ include-dirs: platform/linux/include+ hs-source-dirs: platform/linux/src+ c-sources: platform/linux/cbits/hs_socket.c -test-suite basic++test-suite UDP hs-source-dirs: tests- main-is: Basic.hs+ main-is: UDP.hs type: exitcode-stdio-1.0 default-language: Haskell2010 build-depends: base >= 4.7 && < 5@@ -182,6 +109,36 @@ , 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@@ -190,6 +147,37 @@ 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 source-repository head type: git
src/System/Socket.hsc view
@@ -34,55 +34,24 @@ -- > sendAll peer "Hello world!" mempty `finally` close peer -- -- This downloads the [Haskell website](http://www.haskell.org) and shows how to--- handle exceptions. Note the use of IPv4-mapped IPv6 addresses: This will work+-- handle exceptions. Note the use of IPv4-mapped `INET6` addresses: This will work -- even if you don't have IPv6 connectivity yet and is the preferred method -- when writing new applications. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- > --- > import Control.Monad--- > import Control.Exception--- > --- > import Data.Function (fix)--- > import qualified Data.ByteString as BS--- > --- > import System.IO--- > import System.Exit+-- > import Data.Monoid+-- > import Data.ByteString.Lazy as B -- > import System.Socket -- > -- > main :: IO ()--- > main = fetch--- > `catch` (\e-> do--- > hPutStr stderr "Something failed when resolving the name: "--- > hPutStrLn stderr $ show (e :: AddrInfoException)--- > exitFailure--- > )--- > `catch` (\e-> do--- > hPutStr stderr "Something went wrong with the socket: "--- > hPutStrLn stderr $ show (e :: SocketException)--- > exitFailure--- > )--- > --- > fetch :: IO ()--- > fetch = do--- > addrs <- getAddrInfo6 (Just "www.haskell.org") (Just "80") aiV4MAPPED :: IO [AddrInfo INET6 STREAM TCP]--- > case addrs of--- > (addr:_) ->--- > -- always use the `bracket` pattern to reliably release resources!--- > bracket--- > ( socket :: IO (Socket INET6 STREAM TCP) )--- > ( close )--- > ( \s-> do connect s (addrAddress addr)--- > sendAll s "GET / HTTP/1.0\r\nHost: www.haskell.org\r\n\r\n" mempty--- > fix $ \recvMore-> do--- > bs <- recv s 4096 mempty--- > BS.putStr bs--- > if BS.length bs == 0 -- an empty string means the peer terminated the connection--- > then exitSuccess--- > else recvMore--- > )--- > _ -> error "Illegal state: getAddrInfo yields non-empty list or exception."+-- > main = do+-- > withConnectedSocket "www.haskell.org" "80" (aiALL `mappend` aiV4MAPPED) $ \sock-> do+-- > let _ = sock :: Socket INET6 STREAM TCP+-- > sendAll sock "GET / HTTP/1.0\r\nHost: www.haskell.org\r\n\r\n" mempty+-- > x <- recvAll sock (1024*1024*1024) mempty+-- > B.putStr x ----------------------------------------------------------------------------- module System.Socket ( -- * Name Resolution@@ -109,8 +78,12 @@ -- ** close , close -- * Convenience Operations+ -- ** withConnectedSocket+ , withConnectedSocket -- ** sendAll , sendAll+ -- ** recvAll+ , recvAll -- * Sockets , Socket (..) -- ** Families@@ -152,22 +125,19 @@ , eaiSOCKTYPE , eaiSERVICE , eaiSYSTEM- -- * Options+ -- * Socket Options+ -- ** getSockOpt , GetSockOpt (..)+ -- ** setSockOpt , SetSockOpt (..)- -- ** SO_ACCEPTCONN- , SO_ACCEPTCONN (..)- -- ** SO_REUSEADDR+ , SO_ERROR (..) , SO_REUSEADDR (..) -- * Flags -- ** MsgFlags , MsgFlags (..)- , msgDONTWAIT , msgEOR- , msgMORE , msgNOSIGNAL , msgOOB- , msgTRUNC , msgWAITALL -- ** AddrInfoFlags , AddrInfoFlags (..)@@ -190,12 +160,17 @@ import Control.Exception import Control.Monad import Control.Applicative+import Control.Concurrent import Control.Concurrent.MVar import Data.Function import Data.Monoid+import Data.Int import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Extra as BB+import qualified Data.ByteString.Lazy as LBS import GHC.Conc (closeFdWith) @@ -206,11 +181,10 @@ import System.Socket.Unsafe import System.Socket.Internal.Socket-import System.Socket.Internal.Event-import System.Socket.Internal.FFI import System.Socket.Internal.Exception import System.Socket.Internal.Msg import System.Socket.Internal.AddrInfo+import System.Socket.Internal.Platform import System.Socket.Family import System.Socket.Family.INET@@ -291,41 +265,77 @@ -- | Connects to an remote address. -- -- - Calling `connect` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned.--- - This function returns as soon as a connection has either been established--- or refused. A failed connection attempt does not throw an exception--- if @EINTR@ or @EINPROGRESS@ were caught internally. The operation--- just unblocks and returns in this case. The approach is to--- just try to read or write the socket and eventually fail there instead.--- Also see [these considerations](http://cr.yp.to/docs/connect.html) for an explanation.--- - This operation throws `SocketException`s. Consult your @man@ page for--- details and specific @errno@s.--- - @EINTR@ and @EINPROGRESS@ get catched internally and won't be thrown as the--- connection might still be established asynchronously. Expect failure--- when trying to read or write the socket in this case.+-- - 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. connect :: Family f => Socket f t p -> SockAddr f -> IO ()-connect (Socket mfd) addr = do- mwait <- withMVar mfd $ \fd-> do- when (fd < 0) $ do- throwIO eBADF- alloca $ \addrPtr-> do- poke addrPtr addr- i <- c_connect fd addrPtr (fromIntegral $ sizeOf addr)+connect s@(Socket mfd) addr = do+ alloca $ \addrPtr-> do+ poke addrPtr addr+ let addrLen = fromIntegral (sizeOf addr)+ mwait <- withMVar mfd $ \fd-> do+ when (fd < 0) (throwIO eBADF)+ -- The actual connection attempt.+ i <- c_connect fd addrPtr addrLen+ -- 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 == eINTR then do+ if e == eINPROGRESS || e == eWOULDBLOCK || e == eINTR then do -- The manpage says that in this case the connection -- shall be established asynchronously and one is -- supposed to wait.- wait <- threadWaitWrite' fd+ wait <- socketWaitWrite' 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- Just wait -> wait- Nothing -> return ()+ 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 == eISCONN 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 <$> socketWaitWrite' 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+ -- socketWaitWrite' call signals writeability.+ return Nothing+ case mwait' of+ Nothing -> do+ return ()+ Just wait' -> do+ wait'+ again $! iteration + 1+ ) 1 -- | Bind a socket to an address. --@@ -389,37 +399,38 @@ alloca $ \addrPtr-> do alloca $ \addrPtrLen-> do poke addrPtrLen (fromIntegral $ sizeOf (undefined :: SockAddr f))- fix $ \again-> 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- threadWaitRead' fd >>= return . Left- else if e == eINTR- -- 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- else do- -- This peek operation might be a little expensive, but I don't see an alternative.- addr <- peek addrPtr :: IO (SockAddr 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))- -- If ews is Left we got EAGAIN or EWOULDBLOCK and retry after the next event.- case ews of- Left wait -> wait >> again- Right sock -> return sock+ ( 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+ socketWaitRead' fd iteration >>= return . Left+ else if e == eINTR+ -- 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+ else do+ -- This peek operation might be a little expensive, but I don't see an alternative.+ addr <- peek addrPtr :: IO (SockAddr 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))+ -- 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. -- | Send a message on a connected socket. --@@ -533,12 +544,97 @@ -- Convenience Operations ------------------------------------------------------------------------------- --- | Like `send`, but continues until all data has been sent.+-- | Like `send`, but operates on lazy `Data.ByteString.Lazy.ByteString`s and +-- continues until all data has been sent or an exception occured.+sendAll ::Socket f STREAM p -> LBS.ByteString -> MsgFlags -> IO ()+sendAll s lbs flags =+ LBS.foldlChunks+ (\x bs-> x >> sendAll' bs+ ) (return ()) lbs+ where+ sendAll' bs = do+ sent <- send s bs flags+ when (sent < BS.length bs) $ sendAll' (BS.drop sent bs)++-- | Like `recv`, but operates on lazy `Data.ByteString.Lazy.ByteString`s and+-- continues until either an empty part has been received (peer closed+-- the connection) or given buffer limit has been exceeded or an+-- exception occured. ----- > sendAll sock buf flags = do--- > sent <- send sock buf flags--- > when (sent < length buf) $ sendAll sock (drop sent buf) flags-sendAll ::Socket f STREAM p -> BS.ByteString -> MsgFlags -> IO ()-sendAll s bs flags = do- sent <- send s bs flags- when (sent < BS.length bs) $ sendAll s (BS.drop sent bs) flags+-- - The `Int` parameter is a soft limit on how many bytes to receive.+-- Collection is stopped if the limit has been exceeded. The result might+-- be up to one internal buffer size longer than the given limit.+-- If the returned `Data.ByteString.Lazy.ByteString`s length is lower or+-- eqal than the limit, the data has not been truncated and the+-- transmission is complete.+recvAll :: Socket f STREAM p -> Int64 -> MsgFlags -> IO LBS.ByteString+recvAll sock maxLen flags = collect 0 mempty+ where+ collect len accum+ | len > maxLen = do+ build accum+ | otherwise = do+ bs <- recv sock BB.smallChunkSize flags+ if BS.null bs then do+ build accum+ else do+ collect (len + fromIntegral (BS.length bs))+ $! (accum `mappend` BB.byteString bs)+ build accum = do+ return (BB.toLazyByteString accum)++-- | Looks up a name and executes an supplied action with a connected socket.+--+-- - The addresses returned by `getAddrInfo` are tried in sequence until a+-- connection has been established or all have been tried.+-- - If `connect` fails on all addresses the exception that occured on the+-- last connection attempt is thrown.+-- - The supplied action is executed at most once with the first established+-- connection.+-- - If the address family is `INET6`, `IPV6_V6ONLY` is set to `False` which+-- means the other end may be both IPv4 or IPv6.+-- - All sockets created by this operation get closed automatically.+-- - This operation throws `AddrInfoException`s, `SocketException`s and all+-- exceptions that that the supplied action might throw.+--+-- > withConnectedSocket "wwww.haskell.org" "80" (aiALL `mappend` aiV4MAPPED) $ \sock-> do+-- > let _ = sock :: Socket INET6 STREAM TCP+-- > doSomethingWithSocket sock+withConnectedSocket :: forall f t p a.+ ( GetAddrInfo f, Type t, Protocol p)+ => BS.ByteString+ -> BS.ByteString+ -> AddrInfoFlags+ -> (Socket f t p -> IO a)+ -> IO a+withConnectedSocket host serv flags action = do+ addrs <- getAddrInfo (Just host) (Just serv) flags :: IO [AddrInfo f t p]+ tryAddrs addrs+ where+ tryAddrs :: [AddrInfo f t p] -> IO a+ tryAddrs [] = do+ -- This should not happen.+ throwIO eaiNONAME+ tryAddrs (addr:addrs) = do+ eith <- bracket+ ( socket )+ ( close )+ ( \sock-> do+ configureSocketSpecific sock+ connected <- try (connect sock $ addrAddress addr)+ case connected of+ Left e -> return (Left (e :: SocketException))+ Right _ -> Right <$> action sock+ )+ case eith of+ Left e ->+ -- Rethrow the last exception if there are no more addresses to try.+ if null addrs+ then throwIO e+ else tryAddrs addrs+ Right a -> do+ return a++ configureSocketSpecific sock = do+ when (familyNumber (undefined :: f) == familyNumber (undefined :: INET6)) $ do+ setSockOpt sock (IPV6_V6ONLY False)
src/System/Socket/Family/INET.hsc view
@@ -25,7 +25,7 @@ import Foreign.Marshal.Utils import System.Socket.Family-import System.Socket.Internal.FFI+import System.Socket.Internal.Platform #include "hs_socket.h" #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
src/System/Socket/Family/INET6.hsc view
@@ -1,10 +1,14 @@ {-# LANGUAGE TypeFamilies #-} module System.Socket.Family.INET6 ( INET6+ -- * Addresses , AddrIn6 () , SockAddrIn6 (..)+ -- ** Special Address Constants , in6addrANY , in6addrLOOPBACK+ -- * Socket Options+ , IPV6_V6ONLY (..) ) where import Data.Word@@ -18,7 +22,8 @@ import Foreign.Marshal.Utils import System.Socket.Family-import System.Socket.Internal.FFI+import System.Socket.Internal.Socket+import System.Socket.Internal.Platform #include "hs_socket.h" #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)@@ -130,3 +135,19 @@ sin6_scope_id = (#ptr struct sockaddr_in6, sin6_scope_id) sin6_port = (#ptr struct sockaddr_in6, sin6_port) sin6_addr = (#ptr struct in6_addr, s6_addr) . (#ptr struct sockaddr_in6, sin6_addr)++-------------------------------------------------------------------------------+-- Address family specific socket options+-------------------------------------------------------------------------------++data IPV6_V6ONLY+ = IPV6_V6ONLY Bool+ deriving (Eq, Ord, Show)++instance GetSockOpt IPV6_V6ONLY where+ getSockOpt s =+ IPV6_V6ONLY <$> getSockOptBool s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY)++instance SetSockOpt IPV6_V6ONLY where+ setSockOpt s (IPV6_V6ONLY o) =+ setSockOptBool s (#const IPPROTO_IPV6) (#const IPV6_V6ONLY) o
src/System/Socket/Internal/AddrInfo.hsc view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables,- StandaloneDeriving, FlexibleContexts, TypeFamilies, CPP,+ StandaloneDeriving, FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving #-} module System.Socket.Internal.AddrInfo ( AddrInfo (..)@@ -53,7 +53,7 @@ import System.Socket.Family.INET6 import System.Socket.Type import System.Socket.Protocol-import System.Socket.Internal.FFI+import System.Socket.Internal.Platform #include "hs_socket.h" #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)@@ -148,6 +148,9 @@ aiADDRCONFIG :: AddrInfoFlags aiADDRCONFIG = AddrInfoFlags (#const AI_ADDRCONFIG) +-- | Return both IPv4 (as mapped `SockAddrIn6`) and IPv6 addresses when+-- `aiV4MAPPED` is set independent of whether IPv6 addresses exist for this+-- name. aiALL :: AddrInfoFlags aiALL = AddrInfoFlags (#const AI_ALL) @@ -163,6 +166,8 @@ aiPASSIVE :: AddrInfoFlags aiPASSIVE = AddrInfoFlags (#const AI_PASSIVE) +-- | Return mapped IPv4 addresses if no IPv6 addresses could be found+-- or if `aiALL` flag is set. aiV4MAPPED :: AddrInfoFlags aiV4MAPPED = AddrInfoFlags (#const AI_V4MAPPED) @@ -309,19 +314,3 @@ return (host,serv) else do throwIO (AddrInfoException e)------------------------------------------------------------------------------------ FFI----------------------------------------------------------------------------------foreign import ccall FFI_GETADDRINFO_SAFETY FFI_GETADDRINFO- c_getaddrinfo :: CString -> CString -> Ptr (AddrInfo a t p) -> Ptr (Ptr (AddrInfo a t p)) -> IO CInt--foreign import ccall FFI_FREEADDRINFO_SAFETY FFI_FREEADDRINFO- c_freeaddrinfo :: Ptr (AddrInfo a t p) -> IO ()--foreign import ccall FFI_GETNAMEINFO_SAFETY FFI_GETNAMEINFO- c_getnameinfo :: Ptr a -> CInt -> CString -> CInt -> CString -> CInt -> CInt -> IO CInt--foreign import ccall FFI_GAI_STRERROR_SAFETY FFI_GAI_STRERROR- c_gai_strerror :: CInt -> IO CString
− src/System/Socket/Internal/Event.hs
@@ -1,19 +0,0 @@-module System.Socket.Internal.Event- ( threadWaitWrite', threadWaitRead'- ) where--import GHC.Conc (threadWaitReadSTM, threadWaitWriteSTM, atomically)--import System.Posix.Types ( Fd(..) )------------------------------------------------------------------------------------ Helpers for threadsafe event registration on file descriptors----------------------------------------------------------------------------------threadWaitWrite' :: Fd -> IO (IO ())-threadWaitWrite' fd = do- threadWaitWriteSTM fd >>= return . atomically . fst--threadWaitRead' :: Fd -> IO (IO ())-threadWaitRead' fd = do- threadWaitReadSTM fd >>= return . atomically . fst
src/System/Socket/Internal/Exception.hsc view
@@ -9,7 +9,7 @@ newtype SocketException = SocketException CInt- deriving (Typeable, Eq)+ deriving (Typeable, Eq, Ord) instance Exception SocketException @@ -24,25 +24,30 @@ | e == ePROTONOSUPPORT = "ePROTONOSUPPORT" | e == eINVAL = "eINVAL" | e == eCONNREFUSED = "eCONNREFUSED"+ | e == eNETUNREACH = "eNETUNREACH"+ | e == eNOTCONN = "eNOTCONN"+ | e == eALREADY = "eALREADY"+ | e == eISCONN = "eISCONN"+ | e == eTIMEDOUT = "eTIMEDOUT" | otherwise = "SocketException " ++ show i -eOK :: SocketException-eOK = SocketException (#const SEOK)+eOK :: SocketException+eOK = SocketException (#const SEOK) -eINTR :: SocketException-eINTR = SocketException (#const SEINTR)+eINTR :: SocketException+eINTR = SocketException (#const SEINTR) -eAGAIN :: SocketException-eAGAIN = SocketException (#const SEAGAIN)+eAGAIN :: SocketException+eAGAIN = SocketException (#const SEAGAIN) -eWOULDBLOCK :: SocketException-eWOULDBLOCK = SocketException (#const SEWOULDBLOCK)+eWOULDBLOCK :: SocketException+eWOULDBLOCK = SocketException (#const SEWOULDBLOCK) -eBADF :: SocketException-eBADF = SocketException (#const SEBADF)+eBADF :: SocketException+eBADF = SocketException (#const SEBADF) -eINPROGRESS :: SocketException-eINPROGRESS = SocketException (#const SEINPROGRESS)+eINPROGRESS :: SocketException+eINPROGRESS = SocketException (#const SEINPROGRESS) ePROTONOSUPPORT :: SocketException ePROTONOSUPPORT = SocketException (#const SEPROTONOSUPPORT)@@ -53,3 +58,17 @@ eCONNREFUSED :: SocketException eCONNREFUSED = SocketException (#const SECONNREFUSED) +eNETUNREACH :: SocketException+eNETUNREACH = SocketException (#const SENETUNREACH)++eNOTCONN :: SocketException+eNOTCONN = SocketException (#const SENOTCONN)++eALREADY :: SocketException+eALREADY = SocketException (#const SEALREADY)++eISCONN :: SocketException+eISCONN = SocketException (#const SEISCONN)++eTIMEDOUT :: SocketException+eTIMEDOUT = SocketException (#const SETIMEDOUT)
− src/System/Socket/Internal/FFI.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE CPP #-}-module System.Socket.Internal.FFI where--import Foreign.Ptr-import Foreign.C.Types--import System.Posix.Types ( Fd(..) )--import System.Socket.Internal.Msg-import System.Socket.Internal.Exception--type CSSize- = CInt--foreign import ccall FFI_SOCKET_SAFETY FFI_SOCKET- c_socket :: CInt -> CInt -> CInt -> IO Fd--foreign import ccall FFI_CLOSE_SAFETY FFI_CLOSE- c_close :: Fd -> IO CInt--foreign import ccall FFI_BIND_SAFETY FFI_BIND- c_bind :: Fd -> Ptr a -> CInt -> IO CInt--foreign import ccall FFI_CONNECT_SAFETY FFI_CONNECT- c_connect :: Fd -> Ptr a -> CInt -> IO CInt--foreign import ccall FFI_ACCEPT_SAFETY FFI_ACCEPT- c_accept :: Fd -> Ptr a -> Ptr CInt -> IO Fd--foreign import ccall FFI_LISTEN_SAFETY FFI_LISTEN- c_listen :: Fd -> CInt -> IO CInt--foreign import ccall FFI_SEND_SAFETY FFI_SEND- c_send :: Fd -> Ptr a -> CSize -> MsgFlags -> IO CSSize--foreign import ccall FFI_SENDTO_SAFETY FFI_SENDTO- c_sendto :: Fd -> Ptr a -> CSize -> MsgFlags -> Ptr b -> CInt -> IO CSSize--foreign import ccall FFI_RECV_SAFETY FFI_RECV- c_recv :: Fd -> Ptr a -> CSize -> MsgFlags -> IO CSSize--foreign import ccall FFI_RECVFROM_SAFETY FFI_RECVFROM- c_recvfrom :: Fd -> Ptr a -> CSize -> MsgFlags -> Ptr b -> Ptr CInt -> IO CSSize--foreign import ccall FFI_GETSOCKOPT_SAFETY FFI_GETSOCKOPT- c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt--foreign import ccall FFI_SETSOCKOPT_SAFETY FFI_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--foreign import ccall unsafe "memset"- c_memset :: Ptr a -> CInt -> CSize -> IO ()---
src/System/Socket/Internal/Msg.hsc view
@@ -3,12 +3,9 @@ MsgFlags (..) , Msg , IoVec- , msgDONTWAIT , msgEOR- , msgMORE , msgNOSIGNAL , msgOOB- , msgTRUNC , msgWAITALL ) where @@ -48,10 +45,7 @@ , if msg .&. msgNOSIGNAL /= mempty then Just "msgNOSIGNAL" else Nothing , if msg .&. msgOOB /= mempty then Just "msgOOB" else Nothing , if msg .&. msgWAITALL /= mempty then Just "msgWAITALL" else Nothing- , if msg .&. msgTRUNC /= mempty then Just "msgTRUNC" else Nothing- , if msg .&. msgMORE /= mempty then Just "msgMORE" else Nothing- , if msg .&. msgDONTWAIT /= mempty then Just "msgDONTWAIT" else Nothing- , let (MsgFlags i) = msg `xor` (mconcat [msgEOR,msgNOSIGNAL,msgOOB,msgWAITALL,msgTRUNC,msgMORE,msgDONTWAIT] .&. msg)+ , let (MsgFlags i) = msg `xor` (mconcat [msgEOR,msgNOSIGNAL,msgOOB,msgWAITALL] .&. msg) in if i /= 0 then Just ("MsgFlags " ++ show i) else Nothing ] y = concat $ intersperse "," $ catMaybes x@@ -67,13 +61,3 @@ msgWAITALL :: MsgFlags msgWAITALL = MsgFlags (#const MSG_WAITALL)--msgTRUNC :: MsgFlags-msgTRUNC = MsgFlags (#const MSG_TRUNC)--msgMORE :: MsgFlags-msgMORE = MsgFlags (#const MSG_MORE)--msgDONTWAIT :: MsgFlags-msgDONTWAIT = MsgFlags (#const MSG_DONTWAIT)-
src/System/Socket/Internal/Socket.hsc view
@@ -1,8 +1,10 @@ module System.Socket.Internal.Socket ( Socket (..) , GetSockOpt (..)+ , getSockOptBool , SetSockOpt (..)- , SO_ACCEPTCONN (..)+ , setSockOptBool+ , SO_ERROR (..) , SO_REUSEADDR (..) ) where @@ -17,7 +19,7 @@ import Foreign.Marshal.Alloc import System.Posix.Types -import System.Socket.Internal.FFI+import System.Socket.Internal.Platform import System.Socket.Internal.Exception #include "hs_socket.h"@@ -53,15 +55,17 @@ class SetSockOpt o where setSockOpt :: Socket f t p -> o -> IO () -data SO_ACCEPTCONN- = SO_ACCEPTCONN Bool+data SO_ERROR+ = SO_ERROR SocketException+ deriving (Eq, Ord, Show) -instance GetSockOpt SO_ACCEPTCONN where+instance GetSockOpt SO_ERROR where getSockOpt s =- SO_ACCEPTCONN <$> getSockOptBool s (#const SOL_SOCKET) (#const SO_ACCEPTCONN)+ SO_ERROR . SocketException <$> getSockOptCInt s (#const SOL_SOCKET) (#const SO_ERROR) data SO_REUSEADDR = SO_REUSEADDR Bool+ deriving (Eq, Ord, Show) instance GetSockOpt SO_REUSEADDR where getSockOpt s =@@ -101,3 +105,52 @@ else do v <- peek vPtr return (v == 1)++setSockOptInt :: Socket f t p -> CInt -> CInt -> Int -> IO ()+setSockOptInt (Socket mfd) level name value = do+ withMVar mfd $ \fd->+ alloca $ \vPtr-> do+ poke vPtr (fromIntegral value :: CInt)+ i <- c_setsockopt fd level name + (vPtr :: Ptr CInt)+ (fromIntegral $ sizeOf (undefined :: CInt))+ when (i < 0) $ do+ c_get_last_socket_error >>= throwIO++getSockOptInt :: Socket f t p -> CInt -> CInt -> IO Int+getSockOptInt (Socket mfd) level name = do+ withMVar mfd $ \fd->+ alloca $ \vPtr-> do+ alloca $ \lPtr-> do+ i <- c_getsockopt fd level name+ (vPtr :: Ptr CInt)+ (lPtr :: Ptr CInt)+ if i < 0 then do+ c_get_last_socket_error >>= throwIO+ else do+ v <- peek vPtr+ return (fromIntegral v)++setSockOptCInt :: Socket f t p -> CInt -> CInt -> CInt -> IO ()+setSockOptCInt (Socket mfd) level name value = do+ withMVar mfd $ \fd->+ alloca $ \vPtr-> do+ poke vPtr value+ i <- c_setsockopt fd level name + (vPtr :: Ptr CInt)+ (fromIntegral $ sizeOf (undefined :: CInt))+ when (i < 0) $ do+ c_get_last_socket_error >>= throwIO++getSockOptCInt :: Socket f t p -> CInt -> CInt -> IO CInt+getSockOptCInt (Socket mfd) level name = do+ withMVar mfd $ \fd->+ alloca $ \vPtr-> do+ alloca $ \lPtr-> do+ i <- c_getsockopt fd level name+ (vPtr :: Ptr CInt)+ (lPtr :: Ptr CInt)+ if i < 0 then do+ c_get_last_socket_error >>= throwIO+ else do+ peek vPtr
src/System/Socket/Unsafe.hsc view
@@ -29,10 +29,10 @@ import Foreign.Storable import System.Socket.Internal.Socket-import System.Socket.Internal.Event-import System.Socket.Internal.FFI+import System.Socket.Internal.Platform import System.Socket.Internal.Exception import System.Socket.Internal.Msg+import System.Socket.Internal.Platform import System.Socket.Family import System.Posix.Types (Fd)@@ -41,36 +41,43 @@ unsafeSend :: Socket a t p -> Ptr a -> CSize -> MsgFlags -> IO CInt unsafeSend s bufPtr bufSize flags = do- tryWaitAndRetry s threadWaitWrite' (\fd-> c_send fd bufPtr bufSize (flags `mappend` msgNOSIGNAL) )+ tryWaitAndRetry s socketWaitWrite' (\fd-> c_send fd bufPtr bufSize (flags `mappend` msgNOSIGNAL) ) unsafeSendTo :: Socket f t p -> Ptr b -> CSize -> MsgFlags -> Ptr (SockAddr f) -> CInt -> IO CInt unsafeSendTo s bufPtr bufSize flags addrPtr addrSize = do- tryWaitAndRetry s threadWaitWrite' (\fd-> c_sendto fd bufPtr (fromIntegral bufSize) (flags `mappend` msgNOSIGNAL) addrPtr addrSize)+ tryWaitAndRetry s socketWaitWrite' (\fd-> c_sendto fd bufPtr (fromIntegral bufSize) (flags `mappend` msgNOSIGNAL) addrPtr addrSize) unsafeRecv :: Socket a t p -> Ptr b -> CSize -> MsgFlags -> IO CInt unsafeRecv s bufPtr bufSize flags =- tryWaitAndRetry s threadWaitRead' (\fd-> c_recv fd bufPtr bufSize flags)+ tryWaitAndRetry s socketWaitRead' (\fd-> c_recv fd bufPtr bufSize flags) unsafeRecvFrom :: Socket f t p -> Ptr b -> CSize -> MsgFlags -> Ptr (SockAddr f) -> Ptr CInt -> IO CInt unsafeRecvFrom s bufPtr bufSize flags addrPtr addrSizePtr = do- tryWaitAndRetry s threadWaitRead' (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr)+ tryWaitAndRetry s socketWaitRead' (\fd-> c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr) -tryWaitAndRetry :: Socket f t p -> (Fd -> IO (IO ())) -> (Fd -> IO CInt) -> IO CInt-tryWaitAndRetry (Socket mfd) getWaitAction action = do- fix $ \again-> do- ewr <- withMVar mfd $ \fd-> do- when (fd < 0) $ do- throwIO eBADF- 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 >>= return . Left- else if e == eINTR- then retry- else throwIO e- else return (Right i)- case ewr of- Left wait -> wait >> again- Right result -> return result+tryWaitAndRetry :: Socket f t p -> (Fd -> Int-> IO (IO ())) -> (Fd -> IO CInt) -> IO CInt+tryWaitAndRetry (Socket mfd) getWaitAction action = loop 0+ where+ loop iteration = do+ ewr <- withMVar mfd $ \fd-> do+ when (fd < 0) $ do+ throwIO eBADF+ 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 == eINTR+ then retry+ else throwIO e+ else do+ -- The following is quite interesting for debugging:+ -- when (iteration /= 0) (print iteration)+ return (Right i)+ case ewr of+ Left wait -> do+ wait+ loop $! iteration + 1+ Right result -> do+ return result
tests/AddrInfo.hs view
@@ -13,6 +13,7 @@ main = do t0001 t0002+ t0003 t0001 :: IO () t0001 = do@@ -43,3 +44,24 @@ 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.+t0003 :: IO ()+t0003 = do+ x <- getAddrInfo+ (Just "localhost")+ Nothing+ mempty + `onException` p 0:: IO [AddrInfo INET6 STREAM TCP]+ y <- getAddrInfo+ (Just "localhost")+ Nothing+ (aiALL `mappend` aiV4MAPPED)+ `onException` p 1 :: IO [AddrInfo INET6 STREAM TCP]+ when (length x == length y) (e 2)+ where+ p i = print ("t0003." ++ show i)+ e i = error ("t0003." ++ show i)
− tests/Basic.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-}-module Main where--import Data.Bits-import Data.Monoid-import Data.ByteString (pack)-import qualified Data.ByteString.Lazy as LBS-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.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 "test0002.01" $ test0002 (undefined :: Socket INET DGRAM UDP) localhost- test "test0002.02" $ test0002 (undefined :: Socket INET6 DGRAM UDP) localhost6---- Test send and receive on connection oriented sockets (i.e. TCP).-test0001 :: (Family f, Type t, Protocol p) => Socket f t p -> SockAddr 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- setSockOpt server (SO_REUSEADDR 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"- recv peerSock 4096 mempty `onException` print "E09"- client <- socket `asTypeOf` return server `onException` print "E10"- 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!"---- Test stateless sockets (i.e. UDP).-test0002 :: (Family f, Type t, Protocol p) => Socket f t p -> SockAddr f -> IO (Either String String)-test0002 dummy addr =- bracket- ( do server <- socket `asTypeOf` return dummy- client <- socket `asTypeOf` return dummy- return (server, client)- )- (\(server,client)-> do- close server- close client- )- (\(server,client)-> do- setSockOpt server (SO_REUSEADDR True)- bind server addr- serverRecv <- async $ do- recvFrom server 4096 mempty- client <- socket `asTypeOf` return server- sendTo client helloWorld mempty addr- (msg,peerAddr) <- wait serverRecv- if (msg /= helloWorld)- then return (Left "Received message was bogus.")- else return (Right "")- )- where- helloWorld = "Hello world!"--localhost :: SockAddrIn-localhost =- SockAddrIn- { sinPort = 7777- , sinAddr = inaddrLOOPBACK- }--localhost6 :: SockAddrIn6-localhost6 =- SockAddrIn6- { sin6Port = 7777- , sin6Addr = in6addrLOOPBACK- , sin6Flowinfo = 0- , sin6ScopeId = 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/IPV6_V6ONLY.hs view
@@ -0,0 +1,78 @@+{-# 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.Exit++main :: IO ()+main = do + t0001+ t0002++t0001 :: IO ()+t0001 = + bracket+ ( do+ server <- socket `onException` p 0 :: IO (Socket INET6 DGRAM UDP)+ client <- socket `onException` p 1 :: IO (Socket INET DGRAM UDP)+ return (server, client)+ )+ (\(server,client)-> do+ close server `onException` p 2+ close client `onException` p 3+ )+ (\(server,client)-> do+ setSockOpt server (IPV6_V6ONLY True) `onException` p 4+ bind server (SockAddrIn6 7777 0 in6addrANY 0) `onException` p 5++ threadDelay 1000000 -- wait for the listening socket being set up+ sendTo client "PING" mempty (SockAddrIn 7777 inaddrLOOPBACK)+ `onException` p 6+ eith <- race+ ( recvFrom 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 DGRAM UDP)+ client <- socket `onException` p 1 :: IO (Socket INET DGRAM UDP)+ return (server, client)+ )+ (\(server,client)-> do+ close server `onException` p 2+ close client `onException` p 3+ )+ (\(server,client)-> do+ setSockOpt server (IPV6_V6ONLY False) `onException` p 4+ bind server (SockAddrIn6 7778 0 in6addrANY 0) `onException` p 5++ threadDelay 1000000 -- wait for the listening socket being set up+ sendTo client "PING" mempty (SockAddrIn 7778 inaddrLOOPBACK)+ `onException` p 6+ eith <- race+ ( recvFrom 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 view
@@ -0,0 +1,45 @@+{-# 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.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)+ setSockOpt s (SO_REUSEADDR True) `onException` e 1+ bind s (SockAddrIn 8080 inaddrLOOPBACK) `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 view
@@ -0,0 +1,49 @@+{-# 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.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)+ setSockOpt server (SO_REUSEADDR 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 = SockAddrIn 8080 inaddrLOOPBACK+ e i = print ("t0001." ++ show i)+ loop sock index = ( do+ ping <- recv 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 view
@@ -0,0 +1,45 @@+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++-- | 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"+ recvAll 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 = SockAddrIn 7777 inaddrLOOPBACK
+ tests/TCP.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-}+module Main where++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.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) => Socket f t p -> SockAddr 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+ setSockOpt server (SO_REUSEADDR 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"+ recv 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 :: SockAddrIn+localhost =+ SockAddrIn+ { sinPort = 7777+ , sinAddr = inaddrLOOPBACK+ }++localhost6 :: SockAddrIn6+localhost6 =+ SockAddrIn6+ { sin6Port = 7777+ , sin6Addr = in6addrLOOPBACK+ , sin6Flowinfo = 0+ , sin6ScopeId = 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 view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++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.Exit++main :: IO ()+main = do + test "INET" (undefined :: Socket INET DGRAM UDP) localhost+ test "INET6" (undefined :: Socket INET6 DGRAM UDP) localhost6++-- Test stateless sockets (i.e. UDP).+test :: (Family f, Type t, Protocol p) => String -> Socket f t p -> SockAddr 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+ recvFrom 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 :: SockAddrIn+localhost =+ SockAddrIn+ { sinPort = 7777+ , sinAddr = inaddrLOOPBACK+ }++localhost6 :: SockAddrIn6+localhost6 =+ SockAddrIn6+ { sin6Port = 7777+ , sin6Addr = in6addrLOOPBACK+ , sin6Flowinfo = 0+ , sin6ScopeId = 0+ }