#! /usr/bin/perl
use strict;
use warnings;

use IO::File;
use File::Basename;
use Net::FTP;
use Perl6::Slurp;
use Getopt::Long;
use Sys::Hostname;
use Time::Local;
use Pod::Usage;
use POSIX qw(strftime);;
use English qw(-no_match_vars);
use 5.10.0;
use if $ENV{DEBUG} => qw(Smart::Comments);

$ENV{LC_ALL} = "C";

my $ME = basename $0;

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

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

my $opt_level = undef;
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";

sub get_configs(@);
sub get_candidates();
sub verbose(@);
sub iso2epoch($);

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

my %CONFIG = (
    FTP_DIR => "backup/<LABEL>/<NODE>",
    FTP_PASSIVE => 1,
    FULL_CYCLE => 7,	    # not used yet
);

MAIN: {
    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,
	"dry" => \$opt_dry,
	"f|force" => \$opt_force,
	"h|help" => sub { pod2usage(-exit => 0, -verbose => 1) },
	"m|man" => sub { pod2usage(-exit => 0, -verbose => 3) },
    ) or pod2usage;


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

    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};
    die join "\n", @errors, "" if @errors;

    my $ftp = new FTP($cf{FTP_HOST}, 
	Passive => $cf{FTP_PASSIVE}, 
	Debug => @opt_debug ~~ /^ftp$/) 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});

    ### @dev

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

	$ftp->home();
	$ftp->try(mkpath => $dir);
	$ftp->try(cwd => $dir);

	verbose "Now in @{[$ftp->pwd]}.\n";

	# 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
	my @last;
	foreach (reverse sort $ftp->ls) {
	    /^(?<date>.*)\.(?<level>\d+)$/;
	    $last[$+{level}] = $+{date};
	    last if $+{level} == 0;
	}

	if (not defined $opt_level) {
	    $opt_level = 
		($NOW - iso2epoch $last[0])/86400 > $cf{FULL_CYCLE} ?  0 : 1;
	}

	my $file = strftime("%F_%R", localtime $NOW)
	    . ".$opt_level";
	my $label = "$NODE:" . basename($dev->{rdev});
	verbose "\tdumping $dev->{dev} as $dev->{rdev} on $dev->{mountpoint} to $file\n";
	next if $opt_dry;

	## complain if there is already a full backup in this
	## sequence
	##die "level 0 dir should be empty\n" if @{$ftp->try(ls => "*.0.*")};

	# 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: calculate the size
	    my $snap = "$dev->{lvm}{path}-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*$/;

	    system($_ = "fsck -f @{[$opt_verbose ? '-C0' : '']} -y $device");
	    warn "fsck on $device (using: $_) failed\n" if $?;

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

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

	### $dev

	$ENV{key} = $cf{KEY};
	my $dumper = open(my $dump, "-|") or do {
	    my $head = <<__;
#! /bin/bash
if test "\$1" = "--info"; then
    cat <<___
NODE       : $NODE
DATE       : $NOW @{[localtime $NOW]}
LEVEL      : $opt_level
DEVICE     : $dev->{dev}
REAL_DEVICE: $dev->{rdev}
MOUNTPOINT : $dev->{mountpoint}
FSTYPE     : $dev->{fstype}
___
    exit 0
fi
tail -c XXXXX \$0 | openssl enc -d -blowfish "\$@"
exit

__
	    # adjust the placeholder
	    $head =~ s/XXXXX/sprintf "% 5s", "+" . (length($head) +1)/e;
	    print $head;
	    exec "dump -$opt_level -L $label -f- -u -z6 $dev->{dump}"
	    . "| openssl enc -pass env:key -salt -blowfish";
	    die "Can't exec dumper\n";
	};

	$ftp->try(put => $dump, $file);
	$dev->{cleanup}->() if $dev->{cleanup};
	verbose "Done.\n";
    }

}

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

sub get_candidates() {
# return the list of backup candidates

    my @dev;

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

    foreach (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 = $dev;
	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($rdev = `blkid -c /dev/null -o device -t '$dev'`);
	}
	$rdev = readlink $rdev while -l $rdev;

	# if it's LVM we gather more information (to support snapshots)
	# FIXME: could have used `lvdisplay -c'
	my $lvm;
	if ((stat $rdev)[6] >> 8 == $dev_mapper) {
	    @{$lvm}{qw/vg lv/} = map { s/--/-/g; $_ } basename($rdev) =~ /(.+[^-])-([^-].+)/;
	    $lvm->{path} = "$lvm->{vg}/$lvm->{lv}";
	}

	push @dev, {
	    dev => $dev,
	    rdev => $rdev,
	    mountpoint => $mp,
	    fstype => $fstype,
	    lvm => $lvm,
	};
    }

    return @dev;
}

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!
	};

	my $f = new IO::File $_ 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 iso2epoch($) {
    $_[0] =~ /(?<year>\d+)\D(?<mon>\d+)\D(?<mday>\d+)
	      (?:\D(?<hour>\d\d)\D(?<min>\d\d)(?:\D(?<sec>\d\d))?)?/x;
    my %iso = ((sec => 0, min => 0, hour => 0), %+);
    $iso{mon}--;
    $iso{year} += 1900 if $iso{year} < 100;
    return timelocal(@iso{qw/sec min hour mday mon year/});
}

__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/fstb> 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<--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> and currently nothing else.

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

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

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

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

The backup level. Level other than "0" needs a previous
level 0 (full) backup. If not specified, it is choosen automagically.
(default: undef)

=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
    ~/.ftbackup
    ./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>/<NODE>"
    FTP_PASSIVE = 1
    FULL_CYCLE	= 7

=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 ...

=cut

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