# HG changeset patch
# User Heiko Schlittermann (ZARAFA.ctq.de) hs@schlittermann.de
# Date 1302878486 -7200
# Node ID 84663019017f495b39e2ec5b0b7e092e21a8f240
# Parent  aae83a165bbf74e431693adf54c7327980e8d1be
changed to Build.PL

diff -r aae83a165bbf -r 84663019017f .hgignore
--- a/.hgignore	Fri Apr 15 13:17:20 2011 +0200
+++ b/.hgignore	Fri Apr 15 16:41:26 2011 +0200
@@ -1,8 +1,11 @@
 syntax: glob
 ftbackup.conf
-Makefile
 debian/*
 ftbackup.8
 debian/files
 Makefile
 .version
+_build/
+blib/
+Build
+MANIFEST.bak
diff -r aae83a165bbf -r 84663019017f Build.PL
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Build.PL	Fri Apr 15 16:41:26 2011 +0200
@@ -0,0 +1,16 @@
+use strict;
+use warnings;
+use Module::Build;
+
+Module::Build->new(
+	dist_name => "ftbackup",
+	dist_version => "0.7",
+	requires => {
+		perl => "5.10.0",
+		"Perl6::Slurp" => 0,
+		"Net::FTP" => 0,
+		"Date::Parse" => 0,
+	},
+
+	script_files => [glob("sbin/*")],
+)->create_build_script();
diff -r aae83a165bbf -r 84663019017f MANIFEST
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MANIFEST	Fri Apr 15 16:41:26 2011 +0200
@@ -0,0 +1,7 @@
+.perltidyrc
+sbin/ftbackup
+build-stamp
+configure
+configure-stamp
+MANIFEST			This list of files
+MANIFEST.SKIP
diff -r aae83a165bbf -r 84663019017f MANIFEST.SKIP
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/MANIFEST.SKIP	Fri Apr 15 16:41:26 2011 +0200
@@ -0,0 +1,10 @@
+ftbackup.conf
+debian
+ftbackup.8
+Makefile
+.version
+.hg
+_build/
+blib/
+Build
+MANIFEST.bak
diff -r aae83a165bbf -r 84663019017f Makefile.in
--- a/Makefile.in	Fri Apr 15 13:17:20 2011 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-DESTDIR = 
-prefix = @prefix@
-sbindir = ${prefix}/sbin
-man8dir = ${prefix}/share/man/man8
-
-SCRIPT = ftbackup
-MAN8PAGE = ftbackup.8
-
-all:	
-
-
-install:	man .version all
-	install -d -m 0755 ${DESTDIR}${sbindir}
-	install    -m 0755 ${SCRIPT} ${DESTDIR}${sbindir}
-	perl -i -pe 's/\<VERSION\>/'`cat .version`'/' ${DESTDIR}${sbindir}/${SCRIPT}
-
-	install -d -m 0755 ${DESTDIR}${man8dir}
-	install    -m 0644 ${MAN8PAGE} ${DESTDIR}${man8dir}/
-
-
-	
-man:	${MAN8PAGE}
-
-clean:
-	rm -f ${MAN8PAGE} .version
-
-distclean:	clean
-	rm -f Makefile
-
-.version:	${SCRIPT}
-	test -f .hg_archival.txt \
-		&& { grep ^node: | cut -f2 -d' ' >$@; } \
-		|| { hg id | cut -f1 -d' ' >$@; }
-
-%.8:	%
-	pod2man --section 8 $< >$@
diff -r aae83a165bbf -r 84663019017f ftbackup
--- a/ftbackup	Fri Apr 15 13:17:20 2011 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,638 +0,0 @@
-#! /usr/bin/perl
-
-use 5.010;
-use strict;
-use warnings;
-
-use File::Basename;
-use Net::FTP;
-use Perl6::Slurp;
-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 = '<VERSION>';
-
-my @CONFIGS = ("/etc/$ME.conf", "$ENV{HOME}/.$ME.conf", "$ME.conf");
-
-my $HOSTNAME = 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";
-my $opt_info    = 0;
-my $opt_config  = "";
-my $opt_dumpdates = "/var/lib/dumpdates";
-
-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($);
-
-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,
-    FULL_CYCLE  => 7,
-    COMPRESSION_LEVEL => 6,
-);
-
-
-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,
-	"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 },
-	"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."   if system("command -v dump >/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;
-
-            # 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}] = $+{date};
-                last if $+{level} == 0;
-            }
-        }
-
-	# 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 - str2time($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 - str2time $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/bash
-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 -
-#   sh <(ftpipe <URL>) -pass file:/dev/tty | restore -rf -
-___
-    exit 0
-fi
-while read; do
-    test "\$REPLY" = "### START" \\
-	&& exec openssl enc -d -blowfish "\$@"
-done <"\$0"
-
-### 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) {
-            $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;
-    }
-
-}
-
-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);
-	# fix the dumpdates
-	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($) {
-    my @mm = ((stat shift)[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 get_estimate($$) {
-    my ($dev, $level) = @_;
-    warn "% estimating $dev->{rdev} at level $level\n";
-    chomp(my $_ = `dump -S -$level $dev->{rdev}`);
-    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} = 1 }
-
-	# 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 my $savings = ($estimates[$l-1] - $estimates[$l]) / $estimates[$l-1] >= 0.10;
-	    warn "% savings for level $dev->{level} on $dev->{dev} are @{[int($savings * 100)]}% ",
-		 "will use level ", $dev->{level} - 1, "\n";
-	    --$dev->{level};
-	}
-    }
-
-    return @devs;
-}
-
-#/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> [I<days>]
-
-Cleanup older backups we do not need (that is: incremental backups with
-no previous full backup. If I<days> are given, then all full backups older than
-the number of I<days> are removed (and all incremental backups based on these
-full backups). (default: 0 and not implemented)
-
-=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 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.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
-    FULL_CYCLE	= 7
-    COMPRESSION_LEVEL = 6
-
-=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:
diff -r aae83a165bbf -r 84663019017f sbin/ftbackup
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/sbin/ftbackup	Fri Apr 15 16:41:26 2011 +0200
@@ -0,0 +1,638 @@
+#! /usr/bin/perl
+
+use 5.010;
+use strict;
+use warnings;
+
+use File::Basename;
+use Net::FTP;
+use Perl6::Slurp;
+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 = '<VERSION>';
+
+my @CONFIGS = ("/etc/$ME.conf", "$ENV{HOME}/.$ME.conf", "$ME.conf");
+
+my $HOSTNAME = 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";
+my $opt_info    = 0;
+my $opt_config  = "";
+my $opt_dumpdates = "/var/lib/dumpdates";
+
+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($);
+
+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,
+    FULL_CYCLE  => 7,
+    COMPRESSION_LEVEL => 6,
+);
+
+
+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,
+	"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 },
+	"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."   if system("command -v dump >/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;
+
+            # 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}] = $+{date};
+                last if $+{level} == 0;
+            }
+        }
+
+	# 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 - str2time($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 - str2time $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/bash
+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 -
+#   sh <(ftpipe <URL>) -pass file:/dev/tty | restore -rf -
+___
+    exit 0
+fi
+while read; do
+    test "\$REPLY" = "### START" \\
+	&& exec openssl enc -d -blowfish "\$@"
+done <"\$0"
+
+### 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) {
+            $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;
+    }
+
+}
+
+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);
+	# fix the dumpdates
+	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($) {
+    my @mm = ((stat shift)[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 get_estimate($$) {
+    my ($dev, $level) = @_;
+    warn "% estimating $dev->{rdev} at level $level\n";
+    chomp(my $_ = `dump -S -$level $dev->{rdev}`);
+    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} = 1 }
+
+	# 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 my $savings = ($estimates[$l-1] - $estimates[$l]) / $estimates[$l-1] >= 0.10;
+	    warn "% savings for level $dev->{level} on $dev->{dev} are @{[int($savings * 100)]}% ",
+		 "will use level ", $dev->{level} - 1, "\n";
+	    --$dev->{level};
+	}
+    }
+
+    return @devs;
+}
+
+#/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> [I<days>]
+
+Cleanup older backups we do not need (that is: incremental backups with
+no previous full backup. If I<days> are given, then all full backups older than
+the number of I<days> are removed (and all incremental backups based on these
+full backups). (default: 0 and not implemented)
+
+=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 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.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
+    FULL_CYCLE	= 7
+    COMPRESSION_LEVEL = 6
+
+=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: