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 B<Apache::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},
'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},
'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