From 3c9ebf0969ebc8ed8a489320ea9e2580ab6d9a6d Mon Sep 17 00:00:00 2001 From: Paul Bone Date: Sun, 15 Mar 2015 23:08:25 +1100 Subject: [PATCH] [net] Impement a Mercury interface to getaddrinfo Add a Mercury interface to the C function getaddrinfo. getaddrinfo superceeds gethostbyname and getservbyname. It is reenterant and also makes it easier to support IPv6 amoung other things. Other predicates in netdb.m should be written in terms of getaddrinfo. extras/net/getaddrinfo.m: As above. extras/net/netdb.m: Add predicates that use getaddrinfo to perform lookups. extras/net/types.m: Add predicates to convert to and from the raw values for family and socktype. extras/net/test_lookups.m: extras/net/Makefile: Add a test program. .gitignore: This .gitignore file was causing git to ignore the Mercury.options file in net/extras. A leading slash in .gitignore patterns matches the start of a path, this allows us to ignore these patterns when they're only in the root directory. extras/net/Mercury.options: Work around a Mercury bug. Add this missing file. --- .gitignore | 22 +-- extras/net/Makefile | 10 +- extras/net/Mercury.options | 10 + extras/net/getaddrinfo.m | 384 +++++++++++++++++++++++++++++++++++++ extras/net/net.m | 1 + extras/net/netdb.m | 74 ++++++- extras/net/test_lookups.m | 61 ++++++ extras/net/types.m | 68 +++++++ 8 files changed, 607 insertions(+), 23 deletions(-) create mode 100644 extras/net/Mercury.options create mode 100644 extras/net/getaddrinfo.m create mode 100644 extras/net/test_lookups.m diff --git a/.gitignore b/.gitignore index ebc6c2d2b..d28883000 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,7 @@ -README -INSTALL -TODO -WORK_IN_PROGRESS +/README +/INSTALL +/TODO +/WORK_IN_PROGRESS configure config.cache config.status @@ -10,15 +10,15 @@ configure.log configure.help confdefs.h so_locations +/Mercury.options Mmake.common Mmake.params Mmake.stage.params -stage1 -stage2 -stage3 -install_grade_dir.* -Mercury.options +/stage1 +/stage2 +/stage3 +/install_grade_dir.* autom4te.cache aclocal.m4 -.configured_library_grades -main.o +/.configured_library_grades +/main.o diff --git a/extras/net/Makefile b/extras/net/Makefile index c3bac9415..1b59fa4c6 100644 --- a/extras/net/Makefile +++ b/extras/net/Makefile @@ -12,7 +12,7 @@ MCFLAGS=-O3 --intermodule-optimization --use-grade-subdirs --grade hlc.gc MERCURY_FILES=$(wildcard *.m) -all: libnet.so echo +all: libnet.so echo test_lookups libnet.so: $(MERCURY_FILES) $(MMC) $(MCFLAGS) --make libnet @@ -20,9 +20,15 @@ libnet.so: $(MERCURY_FILES) echo: $(MERCURY_FILES) $(MMC) $(MCFLAGS) --make echo +test_lookups: $(MERCURY_FILES) + $(MMC) $(MCFLAGS) --make test_lookups + tags: $(MERCURY_FILES) $(MTAGS) $(MERCURY_FILES) .PHONY: clean clean: - rm -rf Mercury *.mh *.err echo libnet.so libnet.a net.init tags + rm -rf Mercury *.mh *.err \ + echo test_lookups libnet.so libnet.a \ + net.init \ + tags diff --git a/extras/net/Mercury.options b/extras/net/Mercury.options new file mode 100644 index 000000000..9ad083068 --- /dev/null +++ b/extras/net/Mercury.options @@ -0,0 +1,10 @@ +# +# These options are required to get access to some reenterant versions of +# socket functions. +# +EXTRA_CFLAGS=-D_BSD_SOURCE=1 -D_DEFAULT_SOURCE=1 + +# Workaround a bug in Mercury's pack bits optimisation. +MCFLAGS=--arg-pack-bits 0 + + diff --git a/extras/net/getaddrinfo.m b/extras/net/getaddrinfo.m new file mode 100644 index 000000000..081f77754 --- /dev/null +++ b/extras/net/getaddrinfo.m @@ -0,0 +1,384 @@ +%-----------------------------------------------------------------------------% +% vim: ft=mercury ts=4 sw=4 et +%---------------------------------------------------------------------------% +% Copyright (C) 2014 The Mercury Team +% This file may only be copied under the terms of the GNU Library General +% Public License - see the file COPYING.LIB +%-----------------------------------------------------------------------------% +% +% Module: getaddrinfo +% Main Author: Paul Bone +% Stability: low +% +% Provide an interface to the getaddrinfo C function. +% +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% +:- module net.getaddrinfo. + +:- interface. + +:- import_module int. +:- import_module list. +:- import_module maybe. + +:- import_module net.netdb. +:- import_module net.types. + +%-----------------------------------------------------------------------------% + +:- type node_and_or_service + ---> node_only( + no_node :: string + ) + ; service_only( + so_service :: service + ) + ; node_and_service( + nas_node :: string, + nas_service :: service + ). + +:- type addrinfo + ---> addrinfo( + ai_family :: family, + ai_socktype :: maybe(socktype), + ai_protocol :: protocol_num, + ai_sockaddr :: sockaddr, + ai_maybe_name :: maybe(string) + ). + +%-----------------------------------------------------------------------------% + + % The address info flags bitfield. + % +:- type gai_flags == int. + + % Return only addresses that make sense given the system's network + % interface configuration. For example, IPv6 addresses will only be + % returned if at least one IPv6 interface is configured and is not the + % loopback interface. + % +:- func gai_flag_addrconfig = int. + + % Return addresses suitable for use with the bind() call. WIthout this + % flag returned addresses are suitable for use with the connect() call. + % +:- func gai_flag_passive = int. + +%-----------------------------------------------------------------------------% + +:- pred getaddrinfo(node_and_or_service::in, + gai_flags::in, maybe(family)::in, maybe(socktype)::in, + maybe(protocol)::in, maybe_error(list(addrinfo))::out) is det. + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- implementation. + +:- import_module require. +:- import_module string. + +:- import_module net.errno. + +:- pragma foreign_decl("C", +" +#ifdef MR_WIN32 + #include ""mercury_windows.h"" + #include + #include +#else + #include + #include + #include +#endif +"). + +:- pragma foreign_decl("C", local, +" +#ifdef MR_WIN32 + #define error() WSAGetLastError() +#else + #define error() errno +#endif +"). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% + +:- pragma foreign_proc("C", + gai_flag_addrconfig = (Flag::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Flag = AI_ADDRCONFIG; +"). + +:- pragma foreign_proc("C", + gai_flag_passive = (Flag::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Flag = AI_PASSIVE; +"). + +:- pred flag_numericservice(gai_flags::out) is semidet. + +:- pragma foreign_proc("C", + flag_numericservice(Flag::out), + [will_not_call_mercury, thread_safe, promise_pure, + will_not_throw_exception], +" + #ifdef AI_NUMERICSERV + Flag = AI_NUMERICSERV; + SUCCESS_INDICATOR = MR_YES; + #else + SUCCESS_INDICATOR = MR_NO; + #endif +"). + +%-----------------------------------------------------------------------------% + +getaddrinfo(NodeAndOrService, Flags0, MaybeFamily0, MaybeSocktype0, + MaybeProtocol0, Result) :- + make_node_and_service_c_strings(NodeAndOrService, Node, Service), + ( + nas_service_is_numeric(NodeAndOrService), + flag_numericservice(NumericServiceFlag) + -> + Flags = Flags0 \/ NumericServiceFlag + ; + Flags = Flags0 + ), + map_maybe((pred(A::in, B::out) is det :- + family_int(A, B) + ), MaybeFamily0, MaybeFamily), + maybe_default(0, MaybeFamily, Family), + map_maybe((pred(A::in, B::out) is det :- + socktype_int(A, B) + ), MaybeSocktype0, MaybeSocktype), + maybe_default(0, MaybeSocktype, Socktype), + MaybeProtocol = map_maybe((func(P) = P ^ p_num), MaybeProtocol0), + maybe_default(0, MaybeProtocol, Protocol), + promise_pure ( + getaddrinfo_c(Node, Service, Flags, Family, Socktype, Protocol, + AddrInfoList0, Result0), + ( Result0 = gai_ok -> + addrinfo_c_to_addrinfos(AddrInfoList0, AddrInfoList), + impure free_addrinfo_c(AddrInfoList0), + Result = ok(AddrInfoList) + ; Result0 = gai_not_found -> + Result = ok([]) + ; + Result = error(gai_strerror(Result0)) + ) + ). + +:- pred getaddrinfo_c(nullable_string::in, nullable_string::in, + int::in, int::in, int::in, int::in, addrinfo_c::out, int::out) is det. + +:- pragma foreign_proc("C", + getaddrinfo_c(Node::in, Service::in, Flags::in, Family::in, Socktype::in, + Protocol::in, AddrInfoList::out, Result::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + struct addrinfo hints; + memset(&hints, 0, sizeof(hints)); + hints.ai_flags = Flags; + hints.ai_family = Family; + hints.ai_socktype = Socktype; + hints.ai_protocol = Protocol; + + Result = getaddrinfo(Node, Service, &hints, &AddrInfoList); +"). + +%-----------------------------------------------------------------------% + +:- pred make_node_and_service_c_strings(node_and_or_service::in, + nullable_string::out, nullable_string::out) is det. + +make_node_and_service_c_strings(node_and_service(Node0, Service0), Node, + Service) :- + make_nullable_string(Node0, Node), + make_service(Service0, Service). +make_node_and_service_c_strings(node_only(Node0), Node, null_string) :- + make_nullable_string(Node0, Node). +make_node_and_service_c_strings(service_only(Service0), null_string, + Service) :- + make_service(Service0, Service). + +:- pred make_service(service::in, nullable_string::out) is det. + +make_service(numeric_service(ServiceNum), Service) :- + make_nullable_string(string(ServiceNum), Service). +make_service(string_service(ServiceStr), Service) :- + make_nullable_string(ServiceStr, Service). + +:- pred nas_service_is_numeric(node_and_or_service::in) is semidet. + +nas_service_is_numeric(NAS) :- + ( NAS = service_only(Service) + ; NAS = node_and_service(_, Service) + ), + service_is_numeric(Service). + +:- pred service_is_numeric(service::in) is semidet. + +service_is_numeric(numeric_service(_)). + +%-----------------------------------------------------------------------------% + +:- type addrinfo_c. + +:- pragma foreign_type("C", + addrinfo_c, + "struct addrinfo*", + [can_pass_as_mercury_type]). + +:- pred addrinfo_c_to_addrinfos(addrinfo_c::in, list(addrinfo)::out) is det. + +addrinfo_c_to_addrinfos(AddrInfoC, AddrInfoList) :- + read_addrinfo(AddrInfoC, FamilyInt, SocktypeInt, ProtocolNum, Sockaddr), + ( read_addrinfo_name(AddrInfoC, Name) -> + MaybeName = yes(Name) + ; + MaybeName = no + ), + ( + family_int(FamilyPrime, FamilyInt) + -> + Family = FamilyPrime + ; + unexpected($file, $pred, + "getaddrinfo returned '0' for family") + ), + ( + socktype_int(SocktypePrime, SocktypeInt) + -> + MaybeSocktype = yes(SocktypePrime) + ; + MaybeSocktype = no + ), + AddrInfo = addrinfo(Family, MaybeSocktype, ProtocolNum, Sockaddr, + MaybeName), + ( next_addrinfo_c(AddrInfoC, NextAddrInfoC) -> + addrinfo_c_to_addrinfos(NextAddrInfoC, AddrInfoList0), + AddrInfoList = [AddrInfo | AddrInfoList0] + ; + AddrInfoList = [AddrInfo] + ). + +:- pred read_addrinfo(addrinfo_c::in, int::out, int::out, int::out, + sockaddr::out) is det. + +:- pragma foreign_proc("C", + read_addrinfo(AddrInfo::in, Family::out, Socktype::out, ProtocolNum::out, + Sockaddr::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + int len; + + Family = AddrInfo->ai_family; + Socktype = AddrInfo->ai_socktype; + ProtocolNum = AddrInfo->ai_protocol; + Sockaddr = MR_GC_malloc(AddrInfo->ai_addrlen); + memcpy(Sockaddr, AddrInfo->ai_addr, AddrInfo->ai_addrlen); + + len = sock_addr_size(Sockaddr); + assert((len == -1) || (len == AddrInfo->ai_addrlen)); +"). + +:- pred read_addrinfo_name(addrinfo_c::in, string::out) is semidet. + +:- pragma foreign_proc("C", + read_addrinfo_name(AddrInfo::in, Name::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + SUCCESS_INDICATOR = AddrInfo->ai_canonname != NULL; + if (SUCCESS_INDICATOR) { + MR_make_aligned_string_copy(Name, AddrInfo->ai_canonname); + } +"). + +:- pred next_addrinfo_c(addrinfo_c::in, addrinfo_c::out) is semidet. + +:- pragma foreign_proc("C", + next_addrinfo_c(AddrInfo::in, NextAddrInfo::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + NextAddrInfo = AddrInfo->ai_next; + SUCCESS_INDICATOR = NextAddrInfo != NULL; +"). + +:- impure pred free_addrinfo_c(addrinfo_c::in) is det. + +:- pragma foreign_proc("C", + free_addrinfo_c(AddrInfo::in), + [will_not_call_mercury, thread_safe, will_not_throw_exception], +" + freeaddrinfo(AddrInfo); +"). + +%-----------------------------------------------------------------------------% + +:- func gai_ok = int. +gai_ok = 0. + +:- func gai_not_found = int. +:- pragma foreign_proc("C", + gai_not_found = (Num::out), + [will_not_call_mercury, thread_safe, promise_pure], + " + Num = EAI_NONAME; + "). + +:- func gai_strerror(int) = string. + +:- pragma foreign_proc("C", + gai_strerror(Num::in) = (String::out), + [will_not_call_mercury, thread_safe, promise_pure], + " + MR_make_aligned_string_copy(String, gai_strerror(Num)); + "). + +%-----------------------------------------------------------------------------% + +:- pred maybe_default(T::in, maybe(T)::in, T::out) is det. + +maybe_default(Default, no, Default). +maybe_default(_, yes(X), X). + +%-----------------------------------------------------------------------% + +:- type nullable_string. +:- pragma foreign_type("C", + nullable_string, + "char*"). + +:- func null_string = nullable_string. + +:- pragma foreign_proc("C", + null_string = (X::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + X = NULL; +"). + +:- pred make_nullable_string(string::in, nullable_string::out) is det. + +:- pragma foreign_proc("C", + make_nullable_string(Str0::in, Str::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Str = Str0; +"). + +%-----------------------------------------------------------------------------% +%-----------------------------------------------------------------------------% diff --git a/extras/net/net.m b/extras/net/net.m index 5bc780668..77ac2772c 100644 --- a/extras/net/net.m +++ b/extras/net/net.m @@ -18,5 +18,6 @@ :- implementation. :- include_module errno. +:- include_module getaddrinfo. version("DEV"). diff --git a/extras/net/netdb.m b/extras/net/netdb.m index 73bfa85bd..7959feadf 100644 --- a/extras/net/netdb.m +++ b/extras/net/netdb.m @@ -22,6 +22,7 @@ :- interface. :- import_module io. +:- import_module int. :- import_module list. :- import_module maybe. :- import_module string. @@ -44,10 +45,27 @@ %-----------------------------------------------------------------------------% -:- type addrinfo. +:- 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. @@ -77,6 +95,7 @@ :- import_module bool. :- import_module require. +:- import_module net.getaddrinfo. :- import_module net.errno. :- pragma foreign_decl("C", @@ -223,15 +242,50 @@ c_protocol_to_protocol(CProto, Proto) :- %-----------------------------------------------------------------------------% -% -% We box the pointer to addrinfo since these structures are allocated using -% malloc, we use an extra layer of indirection to use a Boehm GC pointer -% with a finalizer to free the underlying malloc object. -% -:- pragma foreign_type("C", - addrinfo, - "struct addrinfo**", - [can_pass_as_mercury_type]). +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)). %-----------------------------------------------------------------------------% diff --git a/extras/net/test_lookups.m b/extras/net/test_lookups.m new file mode 100644 index 000000000..537ed534f --- /dev/null +++ b/extras/net/test_lookups.m @@ -0,0 +1,61 @@ + +:- module test_lookups. + +:- interface. + +:- import_module io. + +:- pred main(io::di, io::uo) is det. + +:- implementation. + +:- import_module list. +:- import_module maybe. +:- import_module string. + +:- import_module net. +:- import_module net.netdb. +:- import_module net.types. + +main(!IO) :- + TCPS = "tcp", + getprotobyname(TCPS, TCP, !IO), + io.format("get_proto_by_name(""%s"", %s, !IO).\n", + [s(TCPS), s(string(TCP))], !IO), + lookup_host_and_service("www.google.com", string_service("http"), + yes(fam_inet), no, GAIResultHostService), + ( + GAIResultHostService = ok(HostServiceResults), + io.write_string("www.google.com:\n", !IO), + foldl(write_lookup_result, HostServiceResults, !IO) + ; + GAIResultHostService = error(ErrorA), + io.format("Lookup error for www.google.com: %s", [s(ErrorA)], !IO) + ), + lookup_local_socket(string_service("http"), yes(fam_inet), + yes(sock_stream), ResultLocalSocket), + ( + ResultLocalSocket = ok(LocalSockets), + io.write_string("local sockets:\n", !IO), + foldl(write_lookup_result, LocalSockets, !IO) + ; + ResultLocalSocket = error(ErrorB), + io.format("Lookup error for local sockets: %s", [s(ErrorB)], !IO) + ). + +:- pred write_lookup_result(lookup_result::in, + io::di, io::uo) is det. + +write_lookup_result(lookup_result(Family, Socktype, ProtoNum, SockAddr), + !IO) :- + io.format("Family: %s, Socktype: %s, Protocol: %s, Addr: %s\n", + [s(string(Family)), s(string(Socktype)), s(ProtoName), + s(SockStr)], + !IO), + ProtoName = string(ProtoNum), + ( ipv4_sockaddr(InAddr, Port, SockAddr) -> + SockStr = format("%s:%d", [s(to_string(InAddr)), i(Port)]) + ; + SockStr = "unknown" + ). + diff --git a/extras/net/types.m b/extras/net/types.m index b9ecc81fa..7116e5125 100644 --- a/extras/net/types.m +++ b/extras/net/types.m @@ -43,6 +43,16 @@ ---> fam_inet ; fam_inet6. + % Convert to and from the integer representation of a family. This is + % sometimes required, for example when '0' indicates unspecified in the + % underlying foreign code. + % +:- pred family_int(family, int). +:- mode family_int(in, out) is det. +:- mode family_int(out, in) is semidet. + +%-----------------------------------------------------------------------------% + % The socket type. Informally (for fam_inet and fam_inet6) these % correspond to TCP and UDP respectively. More precicely these specify % the socket's behavour, the protocol is optionally specified @@ -52,6 +62,14 @@ ---> sock_stream ; sock_dgram. + % Convert socktypes to and from integers. + % +:- pred socktype_int(socktype, int). +:- mode socktype_int(in, out) is det. +:- mode socktype_int(out, in) is semidet. + +%-----------------------------------------------------------------------------% + % An IPv4 Address. % :- type in_addr. @@ -154,6 +172,31 @@ % fam_appletalk - "AF_APPLETALK", % fam_packet - "AF_PACKET", +:- pragma foreign_proc("C", + family_int(Family::in, Int::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Int = Family; +"). + +:- pragma foreign_proc("C", + family_int(Family::out, Int::in), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Family = Int; + switch (Family) { + case AF_INET: + case AF_INET6: + SUCCESS_INDICATOR = MR_YES; + break; + default: + SUCCESS_INDICATOR = MR_NO; + break; + } +"). + :- pragma foreign_enum("C", socktype/0, [sock_stream - "SOCK_STREAM", sock_dgram - "SOCK_DGRAM"]). @@ -166,6 +209,31 @@ % and SOCK_CLOEXEC values, this functionality should be accessed via % setsocketopt. +:- pragma foreign_proc("C", + socktype_int(Socktype::in, Int::out), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Int = Socktype; +"). + +:- pragma foreign_proc("C", + socktype_int(Socktype::out, Int::in), + [will_not_call_mercury, promise_pure, thread_safe, + will_not_throw_exception], +" + Socktype = Int; + switch (Socktype) { + case SOCK_STREAM: + case SOCK_DGRAM: + SUCCESS_INDICATOR = MR_YES; + break; + default: + SUCCESS_INDICATOR = MR_NO; + break; + } +"). + %-----------------------------------------------------------------------------% :- pragma foreign_type("C",