#!/usr/bin/perl -w

=head1 NAME

xt-install-image - Install a fresh copy of GNU/Linux into a directory

=cut

=head1 SYNOPSIS

  xt-install-image [options]

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

  Debugging Options:
   --verbose      Be verbose in our execution.

  Mandatory Options:
   --location     The location to use for the new installation
   --dist         The name of the distribution which has been installed.

  Misc Options:
   --arch         Pass the given arch setting to debootstrap or rpmstrap.
   --mirror       The mirror to use when installing with 'debootstrap'.

  Installation Options:
   --tar          Untar the given file.
   --debootstrap  Install a new system via the debootstrap tool
   --rpmstrap     Install a new system via the rpmstrap.
   --copy         Copy the given directory recursively.

  All other options from xen-create-image will be passed as environmental
 variables.

=cut


=head1 NOTES

  This script is invoked by xen-create-image after to create a new
 distribution of Linux.  Once the script has been created the companion
 script xt-customize-image will be invoked to perform the network
 configuration, etc.


=cut

=head1 INSTALLATION METHODS

  There are several available methods of installation, depending upon the
 users choice.  Only one option may be chosen at any given time.

  The methods available are:

=over 8

=item B<--tar>
Untar a .tar file into the new installation location.  This tarfile is assumed to contain a complete archived system.

=item B<--copy>
Copy the given directory recursively.  This local directory is assumed to contain a complete installation.

=item B<--rpmstrap>
Install the distribution specified by B<--dist> using the rpmstrap command.

=item B<--debootstrap>
Install the distribution specified by the B<--dist> argument using the debootstrap.  If you use this option you must specify a mirror with B<--mirror>.

=back

=cut


=head1 AUTHOR

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

 $Id: xt-install-image,v 1.37 2006-10-12 23:08:21 steve Exp $

=cut


=head1 LICENSE

Copyright (c) 2005-2006 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 Env;
use File::Copy;
use Getopt::Long;
use Pod::Usage;


#
#  Configuration values read from the command line.
#
my %CONFIG;

#
# Release number.
#
my $RELEASE = '2.7';



#
#  Read the global configuration file.
#
readConfigurationFile( "/etc/xen-tools/xen-tools.conf" );


#
#  Parse the command line arguments.
#
parseCommandLineArguments();


#
#  Check our arguments
#
checkArguments();


#
#  Install the new system.
#
#  Simplest cases first.
#
if ( $CONFIG{'copy'} )
{
    #
    # Make sure we have the cp binary present.
    #
    if ( ! -x '/bin/cp' )
    {
        print "You've chosen to use the copy method, but /bin/cp is not installed.\n";
        exit;
    }

    #
    #  Find the copy command from the configuration file,
    # with a suitable default if one isn't found.
    #
    my $cmd = $CONFIG{'copy-cmd'} ;
    if ( !defined( $cmd ) )
    {
        print "Falling back to default copy command\n";
        $cmd = '/bin/cp -a $src/* $dest';   # Note: single quotes.
    }

    #
    #  Expand the source and the destination.
    #
    $cmd =~ s/\$src/$CONFIG{'copy'}/g;
    $cmd =~ s/\$dest/$CONFIG{'location'}/g;

    #
    #  Run the copy command.
    #
    runCommand( $cmd );

}
elsif ( $CONFIG{'tar'} )
{
    #
    # Make sure we have the tar binary present.
    #
    if ( ! -x '/bin/tar' )
    {
        print "You've chosen to use the tar method, but /bin/tar is not installed.\n";
        exit 1;
    }

    #
    #  Find the copy command from the configuration file,
    # with a suitable default if one isn't found.
    #
    my $cmd = $CONFIG{'tar-cmd'} ;
    if ( !defined( $cmd ) )
    {
        print "Falling back to default tar command\n";
        $cmd = '/bin/tar --numeric-owner -xvf $src';  # Note: single quotes.
    }

    #
    #  Expand the tarfile.
    #
    $cmd =~ s/\$src/$CONFIG{'tar'}/g;

    #
    #  Run a command to copy an installed system into the new root.
    #
    runCommand( "cd $CONFIG{'location'} && $cmd" );
}
elsif ( $CONFIG{'debootstrap'} )
{
    #
    # Make sure we have the debootstrap binary present.
    #
    if ( ! -x '/usr/sbin/debootstrap' )
    {
        print "You've chosen to use the debootstrap program, but it isn't installed.\n";
        exit 1;
    }

    installDebootstrapImage();
}
elsif ( $CONFIG{'rpmstrap'} )
{
    #
    #  Make sure we have the rpmstrap binary present.
    #
    if ( ! -x '/usr/bin/rpmstrap' )
    {
        print "You've chosen to use the rpmstrap program, but it isn't installed.\n";
        exit 1;
    }

    installRPMStrapImage();
}
else
{
    #
    # error
    #
    print "No recognised installation method was discovered.";
    print "Aborting\n";
    exit 1;
}


