Subversion Repositories zfs_utils

#!/usr/bin/env perl

# Simplified BSD License (FreeBSD License)
#
# Copyright (c) 2025, Daily Data Inc.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice, this
#    list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright notice,
#    this list of conditions and the following disclaimer in the documentation
#    and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

# cleanSnaps - detect and remove old ZFS snapshots named like YYYY-MM-DD-<N><d|w|m>
# Usage: cleanSnaps [-f] [-v] [-t <shift>] [-h]
#   -f  actually destroy snapshots (use with care)
#   -v  verbose
#   -t  time shift, simulate running at a different time. Examples:
#       -t 2m   (run as if 2 months ago)
#       -t -4w  (run as if 4 weeks earlier)
#       -t +3d  (run as if 3 days in the future)
#   -h  show this help and exit

use strict;
use warnings;
use Getopt::Long qw(GetOptions);
use Time::Piece;

# Allow short option bundling (e.g. -fv) and accept long names
Getopt::Long::Configure('bundling');

my %opts;
GetOptions(\%opts,
    'force|f',        # force (actually perform destroys)
    'verbose|v',      # verbose
    'help|h',         # help
    'timeshift|t=s',  # time shift string (alias -t)
) or die "Error parsing command line options\n";

# Normalize options: default behaviour is dry-run unless --force is specified.
my $FORCE   = (defined $opts{'force'} || defined $opts{'f'}) ? 1 : 0;
my $VERBOSE = (defined $opts{'verbose'} || defined $opts{'v'}) ? 1 : 0;
my $timeshift = defined $opts{'timeshift'} ? $opts{'timeshift'} : $opts{'t'};

my $ZFS_CMD = $ENV{ZFS_CMD} // 'zfs';

sub logmsg { print @_, "\n" if $VERBOSE }

# show help and exit
if ($opts{'help'} || $opts{'h'}) {
    print "Usage: cleanSnaps [--force|-f] [--verbose|-v] [--timeshift|-t <shift>] [--help|-h] [pool]\n";
    print "  --force, -f         actually destroy snapshots (default: dry-run)\n";
    print "  --verbose, -v       verbose logging\n";
    print "  --timeshift, -t     time shift, simulate running at a previous time (examples: 2m, -4w, +3d)\n";
    print "  --help, -h          show this help and exit\n";
    exit 0;
}

# compute simulated "now" if the user requested a time shift
# allows us to keep or remove snapshots as if we were running at a different time
# giving retention decisions less stringent on, say, backup systems
my $now = time();
if (defined $timeshift && $timeshift =~ /^(?:([+-]?)(\d+)([smhdwy]))$/i) {
    my ($sign, $num, $unit) = ($1, $2, lc $3);
    # default behavior: no leading sign => treat as negative (simulate running in the past)
    $sign = '-' unless defined $sign && $sign ne '';
    my %unit_secs = (
        s => 1,
        m => 30 * 86400,   # months approximated as 30 days to match snapshot 'm' semantics
        h => 3600,
        d => 86400,
        w => 7 * 86400,
        y => 365 * 86400,
    );
    if (!exists $unit_secs{$unit}) {
        die "Invalid time unit '$unit' in -t option; use s,m,h,d,w,y\n";
    }
    my $shift_seconds = $num * $unit_secs{$unit};
    $shift_seconds = -$shift_seconds if $sign eq '-';
    $now += $shift_seconds;
    my $ts_display = defined $timeshift ? $timeshift : $opts{t};
    logmsg("Simulating current time with shift $ts_display; adjusted now -> " . scalar(localtime($now)) );
}

my @candidates; # this will hold the candidates for removal

# Optional command-line parameter: pool name to process (only snapshots from this pool will be considered)
my $pool = shift @ARGV;
if ($pool) {
    logmsg("Filtering snapshots to pool: $pool");
}

# if a pool name was given, limit zfs list to that pool and do a recursive list
# recursion is done by default if no pool given
my $command = $ZFS_CMD . ' list -H -o name -t snapshot' . ($pool ? " -r $pool" : '');

