#!/usr/local/bin/perl

###########################################################################
# zsd
#
# zsd (ZFS snapshot destroyer) destroys snapshots on a given dataset.
# The number of snapshots to destroy can be specified directly, or
# indirectly by specifying the number of snapshots that should be
# kept.
#
# Copyright (c) 2011-2014 Fabian Keil <fk@fabiankeil.de>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
###########################################################################

use warnings;
use strict;
use Getopt::Long;

use constant {
    VERSION => "2014-12-07-c2d3662",
    # When forking, sleep every MAX_UNDELAYED_DESTROY_OPERATIONS
    # forks for DESTROY_DELAY seconds to descrease the chances of
    # hitting process or file descriptor limits.
    #
    # The values were chosen arbitrary and autotuning would
    # be nice.
    MAX_UNDELAYED_DESTROY_OPERATIONS => 100,
    FORKED_DESTROY_DELAY => 5,
};

sub get_snapshots_for_filesystem($$$) {
    my ($zfs_dataset, $sort_by_name, $verbosity) = @_;
    my @zfs_datasets;
    my @zfs_snapshots = ();

    my $zfs_command = "zfs list -H -t snapshot -d 1 -o name";
    $zfs_command .= " -s name" if $sort_by_name;
    $zfs_command .= " '$zfs_dataset'";

    print("Gathering snapshots with: $zfs_command\n") if ($verbosity == 2);
    @zfs_datasets=`$zfs_command`;
    if ($?) {
        print("Failed executing: $zfs_command\n");
        exit 1;
    }

    foreach my $snapshot (@zfs_datasets) {
        chomp $snapshot;
        die "Unexpected snapshot: $snapshot" unless $snapshot =~ /^$zfs_dataset@/;
        push(@zfs_snapshots, $snapshot)
    }

    if (@zfs_datasets eq 0) {
        print("No datasets found\n");
        exit 1;
    }

    return \@zfs_snapshots;
}

sub destroy_snapshots($$$) {
    my ($zfs_snapshots_to_destroy, $fork_and_forget, $verbosity) = @_;
    my $forked_processes = 0;
    my $snapshot_count = 0;

    $SIG{CHLD} = "IGNORE" if ($fork_and_forget);

    foreach my $snapshot_to_destroy (@$zfs_snapshots_to_destroy) {
        my $destroy_command = "zfs destroy '$snapshot_to_destroy'";

        $snapshot_count++;

        if ($verbosity) {
            printf("Destroying snapshot %4d: %s\n", $snapshot_count, $snapshot_to_destroy)
        }

        if ($fork_and_forget) {
            my $pid = fork();
            if (!$pid && defined $pid ) {
                system($destroy_command);
                exit 0;
            }
            $forked_processes++;
            if (0 == $forked_processes % MAX_UNDELAYED_DESTROY_OPERATIONS) {
                if ($verbosity) {
                    printf("Taking a nap after forking %d processes\n", $forked_processes);
                }
                sleep(FORKED_DESTROY_DELAY);
            }
        } else {
            system($destroy_command) == 0
                or exit(1);
        }
    }
}

sub get_snapshots_to_destroy($$$) {
    my $snapshots = shift;
    my $snapshots_to_keep = shift;
    my $verbosity = shift;
    my @snapshots_to_destroy = (@{ $snapshots });

    while ($snapshots_to_keep > 0) {
        my $popped = pop(@snapshots_to_destroy);
        unless (defined $popped) {
            print("No datasets to pop left\n");
            last;
        }
        print("Keeping $popped\n") if ($verbosity == 2);
        $snapshots_to_keep--;
    }
    return \@snapshots_to_destroy;
}

