lxc-conjure

#!/usr/bin/perl -w

use strict;
use warnings;
use Storable 'dclone';
use File::Basename;
use File::Temp qw/ :POSIX /;
use File::Slurp;
use Getopt::Long;
use Parallel::Runner;
use Net::Ping;

use Data::Dumper;

############################################################
#                                                          #
# Copyright (C) 2013 Mate1 Inc.                            #
#                                                          #
############################################################

=head1 NAME

lxc-conjure - Create complete lxc environments easily.

=head1 DESCRIPTION

B<lxc-conjure> is a wrapper around lxc-wizard that makes creating
complete environments via spell (definition) files quick
and pretty painless.

=head1 DEPENDENCIES

cpan -i Parallel::Runner
cpan -i Number::Spell
apt-get install libtie-ixhash-perl libfile-slurp-perl libfile-slurp-unicode-perl libmojolicious-perl libdata-section-simple-perl 

=cut

my ($help, $spell, $create, $start, $stop, $restart, $destroy, $info, $parallel);

GetOptions(
'help'    => \$help,
'spell=s' => \$spell,
'create'  => \$create,
'start'   => \$start,
'stop'    => \$stop,
'restart' => \$restart,
'destroy' => \$destroy,
'info'    => \$info,
'parallel'=> \$parallel,
);

help() if $help;

sub help {
	print <<EOF
Usage: $0 --spell <spell> <action>

  --spell     Spell (file) to get containers from.

  Actions:
  --create    Create containers.
  --start     Start containers.
  --stop      Stop containers.
  --restart   Restart containers.
  --destroy   Destroy containers.
  --info      Get containers' information.

  Spell enhancers:
  
  --parallel  Create containers in parallel across
              different hosts.
EOF
	;

	exit;
}

# set to 0 to run for real
my $DRYRUN = 0;

# environment specific settings

# required, the domain name that the environment's servers will have
my $DOMAIN  = "";

# required, the gateway address that the environment's servers will use
my $GATEWAY = "";

# required, the template that lxc-wizard will use (eg: debian/squeeze), 
# can be overridden per container
my $TEMPLATE = "";

# location of the lxc-wizard
my $WIZ = "sudo -- lxc-wizard";

# if set then this user is used to ssh into
# the host machines
my $USER="root@";

# ssh key that will be transfered to containers
# more configuration follows to determine what
# user accounts the key will go into
my $KEY="";

# where the profiles (postcreate) scripts are found.
# for now there is a limitation that the scripts must
# be on every host. we'll copy them over with us later.
my $PROFILE_HOME = "";

# default settings that will be used for every container.
my $DEFAULTS = {};

# containers to create.
# anything passed in here will override
# the default options.
my $CONTAINERS = [];

die ("No spell specified or spell not found.") if (!defined($spell) || ! -f $spell);
my $conf = read_file($spell);
eval $conf;
warn $@ if $@;

if ($create && $parallel) {
	# parallel creation
	my $hosts = {};

	for my $contoptions (@$CONTAINERS) {

		my $options = hash_merge($DEFAULTS, $contoptions);

		# TODO: this is duplicated further down, clean
		# cleanups and sanity checks 
		$options->{container} = $options->{fqdn} if !$options->{container};
		$options->{template} = $TEMPLATE if !$options->{template};


		push @{ $hosts->{$options->{containerhost}} }, $options;
	}

	my $runner = Parallel::Runner->new(scalar keys %$hosts);

	for my $host ( keys %$hosts ) {
		my $containers = $hosts->{$host};

		$runner->run( sub { wizard($_) foreach (@$containers) } );
	}

	$runner->finish();

} else {

	# serial execution
	CONT: foreach my $contoptions (@$CONTAINERS) {

		my $options = hash_merge($DEFAULTS, $contoptions);
	
		# TODO: this is duplicated above, clean
		# cleanups and sanity checks
		$options->{container} = $options->{fqdn} if !$options->{container};
		$options->{template} = $TEMPLATE if !$options->{template};

		next CONT if ($options->{ignore} && $options->{ignore} == 1);

		if    ($create)  { wizard($options);  }
		elsif ($info)    { info($options);    }
		elsif ($stop)    { stop($options);    }
		elsif ($start)   { start($options);   }
		elsif ($restart) { restart($options); }
		elsif ($destroy) { destroy($options); }
	}
}

sub sshrun {
	my ($ipaddr, $user, $p, $args) = @_;
	my $profile = "/tmp/" . $$ . "-" . basename($p);

	system("scp $p $user$ipaddr:$profile");
	system("ssh -t $user$ipaddr chmod +x $profile");
	system("ssh -t $user$ipaddr $profile " . $args);
}

sub hash_merge {
	my ($dest, $source) = @_;
	my $hash = dclone $dest;
	# source values overwrite dest values
	foreach my $key ( keys %$source ) { $hash->{$key} = $source->{$key} }

	return $hash;
}

sub lxc_command {
	
	my $options = shift;
	my $command = shift;
	my $conthost = $options->{containerhost};
	my $cmd = "ssh -t $USER$conthost -- lxc-$command -n " . $options->{container};

	return $cmd;
}

sub start {
	my $options = shift;
	my $cmd = lxc_command($options, "info");
	my $info = `$cmd`;

	if ($info =~ /STOPPED/) {
		$cmd = lxc_command($options, "start -d");
		system($cmd);
	} else {
		print "Not starting $options->{container}, not in STOPPED state.\n";
	}
}

sub stop {
	my $cmd = lxc_command(shift, "stop");
	system($cmd);
}

sub destroy {

	my $options = shift;

	# TODO: don't do this if it's not needed
	stop($options);
	sleep(2);

	my $conthost = $options->{containerhost};

	if ($options->{LVM} eq "Y") {

		# destroy the LVM volume
		
		my @vgs = `ssh -t $USER$conthost -- vgdisplay | grep Name`;
		$vgs[0] =~ /Name\s+(\w+)/;
		
		my $vgname = $1;
		my $lvname = $options->{container};
		my $volume = "/dev/mapper/$vgname-$lvname";
		my $mountpoint = "/var/lib/lxc/$lvname";

		print "Umounting Logical Volume...\n";
		system("ssh -t $USER$conthost -- umount $mountpoint");

		print "Removing Logical Volume...\n";
		system("ssh -t $USER$conthost -- lvremove -f $volume");

		print "Updating /etc/fstab...\n";
		# delete the line containing a slash followed by the lvname
		# for example: ... /var/lib/lxc/1.sender.tiamail.qa.blackhowler.gene ...
		system("ssh -t $USER$conthost -- sed -i '/\\\\\\/$lvname/d' /etc/fstab");

	} 

	system("ssh -t $USER$conthost -- rm -rf --preserve-root /var/lib/lxc/$options->{container}");
}

sub info {
	my $options = shift;
	my $cmd = lxc_command($options, "info");
	print $options->{container} . ":\n";
	system($cmd);
	print "\n";
}

sub restart {
	stop(@_);
	sleep 3;
	start(@_);
}

sub wizard {

	my $options = shift;
	my $conthost = $options->{containerhost};
	
	# if we're passed a "user" option, check if it's an array or 
	# a scalar. if it's an array it should container user:pass entries
	# otherwise it's a single user:pass entry.

	my $users = "";

	if ($options->{user}) {
		if (ref($options->{user}) eq "ARRAY") {
			for my $userpass (@{$options->{user}}) {
				$users .= "--user $userpass " if ($userpass =~ /(.+):(.+)/);
			}		
		} elsif (ref($options->{user}) eq "") {
			$users .= "--user " . $options->{user}. " ";
		}
	}

	my $postcreate = "";
	my $keys = "";

	# handle ssh keys if any
	if ($options->{key}) {
	
		if (ref($options->{key}) eq "ARRAY") {

			# we're passed multiple keys
			for my $userkey (@{$options->{key}}) {

				# copy key over and change key file accordingly
				my ($user, $keyfile) = split(/:/, $userkey);
				my $key = tmpnam() . $$ . ".key";
				system("scp $keyfile $USER$conthost:$key");
				$keys .= "--key $user:$key ";

			}

		} elsif (ref($options->{key}) eq "") { # we're passed one key			

			# copy key over and change key file accordingly
			my $userkey = $options->{key};
			my ($user, $keyfile) = split(/:/, $userkey);
			my $key = tmpnam() . $$ . ".key";
			system("scp $keyfile $USER$conthost:$key");
			$keys .= "--key $user:$key ";
		}
	}

	my $search = "";

	if ($options->{search}) {
		if (ref($options->{search}) eq "ARRAY") {
			for my $s (@{$options->{search}}) {
				$search .= "--search $s ";
			}
		} elsif (ref($options->{search}) eq "") {
			$users .= "--search " . $options->{search}. " ";
		}
	}

	my $extras = "";
	$extras = " -- " . $options->{"--"} if ($options->{"--"});

	# generate the final command
	my $cmd = <<EOF
	ssh -t $USER$conthost -- $WIZ \\
	--template $options->{template} \\
	--fqdn $options->{fqdn} \\
	--ipaddr $options->{ipaddr} \\
	--gwaddr $options->{gwaddr} \\
	--dnsdomain $options->{dnsdomain} \\
	$search \\
	--ns1 $options->{ns1} \\
	--ns2 $options->{ns2} \\
	--cpushares=$options->{cpushares} \\
	--ioweight=$options->{ioweight} \\
	--memory=$options->{memory} \\
	--container $options->{container} \\
	--SWAP=$options->{SWAP} \\
	--LVM=$options->{LVM} \\
	--lvsize=$options->{LVSize} \\
	--auto \\
	--rootpass $options->{rootpass} \\
	$users \\
	$keys \\
	$extras
EOF
	;

	if ($DRYRUN) { print($cmd . "\n"); }
	else { 

		system($cmd);

		if ($options->{profile} || $options->{deployscript}) {

			# wait for container to come up
			my $pingobj = Net::Ping->new("tcp");
		        $pingobj->port_number(22);
			while ( ! $pingobj->ping($options->{ipaddr}, 1) ) {
			    print ($options->{ipaddr} . " unreachable, wait more time\n");
			    sleep(2);
			}

#			if ($options->{startsleep}) { sleep ($options->{startsleep}) }
#			else { sleep 30 };
	
			if ($options->{profile}) {

				print("Running profile(s)...\n");
				
				# profiles can be scalars, in which case
				# we will take "--" as their args.
				# they can also be arrays, and have no args,
				# or they can be hashes, like this:
				# profile -> profile args
				my $r = ref($options->{profile});

				if ($r eq "ARRAY") {
					for my $p (@{$options->{profile}}) {
						my $NOARGS = "";
						sshrun($options->{ipaddr}, $USER, "$PROFILE_HOME/$p", $NOARGS);
					}
				} elsif ($r eq "HASH") {
					my $profiles = $options->{profile};
					for my $p (keys %$profiles) {
						my $args = $profiles->{$p};
						sshrun($options->{ipaddr}, $USER, "$PROFILE_HOME/$p", $args);
					}	
				} elsif ($r eq "") {
					my $p = $options->{profile};
					my $args = $options->{"--"} || "";
					sshrun($options->{ipaddr}, $USER, "$PROFILE_HOME/$p", $args);
				}
			}

			if ($options->{deployscript}) {

				print("Running deployscript...\n");
				my $depscript = $options->{deployscript};
				my $r = ref($depscript);

				if ($r eq "") {
					
					# scalar, should be a string representing a script			
					system($depscript);

				} elsif ($r eq "CODE") {

					# code, run it
					&$depscript();

				} elsif ($r eq "ARRAY" && scalar($depscript) > 0) {

					if (ref(@$depscript[0]) eq "CODE") {

						# callback, run it and pass params if any
						my $cb = @$depscript[0];

						if (scalar($depscript) > 1) {
							shift(@$depscript);
							&$cb(@$depscript);
						} else {
							&$cb();
						}
					}

				}
			}
		}
	}
	
}