#!/usr/bin/perl -w
# virt-tools
# Copyright (C) 2009 Red Hat Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

use Sys::Virt;
use Sys::Guestfs;
use Sys::Guestfs::Lib qw(open_guest get_partitions);
use Net::SNMP;

use Data::Dumper;

use Pod::Usage;
use Getopt::Long;

use Locale::TextDomain 'virt-tools';

=encoding utf8

=head1 NAME

virt-tools-get-transport - virt-tools helper to get the guest's transport

=head1 SYNOPSIS

 virt-tools-get-transport [--options] domname

=head1 DESCRIPTION

This helper program is used by L<virt-tools(8)> to get the transport
that should be used to connect to the SNMP daemon inside the guest.
If you don't know anything about this, you probably want to start by
reading L<virt-tools(8)>.  Otherwise read on.

The single command line argument should be a libvirt domain name (see
C<virsh list --all>).

=head2 TRANSPORTS

Transports look somewhat like a URL, with a transport schema followed
by some specific details.  Currently we have defined these transports:

=over 4

=item udp:ip-address[:port]

Connect via UDP to C<ip-address>, optionally on the non-default port
C<port> (the usual SNMP port 161 is used otherwise).

=item tcp:ip-address[:port]

Connect via TCP to C<ip-address>, optionally on the non-default port
C<port> (the usual SNMP port 161 is used otherwise).

=item unix:path

Connect via Unix domain socket C<path>.  This would be used in future
for vmchannel implementations, but it is not used at the moment.

=back

=head2 TRANSPORT CACHE

