root/zetaback.in

#!/usr/bin/perl
# vim: sts=2 sw=2 ts=8 et

# Copyright (c) 2007 OmniTI Computer Consulting, Inc. All rights reserved.
# For information on licensing see:
#   https://labs.omniti.com/zetaback/trunk/LICENSE

use strict;
use Getopt::Long;
use MIME::Base64;
use POSIX qw/strftime/;
use Fcntl qw/:flock/;
use File::Copy;
use IO::File;
use Pod::Usage;

use vars qw/%conf %locks $version_string
            $PREFIX $CONF $BLOCKSIZE $DEBUG $HOST $BACKUP
            $RESTORE $RESTORE_HOST $RESTORE_ZFS $TIMESTAMP
            $LIST $SUMMARY $SUMMARY_EXT $SUMMARY_VIOLATORS
            $FORCE_FULL $FORCE_INC $EXPUNGE $NEUTERED $ZFS
            $SHOW_FILENAMES $ARCHIVE $VERSION $HELP/;
$version_string = q$URL$;
$version_string =~ s#/branches/#/b#;
$version_string =~ s#^.*/([^/]+)/[^/]+$#$1#;
$PREFIX = q^__PREFIX__^;
$CONF = qq^$PREFIX/etc/zetaback.conf^;
$BLOCKSIZE = 1024*64;

$conf{'default'}->{'time_format'} = "%Y-%m-%d %H:%M:%S";
$conf{'default'}->{'retention'} = 14 * 86400;
$conf{'default'}->{'compressionlevel'} = 1;
$conf{'default'}->{'dataset_backup'} = 0;

=pod

=head1 NAME

zetaback - perform backup, restore and retention policies for ZFS backups.

=head1 SYNOPSIS

  zetaback -v

  zetaback [-l | -s | -sx | -sv] [--files] [-c conf] [-d] [-h host] [-z zfs]

  zetaback -a [-c conf] [-d] [-h host] [-z zfs]

  zetaback -b [-ff] [-fi] [-x] [-c conf] [-d] [-n] [-h host] [-z zfs]

  zetaback -x [-b] [-c conf] [-d] [-n] [-h host] [-z zfs]

  zetaback -r [-c conf] [-d] [-n] [-h host] [-z zfs] [-t timestamp]
              [-rhost host] [-rzfs fs]

=cut

GetOptions(
  "h=s"     => \$HOST,
  "z=s"     => \$ZFS,
  "c=s"     => \$CONF,
  "a"       => \$ARCHIVE,
  "b"       => \$BACKUP,
  "l"       => \$LIST,
  "s"       => \$SUMMARY,
  "sx"      => \$SUMMARY_EXT,
  "sv"      => \$SUMMARY_VIOLATORS,
  "r"       => \$RESTORE,
  "t=i"     => \$TIMESTAMP,
  "rhost=s" => \$RESTORE_HOST,
  "rzfs=s"  => \$RESTORE_ZFS,
  "d"       => \$DEBUG,
  "n"       => \$NEUTERED,
  "x"       => \$EXPUNGE,
  "v"       => \$VERSION,
  "ff"      => \$FORCE_FULL,
  "fi"      => \$FORCE_INC,
  "files"   => \$SHOW_FILENAMES,
);

# actions allowed together 'x' and 'b' all others are exclusive:
my $actions = 0;
$actions++ if($ARCHIVE);
$actions++ if($BACKUP || $EXPUNGE);
$actions++ if($RESTORE);
$actions++ if($LIST);
$actions++ if($SUMMARY);
$actions++ if($SUMMARY_EXT);
$actions++ if($SUMMARY_VIOLATORS);
$actions++ if($VERSION);
$actions++ if($BACKUP && $FORCE_FULL && $FORCE_INC);
if($actions != 1) {
  pod2usage({ -verbose => 0 });
  exit -1;
}

=pod

=head1 DESCRIPTION

The B<zetaback> program orchestrates the backup (either full or
incremental) of remote ZFS filesystems to a local store.  It handles
frequency requirements for both full and incemental backups as well
as retention policies.  In addition to backups, the B<zetaback> tool
allows for the restore of any backup to a specified host and zfs
filesystem.

=head1 OPTIONS

The non-optional action command line arguments define the invocation purpose
of B<zetaback>.  All other arguments are optional and refine the target
of the action specified.

=head2 Generic Options

The following arguments have the same meaning over several actions:

=over

=item -c <conf>

Use the specified file as the configuration file.  The default file, if
none is specified is /usr/local/etc/zetaback.conf.  The prefix of this 
file may also be specified as an argument to the configure script.

=item -d

Enable debugging output.

=item -n

Don't actually perform any remote commands or expunging.  This is useful with
the -d argument to ascertain what would be done if the command was actually
executed.

=item -t <timestamp>

Used during the restore process to specify a backup image from the desired 
point in time.  If omitted, the command becomes interactive.  This timestamp
is a UNIX timestamp and is shown in the output of the -s and -sx actions.

=item -rhost <host>

Specify the remote host that is the target for a restore operation.  If
omitted the command becomes interactive.

=item -rzfs <zfs>

Specify the remote ZFS filesystem that is the target for a restore
operation.  If omitted the command becomes interactive.

=item -h <host>

Filters the operation to the host specified.  If <host> is of the form
/pattern/, it matches 'pattern' as a perl regular expression against available
hosts.  If omitted, no limit is enforced and all hosts are used for the action.

=item -z <zfs>

Filters the operation to the zfs filesystem specified.  If <zfs> is of the
form /pattern/, it matches 'pattern' as a perl regular expression against
available zfs filesystems.  If omitted, no filter is enforced and all zfs 
filesystems are used for the action.

=back

=head2 Actions

=over

=item -v

Show the version.

=item -l

Show a brief listing of available backups.

=item -s

Like -l, -s will show a list of backups but provides additional information
about the backups including timestamp, type (full or incremental) and the
size on disk.

=item -sx

Shows an extended summary.  In addition to the output provided by the -s
action, the -sx action will show detail for each availble backup.  For
full backups, the detail will include any more recent full backups, if
they exist.  For incremental backups, the detail will include any
incremental backups that are more recent than the last full backup. 

