File Coverage

blib/lib/File/RsyBak.pm

Criterion	Covered	Total	%
statement	122	153	79.7
branch	46	76	60.5
condition	16	39	41.0
subroutine	10	10	100.0
pod	1	1	100.0
total	195	279	69.8

package File::RsyBak;

our $DATE = '2017-07-31'; # DATE
our $VERSION = '0.35'; # VERSION

use 5.010001;
use strict;
use warnings;
use Log::ger;

use File::chdir;

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(backup);

our %SPEC;

sub _parse_path {
    require Cwd;

    my ($path) = @_;
    $path =~ s!/+$!!;
    if ($path =~ m!^(\S+)::([^/]+)/?(.*)$!) {
        return {
            raw=>$path, remote=>1, host=>$1,
            proto=>"rsync", module=>$2, path=>$3,
        };
    } elsif ($path =~ m!([^@]+)?\@?(^\S+):(.*)$!) {
        return {
            raw=>$path, remote=>1, host=>$2,
            user=>$1, proto=>"ssh", path=>$3,
        };
    } else {
        return {
            raw=>$path, remote=>0, path=>$path,
            abs_path=>Cwd::abs_path($path)
        };
    }
}

# rsync requires all source to be local, or remote (same host). check sources
# before we run rsync, so we can report the error and die earlier.
sub _check_sources {
    my ($sources) = @_;

    my $all_local = 1;
    for (@$sources) {
        if ($_->{remote}) { $all_local = 0; last }
    }

    my $all_remote = 1;
    for (@$sources) {
        if (!$_->{remote}) { $all_remote = 0; last }
    }

    return [400, "Sources must be all local or all remote"]
        unless $all_remote || $all_local;

    if ($all_remote) {
        my $host;
        for (@$sources) {
            $host //= $_->{host};
            return [400, "Remote sources must all be from the same machine"]
                if $host ne $_->{host};
        }
    }
    [200, "OK"];
}