The cache is described in detail in L<virt-tools(8)>.  In brief, if
C<@localstatedir@/lib/virt-tools/transports/E<lt>UUIDE<gt>> exists
(where E<lt>UUIDE<gt> is the guest's UUID), then the contents of that
file are returned directly.  Otherwise we will try to create this file
after reading the transport so that we don't have to determine the
guest's transport each time.

=head1 OPTIONS

=over 4

=cut

my $help;

=item B<--help>

Display brief help.

=cut

my $version;

=item B<--version>

Display version number and exit.

=cut

my $uri;

=item B<--connect URI> | B<-c URI>

If using libvirt, connect to the given I<URI>.  If omitted, then we
connect to the default libvirt hypervisor.

=cut

my $verbose;

=item B<--verbose> | B<-v>

Enable verbose messages, useful for debugging.

=cut

my $no_ping;

=item B<--no-ping> | B<-n>

Do not try to check that the transport is working by pinging the
guest.

If this option is I<not> given, then this program will expire the
cache entry for the guest if the transport from the cache doesn't
work, then it will try to determine the new transport, test that, and
fail if it still doesn't work.

=back

=cut

GetOptions ("help|?" => \$help,
            "version" => \$version,
            "connect|c=s" => \$uri,
            "verbose|v" => \$verbose,
	    "no-ping|n" => \$no_ping,
    ) or pod2usage (2);
pod2usage (1) if $help;
if ($version) {
    print "@PACKAGE_STRING@\n";
    exit
}

die __"no domain name listed on the command line\n" unless @ARGV == 1;

my ($g, $conn, $dom);

if ($uri) {
    ($g, $conn, $dom) = open_guest (\@ARGV, address => $uri);
} else {
    ($g, $conn, $dom) = open_guest (\@ARGV);
}

my $uuid = $dom->get_uuid_string ();
my $domname = $dom->get_name ();

# See if the UUID exists in the cache already.
print STDERR "checking for UUID $uuid in the cache directory\n" if $verbose;

my $cachedir = "@localstatedir@/lib/virt-tools/transports";
if (-r "$cachedir/$uuid") {
    print STDERR "$cachedir/$uuid exists\n" if $verbose;
    open FILE, "$cachedir/$uuid" or die "$cachedir/$uuid: $!";
    my $transport = <FILE>;
    chomp $transport;
    close FILE;

    unless ($no_ping) {
	# Test if it works.
	if (!test_transport ($transport)) {
	    unlink "$cachedir/$uuid"; # allow this to fail
	    goto keep_looking;
	}
    }

    print $transport, "\n";

    exit 0;
}

print STDERR "$cachedir/$uuid not found, looking inside guest\n" if $verbose;

keep_looking:
$g->launch ();

# Do not care about mountpoints.  Instead, just look for a
# directory with one of a selection of names on one of the
# partitions that we found.
my @partitions = get_partitions ($g);

my ($transport, $key, $ip);

foreach my $partition (@partitions) {
    eval {
	$g->mount_ro ($partition, "/");
	my $dir;
	my @dirs = ("/var/lib/virt-tools", "/lib/virt-tools");
	foreach $dir (@dirs) {
	    if ($g->is_dir ($dir)) {
		if ($g->is_file ("$dir/transport")) {
		    $transport = $g->cat ("$dir/transport");
		}
		if ($g->is_file ("$dir/key")) {
		    $key = $g->cat ("$dir/key");
		}
		if ($g->is_file ("$dir/ip-eth0")) {
		    $ip = $g->cat ("$dir/ip-eth0");
		}
	    }
	}
    };
    $g->umount_all ();
    last if $transport || $key;
}

undef $g;

die __x("{n}: no transport or key found in guest.\nDoes it have the virt-tool-guest package installed?\n",
	n => $ARGV[0])
    unless $transport && $key;

if ($ip) {
    if ($ip =~ m{inet (\S+)/}) {
        $ip = $1;
    } elsif ($ip =~ m{inet6 (\S+)/}) {
        $ip = $1;
    } else {
        die __"could not parse the content of ip-eth0 file from the guest";
    }
}

if ($transport =~ /^udp:(\d+)/) {
    die __"UDP transport, but no IP address in guest" unless $ip;
    $transport = "udp:$ip:$1";
}
elsif ($transport =~ /^udp/) {
    die __"UDP transport, but no IP address in guest" unless $ip;
    $transport = "udp:$ip:161";
}
elsif ($transport =~ /^tcp:(\d+)/) {
    die __"TCP transport, but no IP address in guest" unless $ip;
    $transport = "tcp:$ip:$1";
}
elsif ($transport =~ /^tcp/) {
    die __"TCP transport, but no IP address in guest" unless $ip;
    $transport = "tcp:$ip:161";
}
else {
    die __x("unknown transport type: {t}", t => $transport);
}

# Test the transport works.
die __x("transport {t} does not work", t => $transport)
    unless test_transport ($transport, $key);

print STDERR "try to write $transport to $cachedir/$uuid\n" if $verbose;

if (open FILE, ">$cachedir/$uuid") {
    print FILE $transport;
    close FILE
}

print $transport;

exit 0;

sub test_transport
{
    my $transport = shift;
    my $key = shift;

    unless ($key) {
	my $cmd = "virt-tools-get-key";
	$cmd .= " -v" if $verbose;
	# XXX quoting
	$cmd .= " -c '$uri'" if $uri;
	$cmd .= " '$domname'";

	print STDERR "$cmd\n" if $verbose;

	open PIPE, "$cmd |" or die "$cmd: $!";
	$key = <PIPE>;
	die __"no response from virt-tools-get-key\n" unless $key;
	chomp $key;
	close PIPE;
    }

    my ($hostname, $port, $domain);
    if ($transport =~ /^udp:(.*):(.*)/) {
	$domain = "udp";
	$hostname = $1;
	$port = $2;
    } elsif ($transport =~ /^tcp:(.*):(.*)/) {
	$domain = "tcp";
	$hostname = $1;
	$port = $2;
    } else {
	die __x("unknown transport type: {t}", t => $transport);
    }

    if ($verbose) {
	print STDERR "creating Net::SNMP session to $domain:$hostname:$port with key $key\n"
    }

    my ($session, $error) = Net::SNMP->session (
	-version => 3,
	-username => "virttools",
	-authpassword => $key,
	-authprotocol => "sha",
	-privpassword => $key,
	-privprotocol => "aes",
	-hostname => $hostname,
	-port => $port,
	-domain => $domain,
	);
    return 0 unless $session;

    my $sysUpTime = "1.3.6.1.2.1.1.3.0";
    my $r = $session->get_request (-varbindlist => [$sysUpTime])
	or return 0;
    print STDERR "test_transport: sysUpTime = $r->{$sysUpTime}\n" if $verbose;

    $session->close ();

    1;
}

=head1 SEE ALSO

L<virt-ifconfig(8)>,
L<guestfs(3)>,
L<guestfish(1)>,
L<Sys::Guestfs(3)>,
L<Sys::Guestfs::Lib(3)>,
L<Sys::Virt(3)>,
L<http://libguestfs.org/>.

=head1 AUTHORS

=over 4

=item *

Richard W.M. Jones (C<rjones at redhat dot com>)

=item *

Matthew Booth (C<mbooth at redhat dot com>)

=back

=head1 COPYRIGHT

Copyright (C) 2009 Red Hat Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