=item -sv

Display all backups in the current store that violate the configured 
backup policy. This is where the most recent full backup is older than
full_interval seconds ago, or the most recent incremental backup is older
than backup_interval seconds ago.

=item --files

Display the on-disk file corresponding to each backup named in the output.
This is useful with the -sv flag to name violating files.  Often times, 
violators are filesystems that have been removed on the host machines and 
zetaback can no longer back them up.  Be very careful if you choose to 
automate the removal of such backups as filesystems that would be backed up 
by the next regular zetaback run will often show up as violators.

=item -a

Performs an archive.  This option will look at all eligible backup points
(as restricted by -z and -h) and move those to the configured archive
directory.  The recommended use is to first issue -sx --files then
carefully review available backup points and prune those that are
unneeded.  Then invoke with -a to move only the remaining "desired"
backup points into the archives.  Archived backups do not appear in any
listings or in the list of policy violators generated by the -sv option.
In effect, they are no longer "visible" to zetaback.

=item -b

Performs a backup.  This option will investigate all eligible hosts, query
the available filesystems from the remote agent and determine if any such
filesystems require a new full or incremental backup to be taken.  This
option may be combined with the -x option (to clean up afterwards.)

=item -ff

Forces a full backup to be taken on each filesystem encountered.  This is 
used in combination with -b.  It is recommended to use this option only when
targeting specific filesystems (via the -h and -z options.)  Forcing a full
backup across all machines will cause staggered backups to coalesce and
could cause performance issues.

=item -fi

Forces an incremental backup to be taken on each filesystem encountered.  
This is used in combination with -b.  It is recommended to use this option 
only when targeting specific filesystems (via the -h and -z options.)  Forcing 
an incremental backup across all machines will cause staggered backups 
to coalesce and could cause performance issues.

=item -x

Perform an expunge.  This option will determine which, if any, of the local
backups may be deleted given the retention policy specified in the
configuration.

=item -r

Perform a restore.  This option will operate on the specified backup and
restore it to the ZFS filesystem specified with -rzfs on the host specified
with the -rhost option.  The -h, -z and -t options may be used to filter
the source backup list.  If the filtered list contains more than one
source backup image, the command will act interactively.  If the -rhost
and -rzfs command are not specified, the command will act interactively.

=back

=cut

if($VERSION) {
  print "zetaback: $version_string\n";
  exit 0;
}

=pod

=head1 CONFIGURATION

The zetaback configuration file consists of a default stanza, containing
settings that can be overridden on a per-host basis.  A stanza begins
either with the string 'default', or a fully-qualified hostname, with 
settings enclosed in braces ({}).  Single-line comments begin with a hash
('#'), and whitespace is ignored, so feel free to indent for better
readability.  Every host to be backed up must have a host stanza in the
configuration file.

=head2 Settings

The following settings are valid in both the default and host scopes:

=over

=item store

The base directory under which to keep backups.  An interpolated variable
'%h' can be used, which expands to the hostname.  There is no default for
this setting.

=item archive

The base directory under which archives are stored.  The format is the same
as the store setting.  This is the destination to which files are relocated 
when issuing an archive action (-a).

=item agent

The location of the zetaback_agent binary on the host.  There is no default
for this setting.

=item time_format

All timestamps within zetaback are in UNIX timestamp format.  This setting
provides a string for formatting all timestamps on output.  The sequences
available are identical to those in strftime(3).  If not specified, the
default is '%Y-%m-%d %H:%M:%S'.

=item backup_interval

The frequency (in seconds) at which to perform incremental backups.  An 
incremental backup will be performed if the current time is more than 
backup_interval since the last incremental backup.  If there is no full backup
for a particular filesystem, then a full backup is performed.  There is no 
default for this setting.

=item full_interval

The frequency (in seconds) at which to perform full backups.  A full backup will
be performed if the current time is more than full_interval since the last full 
backup.

=item retention

The retention time (in seconds) for backups.  This can be a simple number, in
which case all backups older than this will be expunged.

The retention specification can also be more complex, and consist of pairs of
values separated by a comma. The first value is a time period in seconds, and
the second value is how many backups should be retained within that period.
For example:

retention = 3600,4;86400,11

This will keep up to 4 backups for the first hour, and an additional 11
backups over 24 hours. The times do not stack. In other words, the 11 backups
would be kept during the period from 1 hour old to 24 hours old, or one every
2 hours.

Any backups older than the largest time given are deleted. In the above
example, all backups older than 24 hours are deleted.

If a second number is not specified, then all backups are kept within that
period.

Note: Full backups are never deleted if they are depended upon by an
incremental. In addition, the most recent backup is never deleted, regardless
of how old it is.

This value defaults to (14 * 86400), or two weeks.

=item compressionlevel

Compress files using gzip at the specified compression level. 0 means no
compression. Accepted values are 1-9. Defaults to 1 (fastest/minimal
compression.)

=item ssh_config

Full path to an alternate ssh client config.  This is useful for specifying a
less secure but faster cipher for some hosts, or using a different private 
key.  There is no default for this setting.

=item dataset_backup

By default zetaback backs zfs filesystems up to files. This option lets you
specify that the backup go be stored as a zfs dataset on the backup host.

=item offline

Setting this option to 1 for a host will mark it as being 'offline'. Hosts
that are marked offline will not be backed up, will not have any old backups
expunged and will not be included in the list of policy violators. However,
the host will still be shown when listing backups and archiving.

=back

=head1 CONFIGURATION EXAMPLES

=head2 Uniform hosts

This config results in backups stored in /var/spool/zfs_backups, with a
subdirectory for each host.  Incremental backups will be performed
approximately once per day, assuming zetaback is run hourly.  Full backups
will be done once per week.  Time format and retention are default.

  default {
    store = /var/spool/zfs_backups/%h
    agent = /usr/local/bin/zetaback_agent
    backup_interval = 83000
    full_interval = 604800
  }

  host1 {}

  host2 {}

=head2 Non-uniform hosts

