#!/usr/bin/env perl

# arch packages:
# perl
# perl-switch
# perl-config-tiny

use v5.12;
use strict;
use warnings;

use Config::Tiny;
use File::Spec::Functions qw(catdir);
use Getopt::Long qw(:config no_ignore_case gnu_getopt auto_help pass_through);
use Pod::Usage;
use POSIX;
use Switch;

my $config_file = '/etc/snapman.d/snapman.conf';
my $root_snapdir;
my $root_snapvol_prefix;
my $boot_snapdir;
my $boot_snapvol_prefix;
my $fstab_path;
my $fstab_template_path;

my $progname = $0;
my %opts = ();



sub bail_out(@) {
  say "${progname}: ", @_;
  exit 1;
}


sub loadConf() {
  my $conf = Config::Tiny->read($config_file)
    or bail_out "could not read config file ${config_file}";
  $conf = $conf->{_};
  $root_snapvol_prefix = $conf->{root_prefix}
    unless defined $root_snapvol_prefix;
  $boot_snapvol_prefix = $conf->{boot_prefix}
    unless defined $boot_snapvol_prefix;
  $root_snapdir = $conf->{root_snapshot_directory}
    unless defined $root_snapdir;
  $boot_snapdir = $conf->{boot_snapshot_directory}
    unless defined $boot_snapdir;

  $fstab_path = $conf->{fstab_path}
    unless defined $fstab_path;
  $fstab_template_path = $conf->{fstab_template_path}
    unless defined $fstab_template_path;

  bail_out "root prefix unset" unless $root_snapvol_prefix;
  bail_out "root snapshot directory unset" unless $root_snapdir;
}


sub snapshotName($$$) {
  my ($prefix, $name, $defaultsuffix) = @_;

  $name = $defaultsuffix
    if $name eq '';

  $name = ''
    if $name eq '@';

  $name = '_'.$name
    unless $name eq '';

  return $prefix.$name;
}


