mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-21 20:33:55 +00:00
d465fa53cb
Discussion of these changes can be found on the Mercury developers
mailing list archives from June 2018.
COPYING.LIB:
Add a special linking exception to the LGPL.
*:
Update references to COPYING.LIB.
Clean up some minor errors that have accumulated in copyright
messages.
433 lines
13 KiB
Mathematica
433 lines
13 KiB
Mathematica
%-----------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 2014-2015, 2018 The Mercury Team
|
|
% This file is distributed under the terms specified in COPYING.LIB.
|
|
%-----------------------------------------------------------------------------%
|
|
%
|
|
% Module: netdb
|
|
% Main Author: Paul Bone <paul@bone.id.au>
|
|
% Stability: low
|
|
%
|
|
% Provide an interface to the POSIX C interface for network lookups.
|
|
%
|
|
% This interface uses the more modern getaddrinfo(2) interface rather than
|
|
% the old and not-thread-safe gethostbyname(2) interface.
|
|
%
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- module net.netdb.
|
|
:- interface.
|
|
|
|
:- import_module io.
|
|
:- import_module int.
|
|
:- import_module list.
|
|
:- import_module maybe.
|
|
:- import_module string.
|
|
|
|
:- import_module net.types.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type protocol
|
|
---> protocol(
|
|
p_name :: string,
|
|
p_aliases :: list(string),
|
|
p_num :: protocol_num
|
|
).
|
|
|
|
% Lookup a protocol entry by name.
|
|
%
|
|
:- pred getprotobyname(string::in, maybe(protocol)::out,
|
|
io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type service
|
|
---> numeric_service(int)
|
|
; string_service(string).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type lookup_result
|
|
---> lookup_result(
|
|
hasr_family :: family,
|
|
hasr_socktype :: socktype,
|
|
hasr_protocol :: protocol_num,
|
|
hasr_sockaddr :: sockaddr
|
|
).
|
|
|
|
:- pred lookup_host_and_service(string::in, service::in, maybe(family)::in,
|
|
maybe(socktype)::in, maybe_error(list(lookup_result))::out)
|
|
is det.
|
|
|
|
:- pred lookup_local_socket(service::in, maybe(family)::in,
|
|
maybe(socktype)::in, maybe_error(list(lookup_result))::out) is det.
|
|
|
|
%:- pred gethostbyname(string::in, res(hostent)::out,
|
|
% io::di, io::uo) is det.
|
|
|
|
%:- pred getservbyname(string::in, string::in, int::out,
|
|
% io::di, io::uo) is det.
|
|
|
|
% port_address(Host, Port, Result, !IO),
|
|
%
|
|
% Lookup a hostname and build an address structure with the resulting
|
|
% address and the given port.
|
|
%
|
|
:- pragma obsolete(port_address/5).
|
|
:- pred port_address(string::in, int::in, maybe_error(c_pointer)::out,
|
|
io::di, io::uo) is det.
|
|
|
|
% service_address(Host, Service, Result, !IO),
|
|
%
|
|
:- pragma obsolete(service_address/5).
|
|
:- pred service_address(string::in, string::in,
|
|
maybe_error(c_pointer)::out, io::di, io::uo) is det.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module bool.
|
|
:- import_module require.
|
|
|
|
:- import_module net.getaddrinfo.
|
|
:- import_module net.errno.
|
|
|
|
:- pragma foreign_decl("C",
|
|
"
|
|
#ifdef MR_WIN32
|
|
#include ""mercury_windows.h""
|
|
#include <winsock2.h>
|
|
#include <ws2tcpip.h>
|
|
#else
|
|
#include <netdb.h>
|
|
#endif
|
|
").
|
|
|
|
:- pragma foreign_decl("C", local,
|
|
"
|
|
#ifdef MR_WIN32
|
|
#define error() WSAGetLastError()
|
|
|
|
#ifdef MR_THREAD_SAFE
|
|
static MercuryLock lookup_lock = MR_MUTEX_ATTR;
|
|
#endif
|
|
#else
|
|
#define error() errno
|
|
#endif
|
|
").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
getprotobyname(Name, MaybeProtocol, !IO) :-
|
|
getprotobyname_c(buffer_size, Name, CProtocol, Success, Found, !IO),
|
|
(
|
|
Success = yes,
|
|
(
|
|
Found = yes,
|
|
c_protocol_to_protocol(CProtocol, Protocol),
|
|
MaybeProtocol = yes(Protocol)
|
|
;
|
|
Found = no,
|
|
MaybeProtocol = no
|
|
)
|
|
;
|
|
Success = no,
|
|
% A buffer size of 1024 bytes was insufficient for a protocol name,
|
|
% protocols are usually 3 letters long like "tcp".
|
|
unexpected($file, $pred, "Buffer too small")
|
|
).
|
|
|
|
:- pred getprotobyname_c(int::in, string::in, protocol_c::out, bool::out,
|
|
bool::out, io::di, io::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
getprotobyname_c(BufferSize::in, Name::in, Protocol::out, Success::out,
|
|
Found::out, _IO0::di, _IO::uo),
|
|
[will_not_call_mercury, promise_pure, thread_safe, tabled_for_io],
|
|
"
|
|
/*
|
|
** getprotobyname_r is a GNU extension.
|
|
*/
|
|
#if defined(__GNU_LIBRARY__)
|
|
|
|
int result;
|
|
struct protoent *temp = MR_GC_NEW(struct protoent);
|
|
char *buffer = MR_GC_malloc_atomic(BufferSize);
|
|
|
|
result = getprotobyname_r(Name, temp, buffer, BufferSize, &Protocol);
|
|
Success = result == 0 ? MR_YES : MR_NO;
|
|
Found = Protocol != NULL ? MR_YES : MR_NO;
|
|
|
|
#else
|
|
struct protoent *temp;
|
|
int num_aliases;
|
|
int i;
|
|
|
|
#ifdef MR_THREAD_SAFE
|
|
MR_LOCK(lookup_lock, ""getprotobyname_r"");
|
|
#endif
|
|
|
|
temp = getprotobyname(Name);
|
|
if (temp != NULL) {
|
|
Protocol = MR_GC_NEW(struct protoent);
|
|
MR_make_aligned_string_copy(Protocol->p_name, temp->p_name);
|
|
for (num_aliases = 0; temp->p_aliases[num_aliases]; num_aliases++);
|
|
Protocol->p_aliases = MR_GC_NEW_ARRAY(char*, num_aliases);
|
|
for (i = 0; i < num_aliases; i++) {
|
|
MR_make_aligned_string_copy(Protocol->p_aliases[i],
|
|
temp->p_aliases[i]);
|
|
}
|
|
Protocol->p_proto = temp->p_proto;
|
|
Found = MR_YES;
|
|
} else {
|
|
Found = MR_NO;
|
|
}
|
|
Success = MR_YES;
|
|
|
|
#ifdef MR_THREAD_SAFE
|
|
MR_UNLOCK(lookup_lock, ""getprotobyname_r"");
|
|
#endif
|
|
|
|
#endif /* ! __GNU_LIBRARY__ */
|
|
").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- type protocol_c.
|
|
:- pragma foreign_type("C", protocol_c, "struct protoent*",
|
|
[can_pass_as_mercury_type]).
|
|
|
|
:- pred c_protocol_to_protocol(protocol_c::in, protocol::uo) is det.
|
|
|
|
c_protocol_to_protocol(CProto, Proto) :-
|
|
c_protocol_get_name(CProto, OfficialName),
|
|
c_protocol_get_aliases(CProto, Aliases),
|
|
c_protocol_get_number(CProto, Number),
|
|
Proto = protocol(OfficialName, Aliases, Number).
|
|
|
|
:- pred c_protocol_get_name(protocol_c::in, string::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
c_protocol_get_name(Proto::in, Name::uo),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"MR_make_aligned_string_copy_saved_hp(Name, Proto->p_name, NULL);").
|
|
|
|
:- pred c_protocol_get_aliases(protocol_c::in, list(string)::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
c_protocol_get_aliases(Proto::in, List::uo),
|
|
[may_call_mercury, promise_pure, thread_safe],
|
|
"
|
|
int i = 0;
|
|
|
|
List = MR_list_empty();
|
|
|
|
while (Proto->p_aliases[i] != NULL) {
|
|
MR_String str;
|
|
MR_make_aligned_string_copy_saved_hp(str, Proto->p_aliases[i], NULL);
|
|
List = MR_list_cons((MR_Word)str, List);
|
|
i++;
|
|
}
|
|
").
|
|
|
|
:- pred c_protocol_get_number(protocol_c::in, int::uo) is det.
|
|
|
|
:- pragma foreign_proc("C",
|
|
c_protocol_get_number(Proto::in, Number::uo),
|
|
[will_not_call_mercury, promise_pure, thread_safe],
|
|
"Number = Proto->p_proto;").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
lookup_host_and_service(Host, Service, MaybeFamily, MaybeSocktype,
|
|
MaybeResults) :-
|
|
getaddrinfo(node_and_service(Host, Service), gai_flag_addrconfig,
|
|
MaybeFamily, MaybeSocktype, no, MaybeResults0),
|
|
(
|
|
MaybeResults0 = ok(Results0),
|
|
map(make_host_and_service_result, Results0, Results),
|
|
MaybeResults = ok(Results)
|
|
;
|
|
MaybeResults0 = error(Error),
|
|
MaybeResults = error(Error)
|
|
).
|
|
|
|
lookup_local_socket(Service, MaybeFamily, MaybeSocktype, MaybeResults) :-
|
|
getaddrinfo(service_only(Service),
|
|
gai_flag_addrconfig \/ gai_flag_passive, MaybeFamily, MaybeSocktype,
|
|
no, MaybeResults0),
|
|
map_maybe_error(map(make_host_and_service_result),
|
|
MaybeResults0, MaybeResults).
|
|
|
|
:- pred make_host_and_service_result(addrinfo::in,
|
|
lookup_result::out) is det.
|
|
|
|
make_host_and_service_result(AI, lookup_result(Family, SockType,
|
|
ProtocolNum, Sockaddr)) :-
|
|
Family = AI ^ ai_family,
|
|
MaybeSockType = AI ^ ai_socktype,
|
|
(
|
|
MaybeSockType = yes(SockType)
|
|
;
|
|
MaybeSockType = no,
|
|
unexpected($file, $pred, "No socktype")
|
|
),
|
|
ProtocolNum = AI ^ ai_protocol,
|
|
Sockaddr = AI ^ ai_sockaddr.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
:- pred map_maybe_error(pred(T, U), maybe_error(T, E), maybe_error(U, E)).
|
|
:- mode map_maybe_error(pred(in, out) is det, in, out) is det.
|
|
|
|
map_maybe_error(P, ok(X), ok(Y)) :-
|
|
P(X, Y).
|
|
map_maybe_error(_, error(E), error(E)).
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
%gethostbyname(Name, Result, !IO) :-
|
|
% gethostbyname_c(Name, Hostent, Success, Error, !IO),
|
|
% (
|
|
% Success = yes,
|
|
% Result = ok(Hostent)
|
|
% ;
|
|
% Success = no,
|
|
% Result = error(Error)
|
|
% ).
|
|
%
|
|
%:- pred gethostbyname(string::in, hostent::out, bool::out, string::out,
|
|
% io::di, io::uo) is det.
|
|
%
|
|
%:- pragma foreign_proc(c,
|
|
% gethostbyname_c(Name::in, Host::out, _IO0::di, _IO::uo),
|
|
% [will_not_call_mercury, promise_pure, tabled_for_io],
|
|
%"
|
|
% /*
|
|
% * Not thread safe.
|
|
% */
|
|
% struct hostent *host;
|
|
% Host = gethostbyname(Name);
|
|
% Host = (MR_String) host->h_name;
|
|
%").
|
|
%
|
|
%%-----------------------------------------------------------------------------%
|
|
%
|
|
%:- pragma foreign_proc(c,
|
|
% getservbyname(Name::in, Protocol::in, Port::out, _IO0::di, _IO::uo),
|
|
% [will_not_call_mercury, promise_pure, tabled_for_io],
|
|
%"
|
|
% struct servent *service;
|
|
% service = getservbyname(Name, Protocol);
|
|
% if (service != NULL) {
|
|
% Port = (MR_Integer) ntohs(service->s_port);
|
|
% } else {
|
|
% Port = -1;
|
|
% }
|
|
%").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
port_address(Host, Port, MaybeSA, !IO) :-
|
|
port_address(Host, Port, SA, Success, Errno, !IO),
|
|
(
|
|
Success = yes,
|
|
MaybeSA = ok(SA)
|
|
;
|
|
Success = no,
|
|
MaybeSA = error(strerror(Errno))
|
|
).
|
|
|
|
:- pred port_address(string::in, int::in, c_pointer::out, bool::out,
|
|
int::out, io::di, io::uo) is det.
|
|
|
|
% XXX Not thread safe as this uses gethostbyname
|
|
%
|
|
:- pragma foreign_proc("C",
|
|
port_address(Host::in, Port::in, SA::out, Success::out, Errno::out,
|
|
_IO0::di, _IO::uo),
|
|
[will_not_call_mercury, promise_pure, tabled_for_io],
|
|
"
|
|
struct hostent *host;
|
|
struct sockaddr_in *addr;
|
|
|
|
host = gethostbyname(Host);
|
|
if (host == NULL) {
|
|
Errno = error();
|
|
Success = MR_NO;
|
|
} else {
|
|
addr = MR_GC_NEW(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);
|
|
|
|
SA = (MR_Word) addr;
|
|
Success = MR_YES;
|
|
}
|
|
").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
service_address(Service, Host, MaybeSA, !IO) :-
|
|
service_address(Service, Host, SA, Success, Errno, !IO),
|
|
(
|
|
Success = yes,
|
|
MaybeSA = ok(SA)
|
|
;
|
|
Success = no,
|
|
MaybeSA = error(strerror(Errno))
|
|
).
|
|
|
|
:- pred service_address(string::in, string::in, c_pointer::out,
|
|
bool::out, int::out, io::di, io::uo) is det.
|
|
|
|
% XXX Not thread safe as this uses gethostbyname and getservbyname.
|
|
%
|
|
:- pragma foreign_proc("C",
|
|
service_address(Service::in, Host::in, SA::out, Success::out,
|
|
Errno::out, _IO0::di, _IO::uo),
|
|
[will_not_call_mercury, promise_pure, tabled_for_io],
|
|
"
|
|
struct hostent *host;
|
|
struct servent *service;
|
|
struct sockaddr_in *addr;
|
|
|
|
host = gethostbyname(Host);
|
|
if (host == NULL) {
|
|
Errno = error();
|
|
Success = MR_NO;
|
|
} else {
|
|
service = getservbyname(Service,""tcp"");
|
|
|
|
if (service == NULL) {
|
|
Errno = error();
|
|
Success = MR_NO;
|
|
} else {
|
|
addr = MR_GC_NEW(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 = service->s_port;
|
|
SA = (MR_Word) addr;
|
|
Success = MR_YES;
|
|
}
|
|
}
|
|
").
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
|
|
% The initial length of buffers for strings (suggested by
|
|
% getprotobyname_r(3).
|
|
%
|
|
:- func buffer_size = int.
|
|
|
|
buffer_size = 1024.
|
|
|
|
%-----------------------------------------------------------------------------%
|
|
%-----------------------------------------------------------------------------%
|