Here, host1's and host2's agents are found in different places, and host2's
backups should be stored in a different path.

  default {
    store = /var/spool/zfs_backups/%h
    agent = /usr/local/bin/zetaback_agent
    backup_interval = 83000
    full_interval = 604800
  }

  host1 {
    agent = /opt/local/bin/zetaback_agent
  }

  host2 {
    store = /var/spool/alt_backups/%h
    agent = /www/bin/zetaback_agent
  }

=cut

# Make the parser more formal:
# config => stanza*
# stanza => string { kvp* }
# kvp    => string = string
my $str_re = qr/(?:"(?:\\\\|\\"|[^"])*"|\S+)/;
my $kvp_re = qr/($str_re)\s*=\s*($str_re)/;
my $stanza_re = qr/($str_re)\s*\{((?:\s*$kvp_re)*)\s*\}/;

sub parse_config() {
  local($/);
  $/ = undef;
  open(CONF, "<$CONF") || die "Unable to open config file: $CONF";
  my $file = <CONF>;
  # Rip comments
  $file =~ s/^\s*#.*$//mg;
  while($file =~ m/$stanza_re/gm) {
    my $scope = $1;
    my $filepart = $2;
    $scope =~ s/^"(.*)"$/$1/;
    $conf{$scope} ||= {};
    while($filepart =~ m/$kvp_re/gm) {
      my $key = $1;
      my $value = $2;
      $key =~ s/^"(.*)"$/$1/;
      $value =~ s/^"(.*)"$/$1/;
      $conf{$scope}->{lc($key)} = $value;
    }
  }
  close(CONF);
}
sub config_get($$;$) {
  # Params: host, key, class
  # Order of precedence: class, host, default
  if ($_[2]) {
    return $conf{$_[2]}->{$_[1]} || $conf{$_[0]}->{$_[1]} ||
        $conf{'default'}->{$_[1]};
  } else {
    return $conf{$_[0]}->{$_[1]} || $conf{'default'}->{$_[1]};
  }
}

sub get_store($;$) {
  my ($host, $class) = @_;
  my $store = config_get($host, 'store', $class);
  $store =~ s/%h/$host/g;;
  mkdir $store if(! -d $store);
  return $store;
}

sub fs_encode($) {
  my $d = shift;
  my @parts = split('@', $d);
  my $e = encode_base64($parts[0], '');
  $e =~ s/\//_/g;
  $e =~ s/=/-/g;
  $e =~ s/\+/\./g;
  if (exists $parts[1]) {
    $e .= "\@$parts[1]";
  }
  return $e;
}
sub fs_decode($) {
  my $e = shift;
  $e =~ s/_/\//g;
  $e =~ s/-/=/g;
  $e =~ s/\./\+/g;
  return decode_base64($e);
}
sub dir_encode($) {
  my $d = shift;
  my $e = encode_base64($d, '');
  $e =~ s/\//_/;
  return $e;
}
sub dir_decode($) {
  my $e = shift;
  $e =~ s/_/\//;
  return decode_base64($e);
}
sub pretty_size($) {
  my $bytes = shift;
  if($bytes > 1024*1024*1024) {
    return sprintf("%0.2f Gb", $bytes / (1024*1024*1024));
  }
  if($bytes > 1024*1024) {
    return sprintf("%0.2f Mb", $bytes / (1024*1024));
  }
  if($bytes > 1024) {
    return sprintf("%0.2f Kb", $bytes / (1024));
  }
  return "$bytes b";
}
sub lock($;$$) {
  my ($host, $file, $nowait) = @_;
  print "Acquiring lock for $host:$file\n" if($DEBUG);
  $file ||= 'master.lock';
  my $store = get_store($host); # Don't take classes into account - not needed
  return 1 if(exists($locks{"$host:$file"}));
  open(LOCK, "+>>$store/$file") || return 0;
  unless(flock(LOCK, LOCK_EX | ($nowait ? LOCK_NB : 0))) {
    close(LOCK);
    return 0;
  }
  $locks{"$host:$file"} = \*LOCK;
  return 1;
}
sub unlock($;$$) {
  my ($host, $file, $remove) = @_;
  print "Releasing lock for $host:$file\n" if($DEBUG);
  $file ||= 'master.lock';
  my $store = get_store($host); # Don't take classes into account - not needed
  return 0 unless(exists($locks{"$host:$file"}));
  *UNLOCK = $locks{$file};
  unlink("$store/$file") if($remove);
  flock(UNLOCK, LOCK_UN);
  close(UNLOCK);
  return 1;
}
sub scan_for_backups($) {
  my %info = ();
  my $dir = shift;
  $info{last_full} = $info{last_incremental} = $info{last_backup} = 0;
  # Look for standard file based backups first
  opendir(D, $dir) || return \%info;
  foreach my $file (readdir(D)) {
    if($file =~ /^(\d+)\.([^\.]+)\.full$/) {
      my $whence = $1;
      my $fs = dir_decode($2);
      $info{$fs}->{full}->{$whence}->{'file'} = "$dir/$file";
      $info{$fs}->{last_full} = $whence if($whence > $info{$fs}->{last_full});
      $info{$fs}->{last_backup} = $info{$fs}->{last_incremental} > $info{$fs}->{last_full} ?
                                     $info{$fs}->{last_incremental} : $info{$fs}->{last_full};
    }
    elsif($file =~ /^(\d+).([^\.]+)\.incremental.(\d+)$/) {
      my $whence = $1;
      my $fs = dir_decode($2);
      $info{$fs}->{incremental}->{$whence}->{'depends'} = $3;
      $info{$fs}->{incremental}->{$whence}->{'file'} = "$dir/$file";
      $info{$fs}->{last_incremental} = $whence if($whence > $info{$fs}->{last_incremental});
      $info{$fs}->{last_backup} = $info{$fs}->{last_incremental} > $info{$fs}->{last_full} ?
                                     $info{$fs}->{last_incremental} : $info{$fs}->{last_full};
    }
  }
  closedir(D);
  # Now look for zfs based backups
  my $storefs;
  eval {
    $storefs = get_fs_from_mountpoint($dir);
  };
  return \%info if ($@);
  my $rv = open(ZFSLIST, "__ZFS__ list -H -r -t snapshot $storefs |");
  return \%info unless $rv;
  while (<ZFSLIST>) {
      my @F = split(' ');
      my ($rawfs, $snap) = split('@', $F[0]);
      my ($whence) = ($snap =~ /(\d+)/);
      next unless $whence;
      my @fsparts = split('/', $rawfs);
      my $fs = fs_decode($fsparts[-1]);
      # Treat a dataset backup as a full backup from the point of view of the
      # backup lists
      $info{$fs}->{full}->{$whence}->{'snapshot'} = $snap;
      $info{$fs}->{full}->{$whence}->{'dataset'} = "$rawfs\@$snap";
      # Note - this field isn't set for file backups - we probably should do
      # this
      $info{$fs}->{full}->{$whence}->{'pretty_size'} = "$F[1]";
      $info{$fs}->{last_full} = $whence if ($whence >
          $info{$fs}->{last_full});
      $info{$fs}->{last_backup} = $whence if ($whence >
          $info{$fs}->{last_backup});
  }
  close(ZFSLIST);

  return \%info;
}

parse_config();

sub zetaback_log($$;@) {
  my ($host, $mess, @args) = @_;
  my $tf = config_get($host, 'time_format');
  my $file = config_get($host, 'logfile');
  my $fileh;
  if(defined($file)) {
    $fileh = IO::File->new(">>$file");
  }
  $fileh ||= IO::File->new(">&STDERR");
  printf $fileh "%s: $mess", strftime($tf, localtime(time)), @args;
  $fileh->close();
}

sub zfs_remove_snap($$$) {
  my ($host, $fs, $snap) = @_;
  my $agent = config_get($host, 'agent');
  my $ssh_config = config_get($host, 'ssh_config');
  $ssh_config = "-F $ssh_config" if($ssh_config);
  print "Using custom ssh config file: $ssh_config\n" if($DEBUG);
  return unless($snap);
  print "Dropping $snap on $fs\n" if($DEBUG);
  `ssh $ssh_config $host $agent -z $fs -d $snap`;
}

# Lots of args.. internally called.
sub zfs_do_backup($$$$$$;$) {
  my ($host, $fs, $type, $point, $store, $dumpname, $base) = @_;
  my ($storefs, $encodedname);
  my $agent = config_get($host, 'agent');
  my $ssh_config = config_get($host, 'ssh_config');
  $ssh_config = "-F $ssh_config" if($ssh_config);
  print "Using custom ssh config file: $ssh_config\n" if($DEBUG);

  # compression is meaningless for dataset backups
  if ($type ne "s") {
    my $cl = config_get($host, 'compressionlevel');
    if ($cl >= 1 && $cl <= 9) {
        open(LBACKUP, "|gzip -$cl >$store/.$dumpname") ||
        die "zfs_full_backup: cannot create dump\n";
    } else {
        open(LBACKUP, ">$store/.$dumpname") ||
        die "zfs_full_backup: cannot create dump\n";
    }
  } else {
    # Dataset backup - pipe received filesystem to zfs recv
    eval {
      $storefs = get_fs_from_mountpoint($store);
    };
    if ($@) {
      # The zfs filesystem doesn't exist, so we have to work out what it
      # would be
      my $basestore = config_get($host, 'store');
      $basestore =~ s/\/?%h//g;
      $storefs = get_fs_from_mountpoint($basestore);
      $storefs="$storefs/$host";
    }
    $encodedname = fs_encode($dumpname);
    print STDERR "Receiving to zfs filesystem $storefs/$encodedname\n"
      if($DEBUG);
    zfs_create_intermediate_filesystems("$storefs/$encodedname");
    open(LBACKUP, "|__ZFS__ recv $storefs/$encodedname");
  }
  # Do it. yeah.
  eval {
    if(my $pid = fork()) {
      close(LBACKUP);
      waitpid($pid, 0);
      die "error: $?" if($?);
    }
    else {
      my @cmd = ('ssh', split(/ /, $ssh_config), $host, $agent, '-z', $fs);
      if ($type eq "i" || ($type eq "s" && $base)) {
        push @cmd, ("-i", $base);
      }
      if ($type eq "f" || $type eq "s") {
        push @cmd, ("-$type", $point);
      }
      open STDIN, "/dev/null" || exit(-1);
      open STDOUT, ">&LBACKUP" || exit(-1);
      print STDERR "   => @cmd\n" if($DEBUG);
      exec { $cmd[0] } @cmd;
      print STDERR "$cmd[0] failed: $?\n";
      exit($?);
    }
    if ($type ne "s") {
      die "dump failed (zero bytes)\n" if(-z "$store/.$dumpname");
      rename("$store/.$dumpname", "$store/$dumpname") || die "cannot rename dump\n";
    } else {
      # Check everything is ok
      `__ZFS__ list $storefs/$encodedname`;
      die "dump failed (received snapshot $storefs/$encodedname does not exist)\n"
        if $?;
    }
  };
  if($@) {
    if ($type ne "s") {
        unlink("$store/.$dumpname");
    }
    chomp(my $error = $@);
    $error =~ s/[\r\n]+/ /gsm;
    zetaback_log($host, "FAILED[$error] $host:$fs $type\n");
    die "zfs_full_backup: failed $@";
  }
  my $size;
  if ($type ne "s") {
    my @st = stat("$store/$dumpname");
    $size = pretty_size($st[7]);
  } else {
    $size = `__ZFS__ get -Ho value used $storefs/$encodedname`;
    chomp $size;
  }
  zetaback_log($host, "SUCCESS[$size] $host:$fs $type\n");
}

sub zfs_create_intermediate_filesystems($) {
  my ($fs) = @_;
  my $idx=0;
  while (($idx = index($fs, '/', $idx+1)) != -1) {
      my $fspart = substr($fs, 0, $idx);
      `__ZFS__ list $fspart 2>&1`;
      if ($?) {
        print STDERR "Creating intermediate zfs filesystem: $fspart\n"
          if $DEBUG;
        `__ZFS__ create $fspart`;
      }
  }
}

sub zfs_full_backup($$$) {
  my ($host, $fs, $store) = @_;

  # Translate into a proper dumpname
  my $point = time();
  my $efs = dir_encode($fs);
  my $dumpname = "$point.$efs.full";

  zfs_do_backup($host, $fs, 'f', $point, $store, $dumpname);
}

sub zfs_incremental_backup($$$$) {
  my ($host, $fs, $base, $store) = @_;
  my $agent = config_get($host, 'agent');

  # Translate into a proper dumpname
  my $point = time();
  my $efs = dir_encode($fs);
  my $dumpname = "$point.$efs.incremental.$base";

  zfs_do_backup($host, $fs, 'i', $point, $store, $dumpname, $base);
}

sub zfs_dataset_backup($$$$) {
  my ($host, $fs, $base, $store) = @_;
  my $agent = config_get($host, 'agent');

  my $point = time();
  my $dumpname = "$fs\@$point";

  zfs_do_backup($host, $fs, 's', $point, $store, $dumpname, $base);
}

sub perform_retention($$) {
  my ($host, $store) = @_;
  my $backup_info = scan_for_backups($store);
  my $retention = config_get($host, 'retention');
  my $now = time();

  if ($DEBUG) {
    print "Performing retention for $host\n";
  }

  foreach my $disk (sort keys %{$backup_info}) {
    my $info = $backup_info->{$disk};
    next unless(ref($info) eq 'HASH');
    my %must_save;

    if ($DEBUG) {
      print "   $disk\n";
    }

    # Get a list of all the full and incrementals, sorts newest to oldest
    my @backup_points = (keys %{$info->{full}}, keys %{$info->{incremental}});
    @backup_points = sort { $b <=> $a } @backup_points;

    # We _cannot_ throw away _all_ our backups,
    # so save the most recent incremental and full no matter what
    push(@{$must_save{$backup_points[0]}}, "most recent backup");
    my @fulls = grep { exists($info->{full}->{$_}) } @backup_points;
    push(@{$must_save{$fulls[0]}}, "most recent full");

    # Process retention policy
    my @parts = split(/;/, $retention);
    my %retention_map;
    foreach (@parts) {
      my ($period, $amount) = split(/,/);
      if (!defined($amount)) {
        $amount = -1;
      }
      $retention_map{$period} = $amount;
    }
    my @periods = sort { $a <=> $b } keys(%retention_map);
    my %backup_bins;
    foreach(@periods) {
      $backup_bins{$_} = ();
    }
    my $cutoff = $now - $periods[0];
    # Sort backups into time period sections
    foreach (@backup_points) {
      # @backup_points is in descending order (newest first)
      while ($_ <= $cutoff) {
        # Move to the next largest bin if the current backup is not in the
        # current bin. However, if there is no larger bin, then don't
        shift(@periods);
        if (@periods) {
          $cutoff = $now - $periods[0];
        } else {
          last;
        }
      }
      # Throw away all backups older than the largest time period specified
      if (!@periods) {
        last;
      }
      push(@{$backup_bins{$periods[0]}}, $_);
    }
    foreach (keys(%backup_bins)) {
      my $keep = $retention_map{$_}; # How many backups to keep
      if ($backup_bins{$_}) {
        my @backups = @{$backup_bins{$_}};
        my $total = @backups;  # How many backups we have
        # If we didn't specify how many to keep, keep them all
        if ($keep == -1) { $keep = $total };
        # If we have less backups than we should keep, keep them all
        if ($total < $keep) { $keep = $total };
        for (my $i = 1; $i <= $keep; $i++) {
          my $idx = int(($i * $total) / $keep) - 1;
          push(@{$must_save{$backups[$idx]}}, "retention policy - $_");
        }
      }
    }
    if ($DEBUG) {
      print "    => Backup bins:\n";
      foreach my $a (keys(%backup_bins)) {
        print "      => $a\n";
        foreach my $i (@{$backup_bins{$a}}) {
          my $trans = $now - $i;
          print "         => $i ($trans seconds old)";
          if (exists($must_save{$i})) { print " => keep" };
          print "\n";
        }
      }
    }

    # Look for dependencies
    foreach (@backup_points) {
      if(exists($info->{incremental}->{$_})) {
        print "   => $_ depends on $info->{incremental}->{$_}->{depends}\n" if($DEBUG);
        if (exists($must_save{$_})) {
          push(@{$must_save{$info->{incremental}->{$_}->{depends}}},
            "dependency");
        }
      }
    }

    my @removals = grep { !exists($must_save{$_}) } @backup_points;
    if($DEBUG) {
      my $tf = config_get($host, 'time_format');
      print "    => Candidates for removal:\n";
      foreach (@backup_points) {
        print "      => ". strftime($tf, localtime($_));
        print " ($_)";
        print " [". (exists($info->{full}->{$_}) ? "full":"incremental") ."]";
        if (exists($must_save{$_})) {
          my $reason = join(", ", @{$must_save{$_}});
          print " => keep ($reason)";
        } else {
          print " => remove";
        }
        print "\n";
      }
    }
    foreach (@removals) {
      my $efs = dir_encode($disk);
      my $filename;
      my $dataset;
      if(exists($info->{full}->{$_}->{file})) {
        $filename = $info->{full}->{$_}->{file};
      } elsif(exists($info->{incremental}->{$_}->{file})) {
        $filename = $info->{incremental}->{$_}->{file};
      } elsif(exists($info->{full}->{$_}->{dataset})) {
        $dataset = $info->{full}->{$_}->{dataset};
      } elsif(exists($info->{incremental}->{$_}->{dataset})) {
        $dataset = $info->{incremental}->{$_}->{dataset};
      } else {
        print "ERROR: We tried to expunge $host $disk [$_], but couldn't find it.\n";
      }
      print "    => expunging ${filename}${dataset}\n" if($DEBUG);
      unless($NEUTERED) {
        if ($filename) {
          unlink($filename) || print "ERROR: unlink $filename: $?\n";
        } elsif ($dataset) {
          `__ZFS__ destroy $dataset`;
          if ($?) {
            print "ERROR: zfs destroy $dataset: $?\n";
          }
        }
      }
    }
  }
}

sub __default_sort($$) { return $_[0] cmp $_[1]; }
    
sub choose($$;$) {
  my($name, $obj, $sort) = @_;
  $sort ||= \&__default_sort;;
  my @list;
  my $hash;
  if(ref $obj eq 'ARRAY') {
    @list = sort { $sort->($a,$b); } (@$obj);
    map { $hash->{$_} = $_; } @list;
  }
  elsif(ref $obj eq 'HASH') {
    @list = sort { $sort->($a,$b); } (keys %$obj);
    $hash = $obj;
  }
  else {
    die "choose passed bad object: " . ref($obj) . "\n";
  }
  return $list[0] if(scalar(@list) == 1);
  print "\n";
  my $i = 1;
  for (@list) {
    printf " %3d) $hash->{$_}\n", $i++;
  }
  my $selection = 0;
  while($selection !~ /^\d+$/ or
        $selection < 1 or
        $selection >= $i) {
    print "$name: ";
    chomp($selection = <>);
  }
  return $list[$selection - 1];
}

sub backup_chain($$) {
  my ($info, $ts) = @_;
  my @list;
  push @list, $info->{full}->{$ts} if(exists($info->{full}->{$ts}));
  if(exists($info->{incremental}->{$ts})) {
    push @list, $info->{incremental}->{$ts};
    push @list, backup_chain($info, $info->{incremental}->{$ts}->{depends});
  }
  return @list;
}

sub get_fs_from_mountpoint($) {
    my ($mountpoint) = @_;
    my $fs;
    my $rv = open(ZFSLIST, "__ZFS__ list -t filesystem -H |");
    die "Unable to determine zfs filesystem for $mountpoint" unless $rv;
    while (<ZFSLIST>) {
        my @F = split(' ');
        if ($F[-1] eq $mountpoint) {
            $fs = $F[0];
            last;
        }
    }
    close(ZFSLIST);
    die "Unable to determine zfs filesystem for $mountpoint" unless $fs;
    return $fs;
}

sub perform_restore() {
  my %source;

  foreach my $host (grep { $_ ne "default" && $conf{$_}->{"type"} ne "class"} 
      keys %conf) {
    # If -h was specific, we will skip this host if the arg isn't
    # an exact match or a pattern match
    if($HOST &&
       !(($HOST eq $host) ||
         ($HOST =~ /^\/(.*)\/$/ && $host =~ /$1/))) {
      next;
    }

    my $store = get_store($host);

    my $backup_info = scan_for_backups($store);
    foreach my $disk (sort keys %{$backup_info}) {
      my $info = $backup_info->{$disk};
      next unless(ref($info) eq 'HASH');
      next
        if($ZFS &&      # if the pattern was specified it could
           !($disk eq $ZFS ||        # be a specific match or a
             ($ZFS =~ /^\/(.+)\/$/ && $disk =~ /$1/))); # regex
      # We want to see this one
      my @backup_points = (keys %{$info->{full}}, keys %{$info->{incremental}});
      my @source_points;
      foreach (@backup_points) {
        push @source_points, $_ if(!$TIMESTAMP || $TIMESTAMP == $_)
      }
      if(@source_points) {
        $source{$host}->{$disk} = \@source_points;
      }
    }
  }

  if(! keys %source) {
    print "No matching backups found\n";
    return;
  }

  # Here goes the possibly interactive dialog
  my $host = choose("Restore from host",  [keys %source]);
  my $disk = choose("Restore from ZFS", [keys %{$source{$host}}]);
  
  # Times are special.  We build a human readable form and use a numerical
  # sort function instead of the default lexical one.
  my %times;
  my $tf = config_get($host, 'time_format');
  map { $times{$_} = strftime($tf, localtime($_)); } @{$source{$host}->{$disk}};
  my $timestamp = choose("Restore as of timestamp", \%times,
                         sub { $_[0] <=> $_[1]; });

  my $store = get_store($host);
  my $backup_info = scan_for_backups($store);
  my @backup_list = reverse backup_chain($backup_info->{$disk}, $timestamp);

  if(!$RESTORE_HOST) {
    print "Restore to host [$host]:";
    chomp(my $input = <>);
    $RESTORE_HOST = length($input) ? $input : $host;
  }
  if(!$RESTORE_ZFS) {
    print "Restore to zfs [$disk]:";
    chomp(my $input = <>);
    $RESTORE_ZFS = length($input) ? $input : $disk;
  }

  # show intentions
  print "Going to restore:\n";
  print "\tfrom: $host\n";
  print "\tfrom: $disk\n";
  print "\t  at: $timestamp [" . strftime($tf, localtime($timestamp)) . "]\n";
  print "\t  to: $RESTORE_HOST\n";
  print "\t  to: $RESTORE_ZFS\n";
  print "\n";

  foreach(@backup_list) {
    $_->{success} = zfs_restore_part($RESTORE_HOST, $RESTORE_ZFS, $_->{file}, $_->{dataset}, $_->{depends});
  }
}

sub zfs_restore_part($$$$;$) {
  my ($host, $fs, $file, $dataset, $dep) = @_;
  unless ($file || $dataset) {
    print STDERR "=> No dataset or filename given to restore. Bailing out.";
    return 1;
  }
  my $ssh_config = config_get($host, 'ssh_config');
  $ssh_config = "-F $ssh_config" if($ssh_config);
  print "Using custom ssh config file: $ssh_config\n" if($DEBUG);
  my $command;
  if(exists($conf{$host})) {
    my $agent = config_get($host, 'agent');
    $command = "$agent -r -z $fs";
    $command .= " -b $dep" if($dep);
  }
  else {
    $command = "__ZFS__ recv $fs";
  }
  if ($file) {
    print " => piping $file to $command\n" if($DEBUG);
    print "gzip -dfc $file | ssh $ssh_config $host $command\n" if ($DEBUG && $NEUTERED);
  } elsif ($dataset) {
    print " => piping $dataset to $command using zfs send\n" if ($DEBUG);
    print "zfs send $dataset | ssh $ssh_config $host $command\n" if ($DEBUG && $NEUTERED);
  }
  unless($NEUTERED) {
    if ($file) {
      open(DUMP, "gzip -dfc $file |");
    } elsif ($dataset) {
      open(DUMP, "__ZFS__ send $dataset |");
    }
    eval {
      open(RECEIVER, "| ssh $ssh_config $host $command");
      my $buffer;
      while(my $len = sysread(DUMP, $buffer, $BLOCKSIZE)) {
        if(syswrite(RECEIVER, $buffer, $len) != $len) {
          die "$!";
        }
      }
    };
    close(DUMP);
    close(RECEIVER);
  }
  return $?;
}

sub pretty_print_backup($$$) {
  my ($info, $host, $point) = @_;
  my $tf = config_get($host, 'time_format');
  print "\t" . strftime($tf, localtime($point)) . " [$point] ";
  if(exists($info->{full}->{$point})) {
    if ($info->{full}->{$point}->{file}) {
      my @st = stat($info->{full}->{$point}->{file});
      print "FULL " . pretty_size($st[7]);
      print "\n\tfile: $info->{full}->{$point}->{file}" if($SHOW_FILENAMES);
    } elsif ($info->{full}->{$point}->{dataset}) {
      print "FULL $info->{full}->{$point}->{pretty_size}";
      print "\n\tdataset: $info->{full}->{$point}->{dataset}"
        if($SHOW_FILENAMES);
    }
  } else {
    my @st = stat($info->{incremental}->{$point}->{file});
    print "INCR from [$info->{incremental}->{$point}->{depends}] " . pretty_size($st[7]);
    print "\n\tfile: $info->{incremental}->{$point}->{file}" if($SHOW_FILENAMES);
  }
  print "\n";
}

sub show_backups($$$) {
  my ($host, $store, $diskpat) = @_;
  my $backup_info = scan_for_backups($store);
  my $tf = config_get($host, 'time_format');
  my (@files, @datasets);
  foreach my $disk (sort keys %{$backup_info}) {
    my $info = $backup_info->{$disk};
    next unless(ref($info) eq 'HASH');
    next
      if($diskpat &&      # if the pattern was specified it could
         !($disk eq $diskpat ||        # be a specific match or a
           ($diskpat =~ /^\/(.+)\/$/ && $disk =~ /$1/))); # regex

    my @backup_points = (keys %{$info->{full}}, keys %{$info->{incremental}});
    @backup_points = sort { $a <=> $b } @backup_points;
    @backup_points = (pop @backup_points) unless ($ARCHIVE || $SUMMARY_EXT || $SUMMARY_VIOLATORS);

    # Quick short-circuit in the case of retention violation checks
    if($SUMMARY_VIOLATORS) {
      if(time() > $info->{last_full} + config_get($host, 'full_interval') ||
         time() > $info->{last_backup} + config_get($host, 'backup_interval')) {
        print "$host:$disk\n";
        pretty_print_backup($info, $host, $info->{last_full});
        # Only print the last backup if it isn't the same as the last full
        if ($info->{last_full} != $info->{last_backup}) {
            pretty_print_backup($info, $host, $info->{last_backup});
        }
      }
      next;
    }

    # We want to see this one
    print "$host:$disk\n";
    next unless($SUMMARY || $SUMMARY_EXT || $ARCHIVE);
    if($SUMMARY_EXT) {
      print "\tLast Full: ". ($info->{last_full} ? strftime($tf, localtime($info->{last_full})) : "Never") . "\n";
      if($info->{last_full} < $info->{last_incremental}) {
        print "\tLast Incr: ". strftime($tf, localtime($info->{last_incremental})). "\n";
      }
    }
    foreach (@backup_points) {
      pretty_print_backup($info, $host, $_);
      if(exists($info->{full}->{$_}->{file})) {
        push @files, $info->{full}->{$_}->{file};
      } elsif(exists($info->{incremental}->{$_}->{file})) {
        push @files, $info->{incremental}->{$_}->{file};
      } elsif(exists($info->{full}->{$_}->{dataset})) {
        push @datasets, $info->{full}->{$_}->{dataset}
      }
    }
    print "\n";
  }
  if($ARCHIVE && (scalar(@files) || scalar(@datasets))) {
    print "\nAre you sure you would like to archive ".scalar(@files).
      " file(s) and ".scalar(@datasets)." dataset(s)? ";
    while(($_ = <>) !~ /(?:y|n|yes|no)$/i) {
      print "\nAre you sure you would like to archive ".scalar(@files).
        " file(s) and ".scalar(@datasets)." dataset(s)? ";
    }
    if(/^y/i) {
      if (@files) {
        my $archive = config_get($host, 'archive');
        $archive =~ s/%h/$host/g;
        if(! -d $archive) {
          mkdir $archive || die "Cannot mkdir($archive)\n";
        }
        foreach my $file (@files) {
          (my $afile = $file) =~ s/^$store/$archive/;
          move($file, $afile) || print "Error archiving $file: $!\n";
        }
      }
      if (@datasets) {
        my $archive = config_get($host, 'archive');
        my $storefs = get_fs_from_mountpoint($store);
        (my $basearchive = $archive) =~ s/\/?%h//g;
        my $basearchivefs;
        eval {
          $basearchivefs = get_fs_from_mountpoint($basearchive);
        };
        die "Unable to find archive filesystem. The archive directory must be the root of a zfs filesystem to archive datasets." if $@;
        my $archivefs = "$basearchivefs/$host";
        `__ZFS__ create $archivefs`; # We don't care if this fails
        my %seen = ();
        foreach my $dataset (@datasets) {
          $dataset =~ s/@.*$//; # Only rename filesystems, not snapshots
          next if $seen{$dataset}++; # Only rename a filesystem once
          (my $adataset = $dataset) =~ s/^$storefs/$archivefs/;
          `__ZFS__ rename $dataset $adataset`;
          if ($?) {
            print "Error archiving $dataset\n";
          }
        }
      }
    }
  }
}

sub plan_and_run($$) {
  my ($host, $diskpat) = @_;
  my $store;
  my $ssh_config = config_get($host, 'ssh_config');
  $ssh_config = "-F $ssh_config" if($ssh_config);
  my %suppress;
  print "Planning '$host'\n" if($DEBUG);
  my $agent = config_get($host, 'agent');
  my $took_action = 1;
  while($took_action) {
    $took_action = 0;
    my @disklist;

    # We need a lock for the listing.
    return unless(lock($host, ".list"));

    # Get list of zfs filesystems from the agent
    open(SILENT, ">&", \*STDERR);
    close(STDERR);
    my $rv = open(ZFSLIST, "ssh $ssh_config $host $agent -l |");
    open(STDERR, ">&", \*SILENT);
    close(SILENT);
    next unless $rv;
    @disklist = grep { chomp } (<ZFSLIST>);
    close(ZFSLIST);

    if ($DEBUG) {
      print " => Filesystems for $host (zetaback_agent -l output)\n";
      foreach my $diskline (@disklist) {
        print "    $diskline\n";
      }
    }

    foreach my $diskline (@disklist) {
      chomp($diskline);
      next unless($diskline =~ /^(\S+) \[([^\]]*)\](?: {([^}]*}))?/);
      my $diskname = $1;
      my %snaps;
      map { $snaps{$_} = 1 } (split(/,/, $2));
      my $class = $3;
      $store = get_store($host, $class);
 
      # We've just done this.
      next if($suppress{"$host:$diskname"}); 
      # If we are being selective (via -z) now is the time.
      next
        if($diskpat &&          # if the pattern was specified it could
           !($diskname eq $diskpat ||        # be a specific match or a
             ($diskpat =~ /^\/(.+)\/$/ && $diskname =~ /$1/))); # regex
  
      print " => Scanning '$store' for old backups of '$diskname'.\n" if($DEBUG);

      # Make directory on demand
      my $backup_info = scan_for_backups($store);
      # That gave us info on all backups, we just want this disk
      $backup_info = $backup_info->{$diskname} || {};
  
      # Should we do a backup?
      my $backup_type = 'no';
      if(time() > $backup_info->{last_backup} + config_get($host,
          'backup_interval', $class)) {
        $backup_type = 'incremental';
      }
      if(time() > $backup_info->{last_full} + config_get($host,
          'full_interval', $class)) {
        $backup_type = 'full';
      }
      # If we want an incremental, but have no full, then we need to upgrade to full
      if($backup_type eq 'incremental') {
        my $have_full_locally = 0;
        # For each local full backup, see if the full backup still exists on the other end.
        foreach (keys %{$backup_info->{'full'}}) {
          $have_full_locally = 1 if(exists($snaps{'__zb_full_' . $_}));
        }
        $backup_type = 'full' unless($have_full_locally);
      }
      $backup_type = 'full' if($FORCE_FULL);
      $backup_type = 'incremental' if($FORCE_INC);
      $backup_type = 'dataset' if(config_get($host, 'dataset_backup', $class)
        eq 1 && $backup_type ne 'no');

      print " => doing $backup_type backup\n" if($DEBUG);
      # We need to drop a __zb_base snap or a __zb_incr snap before we proceed
      unless($NEUTERED || $backup_type eq 'no') {
        # attempt to lock this action, if it fails, skip -- someone else is working it.
        next unless(lock($host, dir_encode($diskname), 1));
        unlock($host, '.list');

        if($backup_type eq 'full') {
          eval { zfs_full_backup($host, $diskname, $store); };
          if ($@) {
            chomp(my $err = $@);
            print " => failure $err\n";
          }
          else {
            # Unless there was an error backing up, remove all the other full snaps
            foreach (keys %snaps) {
              zfs_remove_snap($host, $diskname, $_) if(/^__zb_full_(\d+)/) 
            }
          }
          $took_action = 1;
        }
        if($backup_type eq 'incremental') {
          eval { 
            zfs_remove_snap($host, $diskname, '__zb_incr') if($snaps{'__zb_incr'});
            # Find the newest full from which to do an incremental (NOTE: reverse numeric sort)
            my @fulls = sort { $b <=> $a } (keys %{$backup_info->{'full'}});
            zfs_incremental_backup($host, $diskname, $fulls[0], $store);
          };
          if ($@) {
            chomp(my $err = $@);
            print " => failure $err\n";
          }
          else { 
            $took_action = 1;
          }
        }
        if($backup_type eq 'dataset') {
          my @backups = sort { $b <=> $a } (keys %{$backup_info->{'full'}});
          eval { zfs_dataset_backup($host, $diskname, $backups[0], $store); };
          if ($@) {
            chomp(my $err = $@);
            print " => failure $err\n";
          }
          else {
            # Unless there was an error backing up, remove all the other dset snaps
            foreach (keys %snaps) {
              zfs_remove_snap($host, $diskname, $_) if(/^__zb_dset_(\d+)/) 
            }
          }
          $took_action = 1;
        }
        unlock($host, dir_encode($diskname), 1);
      }
      $suppress{"$host:$diskname"} = 1;
      last if($took_action);
    }
    unlock($host, '.list');
  }
}

