From 60c440812d735e210fc6a62a4124b21834da80f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= ppisar@redhat.com Date: Thu, 2 Mar 2017 17:31:03 +0100 Subject: Add IPv6 support needed for IPv6-capable HTTP::Daemon
--- RPC-XML-0.80-IPv6-support.patch | 417 ++++++++++++++++++++++++++++++++++++++++ perl-RPC-XML.spec | 10 +- 2 files changed, 425 insertions(+), 2 deletions(-) create mode 100644 RPC-XML-0.80-IPv6-support.patch
diff --git a/RPC-XML-0.80-IPv6-support.patch b/RPC-XML-0.80-IPv6-support.patch new file mode 100644 index 0000000..3af04a8 --- /dev/null +++ b/RPC-XML-0.80-IPv6-support.patch @@ -0,0 +1,417 @@ +From fb7bfaaf0dd8c192f653160ae0fd08a5aa6d6ef0 Mon Sep 17 00:00:00 2001 +From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= ppisar@redhat.com +Date: Wed, 1 Mar 2017 17:43:26 +0100 +Subject: [PATCH] IPv6 support +MIME-Version: 1.0 +Content-Type: text/plain; charset=UTF-8 +Content-Transfer-Encoding: 8bit + +After HTTP::Daemon gains IPv6 support, RPC-XML tests will fail because +the RPC server will listen on IPv6 socket and clients will connect +from an IPv6 address on systems where IPv6 is available. + +This patch changes tests to handle IPv6 addresses correctly. + +This patch also adds "peerfamily" key to RPC::XML::Server connection +objects because a packed network address in "peeraddr" key is +umbiguous and cannot be unpacked without previous knowledge of the +address family that it encodes. + +There are still some hard coded AF_INET calls in test to find used or +unused ports, but the approach is defective by design because of +a possible race between the check for a port and subsequent use of the +port. RPC::XML::Server would have to learn how to run on a user-supplied +socket first to fix the races correctly. + +https://rt.cpan.org/Public/Bug/Display.html?id=120472 + +Signed-off-by: Petr Písař ppisar@redhat.com +--- + Makefile.PL | 17 +++++----- + lib/RPC/XML/Server.pm | 22 +++++++++---- + t/40_server.t | 41 +++++++++--------------- + t/40_server_xmllibxml.t | 41 +++++++++--------------- + t/41_server_hang.t | 4 +-- + t/60_net_server.t | 2 +- + t/util.pl | 84 +++++++++++++++++++++++++++++++++++++++++++++++++ + 7 files changed, 141 insertions(+), 70 deletions(-) + +diff --git a/Makefile.PL b/Makefile.PL +index 4e247dc..2a4e30d 100644 +--- a/Makefile.PL ++++ b/Makefile.PL +@@ -71,13 +71,16 @@ WriteMakefile( + EXE_FILES => @scripts, + PM => %PM_FILES, + PREREQ_PM => { +- 'File::Spec' => 0.8, +- 'constant' => 1.03, +- 'Scalar::Util' => 1.33, +- 'Test::More' => 0.94, +- 'LWP' => 5.834, +- 'XML::Parser' => 2.31, +- 'Module::Load' => 0.24, ++ 'Carp' => 0, ++ 'File::Spec' => 0.8, ++ 'constant' => 1.03, ++ 'IO::Socket::IP' => 0, ++ 'Scalar::Util' => 1.33, ++ 'Socket' => 0, ++ 'Test::More' => 0.94, ++ 'LWP' => 5.834, ++ 'XML::Parser' => 2.31, ++ 'Module::Load' => 0.24, + }, + dist => { COMPRESS => 'gzip -9f' }, + clean => { FILES => $CLEAN }, +diff --git a/lib/RPC/XML/Server.pm b/lib/RPC/XML/Server.pm +index 0dc8882..00399ef 100644 +--- a/lib/RPC/XML/Server.pm ++++ b/lib/RPC/XML/Server.pm +@@ -821,9 +821,9 @@ sub process_request ## no critic (ProhibitExcessComplexity) + my $conn = shift; + + my ( +- $req, $reqxml, $resp, $respxml, $do_compress, +- $parser, $com_engine, $length, $read, $buf, +- $resp_fh, $tmpdir, $peeraddr, $peerhost, $peerport ++ $req, $reqxml, $resp, $respxml, $do_compress, ++ $parser, $com_engine, $length, $read, $buf, ++ $resp_fh, $tmpdir, $peerfamily, $peeraddr, $peerhost, $peerport, + ); + + my $me = ref($self) . '::process_request'; +@@ -856,6 +856,7 @@ sub process_request ## no critic (ProhibitExcessComplexity) + + # These will be attached to any and all request objects that are + # (successfully) read from $conn. ++ $peerfamily = $conn->sockdomain; + $peeraddr = $conn->peeraddr; + $peerport = $conn->peerport; + $peerhost = $conn->peerhost; +@@ -986,6 +987,7 @@ sub process_request ## no critic (ProhibitExcessComplexity) + { + # Set localized keys on $self, based on the connection info + ## no critic (ProhibitLocalVars) ++ local $self->{peerfamily} = $peerfamily; + local $self->{peeraddr} = $peeraddr; + local $self->{peerhost} = $peerhost; + local $self->{peerport} = $peerport; +@@ -2293,14 +2295,22 @@ reference containing one or more datatypes, each a simple string. The first + of the datatypes specifies the expected return type. The remainder (if any) + refer to the arguments themselves. + ++=item peerfamily ++ ++This is the address family, C<AF_INET> or C<AF_INET6>, of a network address of ++the client that has connected and made the current request. It is required ++for unpacking C<peeraddr> properly. ++ + =item peeraddr + +-This is the address part of a packed B<SOCKADDR_IN> structure, as returned by +-L<Socket/pack_sockaddr_in>, which contains the address of the client that has ++This is the address part of a packed B<SOCKADDR_IN> or B<SOCKADDR_IN6> ++structure, as returned by L<Socket/pack_sockaddr_in> or ++L<Socket/pack_sockaddr_in6>, which contains the address of the client that has + connected and made the current request. This is provided "raw" in case you + need it. While you could re-create it from C<peerhost>, it is readily + available in both this server environment and the BApache::RPC::Server +-environment and thus included for convenience. ++environment and thus included for convenience. Apply L<Socket/inet_ntop> to ++C<peerfamily> and this value to obtain textual representation of the address. + + =item peerhost + +diff --git a/t/40_server.t b/t/40_server.t +index 21509f4..d6b3fb1 100644 +--- a/t/40_server.t ++++ b/t/40_server.t +@@ -13,6 +13,7 @@ use IO::Socket; + use File::Spec; + use List::Util 'none'; + use Scalar::Util 'blessed'; ++use Socket (); + + use Test::More; + use LWP::UserAgent; +@@ -165,25 +166,7 @@ if (! ref $srv) + croak "Server allocation failed, cannot continue. Message was: $srv"; + } + $port = $srv->port; +-# Test the URL the server uses. Allow for "localhost", "localhost.localdomain" +-# or the local-net IP address of this host (not always 127.0.0.1). +-# 22/09/2008 - Just allow for anything the user has attached to this address. +-# Aliases keep causing this test to falsely fail. +-my @localhostinfo = gethostbyname 'localhost'; +-my $local_ip = join q{.} => unpack 'C4', $localhostinfo[4]; +-my @allhosts = ($local_ip, $localhostinfo[0], split q{ } => $localhostinfo[1]); +-for (@allhosts) { s/[.]/[.]/g } +-# Per RT 27778: For some reason gethostbyname('localhost') does not return +-# "localhost" on win32 +-if ($^O eq 'MSWin32' || $^O eq 'cygwin') +-{ +- push @allhosts, 'localhost'; +-} +-if (none { /localdomain/ } @allhosts) +-{ +- push @allhosts, 'localhost[.]localdomain'; +-} +-my $allhosts = join q{|} => @allhosts; ++my $allhosts = alllocalhostre(); + like($srv->url, qr{http://($allhosts):$port%7D, + 'RPC::XML::Server::url method (set)'); # This should be non-null this time + # Test some of the simpler cases of add_method and get_method +@@ -269,12 +252,16 @@ $res = $srv->add_method({ name => 'perl.test.suite.peeraddr', + sub { + my $server = shift; + +- my $ipaddr = inet_aton($server->{peerhost}); ++ my $peerfamily = RPC_BASE64 $server->{peerfamily}; + my $peeraddr = RPC_BASE64 $server->{peeraddr}; +- my $packet = pack_sockaddr_in($server->{peerport}, +- $ipaddr); ++ my $packet = pack_sockaddr_any( ++ $server->{peerfamily}, ++ $server->{peerhost}, ++ $server->{peerport} ++ ); + $packet = RPC_BASE64 $packet; +- [ $peeraddr, $packet, ++ ++ [ $peerfamily, $peeraddr, $packet, + $server->{peerhost}, $server->{peerport} ]; + } }); + $child = start_server $srv; +@@ -329,12 +316,12 @@ SKIP: { + } + + $res = $res->value->value; +- is($res->[2], inet_ntoa(inet_aton('localhost')), ++ ok(grep({ $_ cmp $res->[3]} resolve($res->[0], 'localhost')), + 'Third live req: Correct IP addr from peerhost'); +- is($res->[0], inet_aton($res->[2]), ++ is($res->[1], Socket::inet_pton($res->[0], $res->[3]), + 'Third request: peeraddr packet matches converted peerhost'); +- is($res->[1], pack_sockaddr_in($res->[3], inet_aton($res->[2])), +- 'Third request: pack_sockaddr_in validates all'); ++ is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]), ++ 'Third request: pack_sockaddr_any validates all'); + } + } + stop_server $child; +diff --git a/t/40_server_xmllibxml.t b/t/40_server_xmllibxml.t +index bb7e32e..1b48cef 100644 +--- a/t/40_server_xmllibxml.t ++++ b/t/40_server_xmllibxml.t +@@ -13,6 +13,7 @@ use File::Spec; + use Module::Load; + use List::Util 'none'; + use Scalar::Util 'blessed'; ++use Socket (); + use Test::More; + + use LWP::UserAgent; +@@ -87,25 +88,7 @@ if (! ref $srv) + croak "Server allocation failed, cannot continue. Message was: $srv"; + } + $port = $srv->port; +-# Test the URL the server uses. Allow for "localhost", "localhost.localdomain" +-# or the local-net IP address of this host (not always 127.0.0.1). +-# 22/09/2008 - Just allow for anything the user has attached to this address. +-# Aliases keep causing this test to falsely fail. +-my @localhostinfo = gethostbyname 'localhost'; +-my $local_ip = join q{.} => unpack 'C4', $localhostinfo[4]; +-my @allhosts = ($local_ip, $localhostinfo[0], split q{ }, $localhostinfo[1]); +-for (@allhosts) { s/[.]/\./g } +-# Per RT 27778: For some reason gethostbyname('localhost') does not return +-# "localhost" on win32 +-if ($^O eq 'MSWin32' || $^O eq 'cygwin') +-{ +- push @allhosts, 'localhost'; +-} +-if (none { /localdomain/ } @allhosts) +-{ +- push @allhosts, 'localhost.localdomain'; +-} +-my $allhosts = join q{|} => @allhosts; ++my $allhosts = alllocalhostre(); + like($srv->url, qr{http://($allhosts):$port%7D, + 'RPC::XML::Server::url method (set)'); # This should be non-null this time + # Test some of the simpler cases of add_method and get_method +@@ -166,12 +149,16 @@ $res = $srv->add_method({ name => 'perl.test.suite.peeraddr', + sub { + my $server = shift; + +- my $ipaddr = inet_aton($server->{peerhost}); ++ my $peerfamily = RPC_BASE64 $server->{peerfamily}; + my $peeraddr = RPC_BASE64 $server->{peeraddr}; +- my $packet = pack_sockaddr_in($server->{peerport}, +- $ipaddr); ++ my $packet = pack_sockaddr_any( ++ $server->{peerfamily}, ++ $server->{peerhost}, ++ $server->{peerport} ++ ); + $packet = RPC_BASE64 $packet; +- [ $peeraddr, $packet, ++ ++ [ $peerfamily, $peeraddr, $packet, + $server->{peerhost}, $server->{peerport} ]; + } }); + $child = start_server $srv; +@@ -226,12 +213,12 @@ SKIP: { + } + + $res = $res->value->value; +- is($res->[2], inet_ntoa(inet_aton('localhost')), ++ ok(grep({ $_ cmp $res->[3]} resolve($res->[0], 'localhost')), + 'Third live req: Correct IP addr from peerhost'); +- is($res->[0], inet_aton($res->[2]), ++ is($res->[1], Socket::inet_pton($res->[0], $res->[3]), + 'Third request: peeraddr packet matches converted peerhost'); +- is($res->[1], pack_sockaddr_in($res->[3], inet_aton($res->[2])), +- 'Third request: pack_sockaddr_in validates all'); ++ is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]), ++ 'Third request: pack_sockaddr_any validates all'); + } + } + stop_server $child; +diff --git a/t/41_server_hang.t b/t/41_server_hang.t +index 634a2fd..721e032 100644 +--- a/t/41_server_hang.t ++++ b/t/41_server_hang.t +@@ -12,7 +12,7 @@ use subs qw(start_server); + + use Carp qw(carp croak); + use File::Spec; +-use IO::Socket; ++use IO::Socket::IP; + use Test::More; + + use HTTP::Request; +@@ -81,7 +81,7 @@ SKIP: { + # Create an IO::Socket object for the client-side. In order to fool the + # server with a bad Content-Length and terminate early, we have to ditch + # LWP and go old-skool. +- $socket = IO::Socket::INET->new(Proto => 'tcp', PeerAddr => 'localhost', ++ $socket = IO::Socket::IP->new(Proto => 'tcp', PeerAddr => 'localhost', + PeerPort => $port) + or croak "Error creating IO::Socket obj: $!"; + print {$socket} $req; +diff --git a/t/60_net_server.t b/t/60_net_server.t +index f866c1c..0e2f318 100644 +--- a/t/60_net_server.t ++++ b/t/60_net_server.t +@@ -90,7 +90,7 @@ sleep 1; # Allow time for server to spin up + # Unless we see "ok 2", we have a problem + ok(-e $pid_file, 'server started, PID file exists'); + # After this point, we have the obligation of killing the server manually +-$client = RPC::XML::Client->new("http://localhost:$port"); ++$client = RPC::XML::Client->new("http://$srv_hostname:$port"); + is($client->simple_request('system.identity'), $srv->product_tokens, + 'system.identity matches $srv->product_tokens'); + +diff --git a/t/util.pl b/t/util.pl +index 5fefafc..055d99b 100644 +--- a/t/util.pl ++++ b/t/util.pl +@@ -2,6 +2,8 @@ + # test suites + + use IO::Socket; ++use Socket (); ++use Carp (); + + sub start_server + { +@@ -58,4 +60,86 @@ sub find_port + return -1; + } + ++sub pack_sockaddr_any ++{ ++ my ($family, $address, $port) = @_; ++ ++ my $packed_address = Socket::inet_pton($family, $address); ++ my $packet; ++ if ($family == Socket::AF_INET) { ++ $packet = Socket::pack_sockaddr_in($port, $packed_address); ++ } elsif ($family == Socket::AF_INET6) { ++ $packet = Socket::pack_sockaddr_in6($port, $packed_address); ++ } else { ++ Carp::croak "Unsupported address family: $family"; ++ } ++ return $packet; ++} ++ ++sub resolve { ++ my ($family, $hostname) = @_; ++ ++ my ($error, @res) = Socket::getaddrinfo($hostname, '', ++ { socktype => Socket::SOCK_STREAM }); ++ if ($error) { ++ Carp::croak "Could not resolve $hostname: $error"; ++ } ++ my @addresses; ++ while (my $ai = shift @res) { ++ my ($error, $address) = Socket::getnameinfo($ai->{addr}, ++ Socket::NI_NUMERICHOST, Socket::NIx_NOSERV); ++ push @addresses, $address; ++ } ++ return @addresses; ++} ++ ++# Test the URL the server uses. Allow for "localhost", "localhost.localdomain" ++# or the local-net IP address of this host (not always 127.0.0.1). ++# 22/09/2008 - Just allow for anything the user has attached to this address. ++# Aliases keep causing this test to falsely fail. ++sub alllocalhostre { ++ my @allhosts; ++ ++ my ($error, @addresses) = Socket::getaddrinfo('localhost', '', ++ { socktype => Socket::SOCK_STREAM }); ++ if ($error) { ++ Carp::croak "Could not resolve localhost: $error"; ++ } ++ while (my $ai = shift @addresses) { ++ my ($error, $name) = Socket::getnameinfo($ai->{addr}, ++ Socket::NI_NUMERICHOST|Socket::NI_NUMERICSERV, ++ Socket::NIx_NOSERV); ++ if ($error) { ++ Carp::croak "Could not format an IP address: $error"; ++ } ++ push @allhosts, ($name =~ /:/ ? '[' . $name . ']' : $name); ++ ($error, $name) = Socket::getnameinfo($ai->{addr}, ++ Socket::NI_NUMERICSERV, ++ Socket::NIx_NOSERV); ++ if ($error) { ++ Carp::croak "Could not resolve an IP address: $error"; ++ } ++ push @allhosts, $name; ++ } ++ ++ # Obtain aliases ++ push @allhosts, (split q{ } => (gethostbyname('localhost'))[1]); ++ for (@allhosts) { s/[/\[/g; s/]/\]/; s/[.]/[.]/g } ++ # Per RT 27778: For some reason gethostbyname('localhost') does not return ++ # "localhost" on win32 ++ if ($^O eq 'MSWin32' || $^O eq 'cygwin') ++ { ++ push @allhosts, 'localhost'; ++ } ++ if (none { /localdomain/ } @allhosts) ++ { ++ push @allhosts, 'localhost[.]localdomain'; ++ } ++ ++ # Build regular expression ++ my $allhosts = join q{|} => @allhosts; ++ ++ return $allhosts; ++} ++ + 1; +-- +2.7.4 + diff --git a/perl-RPC-XML.spec b/perl-RPC-XML.spec index ff2aabe..855ba98 100644 --- a/perl-RPC-XML.spec +++ b/perl-RPC-XML.spec @@ -2,13 +2,15 @@
Name: perl-%{cpan_name} Version: 0.80 -Release: 4%{?dist} +Release: 5%{?dist} Summary: Set of classes for core data, message and XML handling Group: Development/Libraries License: Artistic 2.0 or LGPLv2 URL: http://search.cpan.org/dist/%%7Bcpan_name%7D/ Source0: http://search.cpan.org/CPAN/authors/id/R/RJ/RJRAY/%%7Bcpan_name%7D-%%7Bversi... Source1: README.license +# Add IPv6 support needed for IPv6-capable HTTP::Daemon, CPAN RT#120472 +Patch0: RPC-XML-0.80-IPv6-support.patch BuildArch: noarch BuildRequires: coreutils BuildRequires: findutils @@ -56,13 +58,13 @@ BuildRequires: perl(LWP::UserAgent) >= 5.834 BuildRequires: perl(Config) BuildRequires: perl(Digest::MD5) BuildRequires: perl(IO::Socket) +BuildRequires: perl(IO::Socket::IP) BuildRequires: perl(List::Util) BuildRequires: perl(LWP) >= 5.834 BuildRequires: perl(Symbol) BuildRequires: perl(Test::More) >= 0.94 # Optional tests: BuildRequires: perl(Compress::Zlib) -# IO::Socket::IP not helpful BuildRequires: perl(Net::Server) Requires: perl(:MODULE_COMPAT_%(eval "`perl -V:version`"; echo $version)) Requires: perl(constant) >= 1.03 @@ -102,6 +104,7 @@ running RPC::XML under mod_perl.
%prep %setup -qn %{cpan_name}-%{version} +%patch0 -p1 cp -p %{SOURCE1} .
%build @@ -131,6 +134,9 @@ make test %{perl_vendorlib}/Apache
%changelog +* Thu Mar 02 2017 Petr Pisar ppisar@redhat.com - 0.80-5 +- Add IPv6 support needed for IPv6-capable HTTP::Daemon (CPAN RT#120472) + * Sat Feb 11 2017 Fedora Release Engineering releng@fedoraproject.org - 0.80-4 - Rebuilt for https://fedoraproject.org/wiki/Fedora_26_Mass_Rebuild