#! /usr/bin/perl

use 5.010;
use strict;
use warnings;

use File::Basename;
use Net::FTP;
use Getopt::Long;
use Sys::Hostname;
use Pod::Usage;
use POSIX qw(strftime);
use Date::Parse qw(str2time);
use Cwd qw(realpath);
use English qw(-no_match_vars);
use if $ENV{DEBUG} => qw(Smart::Comments);

$ENV{LC_ALL} = "C";

my $ME      = basename $0;
my $VERSION = "0.9";

my @CONFIGS = ("/etc/$ME.conf", "$ENV{HOME}/.$ME.conf", "$ME.conf");

my $HOSTNAME = hostname;
my $NOW      = time();

my $opt_level     = 7;
my $opt_today     = strftime("%F", localtime $NOW);
my @opt_debug     = ();
my $opt_verbose   = 0;
my $opt_dry       = 0;
my $opt_force     = 0;
my $opt_label     = "daily";
my $opt_info      = 0;
my $opt_config    = "";
my $opt_clean     = 1;
my $opt_dumpdates = "/var/lib/dumpdates";

sub slurp($);
sub get_configs(@);
sub get_candidates();
sub verbose(@);
sub update_devnames($$$);
sub get_history(@);
sub calculate_level($@);
sub real_device($);
sub get_estimate($$);
sub devno($);
sub unlink_old_dumps($$);

our @AT_EXIT;
END { $_->() foreach @AT_EXIT }
$SIG{INT} = sub { warn "Got signal INT\n"; exit 1 };

my %CONFIG = (
    FTP_DIR           => "backup/<LABEL>/<HOSTNAME>",
    FTP_PASSIVE       => 1,
    COMPRESSION_LEVEL => 6,
    FULL_CYCLE        => 7,
    KEEP              => 2,
);

END {
    say STDERR "*** $ME STOP: " . localtime if not -t STDERR;
}

