#!/usr/bin/perl -w

=head1 NAME

xen-duplicate-image - Duplicate an existing Xen instance.

=head1 SYNOPSIS

  xen-duplicate-image [options]

  Help Options:
   --help     Show this scripts help information.
   --manual   Read this scripts manual.
   --version  Show the version number and exit.

  General options:
   --dir      Specify where the output images should go.

  Networking options:
   --dhcp      Setup the image to get an IP address via DHCP
   --network   Setup the network the host is upon.
   --netmask   Setup the netmask the host should use.
   --gateway   Setup the iamge's network gateway.
   --broadcast Setup the image's network broadcast address.

  Mandatory options:

   --hostname  Set the images hostname.
   --from      The image name we should copy

=cut



=head1 OPTIONS

=over 8

=item B<--boot>
Boot the new instance immediately after creating it.

=item B<--broadcast>
Specify the broadcast address for the virtual image, only useful if DHCP is not used.

=item B<--dhcp>
Specify that the virtual image should use DHCP to obtain its networking information.

=item B<--gateway>
Specify the gateway address for the virtual image, only useful if DHCP is not used.

=item B<--help>
Show the brief help information.

=item B<--manual>
Read the manual, with examples.

=item B<--netmask>
Setup the netmask the host should use.

=item B<--network>
Specify the network the virtual image is living upon.  Only useful if DHCP is not used.

=item B<--from>
Specify the virtual instance that we should copy.

=item B<--version>
Show the version number and exit.

=back

=cut


=head1 EXAMPLES

  The following will copy the existing image vm01, and
 save it as vm02 - with DHCP enabled.

     xen-duplicate-image --dir=/home/xen \
        --from=vm01  --hostname=vm02.my.flat --dhcp

=cut



=head1 DESCRIPTION

  xen-duplicate-image is a simple script which allows you to create new
 Xen instances of Debian Sarge.  The new image will be an identical
 copy of an existing image.


=head1 CONFIGURATION

  To reduce the length of the command line each of the options may
 be specified inside a configuration file.

  The script will check two files for options:

   1. /etc/xen-tools/xen-tools.conf
   2. ~/.xen-tools.conf

  The files may contain comments, which begin with the hash '#' character
 and are otherwise of the format 'key = value.

=head1 AUTHOR


 Steve
 --
 http://www.steve.org.uk/

 $Id: xen-duplicate-image,v 1.8 2005-12-21 22:46:36 steve Exp $

=cut


=head1 CONTRIBUTORS

  Radu Spineanu

=head1 LICENSE

Copyright (c) 2005 by Steve Kemp.  All rights reserved.

This module is free software;
you can redistribute it and/or modify it under
the same terms as Perl itself.
The LICENSE file contains the full text of the license.

=cut


use strict;
use English;
use File::Copy;
use File::Temp qw/ tempdir /;
use Getopt::Long;
use Pod::Usage;



#
#  Configuration options, initially read from the configuration files
# but may be overridden by the command line.
#
#  Command line flags *always* take precedence over the configuration files(s).
#
my %CONFIG;

#
#  Defaults
#
$CONFIG{'xm'} 		= '/usr/sbin/xm';


#
#  Read configuration file(s) if they exist.
#
if ( -e "/etc/xen-tools/xen-tools.conf" )
{
    readConfigurationFile( "/etc/xen-tools/xen-tools.conf" );
}
if ( -e $ENV{'HOME'} . ".xen-tools.conf" )
{
    readConfigurationFile( $ENV{'HOME'} . ".xen-tools.conf" );
}


#
#  Parse command line arguments, these override the values from the
# configuration file.
#
parseCommandLineArguments();


#
#  Check that the arguments the user has supplied are both 
# valid, and complete.
#
checkArguments();


if ( $EFFECTIVE_USER_ID != 0 )
{
    print <<E_O_ROOT;

  In order to use this script you must be running with root privileges.

  (This is necessary to mount the disk images.)

E_O_ROOT

    exit;
}

print "\n";
print "Source      :  $CONFIG{'from'}\n";
print "Destination :  $CONFIG{'hostname'}\n";

if ( $CONFIG{'dhcp'} ) 
{
    print "DHCP\n";
}
else
{
   $CONFIG{'ip'}        && print "IP       : $CONFIG{'ip'}\n";
   $CONFIG{'network'}   && print "Network  : $CONFIG{'network'}\n";
   $CONFIG{'broadcast'} && print "Broadcast: $CONFIG{'broadcast'}\n";
   $CONFIG{'gateway'}   && print "Gateway  : $CONFIG{'gateway'}\n";
}
print "---\n";



