319 lines
8.4 KiB
Perl
319 lines
8.4 KiB
Perl
package Simba::DA;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Encode qw(decode encode);
|
|
use File::Find;
|
|
use File::stat;
|
|
use Readonly;
|
|
use Digest::SHA;
|
|
use List::Util qw(min);
|
|
use IO::Handle;
|
|
use Simba::Util qw(quote unquote typestr);
|
|
use POSIX qw(strftime);
|
|
use Config::YAML;
|
|
use Fcntl;
|
|
|
|
sub O_NOATIME() {
|
|
# XXX - possibly specific to Linux x86/amd64
|
|
return 01000000;
|
|
}
|
|
|
|
Readonly my $BUFSIZE => 128 * 1024;
|
|
#my $BUFSIZE = 128 * 1024;
|
|
|
|
sub new {
|
|
my ($class, $opt) = @_;
|
|
my $self = {};
|
|
bless $self, $class;
|
|
|
|
# read local config file here.
|
|
# such a config file could contain:
|
|
#
|
|
# * some means for the CA to identify itself
|
|
# (currently we use SSH for that)
|
|
#
|
|
# * A list of directories which should not be descended into
|
|
# (for example, /proc, /sys, networked filesystems and
|
|
# filesystems on removable media, ...)
|
|
#
|
|
# * encoding rules (e.g., charset of filenames)
|
|
#
|
|
# * Other system dependent parameters, e.g., whether to use ACLs
|
|
#
|
|
# For now we just hardcode the stuff:
|
|
my $config = Config::YAML->new( config => '/etc/simba/da.conf');
|
|
if ($config->{prune}) {
|
|
for (@{ $config->{prune} }) {
|
|
$_ = ".$_" if (m{^/});
|
|
$self->{prune}{$_} = 1;
|
|
}
|
|
} else {
|
|
$self->{prune} = {
|
|
# directories to prune. These are relative
|
|
# paths which may not be ideal.
|
|
'./proc' => 1,
|
|
'./sys' => 1,
|
|
'./nfs' => 1,
|
|
'./backup' => 1,
|
|
};
|
|
}
|
|
$self->{charset} = 'utf-8';
|
|
$self->{fh_out} = exists($opt->{fh_out}) ? $opt->{fh_out} : \*STDOUT;
|
|
$self->{fh_log} = exists($opt->{fh_log}) ? $opt->{fh_log} : \*STDERR;
|
|
$self->{log_level} = 99;
|
|
|
|
#die "PERL_UNICODE must not be set!" if $ENV{PERL_UNICODE};
|
|
|
|
return $self;
|
|
|
|
}
|
|
|
|
my %dispatch = (
|
|
list => \&list,
|
|
get => \&get,
|
|
default => \&no_such_command,
|
|
);
|
|
|
|
# the main loop:
|
|
# read one-line commands from stdin and dispatch commands
|
|
sub run {
|
|
my ($self) = @_;
|
|
|
|
binmode STDIN, ":raw";
|
|
binmode STDOUT, ":raw";
|
|
|
|
while (<>) {
|
|
chomp;
|
|
$self->log(10, "received: $_");
|
|
my @cmd = split();
|
|
my $sub = $dispatch{$cmd[0]} || $dispatch{default};
|
|
$self->$sub(@cmd);
|
|
}
|
|
}
|
|
|
|
sub list {
|
|
my ($self, $cmd, $path) = @_;
|
|
|
|
$path = $1 if $path =~ /(.*)/;
|
|
my $fh_out = $self->{fh_out};
|
|
|
|
chdir $path or return;
|
|
find({
|
|
preprocess
|
|
=> sub {
|
|
$self->log(10, "list: in $File::Find::dir");
|
|
if ($self->{prune}{$File::Find::dir}) {
|
|
return ();
|
|
}
|
|
my $last_component = $File::Find::dir =~ s{.*/}{}r;
|
|
if ($self->{prune}{$last_component}) {
|
|
return ();
|
|
}
|
|
# not sure if sorting is useful
|
|
return sort @_;
|
|
},
|
|
wanted
|
|
=> sub {
|
|
my $st = lstat($_);
|
|
return unless $st; # ignore unstattable files.
|
|
|
|
my $fn = decode($self->{charset},
|
|
$File::Find::name);
|
|
$fn = quote($fn);
|
|
$fh_out->print($fn);
|
|
|
|
$fh_out->print($self->metastr($File::Find::name, $st));
|
|
|
|
$fh_out->print("\n");
|
|
},
|
|
no_chdir => 1,
|
|
},
|
|
"."
|
|
);
|
|
$fh_out->flush();
|
|
$self->log(10, "$cmd done");
|
|
}
|
|
|
|
sub permstr {
|
|
my ($perm) = @_;
|
|
|
|
return ($perm & 04 ? 'r' : '-') .
|
|
($perm & 02 ? 'w' : '-') .
|
|
($perm & 01 ? 'x' : '-');
|
|
}
|
|
|
|
my %ucache;
|
|
sub uid2name {
|
|
my ($uid) = @_;
|
|
return $ucache{$uid} if ($ucache{$uid});
|
|
my $uname = getpwuid($uid);
|
|
if ($uname) {
|
|
$ucache{$uid} = $uname;
|
|
} else {
|
|
# no user name - use numeric id
|
|
$ucache{$uid} = $uid;
|
|
}
|
|
}
|
|
|
|
|
|
my %gcache;
|
|
sub gid2name {
|
|
my ($gid) = @_;
|
|
return $gcache{$gid} if ($gcache{$gid});
|
|
my $gname = getgrgid($gid);
|
|
if ($gname) {
|
|
$gcache{$gid} = $gname;
|
|
} else {
|
|
# no group name - use numeric id
|
|
$gcache{$gid} = $gid;
|
|
}
|
|
}
|
|
|
|
sub get {
|
|
my ($self, $cmd, $path) = @_;
|
|
|
|
my $fh_out = $self->{fh_out};
|
|
|
|
# sanity checks on $path here?
|
|
|
|
my $fn = encode($self->{charset}, unquote($path));
|
|
|
|
# sanity checks on $path here?
|
|
|
|
my $st = lstat($fn);
|
|
if (!$st) {
|
|
$fh_out->printflush("fail $path ($!)\n");
|
|
return;
|
|
}
|
|
if (typestr($st->mode) eq 'f') {
|
|
my $fh;
|
|
unless (sysopen($fh, $fn, O_RDONLY | O_NOATIME)) {
|
|
$fh_out->printflush("fail $path ($!)\n");
|
|
return;
|
|
}
|
|
$fh_out->print("data $path ", $self->metastr($fn, $st), "\n");
|
|
my $size = $st->size;
|
|
my $err;
|
|
my $sha1 = Digest::SHA->new(1);
|
|
|
|
while ($size > 0) {
|
|
my $buffer;
|
|
my $rc = read($fh, $buffer, min($size, $BUFSIZE));
|
|
if (!defined($rc)) {
|
|
# I/O error
|
|
$err = $!;
|
|
$fh_out->print("\0") for (1 .. $size);
|
|
last;
|
|
} elsif ($rc == 0) {
|
|
# premature EOF.
|
|
$err = "file shrunk by $size bytes";
|
|
$fh_out->print("\0") for (1 .. $size);
|
|
last;
|
|
}
|
|
$fh_out->print($buffer);
|
|
$size -= length($buffer);
|
|
$sha1->add($buffer);
|
|
}
|
|
$fh_out->print("\n");
|
|
if ($err) {
|
|
$fh_out->print("fail ($err)\n");
|
|
} else {
|
|
$fh_out->print("chk sha1 ", $sha1->hexdigest, "\n");
|
|
}
|
|
$fh_out->flush();
|
|
$self->log(10, "$fn done");
|
|
} elsif (typestr($st->mode) eq 'l') {
|
|
my $target = readlink($fn);
|
|
if (length($target) == $st->size) {
|
|
$fh_out->print("data $path ", $self->metastr($fn, $st), "\n");
|
|
$fh_out->print("$target\n");
|
|
$fh_out->print("chk sha1 ", sha1_hex($target), "\n");
|
|
} else {
|
|
$fh_out->print("fail ($!)\n");
|
|
}
|
|
} else {
|
|
$fh_out->print("nodata $path ", $self->metastr($fn, $st), "\n");
|
|
}
|
|
|
|
}
|
|
|
|
=head2 metastr($fn, $st)
|
|
|
|
Return a string with meta information for File $fn.
|
|
The filename must be in native (unquoted) format.
|
|
Most meta information is taken from the File::stat object $st, but metastr may
|
|
also get other meta information from the filename (for example, it will call
|
|
readlink($fn) if it is a symlink). If $st is omitted, metastr will call lstat.
|
|
|
|
=cut
|
|
|
|
sub metastr {
|
|
my ($self, $fn, $st) = @_;
|
|
$st = lstat($fn) unless defined($st);
|
|
|
|
my $s = "";
|
|
|
|
my $mode = $st->mode;
|
|
my $uid = $st->uid;
|
|
my $gid = $st->gid;
|
|
my $rdev = $st->rdev;
|
|
my $size = $st->size;
|
|
my $mtime = $st->mtime;
|
|
|
|
# ignoring nlinks for now. We should store hard links somewhere
|
|
# however.
|
|
|
|
$s .= " " . 'id=' . $st->dev . ":" . $st->ino;
|
|
$s .= " " . 't=' . typestr($mode);
|
|
$s .= " " . 's=' . $size;
|
|
$s .= " " . 'm=' . $mtime;
|
|
$s .= " " . 'o=' . quote(uid2name($uid));
|
|
$s .= " " . 'g=' . quote(gid2name($gid));
|
|
my $acl = 'u::' . permstr(($mode & 0700) >> 6) . ',';
|
|
$acl .= 'g::' . permstr(($mode & 0070) >> 3) . ',';
|
|
$acl .= 'o:' . permstr(($mode & 0007) >> 0);
|
|
$s .= " " . 'acl=' . quote($acl);
|
|
$s .= " " . 'setuid=1' if $mode & 04000;
|
|
$s .= " " . 'setgid=1' if $mode & 02000;
|
|
$s .= " " . 'sticky=1' if $mode & 01000;
|
|
$s .= " " . 'rdev=' . $st->rdev if ($mode & 0120000) == 0020000;
|
|
|
|
if (typestr($mode) eq 'l') {
|
|
$s .= " " . 'lt=' . quote(decode($self->{charset}, readlink($fn)));
|
|
}
|
|
|
|
return $s;
|
|
}
|
|
|
|
sub fh_out {
|
|
my ($self, $fh_out) = @_;
|
|
$self->{fh_out} = $fh_out if defined($fh_out);
|
|
return $self->{fh_out};
|
|
}
|
|
|
|
sub no_such_command {
|
|
my ($self, $cmd) = @_;
|
|
$self->{fh_out}->print("FAIL: no such command: $cmd\n");
|
|
$self->log(5, "FAIL: no such command: $cmd");
|
|
}
|
|
|
|
sub log {
|
|
my ($self, $level, $msg) = @_;
|
|
if ($level <= $self->{log_level}) {
|
|
$self->{fh_log}->print(strftime("%Y-%m-%dT%H:%M:%S%z", localtime), " $$ [$level]: $msg\n")
|
|
or die "write to log failed: $!";
|
|
}
|
|
}
|
|
|
|
|
|
sub log_level {
|
|
my ($self, $log_level) = @_;
|
|
$self->{log_level} = $log_level if defined($log_level);
|
|
return $self->{log_level};
|
|
}
|
|
|
|
1;
|
|
|
|
# vim: sw=4 expandtab tw=0
|