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",