MAIN: {

    say STDERR "*** $ME START: " . localtime if not -t STDERR;

    Getopt::Long::Configure("bundling");
    GetOptions(
        "l|level=i" => \$opt_level,
        "L|label=s" => \$opt_label,
        "d|debug:s" => sub { push @opt_debug, split /,/, $_[1] },
        "v|verbose" => \$opt_verbose,
        "i|info"    => \$opt_info,
        "dry"       => sub { $opt_dry = 1; $opt_verbose = 1 },

        #"f|force"   => \$opt_force,
        "h|help" => sub { pod2usage(-exit => 0, -verbose => 1) },
        "m|man"  => sub { pod2usage(-exit => 0, -verbose => 3) },
        "C|config=s" => sub { @CONFIGS = ($_[1]) },
        "V|version" => sub { print "$ME: $VERSION\n"; exit 0 },
        "c|clean!" => \$opt_clean,
        "D|dumpdates=s" => \$opt_dumpdates,
    ) or pod2usage;

    my %cf = (%CONFIG, get_configs(@CONFIGS));
    $cf{FTP_DIR} =~ s/<HOSTNAME>/$HOSTNAME/g;
    $cf{FTP_DIR} =~ s/<LABEL>/$opt_label/g;

    # get the backup candiates -> all file systems from /etc/fstab
    # with a dump frequence > 0
    my @devs = get_candidates();

    ### %cf
    ### @devs

    verbose +(map { "candidate: $_->{dev} as $_->{rdev}\n" } @devs), "\n";

    my @errors = ();
    push @errors, "Need FTP_HOST (see config)." if not defined $cf{FTP_HOST};
    push @errors, "Need KEY (see config)."      if not defined $cf{KEY};
    push @errors, "Command `dump' not found. ($ENV{PATH})"
      if system("command -v dump >/dev/null");
    push @errors, "Command `lvm' not found. ($ENV{PATH})"
      if system("command -v lvm >/dev/null");
    push @errors, "Command `fsck' not found. ($ENV{PATH})"
      if system("command -v fsck >/dev/null");
    die "$ME: pre-flight check failed:\n\t", join("\n\t" => @errors), "\n"
      if @errors;

    my $ftp;

    if (not "output" ~~ \@opt_debug) {
        $ftp = new FTP(
            $cf{FTP_HOST},
            Passive => $cf{FTP_PASSIVE},
            Debug   => "ftp" ~~ \@opt_debug,
        ) or die $@;
        $ftp->login or die $ftp->message;
        $ftp->home($ftp->try(pwd => ()));
        $ftp->try(binary => ());
        $ftp->try(mkpath => $cf{FTP_DIR});
        $ftp->try(cwd    => $cf{FTP_DIR});
    }

    # get_history the situation - we rely on $opt_dumpdates
    @devs = get_history(@devs);
    @devs = calculate_level($cf{FULL_CYCLE}, @devs);

    ### @devs

    if ($opt_info) {
        my $lr =
          (reverse sort { $a <=> $b } map { length $_->{rdev} } @devs)[0];
        my $ld = (reverse sort { $a <=> $b } map { length $_->{dev} } @devs)[0];
        my $ln =
          (reverse sort { $a <=> $b } map { length $_->{devno} } @devs)[0];

        my %l;
        foreach my $dev (@devs) {
            $l{$dev} = sprintf "%*s (%*s %*s)",
              -$ld => $dev->{dev},
              -$lr => $dev->{rdev},
              -$ln => $dev->{devno};
        }

        say "\ncurrent situation\n", "------------------";
        foreach my $dev (@devs) {
            if (!$dev->{last}) { say "$l{$dev}: never" }
            else {
                for (my $i = 0 ; $i < @{ $dev->{last} } ; $i++) {
                    say "$l{$dev}: $i ",
                      defined($dev->{last}[$i])
                      ? scalar localtime($dev->{last}[$i])
                      : "-";
                }
            }
        }

        say "\nplan for next dump\n", "------------------";
        foreach my $dev (@devs) {
            say "$l{$dev}: level $dev->{level}";
        }

        exit;
    }

    # and now we can start doing something with our filesystems
  DEVICE: foreach my $dev (@devs) {
        my $dir = $dev->{mountpoint};
        $dir =~ s/_/__/g;
        $dir =~ s/\//_/g;
        $dir = "$cf{FTP_DIR}/$dir";

        my @last;
        if ($ftp) {
            $ftp->home();
            $ftp->try(mkpath => $dir);
            $ftp->try(cwd    => $dir);

            #verbose "Now in @{[$ftp->pwd]}.\n" if $ftp;
            unlink_old_dumps($ftp, $cf{KEEP} + 1)
              if $opt_clean;

            # examine the situation and decide about the level
            # FIXME: currently we simply run a full dump every FULL_CYCLE
            # days, the intermediate dumps are level 1
            foreach (reverse sort $ftp->ls) {
                /^(?<date>.*)\.(?<level>\d+)$/ or next;
                $last[$+{level}] = str2time $+{date};
            }
        }

    # for safety we check if there is really a full dump not older than xxx days
        if ($dev->{level} > 0) {
            if (!@last) {
                $dev->{level} = 0;
                warn "adjusted backup level to 0, last full backup missing\n";
            }
            elsif (($NOW - $last[0]) > ($cf{FULL_CYCLE} * 86_400)) {
                $dev->{level} = 0;
                warn sprintf
"adjusted backup level to 0, last full backup is %.1f days old\n",
                  ($NOW - $last[0]) / 86_400;
            }
        }

        my $file = strftime("%FT%R.$dev->{level}", localtime $NOW);
        my $label = basename($dev->{rdev});
        verbose
"> $dev->{dev} ($dev->{rdev}\@$dev->{mountpoint}) to @{[$ftp->pwd]}/$file\n";
        next if $opt_dry;

        # For LVM do a snapshot, for regular partitions
        # do nothing. But anyway the device to dump is named in $dev->{dump}
        if ($dev->{lvm}) {

            # we can do a snapshot
            # FIXME: check the snapshot name is not used already
            my $snap = "$dev->{lvm}{path}-snap.0";

            verbose "Creating snapshot $snap\n";
            system($_ =
                  "lvcreate -s -L 1G -n $snap $dev->{lvm}{path} >/dev/null");
            die "failed system command: $_\n" if $?;

            $dev->{cleanup} = sub {
                system "lvdisplay $snap &>/dev/null"
                  . " && lvremove -f $snap >/dev/null";
            };
            push @AT_EXIT, $dev->{cleanup};

            (my $device) =
              (grep /lv name/i, `lvdisplay $snap`)[0] =~ /(\S+)\s*$/;

            for (my $retries = 3 ; $retries ; $retries--) {
                system($_ =
                      "fsck -f @{[$opt_verbose ? '-C0' : '']} -y $device");
                last if not $?;
                warn "fsck on $device (using: $_) failed"
                  . ($retries > 1 ? ", retrying…\n" : "") . "\n";
            }

            ($dev->{dump}) = $device;

        }
        else {
            $dev->{dump} = $dev->{rdev};
        }

        ### $dev

        $ENV{key} = $cf{KEY};
        my $dumper = open(my $dump, "-|") or do {
            print <<__HEAD;
#! /bin/sh
LC_ALL=C
if test -t 1; then
    cat <<___
HOSTNAME   : $HOSTNAME
DATE       : $NOW @{[scalar localtime $NOW]}
LEVEL      : $dev->{level}
DEVICE     : $dev->{dev}
REAL_DEVICE: $dev->{rdev}
MOUNTPOINT : $dev->{mountpoint}
FSTYPE     : $dev->{fstype}
DEVICE_NO  : $dev->{devno}

# For recovery pass everything following the first
# ^#-- START to "recover -rf -". Or do one of the following
# lines:
#   sh <THIS SCRIPT>   | restore -rf -
#   ftpipe <URL> | sh  | restore -rf -
#   sh <(ftpipe <URL>) | restore -rf -
#
# The tool "ftpipe" can be found at https://keller.schlittermann.de/hg/beta/ftpipe
# or there about.
___
    exit 0
fi

if test -t 0; then input="\$0"
else input="/dev/fd/0"
fi

while read; do
    test "\$REPLY" = "#-- START" \\
	&& exec openssl enc -d -blowfish "\$@"
done <\$input
exit
#-- START
__HEAD

            update_devnames($opt_dumpdates, $dev->{rdev} => $dev->{dump})
              if $opt_dumpdates;

            exec
"dump -$dev->{level} -L $label -f- -u -z$cf{COMPRESSION_LEVEL} $dev->{dump}"
              . "| openssl enc -pass env:key -salt -blowfish";
            die "Can't exec dumper\n";
        };

        if ($ftp) {
            verbose("sending dump to " . $ftp->pwd . "/$file\n");
            $ftp->try(put => $dump, $file);
        }
        else {
            print while <$dump>;
            warn "STOPPED after the first dump\n";
            exit;
        }
        $dev->{cleanup}->() if $dev->{cleanup};
        verbose "Done.\n";

        update_devnames($opt_dumpdates, $dev->{dump} => $dev->{rdev})
          if $opt_dumpdates;

        unlink_old_dumps($ftp, $cf{KEEP})
          if $ftp and $opt_clean;
    }

}