sub get_number_of_snapshots_to_keep($$$$) {
    my ($snapshots_total, $snapshots_to_keep, $snapshots_to_destroy, $dataset) = @_;
    my $actually_kept;
    my $actually_destroyed;

    die "Can't figure out how many snapshots to delete"
        unless defined $snapshots_to_keep or defined $snapshots_to_destroy;

    if (defined $snapshots_to_destroy and not defined $snapshots_to_keep) {

        # If the user didn't specify how many snapshots should
        # be kept, keep at least one so the dataset can continue
        # to receive incremental snapshots.
        $snapshots_to_keep = 1;
    }

    if (defined $snapshots_to_destroy and
        ($snapshots_total > $snapshots_to_keep + $snapshots_to_destroy)) {

        # The specified number of snapshots can be destroyed
        # without reaching the snapshots-to-keep limit.
        $actually_kept = $snapshots_total - $snapshots_to_destroy;

    } else {

        # Honor the snapshots-to-keep limit if possible, otherwise keep all
        # the snapshots. Specifying a limit above the current number of
        # snapshots is useful to grow a certain amount of snapshots on
        # backup pools and thus is not treated as error.
        $actually_kept = ($snapshots_total > $snapshots_to_keep) ?
            $snapshots_to_keep : $snapshots_total;
    }

    if ($actually_kept < $snapshots_to_keep and $snapshots_to_keep < $snapshots_total)
    {
        die "Too few snapshots left. $actually_kept < $snapshots_to_keep";
    }

    $actually_destroyed = $snapshots_total - $actually_kept;

    printf("There are %d snapshots on '$dataset'. Can destroy %d and keep %d.\n",
           $snapshots_total, $actually_destroyed, $actually_kept) if (defined $dataset);

    return $actually_kept;
}

sub get_tests() {
    my @t = (
        [   5,    5,     5,     5],
        [  10,   20,    10,    10],
        [  10,   20,    10,    20],
        [  19,   19,    40,    30],
        [  20,   20,    40,    20],
        [  20,   20,    40,    30],
        [  20,   20,    20,    30],
        [4995, 5000,     5,     5],
        [4900, 5000,     5,   100],
        [4500, 5000,     5,   500],
        [   5, 5000,     5,  5000],
        [   0, 5000,     0,  5000],
        [4000, 5000,  4000,  5000],
        [2000, 5000,  2000,  5000],
        [2000, 5000,  2000,  3000],
        [2000, 5000,  2000,  3001],
        [1999, 5000,  1999,  3001],
        [1999, 4999,  1999,  3001],
        [1999, 4999,  1999,  3100],
        [ 499,  499,  1999,  3100],
        [ 100,  600,   100, undef],
        [ 500,  600, undef,   100],
        [   0,  600,     0,   600],
        [   1,  600, undef,   600],
        );
    my @tests;

    foreach my $i (0..@t-1) {
        $tests[$i]{'expected-result'}      = $t[$i][0];
        $tests[$i]{'snapshots-total'}      = $t[$i][1];
        $tests[$i]{'snapshots-to-keep'}    = $t[$i][2];
        $tests[$i]{'snapshots-to-destroy'} = $t[$i][3];
    }

    return @tests;
}

sub test() {
    my $failures = 0;
    my $executed_tests = 0;
    my @t = get_tests();

    foreach my $i (0..@t-1) {

        my $result = get_number_of_snapshots_to_keep($t[$i]{'snapshots-total'},
                                                     $t[$i]{'snapshots-to-keep'},
                                                     $t[$i]{'snapshots-to-destroy'},
                                                     undef);
        if ($result != $t[$i]{'expected-result'}) {
            $failures++;
            printf("Test %d failed: Expected %d. Got %d\n",
                   $i, $t[$i]{'expected-result'}, $result);
        }
        $executed_tests++;
    }

    printf("Executed %d tests. Failures: %d.\n", $executed_tests, $failures);
    exit($failures);
}

sub usage($) {
    my $exit_code = shift;
    my $script = $0;
    my $version = VERSION;

    $script =~ s@.*/@@;

    print << "EOF"
zsd $version
usage: $script [--gather-snapshots-sorted-by-name] [--fork-and-forget] [--not-really] [--verbose][--verbose] --keep number-of-snapshots --destroy number-of-snapshots dataset
       $script [--gather-snapshots-sorted-by-name] [--fork-and-forget] [--not-really] [--verbose][--verbose] --keep number-of-snapshots dataset
       $script [--gather-snapshots-sorted-by-name] [--fork-and-forget] [--not-really] [--verbose][--verbose] --destroy number-of-snapshots  dataset
       $script --help

For details see: perldoc $script
EOF
    ;

    exit $exit_code;
}

sub incorrect_usage($) {
    my $offense = shift;

    print "Error: ", $offense, "\n";
    usage(1);
}

sub main() {
    my $snapshots_to_keep;
    my $snapshots_to_destroy;
    my $verbosity = 0;
    my $fork_and_forget = 0;
    my $dataset;
    my $snapshots;
    my $snapshots_total;
    my $sort_by_name = 0;
    my $not_really = 0;

    GetOptions(
        'keep=i'                          => \$snapshots_to_keep,
        # --delete is deprecated, but still supported.
        'delete=i'                        => \$snapshots_to_destroy,
        'destroy=i'                       => \$snapshots_to_destroy,
        # Make it obvious to GetOpt, that --destroy doesn't conflict
        # with --delete and thus can be safely shortened to -d.
        'd=i'                             => \$snapshots_to_destroy,
        'not-really'                      => \$not_really,
        'verbose'                         => sub { $verbosity++; },
        'fork-and-forget'                 => \$fork_and_forget,
        'gather-snapshots-sorted-by-name' => \$sort_by_name,
        'help'                            => sub {usage(0);},
        'test'                            => sub {test();},
        ) or usage(1);

    $dataset = $ARGV[0];

    incorrect_usage("No dataset provided") unless defined $dataset;
    incorrect_usage("Snapshot provided as dataset") if ($dataset =~ /@/);
    incorrect_usage("Too many arguments") unless  @ARGV eq 1;
    unless (defined $snapshots_to_keep || defined $snapshots_to_destroy) {
        incorrect_usage("Neither --keep nor --destroy used");
    }
    if (defined $snapshots_to_keep and $snapshots_to_keep < 0) {
        incorrect_usage("Negative number of snapshots to keep");
    }
    if (defined $snapshots_to_destroy and $snapshots_to_destroy < 0) {
        incorrect_usage("Negative number of snapshots to destroy");
    }

    $snapshots = get_snapshots_for_filesystem($dataset, $sort_by_name, $verbosity);
    $snapshots_total = scalar @$snapshots;
    $snapshots_to_keep = get_number_of_snapshots_to_keep($snapshots_total,
                                                         $snapshots_to_keep,
                                                         $snapshots_to_destroy,
                                                         $dataset);

    if ($snapshots_total > $snapshots_to_keep) {
        $snapshots = get_snapshots_to_destroy($snapshots, $snapshots_to_keep, $verbosity);
        unless ($not_really) {
            destroy_snapshots($snapshots, $fork_and_forget, $verbosity);
        }
    }
}

main();

=head1 NAME

B<zsd> - Quickly destroys a specified amount of ZFS snapshots

=head1 SYNOPSIS

B<zsd> [B<--gather-snapshots-sorted-by-name>] [B<--fork-and-forget>]
[B<--verbose>][B<--verbose>] B<--keep number-of-snapshots>
B<--destroy number-of-snapshots> [B<--not-really>]
dataset

B<zsd> [B<--gather-snapshots-sorted-by-name>] [B<--fork-and-forget>]
[B<--verbose>][B<--verbose>] B<--keep number-of-snapshots> [B<--not-really>]
dataset

B<zsd> [B<--gather-snapshots-sorted-by-name>] [B<--fork-and-forget>]
[B<--verbose>][B<--verbose>] B<--destroy number-of-snapshots> [B<--not-really>]
dataset

B<zsd> B<--help>

=head1 DESCRIPTION

