#!/usr/bin/perl

# Copyright (c)2009 Roy Hooper rhooper@toybox.ca
# Distributed under the terms of the Perl Artistic License
# See http://dev.perl.org/licenses/artistic.html

use Date::Parse;
use strict;
use warnings;
use Data::Dumper;

my $server_host = "server";
my $server_pool = "zp1";
my $server_fs = shift || die "Usage: $0 filesystem";
my $server_ss_name = "daily";

my $local_pool = "zpool1";
my $local_fs = "backup/server/$server_fs";
my $local_num_snapshots = 15;

my $rate_limit = "700k";

my $debug = 0;

$ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/sbin:/sbin";

# gather snapshots on server
my @server_snapshots;
open(IN, "ssh $server_host zfs list -rH -t snapshot -o name,creation $server_pool/$server_fs |");
while (<IN>)
{
	parse_snapshot_entry($_, \@server_snapshots);
}

# gather snapshot data from localhost
my @local_snapshots;
open(IN, "zfs list -rH -t snapshot -o name,creation $local_pool/$local_fs |");
while (<IN>)
{
	parse_snapshot_entry($_, \@local_snapshots);
}

# link related snapshots in the metadata
my $seen_count = 0;
foreach my $server_ss (@server_snapshots)
{
	foreach my $local_ss (@local_snapshots)
	{
		if ($server_ss->{date} eq $local_ss->{date} && 
			$server_ss->{ss_name} eq $local_ss->{ss_name})
		{
			$server_ss->{local_ss} = $local_ss;
			$local_ss->{server_ss} = $server_ss;
			$seen_count++;
		}
	}
}

if ($seen_count == 0)
{
	warn Dumper({ 
		server => \@server_snapshots,
		local => \@local_snapshots
	});
		
	die "No snapshots match up locally or remotely: full backup probably required";
}

# purge snapshots we really don't care about (ones not named $server_ss_name)
@server_snapshots = grep { $_->{ss_name} eq $server_ss_name } @server_snapshots;
@local_snapshots = grep { $_->{ss_name} eq $server_ss_name } @local_snapshots;

sub ss_date_sort {	return $a->{date} <=> $b->{date} };

sub remove_unmatched
{
	my $var = shift;
	my $found_matched = 0;
	return grep {
		$found_matched++ if defined($_->{$var});
		print "skipping $_->{fs} because no $var found\n"
			if (!$found_matched && $debug);
		$found_matched;
	} sort ss_date_sort @_;
}

# Remove snapshots we don't care about from the list
@server_snapshots = remove_unmatched('local_ss', @server_snapshots);

# Finally, look for snapshots in the remote list we haven't seen yet.
my @unseen = grep { !defined $_->{local_ss}} @server_snapshots;

if (scalar(@unseen) == 0)
{
	print "No new snapshots to transfer.\n";
	exit 0;
}


foreach my $snapshot (@unseen)
{
	printf "Need to get %s from %s\n", $snapshot->{fs}, $snapshot->{date};
	do_backup($snapshot);
}

sub renumber_local
{
	@local_snapshots = sort { $a->{ss_number} <=> $b->{ss_number} } @local_snapshots;

	# Before renumbering, check that we haven't already got a .0
	if ($local_snapshots[0]->{ss_number} > 0) {
		print "There is no snapshot numbered 0, lowest is ".$local_snapshots[0]->{snapshot}.".\n";
		print "Not renaming any snapshots.\n";
		return;
	}
	
	# Iterate over snapshots in reverse choronoglical order
	foreach my $snapshot (reverse @local_snapshots)
	{
		# Delete excessive snapshots and renumber the rest
		if ($snapshot->{ss_number} >= $local_num_snapshots)
		{
			delete_snapshot($snapshot->{fs});
			$snapshot->{deleted} = 1;
		} else {
			my $newfs = sprintf("%s@%s.%d", 
				$snapshot->{ss_fs}, 
				$snapshot->{ss_name}, 
				$snapshot->{ss_number}+1);
			rename_snapshot($snapshot->{fs}, $newfs);
			foreach my $item (qw(fs snapshot ss_fs ss_name ss_number))
			{
				$snapshot->{"original_$item"} = $snapshot->{$item}
					if defined $snapshot->{$item};
			}
			$snapshot->{fs} = $newfs;
			$snapshot->{snapshot} = sprintf("%s.%d", 
				$snapshot->{ss_name}, 
				$snapshot->{ss_number}+1);
			$snapshot->{ss_number}++;
		}
	}
	@local_snapshots = grep { !defined $_->{deleted} } @local_snapshots;
}

sub rename_snapshot
{
	my ($old,$new) = @_;
	system_or_die("zfs","rename","$old","$new");
	print "Renamed $old to $new\n";
}

sub delete_snapshot
{
	my ($fs) = @_;
	die "cowardly refusing to delete '$fs' that is not a snapshot"
		unless $fs =~ /@/;
	
	system_or_die("zfs","destory",$fs);
	print "Destroyed $fs\n";
}

sub do_backup
{
	my $ss = shift;
	renumber_local;
	
	# Finally, establish the pipeline to do the backup!
	my $target_fs = sprintf("%s/%s@%s.%d", $local_pool, $local_fs, $ss->{ss_name}, 0);
	my $rlcmd = $rate_limit ? "\\| pv -L $rate_limit" : "";
	my $command = sprintf("ssh $server_host zfs send -i %s %s \\| gzip -9 $rlcmd | ".
		"gunzip -dc | zfs recv -Fv %s", 
			sprintf("%s@%s.%d", $ss->{ss_fs}, $ss->{ss_name}, $ss->{ss_number}+1),
			$ss->{fs}, 
			$target_fs);
	system_or_die($command);
}

sub parse_snapshot_entry
{
	my ($line, $ss_array) = @_;
	print $line if $debug;
	chomp($line);
	my ($fs,$date) = split(/\t/, $line);
	return unless defined($date);
	$date = str2time($date);
	return unless defined($date);
	my ($fs_part,$snapshot) = split(/\@/, $fs);
	my ($snapshot_name, $snapshot_number) = split(/\./, $snapshot);

	push @$ss_array,
		{
			fs => $fs,
			date => $date,
			snapshot => $snapshot,
			ss_fs => $fs_part,
			ss_name => $snapshot_name,
			ss_number => $snapshot_number,
		};
}

sub system_or_die
{
	my @args = @_;
	my $cmd = join(" ", @args);

	print "running $cmd\n";
	
	unless (system(@args) == 0)
	{
        if ($? == -1) {
            die "failed to execute: $cmd: $!\n";
        }
        elsif ($? & 127) {
            die sprintf("$cmd died with signal %d, %s coredump\n",
                ($? & 127),  ($? & 128) ? 'with' : 'without');
        }
        else {
            die sprintf("$cmd exited with value %d\n", $? >> 8);
        }
	}	
}