sub verbose(@) {
    return if not $opt_verbose;
    print STDERR @_;
}

sub get_candidates() {

    # return the list of backup candidates

    my @devs;

    # later we need the major of the device mapper
    my $dev_mapper = (grep /device.mapper/, slurp("/proc/devices"))[0];
    $dev_mapper = (split " " => $dev_mapper)[0] if defined $dev_mapper;

    # find all non comment lines
    foreach (grep !/^\s*#/, slurp("/etc/fstab")) {
        my ($dev, $mp, $fstype, $options, $dump, $check) = split;
        next if not $dump;

        # $dev does not have to contain the real device
        my $rdev = real_device($dev);
        my ($major, $minor) = devno($rdev);

        # if it's LVM we gather more information (to support snapshots)
        my $lvm;
        if ($_ = (grep { /:$major:$minor\s*$/ } `lvdisplay -c`)[0]
            and /\s*(?<path>\S+?):/)
        {
            ($lvm->{path} = $+{path}) =~ s/^\/dev\///;
        }

        push @devs,
          {
            dev        => $dev,
            rdev       => $rdev,
            mountpoint => $mp,
            fstype     => $fstype,
            lvm        => $lvm,
            devno      => "$major:$minor",
          };
    }

    return @devs;
}

sub get_configs(@) {
    local $_;
    my %r = ();
    foreach (grep { -f } map { (-d) ? glob("$_/*") : $_ } @_) {

        # check permission and ownership
        {
            my $p = (stat)[2] & 07777;
            my $u = (stat _)[4];
            die
"$ME: $_ has wrong permissions: found @{[sprintf '%04o', $p]}, need 0600\n"
              if $p != 0600;
            die
              "$ME: owner of $_ ($u) is not the EUID ($EUID) of this process\n"
              if (stat _)[4] != $EUID;

            # FIXME: should check the containing directories too!
        };

        open(my $f, $_) or die "Can't open $_: $!\n";
        my %h = map { split /\s*=\s*/, $_, 2 } grep { !/^\s*#/ and /=/ } <$f>;
        map { chomp } values %h;
        %r = (%r, %h);
    }
    return %r;
}

{

    package FTP;
    use strict;
    use warnings;
    use base qw(Net::FTP);

    my %data;

    sub new {
        my $class = shift;
        return bless Net::FTP->new(@_) => $class;
    }

    sub try {
        my $self = shift;
        my $func = shift;
        $self->$func(@_)
          or die "FTP $func failed: " . $self->message . "\n";
    }

    sub mkpath {
        my $self    = shift;
        my $current = $self->pwd();
        foreach (split /\/+/, $_[0]) {
            next if $self->cwd($_);
            return undef if not $self->message ~~ /no such .*dir/i;
            return undef if not $self->SUPER::mkdir($_);
            return undef if not $self->cwd($_);
        }
        $self->cwd($current);
    }

    sub home {
        my $self = shift;
        return $data{ ref $self }{home} = shift if @_;
        $self->try(
            cwd => exists $data{ ref $self }{home}
            ? $data{ ref $self }{home}
            : "/"
        );
        return $self->pwd();
    }

    sub get_home { return $data{ ref shift }{home} }
}

sub update_devnames($$$) {
    my ($file, $from, $to) = @_;
    open(my $f, "+>>" => $file) or die "Can't open $file: $!\n";
    seek($f, 0, 0);
    my $_ = join "", <$f>;
    s/^$from\s/$to /mg;
    truncate($f, 0);
    print $f $_;
    close($f);
}

sub real_device($) {
    my $dev = shift;

    if ($dev ~~ /^(LABEL|UUID)=/) {

        # NOTE: dump is able to handle LABEL=... too, but I think
        # it's more easy for recovery to know the real device
        chomp($dev = `blkid -c /dev/null -o device -t '$dev'`);
    }
    $dev = realpath($dev);
}

sub devno($) {
    stat shift or return wantarray ? () : undef;
    my @mm = ((stat _)[6] >> 8, (stat _)[6] & 0xff);
    return wantarray ? @mm : "$mm[0]:$mm[1]";
}

# put the last dump information (level and date) into
# the device structure - information is obtained from $opt_dumpdates
sub get_history(@) {
    my @devs = @_;
    my %dd;

    open(my $dd, "+>>", $opt_dumpdates);
    seek($dd, 0, 0);
    while (<$dd>) {
        my ($dev, $level, $date) = /^(\S+)\s+(\d+)\s+(.{30})/
          or die "Can't parse $opt_dumpdates: `$_'\n";
        my $rdev  = real_device($dev);
        my $devno = devno($rdev);

        push @{ $dd{$rdev} } => {
            dev   => $dev,
            rdev  => real_device($dev),
            level => $level,
            date  => str2time($date),
            devno => scalar(devno(real_device($dev))),
        };
    }
    close($dd);

    foreach my $dev (@devs) {
        my $dd = $dd{ $dev->{rdev} };

        if (!$dd) {
            $dev->{last} = undef;
            next;
        }

        foreach my $dump (@$dd) {
            $dev->{last}[$dump->{level}] = $dump->{date};
        }
    }

    ### @devs
    return @devs;
}

sub human_number($) {
    my $n = shift;
    my @units = ("", qw(K M G T));
    while (length($n) > 3) {
        $n = int($n / 1024);
        shift @units;
    }
    return "$n $units[0]";
}

sub get_estimate($$) {
    my ($dev, $level) = @_;
    print STDERR "% estimating $dev->{rdev} at level $level: ";
    chomp(my $_ = `dump -S -$level $dev->{rdev}`);
    print STDERR human_number($_) . "Byte\n";
    return $_;
}

sub calculate_level($@) {
    my ($cycle, @devs) = @_;


    foreach my $dev (@devs) {
        if (defined $opt_level) {
            $dev->{level} = $opt_level;
        }
        elsif (!$dev->{last}
            or not $dev->{last}[0]
            or $NOW - $dev->{last}[0] > ($cycle * 86_400))
        {
            $dev->{level} = 0;
        }
        else { $dev->{level} = 0 }

        # now we'll see if the level really saves space compared
        # with the next lower level
        my @estimates;
        while ((my $l = $dev->{level}) > 0) {
            $estimates[$l]     //= get_estimate($dev, $l);
            $estimates[$l - 1] //= get_estimate($dev, $l - 1);
	    last if ($estimates[$l - 1] - $estimates[$l]) / $estimates[$l - 1] >= 0.10;
            --$dev->{level};
        }
	warn "% $dev->{dev} will use level $dev->{level}\n";
    }

    return @devs;
}

sub slurp($) {
    my $f = shift;
    open(my $fh, "<", $f) or die "Can't open $f: $!\n";
    return <$fh>;
}

sub unlink_old_dumps($$) {
    my ($ftp, $keep) = @_;
    my @dumps;
    foreach ($ftp->ls) {
        /^(?<date>.*)\.(?<level>\d+)$/ or next;
        push @{ $dumps[$+{level}] } =>
          { file => $_, date => $+{date}, stamp => str2time($+{date}) };
    }

    # sort the level 0 dumps by date and remove all but the last $keep
    # ones.
    # if we found level 0 dumps, we remove all level 1+ dumps older than
    # the oldest level 0 dump we'll remove
    @{ $dumps[0] } = sort { $a->{stamp} <=> $b->{stamp} } @{ $dumps[0] };

    ### @dumps
    my @unlink = splice(@{ $dumps[0] }, 0, -$keep);

    if ($dumps[1]) {
        if (!@{ $dumps[0] }) { push @unlink, @{ @dumps[1 .. $#dumps] } }
        else {
            push @unlink => grep { $_->{stamp} <= $dumps[0][0]{stamp} }
              @{ @dumps[1 .. $#dumps] };
        }
    }

    ### @unlink

    foreach (@unlink) {
        say "DELETE: $_->{file}";
        next if $opt_dry;
        $ftp->delete($_->{file});
    }
}

#/dev/vda1 0 Thu Apr 14 12:54:31 2011 +0200
#/dev/vda1 1 Thu Apr 14 12:54:16 2011 +0200

__END__

=head1 NAME

ftbackup - ftp backup tool

=head1 SYNOPSIS

    ftbackup [--level <level>] [options]

=head1 DESCRIPTION

The B<ftbackup> tools saves the partitions (file systems) marked in
F</etc/fstab> to an FTP host. It uses dump(8) for generating the backup
and openssl(1) for encrypting the data stream (and thus the written
files).

=head1 OPTIONS

=over

=item B<-D>|B<--dumpdates> I<file>

Update the I<file> as dumpdates file. (default: /var/lib/dumpdates)

=item B<-d>|B<--debug> [I<item>]

Enables debugging for the specified items (comma separated).
If no item is specified, just some debugging is done.

Valid items are B<ftp>, B<output>, B<devices> and currently nothing else.

=over

=item B<ftp>

This switches on debugging of the used L<Net::FTP> module.

=item B<output>

The output is not sent via FTP but to stdout. Beware!

=back

Even more debugging is shown using the DEBUG=1 environment setting.

=item B<--clean> 

Cleanup older backups we do not need (that is: incremental backups with
no previous full backup. The number of old backups we keep 
is read from the configuration file. (default: 1)

=item B<--dry>

Dry run, no real backup is done, this option implies B<--verbose>. (default: off)

=item B<-f>|B<--force>

Use more power (e.g. overwrite a previous level backup and remove all
invalidated other backups). (default: 0 and not implemented)

=item B<-i>|B<--info>

Just output information about the last backups and exit. (default: off)

=item B<-l>|B<--level> I<level>

The proposed backup level. If there are less then 10% savings compared
with a lower level, or if no lower level exists, the level is incremented.
(default: 7)

=item B<-L>|B<--label> I<label>

The label for the backup. (default: daily)

=item B<-v>|B<--verbose>

Be verbose. (default: no)

=back

=head1 FILES

=head2 Configuration

The config files are searched in the following places:

    /etc/ftbackup.conf
    ~/.ftbackup.conf
    ./ftbackup.conf

If the location is a directory, all (not hidden) files in this directory are
considered to be config, if the location a file itself, this is considered to
be a config file. The config files have to be mode 0600 and they have to be 
owned by the EUID running the process.

The config file may contain the following items (listed with their built in defaults)

    KEY		= <no default>
    FTP_HOST	= <no default>
    FTP_DIR	= backup/<LABEL>/<HOSTNAME>
    FTP_PASSIVE = 1
    COMPRESSION_LEVEL = 6
    FULL_CYCLE	= 7
    KEEP        = 2

=over

=item KEY

The encryption key to use. (We use symmetric blowfish encryption currently.)

=item FTP_HOST

The FTP host to send the backup to.

=item FTP_DIR

A template for storing the backup file(s). Each dumped file system needs
its own directory!

=item FTP_PASSIVE

A switch to activate the usage of passive FTP.

=item COMPRESSION_LEVEL

The level of the used gzip compression.

=item FULL_CYCLE

A full backup is forced if the last full backup is older than thi number
of days.

=item KEEP

The number of full backups (including the current one!) to keep. It means, that
normally you'll get KEEP backups in your backup directory. Useless
incremental backups are deleted automgically.

=back

=head2 F<.netrc>

You may miss the login information for the FTP server. Currently we rely on a valid
F<~/.netrc> entry. An example line of the F<~/.netrc>:

    machine ... login ... password ...


=head1 RESTORE

The files B<ftbackup> writes to the FTP server are "selfextracting"
shell scripts.  They contain a file header with some information. If you
download such a file and run it as a shell script, you will get the
instructions:

=head3 EXAMPLE

    -- ftp -- until you have a local copy of the dump file
    $ sh ./2010-04-04T13:00.0 

or
    
    $ ftpipe --get ftp://backupserver/dumps/_/2010-04-04T13:00.0 | sh 

NOTE: B<ftpipe> is a small tool for dumping FTP downloads into a pipe
without storing them in the local file system. See at
L<https://keller.schlittermann.de/hg/beta/ftpipe>.

=head1 AUTHOR

Heiko Schlittermann <hs@schlittermann.de>

=cut

# vim:sts=4 sw=4 aw ai sm:
