#!/usr/bin/perl -T
=head1 NAME
btrbk - backup tool for btrfs volumes
=head1 SYNOPSIS
btrbk --help
=head1 DESCRIPTION
Backup tool for btrfs subvolumes, taking advantage of btrfs specific
send-receive mechanism, allowing incremental backups at file-system
level.
The full btrbk documentation is available at L.
=head1 AUTHOR
Axel Burri
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2014-2015 Axel Burri. All rights reserved.
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
=cut
use strict;
use warnings FATAL => qw( all );
use Carp qw(confess);
use Date::Calc qw(Today Delta_Days Day_of_Week);
use Getopt::Std;
use Data::Dumper;
our $VERSION = "0.15";
our $AUTHOR = 'Axel Burri ';
our $PROJECT_HOME = '';
my $version_info = "btrbk command line client, version $VERSION";
my @config_src = ("/etc/btrbk.conf", "/etc/btrbk/btrbk.conf");
my %day_of_week_map = ( monday => 1, tuesday => 2, wednesday => 3, thursday => 4, friday => 5, saturday => 6, sunday => 7 );
my %config_options = (
# NOTE: the parser always maps "no" to undef
# NOTE: keys "volume", "subvolume" and "target" are hardcoded
snapshot_dir => { default => undef, accept_file => { relative => 1 }, append_trailing_slash => 1 },
receive_log => { default => undef, accept => [ "sidecar", "no" ], accept_file => { absolute => 1 }, deprecated => "removed" },
incremental => { default => "yes", accept => [ "yes", "no", "strict" ] },
snapshot_create_always => { default => undef, accept => [ "yes", "no" ] },
resume_missing => { default => undef, accept => [ "yes", "no" ] },
preserve_day_of_week => { default => "sunday", accept => [ (keys %day_of_week_map) ] },
snapshot_preserve_daily => { default => "all", accept => [ "all" ], accept_numeric => 1 },
snapshot_preserve_weekly => { default => 0, accept => [ "all" ], accept_numeric => 1 },
snapshot_preserve_monthly => { default => "all", accept => [ "all" ], accept_numeric => 1 },
target_preserve_daily => { default => "all", accept => [ "all" ], accept_numeric => 1 },
target_preserve_weekly => { default => 0, accept => [ "all" ], accept_numeric => 1 },
target_preserve_monthly => { default => "all", accept => [ "all" ], accept_numeric => 1 },
btrfs_commit_delete => { default => undef, accept => [ "after", "each", "no" ] },
ssh_identity => { default => undef, accept_file => { absolute => 1 } },
ssh_user => { default => "root", accept_regexp => qr/^[a-z_][a-z0-9_-]*$/ },
btrfs_progs_compat => { default => undef, accept => [ "yes", "no" ] },
);
my @config_target_types = qw(send-receive);
my %vol_info;
my %uuid_info;
my %uuid_fs_map;
my %vol_btrfs_progs_compat; # hacky, maps all subvolumes without received_uuid information
my $dryrun;
my $loglevel = 1;
my $ip_addr_match = qr/(([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])\.){3}([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/;
my $host_name_match = qr/(([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9])/;
my $file_match = qr/[0-9a-zA-Z_@\-\.\/]+/; # note: ubuntu uses '@' in the subvolume layout:
my $ssh_prefix_match = qr/ssh:\/\/($ip_addr_match|$host_name_match)/;
$SIG{__DIE__} = sub {
print STDERR "\nERROR: process died unexpectedly (btrbk v$VERSION)";
print STDERR "\nPlease contact the author: $AUTHOR\n\n";
print STDERR "Stack Trace:\n----------------------------------------\n";
Carp::confess @_;
};
sub VERSION_MESSAGE
{
print STDERR $version_info . "\n\n";
}
sub HELP_MESSAGE
{
print STDERR "usage: btrbk [options] \n";
print STDERR "\n";
print STDERR "options:\n";
print STDERR " --help display this help message\n";
print STDERR " --version display version information\n";
print STDERR " -c FILE specify configuration file\n";
print STDERR " -p preserve all backups (do not delete any old targets)\n";
print STDERR " -v be verbose (set loglevel=info)\n";
print STDERR " -q be quiet (do not print summary at end of \"run\" command)\n";
print STDERR " -l LEVEL set loglevel (warn, info, debug, trace)\n";
print STDERR "\n";
print STDERR "commands:\n";
print STDERR " run perform backup operations as defined in the configuration\n";
print STDERR " dryrun don't run btrfs commands, just show what would be executed\n";
print STDERR " info print useful filesystem information\n";
print STDERR " tree shows backup tree\n";
print STDERR " origin print origin information for subvolume\n";
print STDERR " diff shows new files since subvolume for subvolume \n";
print STDERR "\n";
print STDERR "For additional information, see $PROJECT_HOME\n";
}
sub TRACE { my $t = shift; print STDOUT "... $t\n" if($loglevel >= 4); }
sub DEBUG { my $t = shift; print STDOUT "$t\n" if($loglevel >= 3); }
sub INFO { my $t = shift; print STDOUT "$t\n" if($loglevel >= 2); }
sub WARN { my $t = shift; print STDOUT "WARNING: $t\n" if($loglevel >= 1); }
sub ERROR { my $t = shift; print STDOUT "ERROR: $t\n"; }
sub run_cmd($;$)
{
my $cmd = shift || die;
my $non_destructive = shift;
my $ret = "";
$cmd =~ s/^\s+//;
$cmd =~ s/\s+$//;
if($non_destructive || (not $dryrun)) {
DEBUG "### $cmd";
$ret = `$cmd`;
chomp($ret);
TRACE "Command output:\n$ret";
if($?) {
my $exitcode= $? >> 8;
my $signal = $? & 127;
WARN "Command execution failed (exitcode=$exitcode" . ($signal ? ", signal=$signal" : "") . "): \"$cmd\"";
return undef;
}
else {
DEBUG "Command execution successful";
}
}
else {
DEBUG "### (dryrun) $cmd";
}
return $ret;
}
sub subvol($$)
{
my $root = shift || die;
my $vol = shift || die;
if($vol_info{$root} && $vol_info{$root}->{$vol}) {
return $vol_info{$root}->{$vol}->{node};
}
return undef;
}
sub get_rsh($$)
{
my $url = shift // die;
my $config = shift;
if($config && ($url =~ /^ssh:\/\/(\S+?)(\/\S+)$/)) {
my ($ssh_host, $file) = ($1, $2);
my $ssh_user = config_key($config, "ssh_user");
my $ssh_identity = config_key($config, "ssh_identity");
my $ssh_options = "";
if($ssh_identity) {
$ssh_options .= " -i $ssh_identity";
}
else {
WARN "No SSH identity provided (option ssh_identity is not set) for: $url";
}
my $rsh = "/usr/bin/ssh $ssh_options " . $ssh_user . '@' . $ssh_host;
return ($rsh, $file);
}
return ("", $url);
}
sub config_key($$)
{
my $node = shift || die;
my $key = shift || die;
TRACE "config_key: context=$node->{CONTEXT}, key=$key";
while(not exists($node->{$key})) {
return undef unless($node->{PARENT});
$node = $node->{PARENT};
}
TRACE "config_key: found value=" . ($node->{$key} // "");
return $node->{$key};
}
sub check_file($$$$)
{
my $file = shift;
my $accept = shift;
my $key = shift; # only for error text
my $config_file = shift; # only for error text
if($accept->{ssh} && ($file =~ /^ssh:\/\//)) {
unless($file =~ /^$ssh_prefix_match\/$file_match$/) {
ERROR "Ambiguous ssh url for option \"$key\" in \"$config_file\" line $.: $file";
return undef;
}
}
elsif($file =~ /^$file_match$/) {
if($accept->{absolute}) {
unless($file =~ /^\//) {
ERROR "Only absolute files allowed for option \"$key\" in \"$config_file\" line $.: $file";
return undef;
}
}
elsif($accept->{relative}) {
if($file =~ /^\//) {
ERROR "Only relative files allowed for option \"$key\" in \"$config_file\" line $.: $file";
return undef;
}
}
else {
die("accept_type must contain either 'relative' or 'absolute'");
}
}
else {
ERROR "Ambiguous file for option \"$key\" in \"$config_file\" line $.: $file";
return undef;
}
return $file;
}
sub parse_config(@)
{
my @config_files = @_;
my $file = undef;
foreach(@config_files) {
TRACE "config: checking for file: $_";
if(-r "$_") {
$file = $_;
last;
}
}
unless($file) {
ERROR "Configuration file not found: " . join(', ', @config_files);
return undef;
}
my $root = { CONTEXT => "root", SRC_FILE => $file };
my $cur = $root;
# set defaults
foreach (keys %config_options) {
$root->{$_} = $config_options{$_}->{default};
}
DEBUG "config: parsing file: $file";
open(FILE, '<', $file) or die $!;
while () {
chomp;
next if /^\s*#/; # ignore comments
next if /^\s*$/; # ignore empty lines
TRACE "config: parsing line $. with context=$cur->{CONTEXT}: \"$_\"";
if(/^(\s*)([a-zA-Z_]+)\s+(.*)$/)
{
my ($indent, $key, $value) = (length($1), lc($2), $3);
$value =~ s/\s*$//;
# NOTE: we do not perform checks on indentation!
if($key eq "volume")
{
$cur = $root;
DEBUG "config: context forced to: $cur->{CONTEXT}";
# be very strict about file options, for security sake
return undef unless(check_file($value, { absolute => 1, ssh => 1 }, $key, $file));
$value =~ s/\/+$//; # remove trailing slash
$value =~ s/^\/+/\//; # sanitize leading slash
DEBUG "config: adding volume \"$value\" to root context";
my $volume = { CONTEXT => "volume",
PARENT => $cur,
sroot => $value,
};
$cur->{VOLUME} //= [];
push(@{$cur->{VOLUME}}, $volume);
$cur = $volume;
}
elsif($key eq "subvolume")
{
while($cur->{CONTEXT} ne "volume") {
if(($cur->{CONTEXT} eq "root") || (not $cur->{PARENT})) {
ERROR "subvolume keyword outside volume context, in \"$file\" line $.";
return undef;
}
$cur = $cur->{PARENT} || die;
DEBUG "config: context changed to: $cur->{CONTEXT}";
}
# be very strict about file options, for security sake
return undef unless(check_file($value, { relative => 1 }, $key, $file));
$value =~ s/\/+$//; # remove trailing slash
$value =~ s/^\/+//; # remove leading slash
if($value =~ /\//) {
ERROR "subvolume contains slashes: \"$value\" in \"$file\" line $.";
return undef;
}
DEBUG "config: adding subvolume \"$value\" to volume context: $cur->{sroot}";
my $subvolume = { CONTEXT => "subvolume",
PARENT => $cur,
svol => $value,
};
$cur->{SUBVOLUME} //= [];
push(@{$cur->{SUBVOLUME}}, $subvolume);
$cur = $subvolume;
}
elsif($key eq "target")
{
if($cur->{CONTEXT} eq "target") {
$cur = $cur->{PARENT} || die;
DEBUG "config: context changed to: $cur->{CONTEXT}";
}
if($cur->{CONTEXT} ne "subvolume") {
ERROR "target keyword outside subvolume context, in \"$file\" line $.";
return undef;
}
if($value =~ /^(\S+)\s+(\S+)$/)
{
my ($target_type, $droot) = ($1, $2);
unless(grep(/^$target_type$/, @config_target_types)) {
ERROR "unknown target type \"$target_type\" in \"$file\" line $.";
return undef;
}
# be very strict about file options, for security sake
return undef unless(check_file($droot, { absolute => 1, ssh => 1 }, $key, $file));
$droot =~ s/\/+$//; # remove trailing slash
$droot =~ s/^\/+/\//; # sanitize leading slash
DEBUG "config: adding target \"$droot\" (type=$target_type) to subvolume context: $cur->{PARENT}->{sroot}/$cur->{svol}";
my $target = { CONTEXT => "target",
PARENT => $cur,
target_type => $target_type,
droot => $droot,
};
$cur->{TARGET} //= [];
push(@{$cur->{TARGET}}, $target);
$cur = $target;
}
else
{
ERROR "Ambiguous target configuration, in \"$file\" line $.";
return undef;
}
}
elsif(grep(/^$key$/, keys %config_options)) # accept only keys listed in %config_options
{
if(grep(/^$value$/, @{$config_options{$key}->{accept}})) {
TRACE "option \"$key=$value\" found in accept list";
}
elsif($config_options{$key}->{accept_numeric} && ($value =~ /^[0-9]+$/)) {
TRACE "option \"$key=$value\" is numeric, accepted";
}
elsif($config_options{$key}->{accept_file})
{
# be very strict about file options, for security sake
return undef unless(check_file($value, $config_options{$key}->{accept_file}, $key, $file));
TRACE "option \"$key=$value\" is a valid file, accepted";
$value =~ s/\/+$//; # remove trailing slash
$value =~ s/^\/+/\//; # sanitize leading slash
if($config_options{$key}->{append_trailing_slash}) {
TRACE "append_trailing_slash is specified for option \"$key\", adding trailing slash";
$value .= '/';
}
}
elsif($config_options{$key}->{accept_regexp}) {
my $match = $config_options{$key}->{accept_regexp};
if($value =~ m/$match/) {
TRACE "option \"$key=$value\" matched regexp, accepted";
}
else {
ERROR "Value \"$value\" failed input validation for option \"$key\" in \"$file\" line $.";
return undef;
}
}
else
{
ERROR "Unsupported value \"$value\" for option \"$key\" in \"$file\" line $.";
return undef;
}
DEBUG "config: adding option \"$key=$value\" to $cur->{CONTEXT} context";
$value = undef if($value eq "no"); # we don't want to check for "no" all the time
$cur->{$key} = $value;
if($config_options{$key}->{deprecated}) {
WARN "Found deprecated configuration option \"$key\" in \"$file\" line $.";
}
}
else
{
ERROR "Unknown option \"$key\" in \"$file\" line $.";
return undef;
}
TRACE "line processed: new context=$cur->{CONTEXT}";
}
else
{
ERROR "Parse error in \"$file\" line $.";
return undef;
}
}
TRACE(Data::Dumper->Dump([$root], ["config_root"]));
return $root;
}
sub btr_filesystem_show_all_local()
{
return run_cmd("/sbin/btrfs filesystem show", 1);
}
sub btr_filesystem_show($;$)
{
my $vol = shift || die;
my $config = shift;
my ($rsh, $real_vol) = get_rsh($vol, $config);
my $ret = run_cmd("$rsh /sbin/btrfs filesystem show $real_vol", 1);
return $ret;
}
sub btr_filesystem_df($;$)
{
my $vol = shift || die;
my $config = shift;
my ($rsh, $real_vol) = get_rsh($vol, $config);
my $ret = run_cmd("$rsh /sbin/btrfs filesystem df $real_vol", 1);
return $ret;
}
sub btr_filesystem_usage($;$)
{
my $vol = shift || die;
my $config = shift;
my ($rsh, $real_vol) = get_rsh($vol, $config);
my $ret = run_cmd("$rsh /sbin/btrfs filesystem usage $real_vol", 1);
return $ret;
}
sub btr_subvolume_detail($;$)
{
my $vol = shift || die;
my $config = shift;
my ($rsh, $real_vol) = get_rsh($vol, $config);
my $ret = run_cmd("$rsh /sbin/btrfs subvolume show $real_vol 2>/dev/null", 1);
if($ret)
{
if($ret eq "$real_vol is btrfs root") {
DEBUG "found btrfs root: $vol";
return { id => 5, is_root => 1 };
}
elsif($ret =~ /^$real_vol/) {
TRACE "btr_detail: found btrfs subvolume: $vol";
my %trans = (
name => "Name",
uuid => "uuid",
parent_uuid => "Parent uuid",
creation_time => "Creation time",
id => "Object ID",
gen => "Generation \\(Gen\\)",
cgen => "Gen at creation",
parent_id => "Parent",
top_level => "Top Level",
flags => "Flags",
);
my %detail;
foreach (keys %trans) {
if($ret =~ /^\s+$trans{$_}:\s+(.*)$/m) {
$detail{$_} = $1;
} else {
WARN "Failed to parse subvolume detail \"$trans{$_}\": $ret";
}
}
DEBUG "parsed " . scalar(keys %detail) . " subvolume detail items: $vol";
TRACE "btr_detail for $vol: " . Dumper \%detail;
return \%detail;
}
}
WARN "Failed to fetch subvolume detail for: $vol";
return undef;
}
sub btr_subvolume_list($;$@)
{
my $vol = shift || die;
my $config = shift;
my %opts = @_;
my $btrfs_progs_compat = config_key($config, "btrfs_progs_compat");
my $filter_option = "-a";
$filter_option = "-o" if($opts{subvol_only});
my $display_options = "-c -u -q";
$display_options .= " -R" unless($btrfs_progs_compat);
my ($rsh, $real_vol) = get_rsh($vol, $config);
my $ret = run_cmd("$rsh /sbin/btrfs subvolume list $filter_option $display_options $real_vol", 1);
unless(defined($ret)) {
WARN "Failed to fetch btrfs subvolume list for: $vol";
return undef;
}
my @nodes;
foreach (split(/\n/, $ret))
{
# ID top level path where path is the relative path
# of the subvolume to the top level subvolume. The subvolume?s ID may
# be used by the subvolume set-default command, or at mount time via
# the subvolid= option. If -p is given, then parent is added to
# the output between ID and top level. The parent?s ID may be used at
# mount time via the subvolrootid= option.
# NOTE: btrfs-progs prior to v1.17 do not support the -R flag
my %node;
if($btrfs_progs_compat) {
die("Failed to parse line: \"$_\"") unless(/^ID ([0-9]+) gen ([0-9]+) cgen ([0-9]+) top level ([0-9]+) parent_uuid ([0-9a-z-]+) uuid ([0-9a-z-]+) path (.+)$/);
%node = (
id => $1,
gen => $2,
cgen => $3,
top_level => $4,
parent_uuid => $5, # note: parent_uuid="-" if no parent
# received_uuid => $6,
uuid => $6,
path => $7 # btrfs path, NOT filesystem path
);
} else {
die("Failed to parse line: \"$_\"") unless(/^ID ([0-9]+) gen ([0-9]+) cgen ([0-9]+) top level ([0-9]+) parent_uuid ([0-9a-z-]+) received_uuid ([0-9a-z-]+) uuid ([0-9a-z-]+) path (.+)$/);
%node = (
id => $1,
gen => $2,
cgen => $3,
top_level => $4,
parent_uuid => $5, # note: parent_uuid="-" if no parent
received_uuid => $6,
uuid => $7,
path => $8 # btrfs path, NOT filesystem path
);
}
# NOTE: "btrfs subvolume list " prints prefix only if
# the subvolume is reachable within . (as of btrfs-progs-3.18.2)
#
# NOTE: Be prepared for this to change in btrfs-progs!
$node{path} =~ s/^\///; # remove "/" portion from "path".
push @nodes, \%node;
# $node{parent_uuid} = undef if($node{parent_uuid} eq '-');
}
DEBUG "parsed " . scalar(@nodes) . " total subvolumes for filesystem at: $vol";
return \@nodes;
}
sub btr_subvolume_find_new($$;$)
{
my $vol = shift || die;
my $lastgen = shift // die;
my $config = shift;
my ($rsh, $real_vol) = get_rsh($vol, $config);
my $ret = run_cmd("$rsh /sbin/btrfs subvolume find-new $real_vol $lastgen");
unless(defined($ret)) {
ERROR "Failed to fetch modified files for: $vol";
return undef;
}
my %files;
my $parse_errors = 0;
my $transid_marker;
foreach (split(/\n/, $ret))
{
if(/^inode \S+ file offset (\S+) len (\S+) disk start \S+ offset \S+ gen (\S+) flags (\S+) (.+)$/) {
my $file_offset = $1;
my $len = $2;
my $gen = $3;
my $flags = $4;
my $name = $5;
$files{$name}->{len} += $len;
$files{$name}->{new} = 1 if($file_offset == 0);
$files{$name}->{gen}->{$gen} = 1; # count the generations
if($flags eq "COMPRESS") {
$files{$name}->{flags}->{compress} = 1;
}
elsif($flags eq "COMPRESS|INLINE") {
$files{$name}->{flags}->{compress} = 1;
$files{$name}->{flags}->{inline} = 1;
}
elsif($flags eq "INLINE") {
$files{$name}->{flags}->{inline} = 1;
}
elsif($flags eq "NONE") {
}
else {
WARN "unparsed flags: $flags";
}
}
elsif(/^transid marker was (\S+)$/) {
$transid_marker = $1;
}
else {
$parse_errors++;
}
}
return { files => \%files,
transid_marker => $transid_marker,
parse_errors => $parse_errors,
};
}
sub btr_tree($;$)
{
my $vol = shift || die;
my $config = shift;
my %tree;
my %id;
my $subvol_list = btr_subvolume_list($vol, $config, subvol_only => 0);
return undef unless(ref($subvol_list) eq "ARRAY");
TRACE "btr_tree: processing subvolume list of: $vol";
foreach my $node (@$subvol_list)
{
$id{$node->{id}} = $node;
$uuid_info{$node->{uuid}} = $node;
my $rel_path = $node->{path};
if($node->{top_level} == 5)
{
# man btrfs-subvolume:
# Also every btrfs filesystem has a default subvolume as its initially
# top-level subvolume, whose subvolume id is 5(FS_TREE).
$tree{$node->{id}} = $node;
}
else
{
# set SUBTREE / PARENT node
die unless exists($id{$node->{top_level}});
my $parent = $id{$node->{top_level}};
die if exists($parent->{SUBTREE}->{$node->{id}});
$parent->{SUBTREE}->{$node->{id}} = $node;
$node->{PARENT} = $parent;
# "path" always starts with set REL_PATH
die unless($rel_path =~ s/^$parent->{path}\///);
}
$node->{REL_PATH} = $rel_path; # relative to {PARENT}->{path}
}
# set PARENT node
foreach (values %id){
$_->{PARENT} = $uuid_info{$_->{parent_uuid}} if($_->{parent_uuid} ne "-");
}
return \%tree;
}
sub _subtree_list
{
my $tree = shift;
my $list = shift;
my $prefix = shift;
return $list unless $tree; # silent ignore empty subtrees
foreach(values %$tree) {
my $path = $prefix . $_->{REL_PATH};
push(@$list, { SUBVOL_PATH => $path,
node => $_,
});
# recurse into SUBTREE
_subtree_list($_->{SUBTREE}, $list, $path . '/');
}
return $list;
}
# returns hash of:
# SUBVOL_PATH relative path to $fs_path
# FS_PATH absolute path
# node href to tree node
#
# returns an empty hash if the subvolume at $fs_path exists, but contains no subvolumes
# returns undef if the subvolume at $fs_path does not exists
sub btr_fs_info($;$)
{
my $fs_path = shift || die;
my $config = shift;
my $detail = btr_subvolume_detail($fs_path, $config);
return undef unless($detail);
my $tree = btr_tree($fs_path, $config);
my $tree_root;
if($detail->{is_root}) {
$tree_root = $tree;
}
else {
die unless $uuid_info{$detail->{uuid}};
$uuid_fs_map{$detail->{uuid}}->{$fs_path} = 1;
$tree_root = $uuid_info{$detail->{uuid}}->{SUBTREE};
unless($tree_root) {
DEBUG "No subvolumes found in: $fs_path";
return {};
}
}
# recurse into $tree_root, returns list of href: { FS_PATH, node }
my $list = _subtree_list($tree_root, [], "");
# return a hash of relative subvolume path
my %ret;
foreach(@$list) {
my $subvol_path = $_->{SUBVOL_PATH};
die if exists $ret{$subvol_path};
$_->{FS_PATH} = $fs_path . '/' . $subvol_path;
$uuid_fs_map{$_->{node}->{uuid}}->{$fs_path . '/' . $subvol_path} = 1;
$ret{$subvol_path} = $_;
}
$vol_btrfs_progs_compat{$fs_path} = config_key($config, "btrfs_progs_compat"); # missing received_uuid in node{}
return \%ret;
}
# returns $target, or undef on error
sub btrfs_snapshot($$;$)
{
my $src = shift || die;
my $target = shift || die;
my $config = shift;
my ($rsh, $real_src) = get_rsh($src, $config);
my (undef, $real_target) = get_rsh($target, $config);
DEBUG "[btrfs] snapshot (ro):";
DEBUG "[btrfs] source: $src";
DEBUG "[btrfs] target: $target";
INFO ">>> $target";
my $ret = run_cmd("$rsh /sbin/btrfs subvolume snapshot -r $real_src $real_target");
ERROR "Failed to create btrfs subvolume snapshot: $src -> $target" unless(defined($ret));
return defined($ret) ? $target : undef;
}
sub btrfs_subvolume_delete($@)
{
my $config = shift;
my @targets = @_;
return 0 unless(scalar(@targets));
my @real_targets;
my $rsh;
foreach (@targets) {
my ($r, $t) = get_rsh($_, $config);
die if($rsh && ($rsh ne $r)); # make sure all targets share same ssh host
$rsh = $r;
push(@real_targets, $t);
}
die if(scalar(@targets) != scalar(@real_targets));
my $commit_delete = config_key($config, "btrfs_commit_delete") // "";
DEBUG "[btrfs] delete" . ($commit_delete ? " (commit-$commit_delete):" : ":");
DEBUG "[btrfs] subvolume: $_" foreach(@targets);
my $options = "";
$options = "--commit-after " if($commit_delete eq "after");
$options = "--commit-each " if($commit_delete eq "each");
my $ret = run_cmd("$rsh /sbin/btrfs subvolume delete $options" . join(' ', @real_targets));
ERROR "Failed to delete btrfs subvolumes: " . join(' ', @targets) unless(defined($ret));
return defined($ret) ? scalar(@targets) : undef;
}
sub btrfs_send_receive($$$;$)
{
my $src = shift || die;
my $target = shift || die;
my $parent = shift // "";
my $config = shift;
my ($rsh_src, $real_src) = get_rsh($src, $config);
my ($rsh_target, $real_target) = get_rsh($target, $config);
my (undef, $real_parent) = get_rsh($parent, $config);
my $now = localtime;
my $src_name = $src;
$src_name =~ s/^.*\///;
INFO ">>> $target/$src_name";
DEBUG "[btrfs] send/receive" . ($parent ? " (incremental)" : " (complete)") . ":";
DEBUG "[btrfs] source: $src";
DEBUG "[btrfs] parent: $parent" if($parent);
DEBUG "[btrfs] target: $target";
my $parent_option = $real_parent ? "-p $real_parent" : "";
my $receive_option = "";
$receive_option = "-v" if($loglevel >= 3);
my $cmd = "$rsh_src /sbin/btrfs send $parent_option $real_src | $rsh_target /sbin/btrfs receive $receive_option $real_target/";
my $ret = run_cmd($cmd);
unless(defined($ret)) {
ERROR "Failed to send/receive btrfs subvolume: $src " . ($real_parent ? "[$real_parent]" : "") . " -> $target";
return undef;
}
return 1;
}
# sets $config->{ABORTED} on failure
# sets $config->{subvol_received}
sub macro_send_receive($@)
{
my $config = shift || die;
my %info = @_;
my $incremental = config_key($config, "incremental");
INFO "Receiving from snapshot: $info{src}";
# add info to $config->{subvol_received}
my $src_name = $info{src};
$src_name =~ s/^.*\///;
$info{received_name} = "$info{target}/$src_name";
$config->{subvol_received} //= [];
push(@{$config->{subvol_received}}, \%info);
if($incremental)
{
# create backup from latest common
if($info{parent}) {
INFO "Incremental from parent snapshot: $info{parent}";
}
elsif($incremental ne "strict") {
INFO "No common parent subvolume present, creating full backup";
}
else {
WARN "Backup to $info{target} failed: no common parent subvolume found, and option \"incremental\" is set to \"strict\"";
$info{ERROR} = 1;
$config->{ABORTED} = "No common parent subvolume found, and option \"incremental\" is set to \"strict\"";
return undef;
}
}
else {
INFO "Option \"incremental\" is not set, creating full backup";
delete $info{parent};
}
if(btrfs_send_receive($info{src}, $info{target}, $info{parent}, $config)) {
return 1;
} else {
$info{ERROR} = 1;
$config->{ABORTED} = "btrfs send/receive command failed";
return undef;
}
}
sub get_date_tag($)
{
my $name = shift;
$name =~ s/_([0-9]+)$//;
my $postfix_counter = $1;
my $date = undef;
if($name =~ /\.([0-9]{4})([0-9]{2})([0-9]{2})$/) {
$date = [ $1, $2, $3 ];
}
return ($date, $postfix_counter);
}
sub get_snapshot_children($$)
{
my $sroot = shift || die;
my $svol = shift || die;
my $svol_node = subvol($sroot, $svol);
die("subvolume info not present: $sroot/$svol") unless($svol_node);
my @ret;
foreach (values %{$vol_info{$sroot}}) {
next unless($_->{node}->{parent_uuid} eq $svol_node->{uuid});
TRACE "get_snapshot_children: Found snapshot child: $_->{SUBVOL_PATH}";
push(@ret, $_);
}
DEBUG "Found " . scalar(@ret) . " snapshot children of: $sroot/$svol";
return @ret;
}
sub get_receive_targets($$)
{
my $droot = shift || die;
my $src_href = shift || die;
die("root subvolume info not present: $droot") unless($vol_info{$droot});
my @ret;
if($vol_btrfs_progs_compat{$droot})
{
# guess matches by subvolume name (node->received_uuid is not available if BTRFS_PROGS_COMPAT is set)
DEBUG "Fallback to compatibility mode (get_receive_targets)";
my $src_name = $src_href->{node}->{REL_PATH};
$src_name =~ s/^.*\///; # strip path
foreach my $target (values %{$vol_info{$droot}}) {
my $target_name = $target->{node}->{REL_PATH};
$target_name =~ s/^.*\///; # strip path
if($target_name eq $src_name) {
TRACE "get_receive_targets: by-name: Found receive target: $target->{SUBVOL_PATH}";
push(@ret, $target);
}
}
}
else
{
# find matches by comparing uuid / received_uuid
my $uuid = $src_href->{node}->{uuid};
die("subvolume info not present: $uuid") unless($uuid_info{$uuid});
foreach (values %{$vol_info{$droot}}) {
next unless($_->{node}->{received_uuid} eq $uuid);
TRACE "get_receive_targets: by-uuid: Found receive target: $_->{SUBVOL_PATH}";
push(@ret, $_);
}
}
DEBUG "Found " . scalar(@ret) . " receive targets in \"$droot/\" for: $src_href->{FS_PATH}";
return @ret;
}
sub get_latest_common($$$;$)
{
my $sroot = shift || die;
my $svol = shift || die;
my $droot = shift || die;
my $threshold_gen = shift; # skip all snapshot children with generation >= $threshold_gen
die("source subvolume info not present: $sroot") unless($vol_info{$sroot});
die("target subvolume info not present: $droot") unless($vol_info{$droot});
my $debug_src = "$sroot/$svol";
$debug_src .= "@" . $threshold_gen if($threshold_gen);
# sort children of svol descending by generation
foreach my $child (sort { $b->{node}->{gen} <=> $a->{node}->{gen} } get_snapshot_children($sroot, $svol)) {
TRACE "get_latest_common: checking source snapshot: $child->{SUBVOL_PATH}";
if($threshold_gen && ($child->{node}->{gen} >= $threshold_gen)) {
TRACE "get_latest_common: skipped gen=$child->{node}->{gen} >= $threshold_gen: $child->{SUBVOL_PATH}";
next;
}
if($child->{RECEIVE_TARGET_PRESENT} && ($child->{RECEIVE_TARGET_PRESENT} eq $droot)) {
# little hack to keep track of previously received subvolumes
DEBUG("Latest common snapshots for: $debug_src: src=$child->{FS_PATH} target=");
return ($child, undef);
}
foreach (get_receive_targets($droot, $child)) {
TRACE "get_latest_common: found receive target: $_->{FS_PATH}";
DEBUG("Latest common snapshots for: $debug_src: src=$child->{FS_PATH} target=$_->{FS_PATH}");
return ($child, $_);
}
TRACE "get_latest_common: no matching targets found for: $child->{FS_PATH}";
}
DEBUG("No common snapshots for \"$debug_src\" found in src=$sroot/ target=$droot/");
return (undef, undef);
}
sub _origin_tree
{
my $prefix = shift;
my $uuid = shift;
my $lines = shift;
my $node = $uuid_info{$uuid};
unless($node) {
push(@$lines, ["$prefix", $uuid]);
return 0;
}
if($uuid_fs_map{$uuid}) {
foreach(keys %{$uuid_fs_map{$uuid}}) {
push(@$lines, ["$prefix$_", $uuid]);
}
} else {
push(@$lines, ["$prefix/$node->{path}", $uuid]);
}
$prefix =~ s/./ /g;
if($node->{received_uuid}) {
if($node->{received_uuid} ne '-') {
_origin_tree("${prefix}^---", $node->{received_uuid}, $lines);
}
} else {
push(@$lines, ["$prefix^---", $uuid]); # printed if "btrfs_progs_compat" is set
}
if($node->{parent_uuid} ne '-') {
_origin_tree("${prefix}", $node->{parent_uuid}, $lines);
}
}
sub schedule_deletion(@)
{
my %args = @_;
my $schedule = $args{schedule} || die;
my @today = @{$args{today}};
my $preserve_day_of_week = $args{preserve_day_of_week} || die;
my $preserve_daily = $args{preserve_daily} // die;
my $preserve_weekly = $args{preserve_weekly} // die;
my $preserve_monthly = $args{preserve_monthly} // die;
my $log_verbose = $args{log_verbose};
if($log_verbose) {
INFO "Filter scheme: preserving all within $preserve_daily days";
INFO "Filter scheme: preserving first in week (starting on $preserve_day_of_week), for $preserve_weekly weeks";
INFO "Filter scheme: preserving last weekly of month, for $preserve_monthly months";
}
# first, do our calendar calculations
# note: our week starts on $preserve_day_of_week
my $delta_days_to_eow_from_today = $day_of_week_map{$preserve_day_of_week} - Day_of_Week(@today) - 1;
$delta_days_to_eow_from_today = $delta_days_to_eow_from_today + 7 if($delta_days_to_eow_from_today < 0);
TRACE "last day before next $preserve_day_of_week is in $delta_days_to_eow_from_today days";
foreach my $href (@$schedule)
{
my @date = @{$href->{date}};
my $delta_days = Delta_Days(@date, @today);
my $delta_days_to_eow = $delta_days + $delta_days_to_eow_from_today;
{
use integer; # do integer arithmetics
$href->{delta_days} = $delta_days;
$href->{delta_weeks} = $delta_days_to_eow / 7;
$href->{err_days} = 6 - ( $delta_days_to_eow % 7 );
$href->{delta_months} = ($today[0] - $date[0]) * 12 + ($today[1] - $date[1]);
$href->{month} = "$date[0]-$date[1]";
}
}
# filter daily, weekly, monthly
my %first_in_delta_weeks;
my %last_weekly_in_delta_months;
foreach my $href (sort { $a->{sort} cmp $b->{sort} } @$schedule) {
if($preserve_daily && (($preserve_daily eq "all") || ($href->{delta_days} <= $preserve_daily))) {
$href->{preserve} ||= "preserved daily: $href->{delta_days} days ago";
}
$first_in_delta_weeks{$href->{delta_weeks}} //= $href;
}
foreach (reverse sort keys %first_in_delta_weeks) {
my $href = $first_in_delta_weeks{$_} || die;
if($preserve_weekly && (($preserve_weekly eq "all") || ($href->{delta_weeks} <= $preserve_weekly))) {
$href->{preserve} ||= "preserved weekly: $href->{delta_weeks} weeks ago, " . ($href->{err_days} ? "+$href->{err_days} days after " : "on ") . "$preserve_day_of_week";
}
$last_weekly_in_delta_months{$href->{delta_months}} = $href;
}
foreach (reverse sort keys %last_weekly_in_delta_months) {
my $href = $last_weekly_in_delta_months{$_} || die;
if($preserve_monthly && (($preserve_monthly eq "all") || ($href->{delta_months} <= $preserve_monthly))) {
$href->{preserve} ||= "preserved monthly: " . ($href->{err_days} ? "$href->{err_days} days after " : "") . "last $preserve_day_of_week of month $href->{month} (age: $href->{delta_months} months)";
}
}
# assemble results
my @delete;
foreach my $href (sort { $a->{sort} cmp $b->{sort} } @$schedule)
{
if($href->{preserve}) {
INFO "=== $href->{sort}: $href->{preserve}" if($log_verbose);
}
else {
INFO "<<< $href->{sort}" if($log_verbose);
push(@delete, $href->{name});
}
}
DEBUG "Preserving " . (@$schedule - @delete) . "/" . @$schedule . " items" unless($log_verbose);
return @delete;
}
MAIN:
{
$ENV{PATH} = '';
$Getopt::Std::STANDARD_HELP_VERSION = 1;
$Data::Dumper::Sortkeys = 1;
my $start_time = time;
my @today = Today();
my %opts;
unless(getopts('hc:vql:p', \%opts)) {
VERSION_MESSAGE();
HELP_MESSAGE(0);
exit 1;
}
my $command = shift @ARGV;
# assign command line options
$loglevel = $opts{l} || "";
if (lc($loglevel) eq "warn") { $loglevel = 1; }
elsif(lc($loglevel) eq "info") { $loglevel = 2; }
elsif(lc($loglevel) eq "debug") { $loglevel = 3; }
elsif(lc($loglevel) eq "trace") { $loglevel = 4; }
elsif($loglevel =~ /^[0-9]+$/) { ; }
else {
$loglevel = $opts{v} ? 2 : 1;
}
@config_src = ( $opts{c} ) if($opts{c});
my $quiet = $opts{q};
my $preserve_backups = $opts{p};
# check command line options
if($opts{h} || (not $command)) {
VERSION_MESSAGE();
HELP_MESSAGE(0);
exit 0;
}
my ($action_run, $action_info, $action_tree, $action_diff, $action_origin);
my @subvol_args;
my ($args_expected_min, $args_expected_max) = (0, 0);
if(($command eq "run") || ($command eq "dryrun")) {
$action_run = 1;
$dryrun = 1 if($command eq "dryrun");
$args_expected_min = 0;
$args_expected_max = 9999;
@subvol_args = @ARGV;
}
elsif ($command eq "info") {
$action_info = 1;
}
elsif ($command eq "tree") {
$action_tree = 1;
}
elsif ($command eq "diff") {
$action_diff = 1;
$args_expected_min = $args_expected_max = 2;
@subvol_args = @ARGV;
}
elsif ($command eq "origin") {
$action_origin = 1;
$args_expected_min = $args_expected_max = 1;
@subvol_args = @ARGV;
}
else {
ERROR "Unrecognized command: $command";
HELP_MESSAGE(0);
exit 1;
}
if(($args_expected_min > scalar(@ARGV)) || ($args_expected_max < scalar(@ARGV))) {
ERROR "Incorrect number of arguments";
HELP_MESSAGE(0);
exit 1;
}
# input validation
foreach (@subvol_args) {
s/\/+$//; # remove trailing slash
unless(/^(($ssh_prefix_match)?\/$file_match)$/) { # matches ssh statement or absolute file
ERROR "Bad argument: not a subvolume declaration: $_";
HELP_MESSAGE(0);
exit 1;
}
$_ = $1; # untaint argument
}
INFO "$version_info (" . localtime($start_time) . ")";
if($action_diff)
{
#
# print snapshot diff
#
my $src_vol = $subvol_args[0] || die;
my $target_vol = $subvol_args[1] || die;
# FIXME: allow ssh:// src/dest (does not work since the configuration is not yet read).
my $src_detail = btr_subvolume_detail($src_vol);
unless($src_detail) { exit 1; }
if($src_detail->{is_root}) { ERROR "subvolume at \"$src_vol\" is btrfs root!"; exit 1; }
unless($src_detail->{cgen}) { ERROR "subvolume at \"$src_vol\" does not provide cgen"; exit 1; }
# if($src_detail->{parent_uuid} eq "-") { ERROR "subvolume at \"$src_vol\" has no parent, aborting."; exit 1; }
my $target_detail = btr_subvolume_detail($target_vol);
unless($target_detail) { exit 1; }
unless($src_detail->{cgen}) { ERROR "subvolume at \"$src_vol\" does not provide cgen"; exit 1; }
# if($src_detail->{parent_uuid} eq "-") { ERROR "subvolume at \"$src_vol\" has no parent, aborting."; exit 1; }
my $info = btr_tree($src_vol);
my $src = $uuid_info{$src_detail->{uuid}} || die;
my $target = $uuid_info{$target_detail->{uuid}};
unless($target) { ERROR "target subvolume is not on the same btrfs filesystem!"; exit 1; }
my $lastgen;
# check if given src and target share same parent
if(ref($src->{PARENT}) && ($src->{PARENT}->{uuid} eq $target->{uuid})) {
DEBUG "target subvolume is direct parent of source subvolume";
}
elsif(ref($src->{PARENT}) && ref($target->{PARENT}) && ($src->{PARENT}->{uuid} eq $target->{PARENT}->{uuid})) {
DEBUG "target subvolume and source subvolume share same parent";
}
else {
# TODO: this rule only applies to snapshots. find a way to distinguish snapshots from received backups
# ERROR "subvolumes \"$target_vol\" and \"$src_vol\" do not share the same parents";
# exit 1;
}
# NOTE: in some cases "cgen" differs from "gen", even for read-only snapshots (observed: gen=cgen+1)
$lastgen = $src->{cgen} + 1;
# dump files, sorted and unique
my $ret = btr_subvolume_find_new($target_vol, $lastgen);
exit 1 unless(ref($ret));
print "--------------------------------------------------------------------------------\n";
print "Showing changed files for subvolume:\n $target->{path} (gen=$target->{gen})\n";
print "\nStarting at creation generation from subvolume:\n $src->{path} (cgen=$src->{cgen})\n";
print "\nThis will show all files modified within generation range: [$lastgen..$target->{gen}]\n";
print "Newest file generation (transid marker) was: $ret->{transid_marker}\n";
print "Parse errors: $ret->{parse_errors}\n" if($ret->{parse_errors});
print "\nLegend: \n";
print " +.. file accessed at offset 0 (at least once)\n";
print " .c. flags COMPRESS or COMPRESS|INLINE set (at least once)\n";
print " ..i flags INLINE or COMPRESS|INLINE set (at least once)\n";
print " file was modified in generations\n";
print " file was modified for a total of bytes\n";
print "--------------------------------------------------------------------------------\n";
my $files = $ret->{files};
# calculate the character offsets
my $len_charlen = 0;
my $gen_charlen = 0;
foreach (values %$files) {
my $len = length($_->{len});
my $gen = length(scalar(keys(%{$_->{gen}})));
$len_charlen = $len if($len > $len_charlen);
$gen_charlen = $gen if($gen > $gen_charlen);
}
# finally print the output
foreach my $name (sort keys %$files) {
print ($files->{$name}->{new} ? '+' : '.');
print ($files->{$name}->{flags}->{compress} ? 'c' : '.');
print ($files->{$name}->{flags}->{inline} ? 'i' : '.');
# make nice table
my $gens = scalar(keys(%{$files->{$name}->{gen}}));
my $len = $files->{$name}->{len};
print " " . (' ' x ($gen_charlen - length($gens))) . $gens;
print " " . (' ' x ($len_charlen - length($len))) . $len;
print " $name\n";
}
exit 0;
}
#
# parse config file
#
my $config = parse_config(@config_src);
unless($config) {
ERROR "Failed to parse configuration file";
exit 1;
}
unless(ref($config->{VOLUME}) eq "ARRAY") {
ERROR "No volumes defined in configuration file";
exit 1;
}
if($action_info)
{
#
# print filesystem information
#
print "================================================================================\n";
print "Filesystem information ($version_info)\n\n";
print " Date: " . localtime($start_time) . "\n";
print " Config: $config->{SRC_FILE}\n";
print "================================================================================\n";
# print "\n--------------------------------------------------------------------------------\n";
# print "All local btrfs filesystems\n";
# print "--------------------------------------------------------------------------------\n";
# print (btr_filesystem_show_all_local() // "");
# print "\n";
my %processed;
foreach my $config_vol (@{$config->{VOLUME}})
{
my $sroot = $config_vol->{sroot} || die;
unless($processed{$sroot})
{
print "\n--------------------------------------------------------------------------------\n";
print "Source volume: $sroot\n";
print "--------------------------------------------------------------------------------\n";
# print (btr_filesystem_show($sroot, $config_vol) // "");
# print "\n\n";
print (btr_filesystem_usage($sroot, $config_vol) // "");
print "\n";
$processed{$sroot} = 1;
}
}
foreach my $config_vol (@{$config->{VOLUME}}) {
my $sroot = $config_vol->{sroot} || die;
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}}) {
foreach my $config_target (@{$config_subvol->{TARGET}})
{
my $droot = $config_target->{droot} || die;
unless($processed{$droot})
{
print "\n--------------------------------------------------------------------------------\n";
print "Target volume: $droot\n";
print " ^--- $sroot\n";
print "--------------------------------------------------------------------------------\n";
print (btr_filesystem_usage($droot, $config_target) // "");
print "\n";
$processed{$droot} = 1;
}
}
}
}
exit 0;
}
#
# fill vol_info hash, basic checks on configuration
#
my $subvol_filter_count = undef;
foreach my $config_vol (@{$config->{VOLUME}})
{
my $sroot = $config_vol->{sroot} || die;
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
{
my $svol = $config_subvol->{svol} || die;
# filter subvolumes matching command line arguments
if($action_run && scalar(@subvol_args)) {
$subvol_filter_count //= 0;
if(grep(/^$sroot\/$svol$/, @subvol_args)) {
$subvol_filter_count++;
}
else {
DEBUG "No match on subvolume command line argument, skipping: $sroot/$svol";
$config_subvol->{ABORTED} = "No match on subvolume command line arguments";
$config_subvol->{ABORTED_NOERR} = 1;
next;
}
}
$vol_info{$sroot} //= btr_fs_info($sroot, $config_vol);
unless(subvol($sroot, $svol)) {
$config_subvol->{ABORTED} = "Subvolume \"$svol\" not present in btrfs subvolume list for \"$sroot\"";
WARN "Skipping subvolume section: $config_subvol->{ABORTED}";
next;
}
foreach my $config_target (@{$config_subvol->{TARGET}})
{
my $droot = $config_target->{droot} || die;
$vol_info{$droot} //= btr_fs_info($droot, $config_target);
unless($vol_info{$droot}) {
$config_target->{ABORTED} = "Failed to read btrfs subvolume list for \"$droot\"";
WARN "Skipping target: $config_target->{ABORTED}";
next;
}
}
}
}
if(defined($subvol_filter_count) && ($subvol_filter_count == 0)) {
ERROR "Subvolume command line arguments do not match any volume/subvolume declaration from configuration file, aborting.";
exit 1;
}
TRACE(Data::Dumper->Dump([\%vol_info], ["vol_info"]));
if($action_origin)
{
#
# print origin information
#
my $subvol = $subvol_args[0] || die;
my $dump_uuid = 0;
my $detail = btr_subvolume_detail($subvol);
exit 1 unless($detail);
if($detail->{is_root}) {
ERROR "Subvolume is btrfs root: $subvol\n";
exit 1;
}
my $uuid = $detail->{uuid} || die;
my $node = $uuid_info{$uuid};
unless($node) {
DEBUG "Subvolume not parsed yet, fetching info: $subvol";
$vol_info{$subvol} //= btr_fs_info($subvol);
$node = $uuid_info{$uuid} || die;
}
my $lines = [];
_origin_tree("", $uuid, $lines);
print "--------------------------------------------------------------------------------\n";
print "Origin Tree\n\n";
print " ^--- : received from subvolume\n";
print " newline : parent subvolume\n";
print " orphaned: subvolume uuid could not be resolved (probably deleted)\n";
print "--------------------------------------------------------------------------------\n";
my $len = 0;
if($dump_uuid) {
$len = (length($_->[0]) > $len ? length($_->[0]) : $len) foreach(@$lines);
}
foreach(@$lines) {
print "$_->[0]";
print ' ' x ($len - length($_->[0]) + 4) . "$_->[1]" if($dump_uuid);
print "\n";
}
exit 0;
}
if($action_tree)
{
#
# print snapshot tree
#
# TODO: reverse tree: print all backups from $droot and their corresponding source snapshots
foreach my $config_vol (@{$config->{VOLUME}})
{
my %droot_compat;
my $sroot = $config_vol->{sroot} || die;
print "$sroot\n";
next unless $vol_info{$sroot};
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
{
my $svol = $config_subvol->{svol} || die;
print "|-- $svol\n";
unless($vol_info{$sroot}->{$svol}) {
print " !!! error: no subvolume \"$svol\" found in \"$sroot\"\n";
next;
}
my $sroot_uuid = $vol_info{$sroot}->{$svol}->{node}->{uuid} || die;
foreach my $snapshot (sort { $a->{SUBVOL_PATH} cmp $b->{SUBVOL_PATH} } (values %{$vol_info{$sroot}}))
{
next unless($snapshot->{node}->{parent_uuid} eq $sroot_uuid);
# next unless($snapshot->{SUBVOL_PATH} =~ /^$snapdir/); # don't print non-btrbk snapshots
print "| ^-- $snapshot->{SUBVOL_PATH}\n";
foreach my $config_target (@{$config_subvol->{TARGET}})
{
my $droot = $config_target->{droot} || die;
next unless $vol_info{$droot};
$droot_compat{$droot} = 1 if($vol_btrfs_progs_compat{$droot});
foreach (sort { $a->{SUBVOL_PATH} cmp $b->{SUBVOL_PATH} } get_receive_targets($droot, $snapshot)) {
print "| | ^== $_->{FS_PATH}\n";
}
}
}
}
if(keys %droot_compat) {
print "\nNOTE: Received subvolumes (backups) are guessed by subvolume name for targets:\n";
print " - " . join("\n - ", (sort keys %droot_compat));
}
print "\n";
}
exit 0;
}
if($action_run)
{
#
# create snapshots
#
my $timestamp = sprintf("%04d%02d%02d", @today);
my %snapshot_cache;
foreach my $config_vol (@{$config->{VOLUME}})
{
next if($config_vol->{ABORTED});
my $sroot = $config_vol->{sroot} || die;
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
{
next if($config_subvol->{ABORTED});
my $svol = $config_subvol->{svol} || die;
my $snapdir = config_key($config_subvol, "snapshot_dir") || "";
my $snapshot;
my $snapshot_name;
if($snapshot_cache{"$sroot/$svol"})
{
$snapshot = $snapshot_cache{"$sroot/$svol"}->{file};
$snapshot_name = $snapshot_cache{"$sroot/$svol"}->{name};
}
else
{
# find new snapshot name
my $postfix_counter = -1;
my $postfix;
do {
$postfix_counter++;
$postfix = '.' . $timestamp . ($postfix_counter ? "_$postfix_counter" : "");
TRACE "Testing source snapshot name: $snapdir$svol$postfix";
} while(subvol($sroot, "$snapdir$svol$postfix")); # NOTE: $snapdir always has trailing slash!
$snapshot = "$sroot/$snapdir$svol$postfix";
$snapshot_name = "$svol$postfix";
}
my $create_snapshot = config_key($config_subvol, "snapshot_create_always");
foreach my $config_target (@{$config_subvol->{TARGET}})
{
next if($config_target->{ABORTED});
my $droot = $config_target->{droot} || die;
if(subvol($droot, $snapshot_name)) {
$config_target->{ABORTED} = "Subvolume already exists at destination: $droot/$snapshot_name";
WARN "Skipping target: $config_target->{ABORTED}";
next;
}
if($config_target->{target_type} eq "send-receive") {
$create_snapshot = 1;
}
}
unless($create_snapshot) {
$config_subvol->{ABORTED} = "No targets defined for subvolume: $sroot/$svol";
WARN "Skipping subvolume section: $config_subvol->{ABORTED}";
next;
}
# make snapshot of svol, if not already created by another job
unless($snapshot_cache{"$sroot/$svol"})
{
INFO "Creating subvolume snapshot for: $sroot/$svol";
unless(btrfs_snapshot("$sroot/$svol", $snapshot, $config_subvol)) {
$config_subvol->{ABORTED} = "Failed to create snapshot, skipping subvolume: $sroot/$svol";
WARN "Skipping subvolume section: $config_subvol->{ABORTED}";
}
$snapshot_cache{"$sroot/$svol"} = { name => $snapshot_name,
file => $snapshot };
}
$config_subvol->{snapshot} = $snapshot;
$config_subvol->{snapshot_name} = $snapshot_name;
}
}
#
# create backups
#
foreach my $config_vol (@{$config->{VOLUME}})
{
next if($config_vol->{ABORTED});
my $sroot = $config_vol->{sroot} || die;
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
{
next if($config_subvol->{ABORTED});
my $svol = $config_subvol->{svol} || die;
my $snapshot = $config_subvol->{snapshot} || die;
my $snapshot_name = $config_subvol->{snapshot_name} || die;
foreach my $config_target (@{$config_subvol->{TARGET}})
{
next if($config_target->{ABORTED});
my $droot = $config_target->{droot} || die;
my $target_type = $config_target->{target_type} || die;
if($target_type eq "send-receive")
{
if(config_key($config_target, "receive_log")) {
WARN "Ignoring deprecated option \"receive_log\" for target: $droot"
}
my $parent_snap = "";
# resume missing backups (resume_missing)
if(config_key($config_target, "resume_missing"))
{
INFO "Checking for missing backups of subvolume \"$sroot/$svol\" in: $droot/";
my $found_missing = 0;
# sort children of svol ascending by generation
foreach my $child (sort { $a->{node}->{gen} <=> $b->{node}->{gen} } get_snapshot_children($sroot, $svol))
{
last if($config_target->{ABORTED});
DEBUG "Checking for missing receive targets for \"$child->{FS_PATH}\" in: $droot/";
# TODO: fix for btrfs_progs_compat
if(scalar get_receive_targets($droot, $child)) {
DEBUG "Found matching receive target, skipping: $child->{FS_PATH}";
}
else {
DEBUG "No matching receive targets found, checking schedule for: $child->{FS_PATH}";
# check if the target would be preserved
my ($date, undef) = get_date_tag($child->{SUBVOL_PATH});
next unless($date);
if(scalar schedule_deletion(
schedule => [ { name => $child->{FS_PATH}, sort => $child->{SUBVOL_PATH}, date => $date } ],
today => \@today,
preserve_day_of_week => config_key($config_target, "preserve_day_of_week"),
preserve_daily => config_key($config_target, "target_preserve_daily"),
preserve_weekly => config_key($config_target, "target_preserve_weekly"),
preserve_monthly => config_key($config_target, "target_preserve_monthly"),
))
{
DEBUG "Target would have been deleted by target_perserve rules, skipping resume of: $child->{FS_PATH}";
}
else
{
$found_missing++;
my ($latest_common_src, $latest_common_target) = get_latest_common($sroot, $svol, $droot, $child->{node}->{gen});
$parent_snap = $latest_common_src->{FS_PATH} if($latest_common_src);
INFO "Resuming subvolume backup (send-receive) for: $child->{FS_PATH}";
if(macro_send_receive($config_target,
src => $child->{FS_PATH},
target => $droot,
parent => $parent_snap,
resume => 1, # propagated to $config_target->{subvol_received}
))
{
# tag the source snapshot, so that get_latest_common() above can make use of the newly received subvolume
$child->{RECEIVE_TARGET_PRESENT} = $droot;
}
else {
# note: ABORTED flag is already set by macro_send_receive()
ERROR("Error while resuming backups, aborting");
}
}
}
}
if($found_missing) {
INFO "Resumed $found_missing backups";
} else {
INFO "No missing backups found";
}
}
# skip creation if resume_missing failed
next if($config_target->{ABORTED});
# finally receive the previously created snapshot
INFO "Creating subvolume backup (send-receive) for: $sroot/$svol";
my ($latest_common_src, $latest_common_target) = get_latest_common($sroot, $svol, $droot);
$parent_snap = $latest_common_src ? $latest_common_src->{FS_PATH} : undef;
macro_send_receive($config_target,
src => $snapshot,
target => $droot,
parent => $parent_snap
);
}
else {
ERROR "Unknown target type \"$target_type\", skipping: $sroot/$svol";
$config_target->{ABORTED} = "Unknown target type \"$target_type\"";
}
}
}
}
#
# remove backups following a preserve daily/weekly/monthly scheme
#
if($preserve_backups) {
INFO "Preserving all backups (option \"-p\" present)";
}
else
{
foreach my $config_vol (@{$config->{VOLUME}})
{
next if($config_vol->{ABORTED});
my $sroot = $config_vol->{sroot} || die;
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
{
next if($config_subvol->{ABORTED});
my $svol = $config_subvol->{svol} || die;
my $snapdir = config_key($config_subvol, "snapshot_dir") || "";
my $target_aborted = 0;
foreach my $config_target (@{$config_subvol->{TARGET}})
{
if($config_target->{ABORTED}) {
$target_aborted = 1;
next;
}
my $droot = $config_target->{droot} || die;
#
# delete backups
#
INFO "Cleaning backups of subvolume \"$sroot/$svol\": $droot/$svol.*";
my @schedule;
foreach my $vol (keys %{$vol_info{$droot}}) {
my ($date, undef) = get_date_tag($vol);
next unless($date && ($vol =~ /^svol\./));
push(@schedule, { name => "$droot/$vol", sort => $vol, date => $date });
}
my @delete = schedule_deletion(
schedule => \@schedule,
today => \@today,
preserve_day_of_week => config_key($config_target, "preserve_day_of_week"),
preserve_daily => config_key($config_target, "target_preserve_daily"),
preserve_weekly => config_key($config_target, "target_preserve_weekly"),
preserve_monthly => config_key($config_target, "target_preserve_monthly"),
log_verbose => 1,
);
my $ret = btrfs_subvolume_delete($config_target, @delete);
if(defined($ret)) {
INFO "Deleted $ret subvolumes in: $droot/$svol.*";
$config_target->{subvol_deleted} = \@delete;
}
else {
$config_target->{ABORTED} = "btrfs subvolume delete command failed";
$target_aborted = 1;
}
$config_target->{schedule} = \@schedule;
}
#
# delete snapshots
#
if($target_aborted) {
WARN "Skipping cleanup of snapshots for subvolume \"$sroot/$svol\", as at least one target aborted earlier";
next;
}
INFO "Cleaning snapshots: $sroot/$snapdir$svol.*";
my @schedule;
foreach my $vol (keys %{$vol_info{$sroot}}) {
my ($date, undef) = get_date_tag($vol);
next unless($date && ($vol =~ /^$snapdir$svol\./));
push(@schedule, { name => "$sroot/$vol", sort => $vol, date => $date });
}
my @delete = schedule_deletion(
schedule => \@schedule,
today => \@today,
preserve_day_of_week => config_key($config_subvol, "preserve_day_of_week"),
preserve_daily => config_key($config_subvol, "snapshot_preserve_daily"),
preserve_weekly => config_key($config_subvol, "snapshot_preserve_weekly"),
preserve_monthly => config_key($config_subvol, "snapshot_preserve_monthly"),
log_verbose => 1,
);
my $ret = btrfs_subvolume_delete($config_subvol, @delete);
if(defined($ret)) {
INFO "Deleted $ret subvolumes in: $sroot/$snapdir$svol.*";
$config_subvol->{subvol_deleted} = \@delete;
}
else {
$config_subvol->{ABORTED} = "btrfs subvolume delete command failed";
}
$config_subvol->{schedule} = \@schedule;
}
}
}
my $time_elapsed = time - $start_time;
INFO "Completed within: ${time_elapsed}s (" . localtime(time) . ")";
#
# print summary
#
unless($quiet)
{
my $err_count = 0;
print "--------------------------------------------------------------------------------\n";
print "Backup Summary ($version_info)\n\n";
print " Date: " . localtime($start_time) . "\n";
print " Config: $config->{SRC_FILE}\n";
print "\nLegend:\n";
print " +++ created subvolume (source snapshot)\n";
print " --- deleted subvolume (source snapshot)\n";
print " *** received subvolume (non-incremental)\n";
print " >>> received subvolume (incremental)\n";
# print " %>> received subvolume (incremental, resume_missing)\n";
print "--------------------------------------------------------------------------------";
foreach my $config_vol (@{$config->{VOLUME}})
{
if($config_vol->{ABORTED}) {
print "!!! $config_vol->{sroot}: ABORTED: $config_vol->{ABORTED}\n";
$err_count++ unless($config_vol->{ABORTED_NOERR});
}
foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
{
print "\n$config_vol->{sroot}/$config_subvol->{svol}\n";
if($config_subvol->{ABORTED}) {
print "!!! Subvolume \"$config_subvol->{svol}\" aborted: $config_subvol->{ABORTED}\n";
$err_count++ unless($config_subvol->{ABORTED_NOERR});
}
# if($config_subvol->{schedule}) {
# foreach (sort { $a->{sort} cmp $b->{sort} } @{$config_subvol->{schedule}}) {
# print(($_->{preserve} ? "===" : "---") . " $_->{name}\n");
# }
# }
print "+++ $config_subvol->{snapshot}\n" if($config_subvol->{snapshot});
if($config_subvol->{subvol_deleted}) {
print "--- $_\n" foreach(sort { $b cmp $a} @{$config_subvol->{subvol_deleted}});
}
foreach my $config_target (@{$config_subvol->{TARGET}})
{
# if($config_target->{schedule}) {
# foreach (sort { $a->{sort} cmp $b->{sort} } @{$config_target->{schedule}}) {
# print(($_->{preserve} ? "===" : "---") . " $_->{name}\n");
# }
# }
foreach(@{$config_target->{subvol_received} // []}) {
my $create_mode = "***";
$create_mode = ">>>" if($_->{parent});
# substr($create_mode, 0, 1, '%') if($_->{resume});
$create_mode = "!!!" if($_->{ERROR});
print "$create_mode $_->{received_name}\n";
}
if($config_target->{subvol_deleted}) {
print "--- $_\n" foreach(sort { $b cmp $a} @{$config_target->{subvol_deleted}});
}
if($config_target->{ABORTED}) {
print "!!! Target \"$config_target->{droot}\" aborted: $config_target->{ABORTED}\n";
$err_count++ unless($config_target->{ABORTED_NOERR});
}
}
}
}
if($err_count) {
print "\nNOTE: Some errors occurred, which may result in missing backups!\n";
print "Please check warning and error messages above.\n";
}
if($preserve_backups) {
print "\nNOTE: Preserved all backups (option -p present)\n";
}
if($dryrun) {
print "\nNOTE: Dryrun was active, none of the operations above were actually executed!\n";
}
}
}
}
1;