#
#  If the output directories don't exist then create them.
#
if ( ! -d $CONFIG{'dir'} . "/domains/" )
{
    mkdir $CONFIG{'dir'} . '/domains', 0777
      || die "Cannot create $CONFIG{'dir'}/domains - $!";
}
if ( ! -d $CONFIG{'dir'} . "/domains/" . $CONFIG{'hostname'} )
{
    mkdir $CONFIG{'dir'}. '/domains/' . $CONFIG{'hostname'}, 0777
      || die "Cannot create $CONFIG{'dir'}/domains/$CONFIG{'hostname'} - $!" ;
}



#
# The two images we'll use, one for the disk image, one for swap.
#
my $image_in = $CONFIG{'dir'} .'/domains/'. $CONFIG{'from'} . "/disk.img" ;
my $image_out= $CONFIG{'dir'}.'/domains/'. $CONFIG{'hostname'} . "/disk.img" ;

my $swap_in  = $CONFIG{'dir'} .'/domains/' .$CONFIG{'from'} . "/swap.img" ;
my $swap_out = $CONFIG{'dir'} .'/domains/' .$CONFIG{'hostname'} . "/swap.img" ;


#
#  Copy the swap file, and disk images.
#
print "Copying swapfile ...\n";
File::Copy::cp( $swap_in,  $swap_out );
print "done\n";

print "Copying disk image ...\n";
File::Copy::cp( $image_in, $image_out );
print "done\n";

#
#  Now mount the image, in a secure temporary location.
#

my $dir = tempdir( CLEANUP => 1 );
my $mount_cmd = "mount -t auto -o loop $image_out $dir";
`$mount_cmd`;


# Test that the mount worked

my $mount = `/bin/mount`;

if ( ! $mount =~ /$image_out/) 
{
    print "Something went wrong trying to mount the new filesystem\n";
    exit;
}

#
#  Setup the output directories for the configuration files here - note
# that this should already exist.
#
`mkdir -p $dir/etc/apt`;
`mkdir -p $dir/etc/network`;


#
#  Setup the /etc/network/interfaces file upon the guest image
#
setupNetworking( $dir );


#
#  Now unmount the image.
#
`umount $dir`;


#
# Finally setup Xen to allow us to create the image.
#
print "Setting up Xen configuration file .. ";
open( XEN, ">", "/etc/xen/$CONFIG{'hostname'}.cfg" );
print XEN<<E_O_XEN;
kernel = "/boot/vmlinuz-2.6.12-xenU"
memory = $CONFIG{'memory'}
name   = "$CONFIG{'hostname'}"
disk   = [ 'file:$image_out,sda1,w','file:$swap_out,sda2,w' ]
root   = "/dev/sda1 ro"
E_O_XEN
if ( $CONFIG{'dhcp'} )
{
    print XEN "dhcp=\"dhcp\"\n";
}
else
{
    print XEN "#dhcp=\"dhcp\"\n";
}
close( XEN );

print "Done\n";



#
#  Should we immediately start the new instance?
#  If so fork() and do it so that we can return to the user, they can
# attach to the console via the command : 'xm console $name'.
#
#
if ( $CONFIG{'boot'} )
{
    my $pid = fork();
    if ( $pid )
    {
	exit;
    }
    else
    {
	system( "$CONFIG{'xm'} create $CONFIG{'hostname'}.cfg" );
    }
}


#
#  End of the script.
#
exit;


=head2 readConfigurationFile

  Read the configuration file specified.

=cut