open my $fh, '-|', $command or die "Failed to run $ZFS_CMD: $!";
while (my $snap = <$fh>) {
    chomp $snap;
    next unless defined $snap && $snap =~ /\S/;

    unless ($snap =~ /@/) {
        logmsg("skipping invalid snapshot name: $snap");
        next;
    }
    my ($dataset, $snapname) = split /@/, $snap, 2;

    # match an optional prefix, a date or date-time stamp, optional text, then TTL
    # Examples matched:
    #   pool@snapname-2025-12-01-3d
    #   pool@prefix_2025-12-01T12:30:00_foo_3h
    #   pool@2025-12-01_foo_2w
    # allow time separators of ':' or '.' and optional underscore or space before time
    unless ($snapname =~ m/.*?(\d{4}-\d{2}-\d{2}(?:[T _]\d{2}[:\.]\d{2}(?:[:\.]\d{2})?)?)(?:.*?)(\d+)([smhdwy])$/) {
        logmsg("snapshot does not match ...<date/time>...<N><s|m|h|d|w|y>: $snap");
        next;
    }
    my ($snap_date, $num, $unit) = ($1, $2, $3);

    # parse snapshot date/time using Time::Piece; accept several common formats
    my $snap_epoch;
    my @fmts = (
        '%Y-%m-%d %H:%M:%S',
        '%Y-%m-%dT%H:%M:%S',
        '%Y-%m-%d %H:%M',
        '%Y-%m-%d_%H.%M.%S',
        '%Y-%m-%d_%H.%M',
        '%Y-%m-%d',
    );
    # try to parse using each format until one works
    my $parsed = 0;
    for my $fmt (@fmts) {
        eval {
            my $tp = Time::Piece->strptime($snap_date, $fmt);
            $snap_epoch = $tp->epoch;
            $parsed = 1;
            1;
        };
        last if $parsed;
    }
    # didn't parse successfully, show message and skip
    unless ($parsed) {
        logmsg("failed to parse date/time '$snap_date' for $snap");
        next;
    }

    # compute retention in seconds according to unit (s,m,h,d,w,m,y)
    my $retention_seconds;
    if ($unit eq 's') { $retention_seconds = $num }
    elsif ($unit eq 'm') { $retention_seconds = $num * 30 * 86400 }   # months ~= 30 days
    elsif ($unit eq 'h') { $retention_seconds = $num * 3600 }
    elsif ($unit eq 'd') { $retention_seconds = $num * 86400 }
    elsif ($unit eq 'w') { $retention_seconds = $num * 7 * 86400 }
    elsif ($unit eq 'y') { $retention_seconds = $num * 365 * 86400 }
    else { logmsg("unknown unit $unit for $snap"); next }

   # determine if snapshot is older than retention period
    my $age = $now - $snap_epoch;
    if ($age > $retention_seconds) { # ready for removal
        push @candidates, $snap;
    } else { # keep
        my $age_days = $age / 86400;
        my $ret_days = $retention_seconds / 86400;
        logmsg("keep: $snap (age " . sprintf("%.2f", $age_days) . "d <= " . sprintf("%.2f", $ret_days) . "d)");
    }
}
close $fh;

if (!@candidates) {
    print "No snapshots to remove.\n";
    exit 0;
}

printf "Snapshots to remove (%d):\n", scalar @candidates;
for my $s (@candidates) { printf "  %s\n", $s }

if (!$FORCE) {
    print "\nDry-run: no snapshots were destroyed. Use -f to actually remove them.\n";
    exit 0;
}

# actual removal. If any fail, report error but continue to remove rest
my $failed = 0;
for my $s (@candidates) {
    printf "Destroying: %s\n", $s;
    my $rc = system($ZFS_CMD, 'destroy', $s);
    if ($rc != 0) {
        printf STDERR "Failed to destroy %s\n", $s;
        $failed = 1;
    }
}

if ($failed) {
    print STDERR "One or more destroys failed.\n";
    exit 1;
}

print "Done.\n";