$SPEC{backup} = {
    v             => 1.1,
    summary       =>
        'Backup files/directories with histories, using rsync',
    args          => {
        source           => {
            summary      => 'Director(y|ies) to backup',
            #schema       => ['any*'   => {
            #    of => ['str*', ['array*' => {of=>'str*'}]]
            #}],
            schema       => 'str*', # temp, because in pericmd when specifying as arg#0, there is a warning of JSON decoding failure
            req          => 1,
            pos          => 0,
        },
        target           => {
            summary      => 'Backup destination',
            schema       => ['str*'   => {}],
            req          => 1,
            pos          => 1,
        },
        histories        => {
            summary      => 'Histories/history levels',
            schema       => ['array' => {
                default      => [-7, 4, 3],
                of           => 'int*',
            }],
            description  => <<'_',

Specifies number of backup histories to keep for level 1, 2, and so on. If
number is negative, specifies number of days to keep instead (regardless of
number of histories).

_
        },
        extra_dir        => {
            summary      =>
                'Whether to force creation of source directory in target',
            schema       => ['bool'   => {}],
            description  => <<'_',

If set to 1, then backup(source => '/a', target => '/backup/a') will create
another 'a' directory in target, i.e. /backup/a/current/a. Otherwise, contents
of a/ will be directly copied under /backup/a/current/.

Will always be set to 1 if source is more than one, but default to 0 if source
is a single directory. You can set this to 1 to so that behaviour when there is
a single source is the same as behaviour when there are several sources.

_
        },
        backup           => {
            summary      => 'Whether to do backup or not',
            schema       => [bool     => {
                default      => 1,
            }],
            description  => <<'_',

If backup=1 and rotate=0 then will only create new backup without rotating
histories.

_
        },
        rotate           => {
            summary      => 'Whether to do rotate after backup or not',
            schema       => [bool     => {
                default      => 1,
            }],
            description  => <<'_',

If backup=0 and rotate=1 then will only do history rotating.

_
        },
        extra_rsync_opts => {
            summary      => 'Pass extra options to rsync command',
            schema       => [array    => {
                of           => 'str*',
            }],
            description  => <<'_',

Extra options to pass to rsync command when doing backup. Note that the options
will be shell quoted, , so you should pass it unquoted, e.g. ['--exclude',
'/Program Files'].

_
        },
    },

    examples => [
        {
            argv         => ['/home/jajang/mydata','/backup/jajang/mydata'],
            test         => 0,
            'x.doc.show_result' => 0,
            description  => <<'_',

Backup /home/jajang/mydata to /backup/jajang/mydata using the default number of
histories ([-7, 4, 3]).

_
        },
    ],

    deps => {
        all => [
            {prog => 'nice'},
            {prog => 'rsync'}, # XXX not needed if backup=0
            {prog => 'rm'},    # XXX not needed if rotate=0
        ],
    },
};
sub backup {
    require File::Flock::Retry;
    require File::Path;
    require File::Which;

    my %args = @_;

    # XXX schema
    my $source    = $args{source} or return [400, "Please specify source"];
    my @sources   = ref($source) eq 'ARRAY' ? @$source : ($source);
    for (@sources) { $_ = _parse_path($_) }
    my $res = _check_sources(\@sources);
    return $res unless $res->[0] == 200;
    my $target    = $args{target} or return [400, "Please specify target"];
    $target       = _parse_path($target);
    $target->{remote} and
        return [400, "Sorry, target can't be remote at the moment"];
    my $histories = $args{histories} // [-7, 4, 3];
    ref($histories) eq 'ARRAY' or return [400, "histories must be array"];
    my $backup    = $args{backup} // 1;
    my $rotate    = $args{rotate} // 1;
    my $extra_dir = $args{extra_dir} || (@sources > 1);

    # sanity
    my $rsync_path = File::Which::which("rsync")
        or return [500, "Can't find rsync in PATH"];

    unless (-d $target->{abs_path}) {
        log_debug("Creating target directory %s ...", $target->{abs_path});
        File::Path::make_path($target->{abs_path})
            or return [500, "Error: Can't create target directory ".
                "$target->{abs_path}: $!"];
    }

    my $lock = File::Flock::Retry->lock("$target->{abs_path}/.lock");

    if ($backup) {
        _backup(
            \@sources, $target,
            {
                extra_dir        => $extra_dir,
                extra_rsync_opts => $args{extra_rsync_opts},
            });
    }

    if ($rotate) {
        _rotate($target->{abs_path}, $histories);
    }

    [200, "OK"];
}

sub _backup {
    require POSIX;
    require String::ShellQuote; String::ShellQuote->import;

    my ($sources, $target, $opts) = @_;
    log_info("Starting backup %s ==> %s ...",
                [map {$_->{raw}} @$sources], $target);
    my $cmd;
    $cmd = join(
        "",
        "nice -n19 rsync ",
        ($opts->{extra_rsync_opts} ? map { shell_quote($_), " " }
             @{$opts->{extra_rsync_opts}} : ()),
        "-a --del --force --ignore-errors --ignore-existing ",
        (log_is_debug() ? "-v " : ""),
        ((-e "$target->{abs_path}/current") ?
             "--link-dest ".shell_quote("$target->{abs_path}/current")." "
                 : ""),
        map({ shell_quote($_->{raw}), ($opts->{extra_dir} ? "" : "/"), " " }
                @$sources),
        shell_quote("$target->{abs_path}/.tmp/"),
    );
    log_debug("Running rsync ...");
    log_trace("system(): $cmd");
    system $cmd;
    log_warn("rsync didn't succeed ($?)".
                   ", please recheck") if $?;

    # but continue anyway, half backups are better than nothing

    if (-e "$target->{abs_path}/current") {
        my $tspath = "$target->{abs_path}/.current.timestamp";
        my @st     = stat($tspath);
        my $tstamp = POSIX::strftime(
            "%Y-%m-%d\@%H:%M:%S+00",
            gmtime( $st[9] || time() )); # timestamp might not exist yet
        log_debug("rename $target->{abs_path}/current ==> ".
                        "hist.$tstamp ...");
        unless (rename "$target->{abs_path}/current",
                "$target->{abs_path}/hist.$tstamp") {
            log_warn("Failed renaming $target->{abs_path}/current ==> ".
                         "hist.$tstamp: $!");
        }
        log_debug("touch $tspath ...");
        system "touch ".shell_quote($tspath);
    }

    log_debug("rename $target->{abs_path}/.tmp ==> current ...");
    unless (rename "$target->{abs_path}/.tmp",
            "$target->{abs_path}/current") {
        log_warn("Failed renaming $target->{abs_path}/.tmp ==> current: $!");
    }

    log_info("Finished backup %s ==> %s", $sources, $target);
}

