#!/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.
   --config         Read the specified config file in addition to the global
                    configuration file.
   --mirror         The mirror to use when installing with 'debootstrap'.

  Installation Options:
   --install-method  Specify the installation method to use.
   --install-source  Specify the installation source to use.
   --debootstrap-cmd Specify which debootstrap command to
                     use. Defaults to debootstrap if both, debootstrap
                     and cdebootstrap are installed.

  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<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>.

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

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

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

=item B<tar>
Untar a .tar file into the new installation location.  This tarfile is assumed to contain a complete archived system.   Specify the directory to copy with the B<--install-source> argument.

=back

=cut


=head1 AUTHOR

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

=cut


=head1 LICENSE

Copyright (c) 2005-2009 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 = '4.2rc2';


#
# Dispatch table mapping installation types to their names.
#
# The names are the methods, and the hash keys are:
#
#  sub           The routine to execute.
#  needBinary    If set the name of an executable we need to exist.
#  needFile      Defined if we need an install-source file specified.
#  needDirectory Defined if we need an install-source directory specified.
#
#
my %dispatch = (
                 "copy" => { sub           => \&do_copy,
                             needBinary    => "/bin/cp",
                             needDirectory => 1,
                           },
                 "debootstrap" => { sub        => \&do_debootstrap,
                                    needBinary => "/usr/sbin/debootstrap",
                                  },
                 "rinse" => { sub        => \&do_rinse,
                              needBinary => "/usr/sbin/rinse",
                            },
                 "rpmstrap" => { sub        => \&do_rpmstrap,
                                 needBinary => "/usr/bin/rpmstrap",
                               },
                 "tar" => { sub        => \&do_tar,
                            needBinary => "/bin/tar",
                            needFile   => 1,
                          } );



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


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


#
#  If we received a configuration file then read it.
#
if ( $CONFIG{ 'config' } )
{
    my $path = $CONFIG{ 'config' };

    # If not fully-qualified then read from /etc/xen-tools.
    if ( $path !~ /^[\/]/ )
    {
        $path = "/etc/xen-tools/" . $path;
    }

    # Read the file, if it exists.
    readConfigurationFile($path) if ( -e $path );
}


#
#  Check our arguments
#
checkArguments();


#
#  Now lookup our installation type and dispatch control to it.
#
if ( defined( $CONFIG{ 'install-method' } ) &&
     length( $CONFIG{ 'install-method' } ) )
{

    #
    #  Get the entry from the dispatch table.
    #
    my $installer = $dispatch{ lc( $CONFIG{ 'install-method' } ) };

    if ( defined($installer) )
    {

        #
        #  If we found it.
        #

        # Do we need to test for a binary.
        if ( ( $installer->{ 'needBinary' } ) &&
             ( !-x $installer->{ 'needBinary' } ) )
        {
            print
              "The following required binary for the installation was not found\n";
            print "\t" . $installer->{ 'needBinary' } . "\n";
            exit 1;
        }

        # Do we need a directory specified as the installation source?
        if ( ( $installer->{ 'needDirectory' } ) &&
             ( !$CONFIG{ 'install-source' } || !-d $CONFIG{ 'install-source' } )
           )
        {
            print "Please specify the source directory with --install-source\n";
            if ( $CONFIG{ 'install-source' } )
            {
                print
                  "The specified directory $CONFIG{'install-source'} does not exist.\n";
            }
            exit 1;
        }

        # Do we need a file specified as the installation source?
        if ( ( $installer->{ 'needFile' } ) &&
             ( !$CONFIG{ 'install-source' } || !-e $CONFIG{ 'install-source' } )
           )
        {
            print "Please specify the source file with --install-source\n";

            if ( $CONFIG{ 'install-source' } )
            {
                print
                  "The specified file $CONFIG{'install-source'} does not exist.\n";
            }
            exit 1;
        }

        #
        #  Now we can call the appropriate handler.
        #
        $installer->{ 'sub' }->();

        #
        #  Did the operation succeed?
        #
        #  Test that we have some "standard" files present.
        #

        checkForCommonFilesInChroot($CONFIG{ 'location' },
                                    "installed system");

        #
        #  All done.
        #
        exit 0;
    }
    else
    {
        print "The installation method specified is invalid.\n";
        exit 1;
    }
}
else
{
    print "An installation method is mandatory\n";
    exit 1;
}



=begin doc

  Read the specified configuration file, and update our global configuration
 hash with the values found in it.

