%---------------------------------------------------------------------------% % vim: ft=mercury ts=4 sw=4 et %---------------------------------------------------------------------------% % Copyright (C) 2000, 2007, 2011 The University of Melbourne % Copyright (C) 2014-2018 The Mercury team. % This file is distributed under the terms specified in COPYING.LIB. %---------------------------------------------------------------------------% % % Module: tcp % Main Author: peter.ross@miscrit.be (based on code written by pma@miscrit.be) % Stability: low % % An implementation of TCP streams. % %---------------------------------------------------------------------------% :- module net.tcp. :- interface. :- import_module io. :- import_module stream. :- import_module string. %---------------------------------------------------------------------------% :- type tcp. :- type bound_tcp. :- type result(T) ---> ok(T) ; error(string). :- type host == string. % A hostname ie "localhost" :- type service == string. % A service ie "www" :- type protocol == string. % A protocol ie "tcp" :- type port == int. % A portnumber ie 80 - the webserver :- pred connect(host::in, port::in, tcp.result(tcp)::out, io::di, io::uo) is det. :- pred bind(host::in, port::in, tcp.result(bound_tcp)::out, io::di, io::uo) is det. :- pred accept(bound_tcp::in, tcp.result(tcp)::out, io::di, io::uo) is det. :- pred shutdown(tcp::in, io::di, io::uo) is det. % Accesses the stream to see if there is data available, waits for a given % period before timing out. (Use this rather than a failure driven test % and loop on connects.) % :- pred data_available(bound_tcp::in, int::in, int::out, io::di, io::uo) is det. :- func socket_fd(tcp) = int. % Sending data to a broken pipe will cause the SIGPIPE signal to be % sent to the process. If SIGPIPE is ignored or blocked then send() % fails with EPIPE. This predicate causes SIGPIPE signals to be ignored. % :- pred ignore_sigpipe(io::di, io::uo) is det. % Restores the SIGPIPE signal handler before the last % ignore_sigpipe() call. % :- pred unignore_sigpipe(io::di, io::uo) is det. %---------------------------------------------------------------------------% % % Stream type class instances % :- type error. :- instance stream(tcp, io.state). :- instance error(tcp.error). :- instance input(tcp, io.state). :- instance reader(tcp, character, io.state, tcp.error). :- instance reader(tcp, line, io.state, tcp.error). :- instance output(tcp, io.state). :- instance writer(tcp, character, io.state). :- instance writer(tcp, string, io.state). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- implementation. :- import_module bool. :- import_module char. :- import_module list. :- import_module require. %---------------------------------------------------------------------------% :- type tcp ---> tcp( name :: string, handle :: tcp_handle ). :- type bound_tcp ---> bound_tcp( int, % socket fd c_pointer % struct sockaddr ). %---------------------------------------------------------------------------% connect(Host, Port, Result, !IO) :- handle_connect(Host, Port, Handle, Errno, !IO), ( if Errno = 0 then Result = ok(tcp(Host, Handle)) else Result = tcp.error(tcp.error_message(Errno)) ). %---------------------------------------------------------------------------% bind(Host, Port, Result, !IO) :- handle_bind(Host, Port, Socket, Addr, Errno, !IO), ( if Errno = 0 then Result = ok(bound_tcp(Socket, Addr)) else Result = tcp.error(tcp.error_message(Errno)) ). %---------------------------------------------------------------------------% accept(bound_tcp(Socket, Addr), Result, !IO) :- handle_accept(Socket, Addr, Handle, Errno, !IO), ( if Errno = 0 then Result = ok(tcp("XXX unknown host", Handle)) else Result = tcp.error(tcp.error_message(Errno)) ). %---------------------------------------------------------------------------% shutdown(tcp(_, Handle), !IO) :- handle_shutdown(Handle, !IO). :- pred handle_shutdown(tcp_handle::in, io::di, io::uo) is det. :- pragma foreign_proc("C", handle_shutdown(TCP::in, _IO0::di, _IO::uo), [may_call_mercury, thread_safe, promise_pure, tabled_for_io], " struct linger sockets_linger = { MR_TRUE, 2 }; ML_tcp *sock; int shutdown_erro = 0; sock = (ML_tcp *) TCP; // setsockopt(sock->socket, SOL_SOCKET, SO_LINGER, // &sockets_linger, sizeof(sockets_linger)); errno=0; if (close(((int)sock->socket)) == SOCKET_ERROR) { ML_throw_tcp_exception((MR_String) ""tcp.shutdown failed (close)""); } "). %---------------------------------------------------------------------------% :- type tcp_handle ---> socket(c_pointer). :- pragma foreign_decl("C", " #ifdef MR_WIN32 #include ""mercury_windows.h"" #include #include #include #define ML_error() WSAGetLastError() #else // !MR_WIN32 #include #include #include #include #include #include #define ML_error() errno #define INVALID_SOCKET -1 #define SOCKET_ERROR -1 #endif // !MR_WIN32 #define ADDRLEN 16 #define BACKLOG 16 #define FULL 2 #define TCP_BUFSIZE 1024 typedef struct { int socket; int error; size_t buf_len; off_t buf_pos; char buf[TCP_BUFSIZE]; } ML_tcp; void ML_tcp_init(void); "). :- pragma foreign_code("C", " // We must ensure that the socket DLL is initialiased before // use under Win32. void ML_tcp_init(void) { #ifdef MR_WIN32 static int initialiased = MR_FALSE; WORD wVersionRequested; WSADATA wsaData; int err; if (!initialiased) { wVersionRequested = MAKEWORD( 2, 2 ); err = WSAStartup(wVersionRequested, &wsaData); if (err != 0) { MR_fatal_error(""Unable to find a usable winsock.dll\\n""); } if (LOBYTE( wsaData.wVersion ) != 2 || HIBYTE( wsaData.wVersion ) != 2) { WSACleanup(); MR_fatal_error(""Unable to find a usable winsock.dll\\n""); } initialiased = MR_TRUE; } #endif // MR_WIN32 } "). :- pred handle_connect(string::in, port::in, tcp_handle::out, int::out, io::di, io::uo) is det. :- pragma foreign_proc("C", handle_connect(Host::in, Port::in, TCP::out, Errno::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " ML_tcp *sock; struct hostent *host; struct sockaddr_in *addr; ML_tcp_init(); sock = MR_GC_NEW(ML_tcp); sock->socket = socket(PF_INET, SOCK_STREAM, 0); sock->error = 0; sock->buf_len = 0; sock->buf_pos = 0; if (sock->socket == INVALID_SOCKET) { sock->error = ML_error(); } else { host = gethostbyname(Host); if (host == NULL) { sock->error = ML_error(); } else { addr = MR_GC_NEW(struct sockaddr_in); MR_memset(addr, 0, sizeof(struct sockaddr_in)); MR_memcpy(&(addr->sin_addr), host->h_addr_list[0], host->h_length); addr->sin_family = host->h_addrtype; addr->sin_port = htons(Port); // MR_memset(&addr, 0, sizeof(addr)); // MR_memcpy((char *) &addr.sin_addr, host->h_addr, host->h_length); // addr.sin_family = host->h_addrtype; // addr.sin_port = htons(Port); if (connect(sock->socket, (struct sockaddr *) addr, ADDRLEN) == SOCKET_ERROR) { sock->error = ML_error(); } } } Errno = sock->error; TCP = (MR_Word) sock; "). socket_fd(Tcp) = socket_fd_c(Tcp ^ handle). :- func socket_fd_c(tcp_handle) = int. :- pragma foreign_proc("C", socket_fd_c(Tcp::in) = (FD::out), [will_not_call_mercury, thread_safe, promise_pure], " ML_tcp *sock = (ML_tcp *) Tcp; FD = sock->socket; "). %---------------------------------------------------------------------------% :- pred handle_bind(string::in, port::in, int::out, c_pointer::out, int::out, io::di, io::uo) is det. :- pragma foreign_proc("C", handle_bind(Host::in, Port::in, Socket::out, Addr::out, Errno::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " struct hostent *host = NULL; struct sockaddr_in *addr = NULL; ML_tcp_init(); Socket = socket(PF_INET, SOCK_STREAM, 0); Errno = 0; if (Socket == INVALID_SOCKET) { Errno = ML_error(); } else { host = gethostbyname(Host); if (host == NULL) { Errno = ML_error(); } else { addr = MR_GC_NEW(struct sockaddr_in); MR_memset(addr, 0, sizeof(struct sockaddr_in)); MR_memcpy(&(addr->sin_addr), host->h_addr_list[0], host->h_length); addr->sin_family = host->h_addrtype; addr->sin_port = htons(Port); if (bind(Socket, (struct sockaddr *) addr, ADDRLEN) == SOCKET_ERROR) { Errno = ML_error(); } else { if (listen(Socket, BACKLOG) == SOCKET_ERROR) { Errno = ML_error(); } } } } Addr = (MR_Word) addr; "). :- pred handle_accept(int::in, c_pointer::in, tcp_handle::out, int::out, io::di, io::uo) is det. :- pragma foreign_proc("C", handle_accept(Socket::in, Addr::in, TCP::out, Errno::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " ML_tcp *sock; struct sockaddr *addr; // For Winsock the third argument of accept is pointer to a signed int. // On POSIX, systems, it has type socklen_t which is unsigned. #if defined(MR_WIN32) int size = sizeof(struct sockaddr_in); #else socklen_t size = sizeof(struct sockaddr_in); #endif sock = MR_GC_NEW(ML_tcp); addr = (struct sockaddr *) Addr; sock->socket = accept(Socket, addr, &size); sock->error = 0; sock->buf_len = 0; sock->buf_pos = 0; if (sock->socket == INVALID_SOCKET) { sock->error = ML_error(); } TCP = (MR_Word) sock; Errno = sock->error; "). %---------------------------------------------------------------------------% :- type tcp.error ---> errno(int). :- instance stream(tcp, io.state) where [ name(TCP, TCP ^ name, !IO) ]. :- instance error(tcp.error) where [ (error_message(E) = S :- get_error(E, S) ) ]. :- instance input(tcp, io.state) where []. :- instance reader(tcp, character, io.state, tcp.error) where [ (get(T, Result, !IO) :- tcp.read_char(T ^ handle, Char, !IO), ( if Char = -1 then Result = eof else if Char = -2 then get_errno(T ^ handle, Errno, !IO), Result = error(Errno) else Result = ok(char.det_from_int(Char)) ) ) ]. :- instance reader(tcp, line, io.state, tcp.error) where [ (get(T, Result, !IO) :- tcp.read_line_as_string_2(T ^ handle, ErrCode, String, !IO), ( if ErrCode = -1 then Result = eof else if ErrCode = -2 then get_errno(T ^ handle, Errno, !IO), Result = error(Errno) else Result = ok(line(String)) ) ) ]. :- instance output(tcp, io) where [ % XXX can one flush a socket? flush(_, !IO) ]. :- instance writer(tcp, character, io.state) where [ (put(T, C, !IO) :- tcp.write_char(T ^ handle, C, B, !IO), ( B = yes, true ; B = no, get_errno(T ^ handle, Errno, !IO), get_error(Errno, String), error("put(char): " ++ String) ) ) ]. :- instance writer(tcp, string, io.state) where [ (put(T, S, !IO) :- tcp.write_string(T ^ handle, S, B, !IO), ( B = yes ; B = no, get_errno(T ^ handle, Errno, !IO), get_error(Errno, String), error("put(string): " ++ String) ) ) ]. %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- pragma foreign_decl("C", " // Note: some Mercury code uses the -1 and -2 constants directly. #define TCP_EOF -1 #define TCP_ERROR -2 int TCP_get_char(ML_tcp *sock); "). :- pragma foreign_code("C", " int TCP_get_char(ML_tcp *sock) { if (sock->buf_pos >= sock->buf_len) { // Refill buffer. int nchars = recv(sock->socket, sock->buf, sizeof(sock->buf), 0); if (nchars == SOCKET_ERROR) { sock->error = ML_error(); return TCP_ERROR; } else if (nchars == 0) { return TCP_EOF; } else { sock->buf_pos = 1; sock->buf_len = nchars; return sock->buf[0]; } } else { return sock->buf[sock->buf_pos++]; } } "). :- pred read_char(tcp_handle::in, int::out, io::di, io::uo) is det. :- pragma foreign_proc("C", read_char(Socket::in, Chr::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " ML_tcp *sock = (ML_tcp *) Socket; Chr = TCP_get_char(sock); "). % This implementation is based on io.read_line_as_string_2. % :- pred read_line_as_string_2(tcp_handle::in, int::out, string::out, io::di, io::uo) is det. :- pragma foreign_proc("C", read_line_as_string_2(TCP::in, Res::out, RetString::out, _IO0::di, _IO::uo), [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io], " #define TCP_IO_READ_LINE_GROW(n) ((n) * 3 / 2) #define TCP_IO_BYTES_TO_WORDS(n) (((n) + sizeof(MR_Word) - 1) / sizeof(MR_Word)) #define TCP_IO_READ_LINE_START 1024 ML_tcp *sock = (ML_tcp *) TCP; MR_Char initial_read_buffer[TCP_IO_READ_LINE_START]; MR_Char *read_buffer = initial_read_buffer; size_t read_buf_size = TCP_IO_READ_LINE_START; size_t i; int char_code = '\\0'; Res = 0; for (i = 0; char_code != '\\n'; ) { char_code = TCP_get_char(sock); if (char_code == TCP_EOF) { if (i == 0) { Res = -1; } break; } if (char_code == TCP_ERROR) { Res = -2; break; } read_buffer[i++] = char_code; MR_assert(i <= read_buf_size); if (i == read_buf_size) { /* Grow the read buffer */ read_buf_size = TCP_IO_READ_LINE_GROW(read_buf_size); if (read_buffer == initial_read_buffer) { read_buffer = MR_NEW_ARRAY(MR_Char, read_buf_size); MR_memcpy(read_buffer, initial_read_buffer, TCP_IO_READ_LINE_START); } else { read_buffer = MR_RESIZE_ARRAY(read_buffer, MR_Char, read_buf_size); } } } if (Res == 0) { MR_Word ret_string_word; MR_offset_incr_hp_atomic_msg(ret_string_word, 0, TCP_IO_BYTES_TO_WORDS((i + 1) * sizeof(MR_Char)), MR_ALLOC_ID, ""string.string/0""); RetString = (MR_String) ret_string_word; MR_memcpy(RetString, read_buffer, i * sizeof(MR_Char)); RetString[i] = '\\0'; } else { // We can't just return NULL here, because otherwise mdb will break // when it tries to print the string. RetString = MR_make_string_const(""""); } if (read_buffer != initial_read_buffer) { MR_free(read_buffer); } "). :- pred write_char(tcp_handle::in, char::in, bool::out, io::di, io::uo) is det. :- pragma foreign_proc(c, write_char(Socket::in, Chr::in, Success::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " ML_tcp *sock = (ML_tcp *) Socket; if (send(sock->socket, &Chr, 1, 0) == SOCKET_ERROR) { sock->error = ML_error(); Success = MR_FALSE; } else { Success = MR_TRUE; } "). :- pred write_string(tcp_handle::in, string::in, bool::out, io::di, io::uo) is det. :- pragma foreign_proc(c, write_string(Socket::in, Str::in, Success::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " ML_tcp *sock = (ML_tcp *) Socket; if (send(sock->socket, Str, strlen(Str), 0) == SOCKET_ERROR) { sock->error = ML_error(); Success = MR_NO; } else { Success = MR_YES; } "). :- pred get_errno(tcp_handle::in, tcp.error::out, io::di, io::uo) is det. :- pragma foreign_proc("C", get_errno(Socket::in, Errno::out, _IO0::di, _IO::uo), [will_not_call_mercury, thread_safe, promise_pure, tabled_for_io], " ML_tcp *sock = (ML_tcp *) Socket; Errno = sock->error; "). :- pred get_error(tcp.error::in, string::out) is det. :- pragma foreign_proc("C", get_error(Errno::in, Msg::out), [will_not_call_mercury, thread_safe, promise_pure], " char errbuf[MR_STRERROR_BUF_SIZE]; MR_save_transient_hp(); MR_make_aligned_string_copy(Msg, MR_strerror(Errno, errbuf, sizeof(errbuf))); MR_restore_transient_hp(); "). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- pragma foreign_proc("C", data_available(Socket::in, Wait::in, Int::out, _IO0::di, _IO::uo), [promise_pure, tabled_for_io], " ML_tcp *sock = (ML_tcp *) Socket; int selres = 0; fd_set readfds, writefds, exceptfds; struct timeval *sockets__timeout; struct timeval sockets__timeout_struct; if ( Wait > 0 ) { sockets__timeout = &sockets__timeout_struct; sockets__timeout->tv_sec = ((int)Wait * 60); sockets__timeout->tv_usec = 0; } else { sockets__timeout = NULL; } FD_ZERO(&writefds); FD_ZERO(&readfds); FD_ZERO(&exceptfds); FD_SET(sock->socket,&readfds); if ( sockets__timeout != NULL ) { // Do a select to see if something is available ... selres = select(0, &readfds, &writefds, &exceptfds, sockets__timeout); if ( selres == 0 ) { Int = -1; } else { if ( selres == SOCKET_ERROR ) { Int = -2; } else { Int = 0; }; }; } else { Int = 0; } "). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- func error_message(int) = string. :- pragma foreign_proc("C", error_message(Errno::in) = (Err::out), [promise_pure, will_not_call_mercury, thread_safe], " char errbuf[MR_STRERROR_BUF_SIZE]; MR_make_aligned_string_copy(Err, MR_strerror(Errno, errbuf, sizeof(errbuf))); "). :- pred throw_tcp_exception(string::in) is erroneous. :- pragma foreign_export("C", throw_tcp_exception(in), "ML_throw_tcp_exception"). throw_tcp_exception(S) :- error(S). %---------------------------------------------------------------------------% %---------------------------------------------------------------------------% :- pragma foreign_decl("C", " #include #if defined(SIGPIPE) extern void *TCP__prev_sigpipe_handler; #endif "). :- pragma foreign_code("C", " #if defined(SIGPIPE) void *TCP__prev_sigpipe_handler = SIG_DFL; #endif "). :- pragma foreign_proc("C", ignore_sigpipe(_IO0::di, _IO::uo), [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io], " #if defined(SIGPIPE) TCP__prev_sigpipe_handler = signal(SIGPIPE, SIG_IGN); #else MR_external_fatal_error(""tcp"", ""SIGPIPE not available on this system."") #endif "). :- pragma foreign_proc("C", unignore_sigpipe(_IO0::di, _IO::uo), [will_not_call_mercury, promise_pure, thread_safe, tabled_for_io], " #if defined(SIGPIPE) signal(SIGPIPE, TCP__prev_sigpipe_handler); #else MR_external_fatal_error(""tcp"", ""SIGPIPE not available on this system."") #endif "). %---------------------------------------------------------------------------% :- end_module tcp. %---------------------------------------------------------------------------%