Implement tar backup

* lib/App/Beam/Config.pm (get): Return dereferenced array and hash
refs.
(__lint): Fix array collection.
* lib/App/Beam.pm (%parameters): Mark unhandled keywords as arrays
(logger): Read from fd, if passed as the first argument.
(logcommand): New method.
* lib/App/Beam/Backend.pm: New file.
* lib/App/Beam/Backend/Tar.pm: New file.
* lib/App/Beam/Backup.pm (run): Assume result OK, unless already set
otherwise.
* lib/App/Beam/Command.pm: New file.
* MANIFEST: Update.

6 files changed, 462 insertions, 25 deletions

diff --git a/lib/App/Beam.pm b/lib/App/Beam.pm
index 84eb4cc..54b3cd3 100644
--- a/lib/App/Beam.pm
+++ b/lib/App/Beam.pm
@@ -7,7 +7,7 @@ use Sys::Syslog;
 use Unix::Sysexits;
 use Fcntl qw(:flock SEEK_SET);
 use Storable qw(fd_retrieve nstore_fd);
-use POSIX qw(strftime);
+use POSIX qw(strftime floor);
 
 require App::Beam::Config;
 our @ISA = qw(App::Beam::Config);
@@ -101,7 +101,9 @@ my %parameters = (
 	section => {
 	    '*' => {
 		section => {
-		    '*' => 1
+		    '*' => {
+			array => 1
+		    }
 		}
 	    }
 	}
@@ -111,7 +113,9 @@ my %parameters = (
 	    '*' => {
 		section => {
 		    backend => { mandatory => 1 },
-		    '*' => 1
+		    '*' => {
+			array => 1
+		    }
 		}
 	    }
 	}
@@ -208,11 +212,20 @@ sub logger_line {
 
 sub logger {
     my $self = shift;
-    my $prio = shift;    
-    my @msg = split(/\n/, join(' ', @_));
-    $self->logger_line($prio, shift @msg);
-    for (@msg) {
-	$self->logger_line($prio, " $_");
+    my $prio = shift;
+
+    if (ref($_[0]) eq 'GLOB') {
+	my $fd = shift;
+	while (<$fd>) {
+	    chomp;
+	    $self->logger_line($prio, $_);
+	}
+    } else {
+	my @msg = split(/\n/, join(' ', @_));
+	$self->logger_line($prio, shift @msg);
+	for (@msg) {
+	    $self->logger_line($prio, " $_");
+	}
     }
 }
 
@@ -250,21 +263,28 @@ sub lock {
     }
     seek($self->{statfd}, 0, SEEK_SET);
     if ((stat($self->{statfd}))[7] == 0) {
-	$self->{status} = { round => 0,
-			    level => 0,
-			    timestamp => time() };
+	$self->{status} = [];
     } else {
 	$self->{status} = fd_retrieve($self->{statfd})
 	    or $self->abend(EX_UNAVAILABLE, "can't retrieve status from $file: $!");
+	if (ref($self->{status}) ne 'ARRAY') {
+	    $self->abend(EX_DATAERR, "$file: malformed status file");
+	}
     }
+    my ($cycle, $round, $level) = $self->compute_triplet(1);
+    unshift @{$self->{status}}, { timestamp => time(),
+				  result => 'PENDING',
+				  cycle => $cycle,
+				  round => $round,
+				  level => $level };
 }
 
 # Saves the current status and unlocks the status file.
 sub unlock {
     my ($self) = @_;
     croak "unlock without lock" unless defined $self->{statfd};
-    if ($self->{status}{updated}) {
-	delete $self->{status}{updated};
+    $self->debug(1, "saving state: ".$self->status('result'));
+    if (!$self->{dry_run} && $self->status('result') ne 'PENDING') {
 	seek($self->{statfd}, 0, SEEK_SET);
 	truncate($self->{statfd}, 0);
 	nstore_fd($self->{status}, $self->{statfd});
@@ -273,15 +293,81 @@ sub unlock {
     close($self->{statfd});
 }
 
-sub status {
-    my ($self,$name,$val) = @_;
-    my $ret = $self->{status}{$name} if exists $self->{status}{$name};
-    if (defined($val)) {
-#	print "SET $name=$val\n";
-	$self->{status}{$name} = $val;
-	$self->{status}{updated} = 1 unless $self->{dry_run};
+sub compute_triplet {
+    my ($self, $off, $base) = @_;
+
+    $base = 0 unless defined $base;
+    if ($#{$self->{status}} == -1) {
+	return (0, 0, 0);
+    }
+    croak "invalid base" unless $base <= $#{$self->{status}};
+    
+    my ($cycle, $round, $level) =
+	(${$self->{status}}[$base]{cycle},
+	 ${$self->{status}}[$base]{round},
+	 ${$self->{status}}[$base]{level});
+
+    my ($maxround, $maxlevel) =
+	($self->get('schedule', 'rounds'),
+	 $self->get('schedule', 'levels'));
+    if ($off == 1) {
+	$level++;
+	if ($level > $maxlevel) {
+	    $round++;
+	    $level = 0;
+	    if ($round > $maxround) {
+		$cycle++;
+		$round = 0;
+	    }
+	}
+    } elsif ($off == -1) {
+	$level--;
+	if ($level < 0) {
+	    $level += $maxlevel + 1;
+	    $round--;
+	}
+	if ($round < 0) {
+	    $round += $maxround + 1;
+	    $cycle--;
+	    if ($cycle == 0) {
+		$round = $level = 0;
+		last;
+	    }
+	}
+    } elsif ($off) {
+	croak "invalid offset";
     }
-    return $ret;
+    return ($cycle, $round, $level);
+}
+
+sub status {
+    my ($self,$item,$base) = @_;
+    $base = 0 unless defined $base;
+    return undef unless $base <= $#{$self->{status}};
+    return $self->{status}[$base]{$item};
+}
+
+sub result {
+    my ($self) = @_;
+    return $self->{status}[0]{result};
+}
+
+sub set_result {
+    my ($self, $result) = @_;
+    $self->{status}[0]{result} = $result;
+}
+
+sub format_name {
+    my ($self, $name, $base) = @_;
+    $base = 0 unless defined $base;
+    return undef unless $base <= $#{$self->{status}};
+    $name .= '-'
+          . $self->status('cycle', $base)
+          . '-'
+          . $self->status('round', $base)
+          . '-'
+          . $self->status('level', $base);
+    return $name;
 }
 
 sub load_backends {
diff --git a/lib/App/Beam/Backend.pm b/lib/App/Beam/Backend.pm
new file mode 100644
index 0000000..525b57d
--- /dev/null
+++ b/lib/App/Beam/Backend.pm
@@ -0,0 +1,88 @@
+package App::Beam::Backend;
+
+use strict;
+use Carp;
+
+require Exporter;
+our @ISA = qw(Exporter);
+use App::Beam::Command qw(:channels);
+
+sub new {
+    my $class = shift;
+    my $beam = shift or croak "required argument missing";
+    return bless { beam => $beam }, $class;
+}
+
+sub logger {
+    my $self = shift;
+    $self->{beam}->logger(@_);
+}
+
+sub error {
+    my $self = shift;
+    $self->{beam}->error(@_);
+}
+
+sub debug {
+    my $self = shift;
+    $self->{beam}->debug(@_);
+}
+
+sub abend {
+    my $self = shift;
+    $self->{beam}->abend(@_);
+}
+
+sub dry_run {
+    my ($self) = @_;
+    return $self->{beam}{dry_run};
+}
+
+sub get {
+    my $self = shift;
+    return $self->{beam}->get(@_);
+}
+
+sub isset {
+    my $self = shift;
+    return $self->{beam}->isset(@_);
+}
+
+sub status {
+    my $self = shift;
+    return $self->{beam}->status(@_);
+}
+
+sub logcommand {
+    my ($self, $cmd) = @_;
+    my $ret = $cmd->status;
+    return unless defined $ret;
+    my $comname = $cmd->command_name;
+    if ($ret) {
+	if ($ret == -1) {
+	    $self->logger('err', "failed to run $comname");
+	} elsif ($ret & 127) {
+	    $self->logger('err',
+			  "$comname exited on signal " . ($? & 127));
+	} elsif (my $e = ($ret >> 8)) {
+	    $self->logger('err',
+			  "$comname exited with status $e");
+	}
+	$self->logger('err', "command line was: ".$cmd->command_line);
+    }
+
+    my $fd = $cmd->channel(CHAN_STDERR);
+    while (<$fd>) {
+	chomp;
+	$self->logger('err', "[$comname]: $_");
+    }
+}
+
+sub backup {
+    my ($self, $item) = @_;
+    $self->error("backup method not implemented",
+		 locus => $self->get({variable => [ 'item', $item ],
+				      return => '-locus'}));
+}
+
+1;
diff --git a/lib/App/Beam/Backend/Tar.pm b/lib/App/Beam/Backend/Tar.pm
new file mode 100644
index 0000000..c6d1da7
--- /dev/null
+++ b/lib/App/Beam/Backend/Tar.pm
@@ -0,0 +1,160 @@
+package App::Beam::Backend::Tar;
+
+use strict;
+use Carp;
+
+require App::Beam::Backend;
+use Data::Dumper;
+our @ISA = qw(App::Beam::Backend);
+
+use POSIX qw(strftime);
+use App::Beam::Command qw(:channels);
+
+sub ck_dir {
+    my ($v) = @_;
+    
+    if (-d $$v) {
+	return undef;
+    } elsif (! -e $$v) {
+	return "directory does not exist";
+    } else {
+	return "not a directory";
+    }
+}
+
+my %synt = (
+    backend => {
+	section => {
+	    tar => {
+		section => {
+		    binary => {
+			default => '/bin/tar',
+			check => sub {
+			    my ($v) = @_;
+			    if (! -x $$v) {
+				if (! -e $$v) {
+				    return "binary does not not exist";
+				} else {
+				    return "not an executable";
+				}
+			    }
+			    return undef;
+			}
+		    },
+		    options => {
+			array => 1
+		    },
+		    suffix => { default => 'tar' },
+		    'snapshot-dir' => {
+			default => '/var/lib/backups',
+			check => \&ck_dir,
+		    },
+		}
+	    }
+	}
+    },
+    item => {
+	section => {
+	    '*' => {
+		select => sub {
+		    my ($vref, @path) = @_;
+		    return 0 unless ref($vref) eq 'HASH';
+		    return $vref->{backend}->{-value} eq 'tar';
+		},
+		section => {
+		    backend => 1,
+		    directory => {
+			mandatory => 1,
+			check => \&ck_dir
+		    },
+		    files => 1,
+		    options => {
+			array => 1
+		    }
+		}
+	    }
+	}
+    }
+);
+
+sub new {
+    my $class = shift;
+    my $self = $class->SUPER::new(@_);
+
+    unless ($self->{beam}->lint(\%synt)) {
+	return undef;
+    }
+
+    return $self;
+}
+
+sub snapshot_name {
+    my ($self, $basename, $idx) = @_;
+    my $name = $self->{beam}->format_name($basename, $idx);
+    if ($name) {
+	$name = $self->get('backend', 'tar', 'snapshot-dir')
+	        . '/' . $name . '.db';
+    }
+    return $name;
+}
+
+sub mksnapshot {
+    my ($self, $item) = @_;
+    my $snapshot = $self->snapshot_name($item);
+    if ($self->status('level') != 0) {
+	my $prev = $self->snapshot_name($item, 1);
+	if ($prev) {
+	    $self->debug(1, "cp $prev $snapshot");
+	    unless ($self->dry_run) {
+		use File::Copy;
+		unless (copy($prev, $snapshot)) {
+		    $self->error("can't copy $prev to $snapshot: $!");
+		} 
+	    }
+	} else {
+	    $self->error("$item: warning: can't locate previous snapshot\n"
+			 . "falling back to level 0");
+	}
+    }
+    return $snapshot;
+}
+
+sub backup {
+    my ($self, $item) = @_;   
+
+    my $basename = $self->{beam}->format_name($item);
+    croak "undefined basename" unless defined $basename;
+    my $archive = $self->get('core', 'archivedir')
+                  . '/'
+	          . $basename
+		  . '.'
+		  . $self->get('backend', 'tar', 'suffix');
+
+    my $cmd = new App::Beam::Command($self->get('backend', 'tar', 'binary'));
+    if ($self->isset('backend', 'tar', 'options')) {
+	$cmd->add($self->get('backend', 'tar', 'options'));
+    }
+    if ($self->isset('item', $item, 'options')) {
+	$cmd->add($self->get('item', $item, 'options'));
+    }
+    $cmd->add('-c');
+    $cmd->add('-f', $archive);
+    $cmd->add('-C', $self->get('item', $item, 'directory'));
+    $cmd->add('--listed', $self->mksnapshot($item));
+
+    if ($self->isset('item', $item, 'files')) {
+	$cmd->add($self->get('item', $item, 'files'));
+    } else {
+	$cmd->add('.');
+    }
+
+    $self->debug(1, "running ".$cmd->command_line);
+    unless ($self->dry_run) {
+	$cmd->run;
+	$self->logcommand($cmd);
+	my $ret = $cmd->exit_code;
+	$self->set_result('FAILURE') if ($ret && $ret != 2);
+    }
+}
+    
+1;
diff --git a/lib/App/Beam/Backup.pm b/lib/App/Beam/Backup.pm
index 3243513..b026f30 100644
--- a/lib/App/Beam/Backup.pm
+++ b/lib/App/Beam/Backup.pm
@@ -14,5 +14,8 @@ sub run {
 	my $backend = $self->{backend}{$self->get("item.$item.backend")};
 	$backend->backup($item);
     }
+    $self->set_result('OK') if $self->result eq 'PENDING';
     $self->unlock();
 }
+
+1;
diff --git a/lib/App/Beam/Command.pm b/lib/App/Beam/Command.pm
new file mode 100644
index 0000000..ed6c686
--- /dev/null
+++ b/lib/App/Beam/Command.pm
@@ -0,0 +1,96 @@
+package App::Beam::Command;
+
+use strict;
+use Carp;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(CHAN_STDOUT CHAN_STDERR);
+our %EXPORT_TAGS = (
+    channels => [ qw(CHAN_STDOUT CHAN_STDERR) ]
+);
+
+use IPC::Open3;
+use Symbol 'gensym';
+
+sub new {
+    my $class = shift;
+    return bless { argv => \@_ }, $class;
+}
+
+sub add {
+    my $self = shift;
+    push @{$self->{argv}}, @_;
+}
+
+use constant {
+    CHAN_STDOUT => 0,
+    CHAN_STDERR => 1
+};
+
+sub run {
+    my $self = shift;
+    my $out = gensym;
+    my $err = gensym;
+
+    return $self->{status} if exists($self->{status});
+    
+    my $pid = open3(\*STDIN, $out, $err, @{$self->{argv}});
+    waitpid($pid, 0);
+    $self->{status} = $?;
+    local $/ = undef;
+    $self->{channel}[CHAN_STDOUT] = <$out>;
+    $self->{channel}[CHAN_STDERR] = <$err>;
+    return $self->{status};
+}
+
+sub restart {
+    my $self = shift;
+
+    delete $self->{status};
+    delete $self->{channel};
+    return $self->run;
+}
+
+sub status {
+    my $self = shift;
+    return undef unless exists $self->{status};
+    return $self->{status};
+}
+
+sub channel {
+    my ($self, $chan) = @_;
+    return undef if !exists($self->{channel}) || $chan > $#{$self->{channel}};
+    open(my $fd, '<', \$self->{channel}[$chan]) or croak "can't dup: $!"; 
+    return $fd;
+}
+
+sub argv {
+    my ($self) = @_;
+    return @{$self->{argv}};
+}
+
+sub command_line {
+    my ($self) = @_;
+    return join(' ', $self->argv);
+}
+
+sub command_name {
+    my ($self) = @_;
+    return $self->{argv}[0];
+}
+
+sub exit_code {
+    my ($self) = @_;
+    my $code = $self->status;
+    return -1 if (!defined($code) || $code == -1 || ($code & 127));
+    return $code >> 8;
+}
+
+1;
+
+    
+
+	
+
+
diff --git a/lib/App/Beam/Config.pm b/lib/App/Beam/Config.pm
index 829e6e3..5e5e7d7 100644
--- a/lib/App/Beam/Config.pm
+++ b/lib/App/Beam/Config.pm
@@ -733,6 +733,11 @@ sub get {
 	    $ref = $ref->{-value};
 	}
     }
+    if (ref($ref) eq 'ARRAY') {
+	return @$ref
+    } elsif (ref($ref) eq 'HASH') {
+	return %$ref;
+    }
     return $ref;
 }
 
@@ -976,7 +981,7 @@ sub flatten {
 sub __lint {
     my ($self, $syntax, $vref, @path) = @_;
 
-    return unless ref($syntax) eq 'HASH';
+    $syntax = {} unless ref($syntax) eq 'HASH';
     if (exists($syntax->{section})) {
 	return unless is_section_ref($vref);
     } else {
@@ -984,7 +989,6 @@ sub __lint {
     }
 
     if (exists($syntax->{select}) && !&{$syntax->{select}}($vref, @path)) {
-	print "IGNORE @path\n";
 	return;
     }
 
@@ -992,7 +996,7 @@ sub __lint {
 	$self->_lint($syntax->{section}, $vref, @path);
     } else {
 	my $val = $vref->{-value};
-	my %opts = { locus => $vref->{-locus} };
+	my %opts = ( locus => $vref->{-locus} );
 		     
 	if (ref($val) eq 'ARRAY') {
 	    if ($syntax->{array}) {
@@ -1013,8 +1017,8 @@ sub __lint {
 			    $self->{error_count}++;
 			    next;
 			}
-			push @ar, $v;
 		    }
+		    push @ar, $v;
 		}
 		$vref->{-value} = \@ar;
 		return;