sub _rotate {
    require String::ShellQuote; String::ShellQuote->import;
    require Time::Local;

    my ($target, $histories) = @_;
    log_info("Rotating backup histories in %s (%s) ...",
                $target, $histories);

    local $CWD = $target; # throws exception when failed

    my $now = time();
    for my $level (1 .. @$histories) {
        my $is_highest_level  = $level == @$histories;
        my $prefix            = "hist" . ($level == 1 ? '' : $level);
        my $prefix_next_level = "hist" . ($level + 1);
        my $n                 = $histories->[$level - 1];
        my $moved             = 0;

        if ($n > 0) {
            log_debug("Only keeping $n level-$level histories ...");
            my @f = reverse sort grep { !/\.tmp$/ } glob "$prefix.*";
            #untaint for @f;
            my $any_tagged = (grep {/t$/} @f) ? 1 : 0;
            for my $f (@f[ $n .. @f - 1 ]) {
                my ($st, $tagged) = $f =~ /[^.]+\.(.+?)(t)?$/;
                my $f2 = "$prefix_next_level.$st";
                if (!$is_highest_level &&
                        !$moved && ($tagged || !$any_tagged)) {
                    log_debug("Moving history level: $f -> $f2");
                    rename $f, $f2;
                    $moved++;
                    if ($f ne $f[0]) {
                        rename $f[0], "$f[0]t";
                    }
                } else {
                    log_debug("Removing history: $f ...");
                    system "nice -n19 rm -rf " . shell_quote($f);
                }
            }
        } else {
            $n = -$n;
            log_debug("Only keeping $n day(s) of level-$level histories ...");
            my @f = reverse sort grep { !/\.tmp$/ } glob "$prefix.*";
            my $any_tagged = ( grep {/t$/} @f ) ? 1 : 0;
            for my $f (@f) {
                my ($st, $tagged) = $f =~ /[^.]+\.(.+?)(t)?$/;
                my $f2 = "$prefix_next_level.$st";
                my $t;
                $st =~ /(\d\d\d\d)-(\d\d)-(\d\d)\@(\d\d):(\d\d):(\d\d)\+00/;
                $t = Time::Local::timegm($6, $5, $4, $3, $2 - 1, $1) if $1;
                unless ($st && $t) {
                    log_warn("Wrong format of history, ignored: $f");
                    next;
                }
                if ($t > $now) {
                    log_warn("History in the future, ignored: $f");
                    next;
                }
                my $delta = ($now - $t) / 86400;
                if ($delta > $n) {
                    if (!$is_highest_level &&
                            !$moved && ( $tagged || !$any_tagged)) {
                        log_debug("Moving history level: $f -> $f2");
                        rename $f, $f2;
                        $moved++;
                        if ($f ne $f[0]) {
                            rename $f[0], "$f[0]t";
                        }
                    } else {
                        log_debug("Removing history: $f ...");
                        system "nice -n19 rm -rf " . shell_quote($f);
                    }
                }
            }
        }
    }
}

1;
# ABSTRACT: Backup files/directories with histories, using rsync

__END__