=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+$//;

            # command expansion?
            if ( $val =~ /(.*)`([^`]+)`(.*)/ )
            {

                # store
                my $pre  = $1;
                my $cmd  = $2;
                my $post = $3;

                # get output
                my $output = `$cmd`;
                chomp($output);

                # build up replacement.
                $val = $pre . $output . $post;
            }

            # 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' },

        # Installation method
        "install-method=s", \$CONFIG{ 'install-method' },
        "install-source=s", \$CONFIG{ 'install-source' },
        "debootstrap-cmd=s", \$CONFIG{ 'debootstrap-cmd' },

        # Misc
        "arch=s",   \$CONFIG{ 'arch' },
        "cache=s",  \$CONFIG{ 'cache' },
        "cachedir=s", \$CONFIG{ 'cachedir' },
        "config=s", \$CONFIG{ 'config' },
        "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.65 $';
        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 are trying to configure an installation of $CONFIG{'dist'} in
 $CONFIG{'location'} - but there is no hook directory for us to use.

  This means we would not know how to configure this installation.

  We would expect the hook directory to be $dir.

  Aborting.
E_OR
        exit 1;
    }


    #
    #  Test that we received a valid installation type.
    #
    my $valid = 0;
    if ( defined( $CONFIG{ 'install-method' } ) )
    {
        foreach my $recognised ( keys %dispatch )
        {
            $valid = 1
              if ( lc( $CONFIG{ 'install-method' } ) eq lc($recognised) );
        }
    }
    else
    {
        $valid = 1;
    }

    if ( !$valid )
    {
        print <<EOF;
  Please specify the installation method to use.

  For example:

     --install-method=copy        --install-source=/some/path
     --install-method=debootstrap
     --install-method=rpmstrap
     --install-method=tar         --install-source=/some/file.tar

EOF
        exit;
    }

}



=begin doc

  Check if there are some common files in some chroot

=end doc

=cut

sub checkForCommonFilesInChroot {
    my ($chroot, $what) = @_;
    foreach my $file (qw( /bin/ls /bin/cp ))
    {
        if ( !-x $chroot.$file )
        {
            print STDERR <<EOT;
WARNING ($0): The $what at $chroot doesn\'t seem to be a full system.
WARNING ($0): The $what is missing the common file: $file.
EOT
        }
    }
}



=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 127;
    }

    #
    #  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";
}



###
#
#  Installation functions follow.
#
###



=begin doc

  Install a new image of a distribution using `cp`.

=end doc

=cut

sub do_copy
{

    #
    #  Check if the copy source has at least some "standard" files present.
    #
    checkForCommonFilesInChroot($CONFIG{ 'install-source' },
                                "installation source");

    #
    #  Find the copy command to run from the configuration file.
    #
    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{'install-source'}/g;
    $cmd =~ s/\$dest/$CONFIG{'location'}/g;

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



=begin doc

  Install a new image of Debian using 'debootstrap'.

=end doc

=cut

sub do_debootstrap
{

    #
    #  The command is a little configurable - mostly to allow you
    # to use cdebootstrap.
    #
    my $cmd = $CONFIG{ 'debootstrap-cmd' };
    my $cachedir = $CONFIG{ 'cachedir' };
    if ( !$cmd )
    {
        if (-x '/usr/sbin/debootstrap') {
            $cmd = '/usr/sbin/debootstrap';
        } elsif (-x '/usr/sbin/cdebootstrap') {
            $cmd = '/usr/sbin/cdebootstrap';
        } else {
            print STDERR "Found neither debootstrap nor cdebootstrap and no --debootstrap-cmd given\n";
            exit 1;
        }
        print "Using $cmd as debootstrap command\n";
    }


    #
    #  Cache from host -> new installation if we've got caching
    # enabled.
    #
    if ( $CONFIG{ 'cache' } eq "yes" )
    {
        print "\nCopying files from host to image.\n";
        unless( -d $cachedir ) {
            my $xtcache = '/var/cache/xen-tools/archives/';
            print("$cachedir not found, defaulting to $xtcache\n");
            unless ( -d $xtcache ) {
                system "mkdir -p $xtcache";
            }
            $cachedir = $xtcache;
        }
        runCommand("mkdir -p $CONFIG{'location'}/var/cache/apt/archives");
        copyDebFiles( "$cachedir",
                      "$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 =
      "$cmd $EXTRA $CONFIG{'dist'} $CONFIG{'location'} $CONFIG{'mirror'}";

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


    #
    #  Cache from the new installation -> the host 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",
                      "$cachedir" );
        print("Done\n");
    }


}



=begin doc

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

=end doc

=cut

sub do_rinse
{

    #
    #  The command we're going to run.
    #
    my $command =
      "rinse --distribution=$CONFIG{'dist'} --directory=$CONFIG{'location'}";

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


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

    runCommand($command);
}



=begin doc

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

=end doc

=cut

sub do_rpmstrap
{

    #
    #  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'}";
    }

    #
    #  Setup mirror if present.
    #
    my $mirror = "";
    $mirror = $CONFIG{ 'mirror' } if ( $CONFIG{ 'mirror' } );

    #
    #  The command we're going to run.
    #
    my $command = "rpmstrap $EXTRA $CONFIG{'dist'} $CONFIG{'location'} $mirror";
    runCommand($command);
}



=begin doc

  Install a new image of a distribution using `tar`.

=end doc

=cut

sub do_tar
{

    #
    #  Find the tar command to run from the configuration file.
    #
    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{'install-source'}/g;

    #
    #  Run a command to copy an installed system into the new root.
    #
    runCommand("cd $CONFIG{'location'} && $cmd");
}