sub stripSnapdir($$) {
  my ($snapdir, $snap_path) = @_;
  return ($snap_path =~ m|$snapdir/*(.*)|)[0];
}


sub snapshotDefault($$$$$$$$) {
  my ($basevol_name, $default_base_suffix, $snapvol_name, $default_snap_suffix, $prefix, $snapdir, $replace, $patch_fstab) = @_;

  my $snapvol = snapshotName($prefix, $snapvol_name, $default_snap_suffix);
  my $basevol = snapshotName($prefix, $basevol_name, $default_base_suffix);
  my $snapvol_path = catdir($snapdir, $snapvol);
  my $basevol_path = catdir($snapdir, $basevol);

  # we don't want to accidently create a subvolume inside an already existing
  # subvolume or folder with given name
  # if --replace is given, the destination subvolume is deleted beforehand
  if (-e $snapvol_path) {
    if ($replace) {
      system("btrfs subvolume delete ${snapvol_path}") == 0
        or bail_out("cannot delete snapshot: $!");
    } else {
      bail_out "subvolume ${snapvol_path} already exists (use --force to override)"
    }
  }

  system("btrfs subvolume snapshot ${basevol_path} ${snapvol_path}") == 0
    or bail_out("cannot create snapshot: $!");

  patchFstab($snapdir, $snapvol, $basevol, $snapvol_name, $default_snap_suffix)
    if $patch_fstab && $fstab_path && $fstab_template_path;
}


sub snapshot($$$$$$) {
 my ($basevol_name, $snapvol_name, $prefix, $snapdir, $replace, $path_fstab) = @_;

 my $datesuffix = 'date@'.strftime("%FT%T", localtime $^T);
 snapshotDefault($basevol_name, '@', $snapvol_name, $datesuffix, $prefix, $snapdir, $replace, $path_fstab);
}


sub rollback($$$$$$) {
  my ($rollvol_name, $basevol_name, $prefix, $snapdir, $replace, $patch_fstab) = @_;
  snapshotDefault($basevol_name, '@', $rollvol_name, '@', $prefix, $snapdir, $replace, $patch_fstab);
}


sub listSnapshots($$$) {
  my ($snapdir, $prefix, $namedOrDate) = @_;

  my $snapglob_prefix = catdir($snapdir, $prefix);
  my @snaps = <${snapglob_prefix}*>;

  if ($namedOrDate eq 'date') {
    @snaps = grep {/${prefix}_date@/} @snaps;
  } elsif ($namedOrDate eq 'named') {
    @snaps = grep {!/${prefix}_date@/} @snaps;
  }

  return @snaps;
}


sub deleteSnapshot($) {
  my ($snap) = @_;
  system "btrfs subvolume delete ${snap}";
}

sub patchFstab($$$$$) {
  my ($snap_path, $fstab_snap, $template_snap, $suffix, $default_suffix) = @_;

  my $root_snap = snapshotName($root_snapvol_prefix, $suffix, $default_suffix);
  my $boot_snap = snapshotName($boot_snapvol_prefix, $suffix, $default_suffix);

  my $fstab_file_path = catdir($snap_path, $fstab_snap, $fstab_path);
  open(FSTAB_FILE, '>', $fstab_file_path)
    or die "could not open fstab '$fstab_file_path'";
  my $template_file_path = catdir($snap_path, $template_snap, $fstab_template_path);
  open(TEMPLATE_FILE, '<', $template_file_path)
    or die "could not open fstab template '$template_file_path'";

  while (my $line = <TEMPLATE_FILE>) {
    $line =~ s/%ROOT%/$root_snap/gi;
    $line =~ s/%BOOT%/$boot_snap/gi;
    print FSTAB_FILE $line;
  }
}


sub tail($\@) {
  my ($length, $array) = @_;
  splice @$array, (scalar(@$array)-$length), $length;
}


# === subcommand functions ===


sub cmdSnapshot() {
  my %opts = ();
  GetOptions(\%opts,
             'force|f')
    or pod2usage(1);

  loadConf();

  my $basevol = ''; # the subvolume that is snapshotted
  my $snapvol = ''; # the new snapshot

  if (@ARGV == 1) {
    $snapvol = $ARGV[0];
  } elsif (@ARGV == 2) {
    $basevol = $ARGV[0];
    $snapvol = $ARGV[1];
  } elsif (@ARGV > 2) {
    bail_out "to many arguments to command snapshot";
  }

  snapshot($basevol, $snapvol, $root_snapvol_prefix, $root_snapdir, $opts{force}, 1);
  snapshot($basevol, $snapvol, $boot_snapvol_prefix, $boot_snapdir, $opts{force}, 0)
    if $boot_snapdir && $boot_snapvol_prefix;
}



sub cmdRollback() {
  my %opts = ();
  GetOptions(\%opts,
             'force|f')
    or pod2usage(1);

  loadConf();

  my $basevol = ''; # the subvolume, that should serve as snapshot source for the rollback
  my $rollvol = ''; # the one, that should be rolled back (created; replacement not yet supported)

  if (@ARGV == 1) {
    $basevol = $ARGV[0];
  } elsif (@ARGV == 2) {
    $basevol = $ARGV[1];
    $rollvol = $ARGV[0];
  } elsif (@ARGV > 2) {
    bail_out "to many arguments to command rollback";
  }


  bail_out 'searching active subvolume not yet supported'
    if $basevol eq '';

  rollback($rollvol, $basevol, $root_snapvol_prefix, $root_snapdir, $opts{force}, 1);
  rollback($rollvol, $basevol, $boot_snapvol_prefix, $boot_snapdir, $opts{force}, 0)
    if $boot_snapdir && $boot_snapvol_prefix;
}




sub cmdList() {
  my %opts = ();
  GetOptions(\%opts,
             'fullpath|path|f',
             'time|date|t|d',
             'named|n')
    or pod2usage(1);

  my $namedOrDate = '';
  $namedOrDate = 'named'
    if ($opts{named});
  $namedOrDate = 'date'
    if ($opts{time});

  my @rootsnaps = listSnapshots($root_snapdir, $root_snapvol_prefix, $namedOrDate);
  my @snaplist = ();

  # find matching boot subvolumes (if seperate boot snapshot directory is set)
  if ($boot_snapdir && $boot_snapvol_prefix) {
    foreach my $rootsnap (@rootsnaps) {
      my ($suffix) = stripSnapdir($root_snapdir, $rootsnap) =~ m/${root_snapvol_prefix}(.*)$/;
      my $bootsnap = catdir($boot_snapdir, $boot_snapvol_prefix.$suffix);

      if (-e $bootsnap) {
        push(@snaplist, [$rootsnap, $bootsnap]);
      } else {
        push(@snaplist, [$rootsnap]);
      }
    }
  } else {
    @snaplist = map {[$_]} @rootsnaps;
  }

  # print list of snapshots
  foreach my $elem (@snaplist) {
    if ($opts{fullpath}) {
      say join("\t", @{$elem});
    } else {
      if (@{$elem} > 1) {
        my ($rootsnap, $bootsnap) = @{$elem};
        say(stripSnapdir($root_snapdir, $rootsnap)."\t".stripSnapdir($boot_snapdir, $bootsnap));
      } else {
        my ($rootsnap) = @{$elem};
        say stripSnapdir($root_snapdir, $rootsnap);
      }
    }
  }
}



sub cmdPrintname() {
  my %opts = ();
  GetOptions(\%opts,
             'fullpath|path|f')
    or pod2usage(1);

  if (@ARGV > 0) {
    for my $snap_name (@ARGV) {
      my $root_snap = snapshotName($root_snapvol_prefix, $snap_name, '');
      my $boot_snap = snapshotName($boot_snapvol_prefix, $snap_name, '')
        if $boot_snapvol_prefix && $boot_snapdir;

      if ($opts{fullpath}) {
        $root_snap = catdir($root_snapdir, $root_snap);
        $boot_snap = catdir($boot_snapdir, $boot_snap)
          if $boot_snapvol_prefix && $boot_snapdir;
      }

      print $root_snap;
      print "\t".$boot_snap
        if $boot_snapvol_prefix && $boot_snapdir;
      say "";
    }
  } else {
    bail_out "command printname needs the name (suffix) of a snapshot as argument";
  }
}


sub cmdDelete() {
  my %opts = ();
  GetOptions(\%opts,
             'date|d',
             'keep|k=i',
             'older-than|older|o=s',
             'newer-than|newer|n=s')
    or pod2usage(1);

  bail_out "option --keep only makes sense in conjunction with --date"
    if $opts{keep} && !$opts{date};

  if ($opts{date}) {
    bail_out "unexpected additional arguments @ARGV"
      if @ARGV > 0;

    my @rootsnaps = listSnapshots($root_snapdir, $root_snapvol_prefix, 'date');
    my @bootsnaps = listSnapshots($boot_snapdir, $boot_snapvol_prefix, 'date')
      if $boot_snapdir && $boot_snapvol_prefix;

    if ($opts{'older-than'}) {
      my $olderthansnapname = snapshotName($root_snapvol_prefix, 'date@'.$opts{'older-than'}, '');
      my $olderthansnap = catdir($root_snapdir, $olderthansnapname);
      @rootsnaps = grep{$_ lt $olderthansnap} @rootsnaps; # filter all which are lexically greater

      if ($boot_snapdir && $boot_snapvol_prefix) {
        $olderthansnapname = snapshotName($boot_snapvol_prefix, 'date@'.$opts{'older-than'}, '');
        $olderthansnap = catdir($boot_snapdir, $olderthansnapname);
        @bootsnaps = grep{$_ lt $olderthansnap} @bootsnaps; # filter all which are lexically greater
      }
    }

    if ($opts{'newer-than'}) {
      my $newerthansnapname = snapshotName($root_snapvol_prefix, 'date@'.$opts{'newer-than'}, '');
      my $newerthansnap = catdir($root_snapdir, $newerthansnapname);
      @rootsnaps = grep{$_ gt $newerthansnap} @rootsnaps; # filter all which are lexically smaller

      if ($boot_snapdir && $boot_snapvol_prefix) {
        $newerthansnapname = snapshotName($boot_snapvol_prefix, 'date@'.$opts{'newer-than'}, '');
        $newerthansnap = catdir($boot_snapdir, $newerthansnapname);
        @bootsnaps = grep{$_ gt $newerthansnap} @bootsnaps; # filter all which are lexically smaller
      }
    }

    if ($opts{keep}) {
      tail $opts{keep}, @rootsnaps;
      tail $opts{keep}, @bootsnaps
        if $boot_snapdir && $boot_snapvol_prefix;
    }

    for my $root_snap (@rootsnaps) {
      deleteSnapshot $root_snap;
    }

    for my $boot_snap (@bootsnaps) {
      deleteSnapshot $boot_snap;
    }
  } elsif (@ARGV > 0) {
    for my $snap_name (@ARGV) {
      my $root_snap = snapshotName($root_snapvol_prefix, $snap_name, '');
      my $boot_snap = snapshotName($boot_snapvol_prefix, $snap_name, '')
        if $boot_snapvol_prefix && $boot_snapdir;

      $root_snap = catdir($root_snapdir, $root_snap);
      $boot_snap = catdir($boot_snapdir, $boot_snap)
        if $boot_snapvol_prefix && $boot_snapdir;

      deleteSnapshot $root_snap;
      deleteSnapshot $boot_snap
        if $boot_snapvol_prefix && $boot_snapdir && -e $boot_snap;
    }
  } else {
    bail_out "command delete needs the name (suffix) of at least one snapshot as argument";
  }
}


# === main program ===

GetOptions('config|c=s' => \$config_file,
           'root-prefix|R=s' => \$root_snapvol_prefix,
           'root-snapdir|r=s' => \$root_snapdir,
           'boot-prefix|B=s' => \$boot_snapvol_prefix,
           'boot-snapdir|b=s' => \$boot_snapdir,
           'fstab-path|fstab=s' => \$fstab_path,
           'fstab-template-path|fstab-template|template=s' => \$fstab_template_path)
  or pod2usage(1);

# we do not want pass_through any more
Getopt::Long::Configure(qw(default no_ignore_case gnu_getopt auto_help));

loadConf();

my $command = shift @ARGV;
switch ($command) {
  case ["snapshot", "snap"] { cmdSnapshot }
  case ["rollback", "roll"] { cmdRollback }
  case ["delete", "del"] { cmdDelete }
  case "list" { cmdList }
  case "printname" { cmdPrintname }
  else { pod2usage( -verbose => 1,
                    -exitval => 1,
                    -noperldoc => 1) }
}


__END__

=head1 NAME

B<snapman> - simple (system) snapshot manager



=head1 SYNOPSIS

B<snapman> [<options>] <command> [<args>]


=head1 DESCRIPTION

B<snapman> is a simple tool for managing snapshots of the system and boot file systems. It is meant to be integrated with the package manager, so that on each transaction, a snapshot of the current system (and possibly seperate boot file system) can be created. B<snapman> currently only works with B<btrfs> on B<linux>.

In this man page, the terms I<snapshot> and I<subvolume> are used interchangably (as in btrfs, a subvolume and a snapshot are roughly the same thing). When this manual refers to the I<file system name> it means the name of a snaphot as it appears in the file system. The file system name of a snapshot consists of a I<prefix>, which can be configured in the configuration file or via command options, and a suffix which is given to the commands and this manual refers to it as the I<name> of the snapshot. Prefix and name are delimited with an underscore. An exception to this rule is the so called I<default snapshot>, which is also referred to as I<@> in this manual and can also be given to B<snapman> as argument in this way. The file system name of I<@> is just the prefix. The name I<@> was chosen because in btrfs '@' also designates the default subvolume, although note that the default btrfs snapshot and the default snapshot in terms of B<snapman> are not the same.

For situations, where manually given names are not needed or not practicable, I<date snapshots> can be created. (In contrast, all other snapshots, including the I<default snapshot> are called I<named snapshots>). The name of a date snapshot consists of the string "date@" and the (current) date in B<ISO 8601> format. Most commands provide means to act only on date snapshots or named snapshots.

B<snapman> can work with either one root file system or a setup with different file systems for F</> and F</boot>. The latter is assumed when the variables I<boot_prefix> and I<boot_snapshot_directory> are both configured. In this case, commands that work with snapshots act on both the root and the corresponding boot snapshot, if such exists (e.g. B<snapshot> will create a snapshot for F</> and F</boot> with the same name in their corresponding snapshot directories, while B<delete> deletes both if they exist).



=head1 COMMANDS

=over

=item B<snapshot | snap> [[<SOURCESNAP>] <TARGETSNAP>]

Creates a snapshot with name I<TARGETSNAP> from a snapshot named I<SOURCESNAP>. Both arguments may be omitted; default for the target is a date snapshot with the current date and for source is I<@>.


=item B<rollback | roll> [<TARGETSNAP>] <SOURCESNAP>

Rolls back I<TARGETSNAP> from I<SOURCESNAP> by creating a snapshot. The target may be omitted, defaulting to I<@>.

In principle this is the same as B<snapman snapshot>, but with arguments reversed and different defaults, creating a different logic.


=item B<delete | del> <SNAP>

When no command-specific option is given, deletes snapshot I<SNAP>. See the section for command-specific options for details on modifying this behaviour.


=item B<list>

Lists all snapshots found in the I<root snapshot directory>. Should a corresponding boot snapshot exist in the I<boot snapshot directory>, then it is listed in a second column on the same line as the root snapshot. If a boot snapshot has no corresponding root snapshot, it is not listed.


=item B<printname> <SNAP>

Prints the name of the root snapshot and the corresponding boot snapshot given by I<SNAP> according to the current configuration. It is not checked if these actually exist. If either I<boot snapshot directory> or I<boot prefix> are not configured, the boot snapshot is omitted.

Only meant for scripting.

=back



=head1 OPTIONS

=over

=item B<-c> <file>, B<--config> <file>

Use I<file> as the configuration file, overriding the default path F</etc/snapman.d/snapman.conf>


=item B<-r> <directory>, B<--root-snapdir> <directory>

Sets the I<root snapshot directory>, overriding the I<root_snapshot_directory> variable from the configuration.


=item B<-R> <value>, B<--root-prefix> <value>

Sets the I<root snapshot prefix>, overriding the I<root_prefix> variable from the configuration.


=item B<-b> <directory>, B<--boot-snapdir> <directory>

Sets the I<boot snapshot directory>, overriding the I<boot_snapshot_directory> variable from the configuration. If this is set to "", it is handled equal to unconfigured.


=item B<-B> <value>, B<--boot-prefix> <value>

Sets the I<root snapshot prefix>, overriding the I<root_prefix> variable from the configuration. If this is set to "", it is handled equal to unconfigured.


=item B<--fstab> <file>, B<--fstab-path> <file>

Sets the path to the I<fstab> file to be written, based on the I<fstab template>.


=item B<--fstab-template> <file>, B<--fstab-template-path> <file>

Sets thes path to the I<fstab template>, from which the I<fstab> file should be created.


=back



=head1 SNAPSHOT OPTIONS (APPLY TO COMMANDS snapshot AND rollback)

=over

=item B<-f>, B<--force>

Force this action.

When a snapshot of given target name already exists, B<snapman> aborts with an error. This option overrides this behaviour by deleting the the target snapshot first, if it exists, essentially overwriting the snapshot.


=back


=head1 LIST OPTIONS

=over

=item B<-f>, B<--path>, B<--fullpath>

Prints the full absolute path to the snapshot, instead of just the name.


=item B<-d>, B<-t>, B<--date>, B<--time>

Only list date snapshots.


=item B<-n>, B<--named>

Exclude date snapshots from the list.


=back



=head1 DELETE OPTIONS

=over

=item B<-d>, B<--date>

Deletes (all) date snapshots. Behaviour can be modified with B<--older-than> and B<--newer-than>.


=item B<-o> <datestring>, B<--older> <datestring>, B<--older-than> <datestring>

When given in addition to B<--date>, deletes only snapshots where the date string is lower or equal compared to I<datestring>. Only part of the date may be given.

Note that no real date comparison is done nor is I<datestring> checked to be a valid (part of a) date; the comparison relies on the property of the date format, that a date and the corresponding date string in this format have the same order relation. Nonsensical strings may also be given, without this script checking or noticing a difference.


=item B<-n> <datestring>, B<--newer> <datestring>, B<--newer-than> <datestring>

When given in addition to B<--date>, deletes only snapshots where the date string is greater or equal compared to I<datestring>. Only part of the date may be given.

Note that no real date comparison is done nor is I<datestring> checked to be a valid (part of a) date; the comparison relies on the property of the date format, that a date and the corresponding date string in this format have the same order relation. Nonsensical strings may also be given, without this script checking or noticing a difference.


=item B<-k> <n>, B<--keep> <n>

When given in addition to B<--date>, the last n date snapshots are not deleted.

n must be a positive integer. 0 is treated as if <--keep> was not given at all.

=back



=head1 PRINTNAME OPTIONS

=over

=item B<-f>, B<--path>, B<--fullpath>

Prints the full absolute path to the snapshot, instead of just the name.


=back



=head1 EXAMPLES

The examples in this section assume that the I<root prefix> is "ROOT", the I<root snapshot directory> is F</snaps/root>, the I<boot prefix> is "BOOT" and the I<boot snapshot directory> is F</snaps/boot>.

=over

=item C<snapman snapshot foo>

Creates snapshots of F</snaps/root/ROOT> and F</snaps/boot/BOOT> as F</snaps/root/ROOT_foo> and F</snaps/boot/BOOT_foo> respectively


=item C<snapman snapshot -B ''>

Creates a date snapshot of F</snaps/root/ROOT> (e.g F</snaps/root/ROOT_date@2016-10-06T21:07:35>). Creates no snapshot for F</boot>.


=item C<snapman rollback -f foo>

Deletes F</snaps/root/ROOT> if it exists and replaces is with a snapshot of F</snaps/root/ROOT_foo>. Does the same for F</snaps/root/BOOT>.


=item C<snapman delete -do 2016-10-01 -n 2016-01-01>

Deletes date snapshots for dates between 2016-01-01T00:00:00 and 2016-10-01T00:00:00. In particular, snapshots for points in time on 2016-01-01 are deleted, while snapshots for 2016-10-01 are not.

=back


=cut
