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