B<zsd> (ZFS snapshot destroyer) is a zfs(8) wrapper to destroy
a number of snapshots on a given dataset using a more convenient
interface.

The number of snapshots to destroy can be specified directly,
or indirectly by specifying the number of snapshots that should be
kept. Snapshots are destroyed in the (by default chronological) order
they are listed by B<zfs list>.

B<zsd> goes nicely with B<zogftw's> B<zogftw_snapshot_successfully_sent_hook>
to grow a certain number of snapshots on new backup datasets while
keeping the number of snapshots on old backup datasets constant.

B<zsd> is mainly developed and tested using OpenZFS on FreeBSD,
but is expected to work on other platforms as well.

=head1 OPTIONS

B<--destroy number-of-snapshots> If enough snapshots are available,
destroy snapshots until reaching either the specified number or the
number of snapshots to keep specified with B<--keep>. If B<--keep>
isn't used, one snapshot is kept so receival of incremental snapshots
continues to work.

B<--gather-snapshots-sorted-by-name> Let zfs(8) list the available
snapshots sorted by name which is a lot faster (on FreeBSD) as
less metadata has to be read. This should only be used if the order
in which snapshots are destroyed doesn't matter or if sorting the
snapshots by name keeps the chronological order.

B<--fork-and-forget> Fork a process for each snapshots that should be
destroyed and don't check if the operation is successful. If the ZFS
pool feature B<async_destroy> is unsupported or disabled, this is
generally faster than destroying the snapshots one-by-one.
The downside is that it requires more memory and that errors
are ignored.

Destroying too many snapshots at the same time can cause some
FreeBSD versions to become unresponsive under some conditions and
rebooting the system a couple of times may take longer than
destroying the snapshots one-by-one. You may want to experiment
with this option before using it in production environments.

B<--keep number-of-snapshots> When used without B<--destroy>
and if enough snapshots are available, snapshots are destroyed
until the given number of snapshots is reached. If the option
is used together with B<--destroy>, it specifies the number of
snapshots that should be kept.

B<--not-really> Show how many snapshots would be destroyed if
the option wasn't being used, but don't actually destroy them.

B<--verbose> Be more verbose. When specified once, the destroyed
snapshots are shown. When specified twice, the kept snapshots are
shown as well.

All options can be shortened as long as there are no ambiguities.

=head1 EXAMPLES

The following examples are independent and assume a dataset
B<tank/blafasel> with 100 snapshots.

B<zsd> B<--destroy 10> B<tank/blafasel>
Destroys 10 snapshots.

B<zsd> B<--destroy 100> B<tank/blafasel>
Destroys 99 snapshots as not using B<--keep> implies that
at least one snapshot should be kept.

B<zsd> B<--destroy 100> B<--keep 0> B<tank/blafasel>
Destroys all the 100 snapshots as no snapshot has to be kept.

B<zsd> B<-d 100> B<-k 0> B<tank/blafasel>
Same as the above, but requires less typing.

B<zsd> B<--destroy 100> B<--keep 40> B<tank/blafasel>
Destroys 60 snapshots as 40 snapshots have to be kept.

B<zsd> B<--destroy 10> B<--keep 40> B<tank/blafasel>
Destroys 10 snapshots, keeping 90 as 40 is only the lower limit.

B<zsd> B<-d 20> B<-k 20> B<-n> B<tank/blafasel>
Shows how many snapshots would be destroyed without B<-n>.

B<zsd> B<--destroy 100> B<--keep 200> B<tank/blafasel>
Destroys no snapshot as the number of snapshots to keep is above
the number of snapshots available on the dataset.

B<zsd> B<--keep 10> B<tank/blafasel>
Destroys 90 snapshots as not using B<--destroy> implies that
all the snapshots above the limit should be destroyed.

=head1 SEE ALSO

zfs(8) zogftw(8) zpool-features(7)

=head1 AUTHOR

Fabian Keil <fk@fabiankeil.de>

=cut
