#!/usr/bin/perl -w
#############################
# snap
#
# This script implements NetApp OnTap-style snapshotting on a btrfs volume.
#
# It works by recursing down a given btrfs volume tree looking for
# subdirectories named .snapshot
#
# If a .snapshot directory is found, it then looks for a .config file
# inside.  If no .config, it will move on.  Otherwise, it will perform
# an action based on the .config.
#
# The syntax of the .config file is NetApp-like and very simple.  It is
# broken into three sections:
#
#  Number of hourly snapshots to keep
#  Number of daily snapshots to keep, and when to take them
#  Number of weekly snapshots to keep, and on what day to take them
#
# This works out like so:
# 3 2@0 1@0
#
# This would keep 3 hourly snapshots, rotating them out each hour.
# Keep 2 daily snapshots taken at 00:00, rotating them out each day.
# Keep 1 weekly snapshot, taken at 00:00 on the first day of the week.
#
# Currently, weekly snapshots are only taken at system-time 00:00.  Feel free
# to patch in functionality to add in the ability to change this.  Let
# me know if you do.
#
# This code is provided to the public domain.  If you find it useful,
# drop me a line and let me know.  :)
#
# -JSK, 2010 June 4
# www.generalcriticism.com
# jking at projectkutani com
#####################################

use strict;
use File::Copy;


# This is the root of the btrfs volume we want snapshots implemented on
my $root = "/data";

if( run() ) { Error("Failed at root path, exiting..."); }
exit;


sub run {
	if( descend($root) ) { return 1; }
	return 0;
}


sub descend {
	my $dir  = shift;
	my @list = ();

	if( -d "$dir/.snapshot" ) {

		if( process($dir) ) {
			Error("Failed processing snapshots for $dir");
			return 1;
		} else {
			return 0;
		}

	}
	
	unless( opendir(DIR,"$dir") ) {
		Error("Failed opening dir $dir: $!");
		return 1;
	}
	while( defined( my $d = readdir(DIR) ) ) {
		if( $d =~ /^\.+$/ ) { next; }
		if( -d "$dir/$d" && $d !~ /^\.snapshot$/ ) {
			push @list, "$dir/$d";
		}
	}
	closedir(DIR);

	foreach( @list ) { descend($_); }
	return 0;
}


sub process {
	my $subvol   = shift;
	my $snapdir  = "$subvol/.snapshot";
	my $conf     = undef;
	my $hr       = undef;
	my $day      = undef;
	my $daytime  = undef;
	my $week     = undef;
	my $weekday  = undef;
	my $cnt      = 0;
	my @prs      = ();
	my @time     = ();

	if( ! -e "$snapdir/.config" ) {
		Error("Subvol $subvol has no snapshot config");
		return 1;
	}

	unless( open(FILE,"<$snapdir/.config") ) {
		Error("Failed opening $subvol config for reading: $!");
		return 1;
	}
	$conf = <FILE>;
	chomp($conf);
	close(FILE);


	($hr, $day, $week) = split /\s+/, $conf, 3;

	if( $day  =~ /\@/ ) { ($day, $daytime)  = split /\@/, $day;  }
	else                { $daytime = 0; }

	if( $week =~ /\@/ ) { ($week, $weekday) = split /\@/, $week; }
	else                { $weekday = 0; }

	if( ! shiftsnaps( $snapdir, "hourly", 0, $hr ) && $hr > 0 ) {
		system("btrfs subvolume snapshot $subvol $snapdir/hourly.0");
		if( $? >> 8 == 1 ) {
			Error("Failed creating hourly snapshot on $subvol");
		}
	}

	@time = localtime(time);
	if( $time[2] == $daytime ) {
		if( ! shiftsnaps( $snapdir, "daily", 0, $day ) && $day > 0 ) {
			system("btrfs subvolume snapshot $subvol $snapdir/daily.0");
			if( $? >> 8 == 1 ) {
				Error("Failed creating daily snapshot on $subvol");
			}
		}
	}

	if( $time[6] == $weekday && $time[2] == 0 ) {
		if( ! shiftsnaps( $snapdir, "weekly", 0, $week ) && $week > 0 ) {
			system("btrfs subvolume snapshot $subvol $snapdir/weekly.0");
			if( $? >> 8 == 1 ) {
				Error("Failed creating weekly snapshot on $subvol");
			}
		}
	}

	return 0;
}

sub shiftsnaps {
	my $snapdir = shift;
	my $type    = shift;
	my $cnt     = shift;
	my $cut     = shift;
	my $ncnt    = $cnt+1; 

	if( -e "$snapdir/$type.$cnt" ) {

		if( $ncnt >= $cut ) {
			system("btrfsctl -D $type.$cnt $snapdir");
			if( $? >> 8 == 0 ) { 
				Error("Failed removing $type.$cnt from $snapdir");
				return 1;
			}
			return 0;
		} else {
			if( shiftsnaps($snapdir,$type,$ncnt,$cut) ) { return 1; }
		}

		unless( move("$snapdir/$type.$cnt", "$snapdir/$type.$ncnt") ) {
			Error("Failed shifting $type.$cnt up in $snapdir");
			return 1;
		}
	}

	return 0;
}

sub Error {
	my $msg = shift;
	print "$msg\n";
	return;
}