sub readConfigurationFile
{
    my ($file) = ( @_ );

    open( FILE, "<", $file ) or die "Cannot read file '$file' - $!";

    my $line       = ""; 

    while (defined($line = <FILE>) ) 
    {
        chomp $line;
	if ($line =~ s/\\$//) 
	{
	    $line .= <FILE>;
	    redo unless eof(FILE);
	}
      
	# Skip lines beginning with comments
	next if ( $line =~ /^([ \t]*)\#/ );

	# Skip blank lines
	next if ( length( $line ) < 1 );

	# Strip trailing comments.
	if ( $line =~ /(.*)\#(.*)/ )
	{
	    $line = $1;
	}

	# Find variable settings
	if ( $line =~ /([^=]+)=([^\n]+)/ )
	{
	    my $key = $1;
	    my $val = $2;

	    # Strip leading and trailing whitespace.
	    $key =~ s/^\s+//;
	    $key =~ s/\s+$//;
	    $val =~ s/^\s+//;
	    $val =~ s/\s+$//;
	    
	    # Store value.
	    $CONFIG{ $key } = $val;
	}
    }

    close( FILE );
}




=head2 parseCommandLineArguments

  Parse the arguments specified upon the command line.

=cut

sub parseCommandLineArguments
{
    my $HELP	= 0;
    my $MANUAL	= 0;
    my $VERSION	= 0;

    #  Parse options.
    #
    GetOptions(
	       "hostname=s", \$CONFIG{'hostname'},
	       "from=s",     \$CONFIG{'from'},
	       "ip=s",       \$CONFIG{'ip'},
	       "gateway=s",  \$CONFIG{'gateway'},
	       "mask=s",     \$CONFIG{'netmask'},
	       "broadcast=s",\$CONFIG{'broadcast'},
	       "network=s",  \$CONFIG{'network'},
	       "dir=s",      \$CONFIG{'dir'},
	       "dhcp",       \$CONFIG{'dhcp'},
	       "help",       \$HELP,
	       "manual",     \$MANUAL,
	       "version",    \$VERSION
	      );
    
    pod2usage(1) if $HELP;
    pod2usage(-verbose => 2 ) if $MANUAL;


    if ( $VERSION )
    {
	my $REVISION      = '$Id: xen-duplicate-image,v 1.8 2005-12-21 22:46:36 steve Exp $';
	$VERSION = join (' ', (split (' ', $REVISION))[2]);
	$VERSION =~ s/,v\b//;
	$VERSION =~ s/(\S+)$/$1/;

	print "xen-duplicate-image release 0.5 - CVS: $VERSION\n";
	exit;

    }
}



=head2 checkArguments

  Check that the arguments the user has specified are complete and
 make sense.

=cut

sub checkArguments
{

    if (!defined( $CONFIG{'hostname'} ) )
    {
	print<<EOF

  You should set a hostname with '--hostname=foo'.

  This option is required.
EOF
      ;
	exit;
    }

    if (!defined ($CONFIG{'from'} ) )
    {
        print<<EOF

  You should set a source with '--from=bar'.

  This option is required.
EOF
      ;
        exit;

    }

    if (!defined( $CONFIG{'dir'} ) )
    {
	print<<EOF

  You should set an output directory with '--dir=/my/path'.

  This option is required.  Subdirectories will be created
 beneath the directory you name.

EOF
	  ;
	exit;
    }

    #
    #  Make sure we have every binary we need
    #
    if ( ! -x $CONFIG{'xm'} )
    {
        print "Could not find " .$CONFIG{'xm'}. ".\n";
        exit;
    }


    #
    #  Make sure the directory exists.
    #
    if ( ! -d $CONFIG{'dir'} )
    {
	print "Output directory '$CONFIG{'dir'}' doesn't exist\n";
	exit;
    }

    if ( ! -w $CONFIG{'dir'} )
    {
	print "Output directory '$CONFIG{'dir'}' isn't writable.\n";
	exit;
    }

    #
    # Make sure the source image we're copying exists.
    #
    my $source = $CONFIG{'dir'} . "/domains/" . $CONFIG{'from'} . "/disk.img";
    if ( ! -e $source )
    {
	print "The source image you've specified doesn't exist";
	exit;
    }


    # Strip trailing Mb from the memory size.
    if ( $CONFIG{'memory'} =~ /^(\d+)Mb*$/i )
    {
	$CONFIG{'memory'} = $1;
    }

    #
    #  Only one of DHCP / IP is required.
    #
    if ( $CONFIG{'ip'} && $CONFIG{'dhcp'})
    {
	print "You've chosen both DHCP and an IP address.\n";
	print "Only one is supported\n";
	exit;
    }

    #
    #  If we're using DHCP then the other networking options should
    # be unsent.
    #
    if ( $CONFIG{'dhcp'} )
    {
	$CONFIG{'gateway'}   = '';
	$CONFIG{'netmask'}   = '';
	$CONFIG{'broadcast'} = '';
	$CONFIG{'ip'}	     = '';
    }
}



=head2 setupNetworking

  Setup the /etc/network/interfaces file, and the hostname 
 upon the virtual instance.

=cut

sub setupNetworking
{
    my ( $prefix ) = ( @_ );

    `echo '$CONFIG{'hostname'}' > $prefix/etc/hostname`;

    open( IP, ">", $prefix . "/etc/network/interfaces" );

    if ( $CONFIG{'dhcp'} )
    {
	print IP<<E_O_DHCP;
# This file describes the network interfaces available on your system
# and how to activate them. For more information, see interfaces(5).

# The loopback network interface
auto lo
iface lo inet loopback
	    
# The primary network interface
auto eth0
iface eth0 inet dhcp

E_O_DHCP
    }
    else
    {
	print IP<<E_O_STATIC_IP;
# This file describes the network interfaces available on your system
# and how to activate them. For more information, see interfaces(5).

# The loopback network interface
auto lo
iface lo inet loopback
	    
# The primary network interface
auto eth0
iface eth0 inet static
 address $CONFIG{'ip'}
 gateway $CONFIG{'gateway'}
 netmask $CONFIG{'netmask'}
 network $CONFIG{'network'}
 broadcast $CONFIG{'broadcast'}

E_O_STATIC_IP
    }

    close( IP );
}