if($RESTORE) {
  perform_restore();
}
else {
  foreach my $host (grep { $_ ne "default" && $conf{$_}->{"type"} ne "class"}
      keys %conf) {
    # If -h was specific, we will skip this host if the arg isn't
    # an exact match or a pattern match
    if($HOST &&
       !(($HOST eq $host) ||
         ($HOST =~ /^\/(.*)\/$/ && $host =~ /$1/))) {
      next;
    }

    # Skip if the host is marked as 'offline' and we are not listing backups
    if (config_get($host, 'offline') == 1 && 
        !$LIST && !$SUMMARY && !$SUMMARY_EXT && !$ARCHIVE) {
      next;
    }

    # TODO - remove once class functionality is completed
    my $store = get_store($host, '');
  
    if($LIST || $SUMMARY || $SUMMARY_EXT || $SUMMARY_VIOLATORS || $ARCHIVE) {
      show_backups($host, $store, $ZFS);
    }
    if($BACKUP) {
      plan_and_run($host, $ZFS);
    }
    if($EXPUNGE) {
      perform_retention($host, $store);
    }
  }
}

exit 0;

=pod

=head1 FILES

=over

=item zetaback.conf

The main zetaback configuration file.  The location of the file can be
specified on the command line with the -c flag.  The prefix of this 
file may also be specified as an argument to the configure script.

=back

=head1 SEE ALSO

zetaback_agent(1)

=cut