#!/usr/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-2013 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 => "0.1 (3b9e2c2)",
    # 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("Fail with '$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. Will destroy %d, keeping %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] [--verbose][--verbose] --keep number-of-snapshots --destroy number-of-snapshots dataset
       $script [--gather-snapshots-sorted-by-name] [--fork-and-forget] [--verbose][--verbose] --keep number-of-snapshots dataset
       $script [--gather-snapshots-sorted-by-name] [--fork-and-forget] [--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;

    GetOptions(
        'keep=i'                          => \$snapshots_to_keep,
        # --delete is deprecated, but still supported.
        'delete=i'                        => \$snapshots_to_destroy,
        'destroy=i'                       => \$snapshots_to_destroy,
        '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);
        destroy_snapshots($snapshots, $fork_and_forget, $verbosity);
    }
}

main();

=head1 NAME

B<zsd> - Destroys 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>
dataset

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

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

B<zsd> B<--help>

=head1 DESCRIPTION

B<zsd> (ZFS snapshot destroyer) is a zfs(8) wrapper to destroy
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.

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

=head1 OPTIONS

B<--keep number-of-snapshots> If this option is used without
B<--destroy>, every snapshot above the specified number is destroyed.
If it is used together with B<--destroy>, it specifies a number of
snapshots that should be kept.

B<--destroy number-of-snapshots> 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, a limit of 1
is assumed to keep incrementals working.

B<--gather-snapshots-sorted-by-name> Let zfs(8) list the available
snapshots sorted by name which is a lot faster 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. This is
generally faster than destroying the snapshots one-by-one, especially
if the zpool feature async_destroy isn't used. The downside is that it
requires more memory and that errors are ignored.

Note that on FreeBSD destroying too many snapshots at the same time
can apparently cause the system to become unresponsive under some
conditions and rebooting the system a couple of times may take longer
than destroying the snapshots one-by-one.

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<--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<--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)

=head1 AUTHOR

Fabian Keil <fk@fabiankeil.de>

=cut