#
#  At this point we should have a freshly installed system.
#
#  However errors have been known to happen ;)
#
#  Test that we have some standard files present.
#
foreach my $file ( qw( /bin/ls /bin/cp ) )
{
    if ( ! -x $CONFIG{'location'} . $file )
    {
        print "The installation of the new system appears to have failed.\n";
        print "\n";
        print "There is no '$file' installed in the new installation directory\n";
        exit 1;
    }
}


#
#  Exit cleanly - any errors which have already occurred will result
# in "exit 1".
#
exit 0;



=begin doc

  read the global configuration file /etc/xen-tools/xen-tools.conf

=end doc

=cut

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

    # Don't read the file if it doesn't exist.
    return if ( ! -e $file );


    my $line = "";

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

    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 );
}



=begin doc

  Parse the command line arguments this script was given.

=end doc

=cut

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

    #
    #  Parse options.
    #
    GetOptions(
               # Mandatory
               "location=s",     \$CONFIG{'location'},
               "dist=s",         \$CONFIG{'dist'},
               "hostname=s",     \$CONFIG{'hostname'},

               # Exclusive.
               "tar=s",          \$CONFIG{'tar'},
               "copy=s",         \$CONFIG{'copy'},
               "rpmstrap",       \$CONFIG{'rpmstrap'},
               "debootstrap",    \$CONFIG{'debootstrap'},

               # Misc
               "arch=s",         \$CONFIG{'arch'},
               "cache=s",        \$CONFIG{'cache'},
               "mirror=s",       \$CONFIG{'mirror'},

               # Help.
               "verbose",        \$CONFIG{'verbose'},
               "help",           \$HELP,
               "manual",         \$MANUAL,
               "version",        \$VERSION
             );

    pod2usage(1) if $HELP;
    pod2usage(-verbose => 2 ) if $MANUAL;


    if ( $VERSION )
    {
        my $REVISION      = '$Revision: 1.37 $';
        if ( $REVISION =~ /1.([0-9.]+) / )
        {
            $REVISION = $1;
        }

        print "xt-install-image release $RELEASE - CVS: $REVISION\n";
        exit;
    }
}



=begin doc

  Test that the command line arguments we were given make sense.

=end doc

=cut

sub checkArguments
{
    #
    #  We require a location.
    #
    if ( ! defined( $CONFIG{'location'} ) )
    {
        print "The '--location' argument is mandatory\n";
        exit 1;
    }


    #
    #  Test that the location we've been given exists
    #
    if ( ! -d $CONFIG{'location'} )
    {
        print "The installation directory we've been given doesn't exist\n";
        print "We tried to use : $CONFIG{'location'}\n";
        exit 1;
    }


    #
    #  We require a distribution name.
    #
    if ( ! defined( $CONFIG{'dist'} ) )
    {
        print "The '--dist' argument is mandatory\n";
        exit 1;
    }


    #
    #  Test that the distribution name we've been given
    # to configure has a collection of hook scripts.
    #
    #  If there are no scripts then we clearly cannot
    # customise it!
    #
    my $dir = "/usr/lib/xen-tools/"  . $CONFIG{'dist'} .  ".d";

    if ( ! -d $dir )
    {
        print <<E_OR;

  We're trying to configure an installation of $CONFIG{'dist'} in
 $CONFIG{'location'} - but there is no hook directory for us to use.

  This means we won't know how to configure this installation.

  We'd expect the hook directory to be : $dir

  Aborting.
E_OR
        exit 1;
    }


    ##
    # Now check the mutually distinct arguments
    ##
    my $count = 0;
    foreach my $key ( qw(copy debootstrap rpmstrap tar ) )
    {
        if ( defined( $CONFIG{$key} ) )
        {
            $count += 1;
        }
    }

    #
    # If count == 0 we had no recognised installation method.
    #
    if ( $count == 0 )
    {
        print <<EOF;
 You did not specify an installation method.

 One of the following must be given.  (Run "xt-install-image --manual" for details)

   --copy
   --debootstrap
   --rpmstrap
   --tar

 Aborting.
EOF

        exit 1;
    }
    elsif ( $count > 1 )
    {
        print <<EOF;
 You specify multiple installation methods.

 Only one of the following must be given:

   --copy
   --debootstrap
   --rpmstrap
   --tar

 Aborting.
EOF
        exit 1;
    }

}




