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
ambiguous 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(-)

--- 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 },
--- a/lib/RPC/XML/Server.pm
+++ b/lib/RPC/XML/Server.pm
@@ -821,9 +821,9 @@ sub process_request ## no critic (Prohib
     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 (Prohib
 
     # 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 (Prohib
             {
                 # 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 datatyp
 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
 
--- a/t/40_server.t
+++ b/t/40_server.t
@@ -14,6 +14,7 @@ use IO::Socket;
 use File::Spec;
 use List::Util 'none';
 use Scalar::Util 'blessed';
+use Socket ();
 
 use Test::More;
 use LWP::UserAgent;
@@ -166,25 +167,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
@@ -270,12 +253,16 @@ $res = $srv->add_method({ name      => '
                           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;
@@ -330,12 +317,12 @@ SKIP: {
         }
 
         $res = $res->value->value;
-        is($res->[2], inet_ntoa(inet_aton('localhost')),
+        ok(grep({ $_ eq $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;
--- a/t/40_server_xmllibxml.t
+++ b/t/40_server_xmllibxml.t
@@ -14,6 +14,7 @@ use File::Spec;
 use Module::Load;
 use List::Util 'none';
 use Scalar::Util 'blessed';
+use Socket ();
 use Test::More;
 
 use LWP::UserAgent;
@@ -88,25 +89,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
@@ -167,12 +150,16 @@ $res = $srv->add_method({ name      => '
                           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;
@@ -227,12 +214,12 @@ SKIP: {
         }
 
         $res = $res->value->value;
-        is($res->[2], inet_ntoa(inet_aton('localhost')),
+        ok(grep({ $_ eq $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;
--- 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;
--- a/t/60_net_server.t
+++ b/t/60_net_server.t
@@ -90,7 +90,7 @@ sleep 1; # Allow time for server to spin
 # 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');
 
--- 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;