=begin doc

  Install a new image of Debian using 'debootstrap'.

=end doc

=cut

sub installDebootstrapImage
{
    #
    #  Cache from host -> new installation if we've got caching
    # enabled.
    #
    if ( $CONFIG{'cache'} eq "yes" )
    {
        print "\nCopying files from host to image.\n";
        runCommand( "mkdir -p $CONFIG{'location'}/var/cache/apt/archives" );
        copyDebFiles( "/var/cache/apt/archives", "$CONFIG{'location'}/var/cache/apt/archives" );
        print( "Done\n" );
    }

    #
    #  Propogate --verbose appropriately.
    #
    my $EXTRA = '';
    if ( $CONFIG{'verbose'} )
    {
        $EXTRA = ' --verbose';
    }

    #
    #  Propogate the --arch argument
    #
    if ( $CONFIG{'arch'} )
    {
        $EXTRA .= " --arch $CONFIG{'arch'}"
    }


    #
    #  This is the command we'll run
    #
    my $command = "/usr/sbin/debootstrap $EXTRA $CONFIG{'dist'} $CONFIG{'location'} $CONFIG{'mirror'}";

    #
    #  Run the command.
    #
    runCommand( $command );


    #
    #  Cache from host -> new installation if we've got caching
    # enabled.
    #
    if ( $CONFIG{'cache'} eq "yes" )
    {
        print "\nCopying files from new installation to host.\n";
        copyDebFiles( "$CONFIG{'location'}/var/cache/apt/archives",
                      "/var/cache/apt/archives" );
        print( "Done\n" );
    }


}



=begin doc

  Install a new distribution of GNU/Linux using the rpmstrap tool.

=end doc

=cut

sub installRPMStrapImage
{

    #
    #  Propogate the verbosity setting.
    #
    my $EXTRA='';
    if ( $CONFIG{'verbose'} )
    {
        $EXTRA .= " --verbose";
    }

    #
    #  Propogate any arch setting we might have.
    #
    if ( $CONFIG{'arch'} )
    {
        $EXTRA .= " --arch $CONFIG{'arch'}";
    }
    #
    #  The command we're going to run.
    #
    my $command = "rpmstrap $EXTRA $CONFIG{'dist'} $CONFIG{'location'}";
    runCommand( $command );
}



=begin doc

  A utility method to run a system command.  We will capture the return
 value and exit if the command fails.

  When running verbosely we will also display any command output.

=end doc

=cut

sub runCommand
{
    my ( $cmd ) = (@_ );

    #
    #  Command start.
    #
    $CONFIG{'verbose'} && print "Executing : $cmd\n";

    #
    #  Copy stderr to stdout, so we can see it, and make sure we log it.
    #
    $cmd .= " 2>&1 | tee --append /var/log/xen-tools/$CONFIG{'hostname'}.log";

    #
    #  Run it.
    #
    my $output = `$cmd`;

    if ( $? != 0 )
    {
        print "Running command '$cmd' failed.\n";
        print "Aborting\n";
        exit;
    }

    #
    #  Command finished.
    #
    $CONFIG{'verbose'} && print "Finished : $cmd\n";

    return( $output );
}




=begin doc

  This function will copy all the .deb files from one directory
 to another as a caching operation which will speed up installations via
 debootstrap.

=end doc

=cut

sub copyDebFiles
{
    my ( $source, $dest ) = ( @_ );

    print "Copying files from $source -> $dest\n";

    #
    # Loop over only .deb files.
    #
    foreach my $file ( sort ( glob( $source . "/*.deb" ) ) )
    {
        my $name = $file;
        if ( $name =~ /(.*)\/(.*)/ )
        {
            $name = $2;
        }

        #
        #  Only copy if the file doesn't already exist.
        #
        if ( ! ( -e $dest . "/" . $name ) )
        {
            File::Copy::cp( $file, $dest );
        }
    }

    print "Done\n";
}