File Coverage

File:blib/lib/Simba/DA.pm
Coverage:72.0%

linestmtbrancondsubpodtimecode
1package Simba::DA;
2
1
1
1
1
35390
3
35
use strict;
3
1
1
1
1
5
2
41
use warnings;
4
5
1
1
1
1
13048
16118
89
use Encode qw(decode encode);
6
1
1
1
1
6
1
95
use File::Find;
7
1
1
1
1
409
15838
17
use File::stat;
8
1
1
1
1
477
3754
56
use Readonly;
9
1
1
1
1
4437
2523
52
use Digest::SHA;
10
1
1
1
1
6
1
70
use List::Util qw(min);
11
1
1
1
1
331
5125
50
use IO::Handle;
12
1
1
1
1
8421
3
59
use Simba::Util qw(quote unquote typestr);
13
1
1
1
1
246
5768
20
use POSIX qw(strftime);
14
1
1
1
1
9445
41716
2274
use Config::YAML;
15
16Readonly my $BUFSIZE => 128 * 1024;
17#my $BUFSIZE = 128 * 1024;
18
19sub new {
20
1
1
0
164247
    my ($class, $opt) = @_;
21
1
3
    my $self = {};
22
1
8
    bless $self, $class;
23
24    # read local config file here.
25    # such a config file could contain:
26    #
27    # * some means for the CA to identify itself
28    # (currently we use SSH for that)
29    #
30    # * A list of directories which should not be descended into
31    # (for example, /proc, /sys, networked filesystems and
32    # filesystems on removable media, ...)
33    #
34    # * encoding rules (e.g., charset of filenames)
35    #
36    # * Other system dependent parameters, e.g., whether to use ACLs
37    #
38    # For now we just hardcode the stuff:
39
1
18
    my $config = Config::YAML->new( config => '/etc/simba/da.conf');
40
1
50
87726
    if ($config->{prune}) {
41
1
1
3
4
        for (@{ $config->{prune} }) {
42
6
50
19
            $_ = ".$_" if (m{^/});
43
6
12
            $self->{prune}{$_} = 1;
44        }
45    } else {
46
0
0
        $self->{prune} = {
47                            # directories to prune. These are relative
48                            # paths which may not be ideal.
49                            './proc' => 1,
50                            './sys' => 1,
51                            './nfs' => 1,
52                            './backup' => 1,
53                        };
54    }
55
1
3
    $self->{charset} = 'utf-8';
56
1
50
4
    $self->{fh_out} = exists($opt->{fh_out}) ? $opt->{fh_out} : \*STDOUT;
57
1
50
4
    $self->{fh_log} = exists($opt->{fh_log}) ? $opt->{fh_log} : \*STDERR;
58
1
2
    $self->{log_level} = 99;
59
60    #die "PERL_UNICODE must not be set!" if $ENV{PERL_UNICODE};
61
62
1
20
    return $self;
63
64}
65
66my %dispatch = (
67    list => \&list,
68    get => \&get,
69    default => \&no_such_command,
70);
71
72# the main loop:
73# read one-line commands from stdin and dispatch commands
74sub run {
75
0
0
0
0
    my ($self) = @_;
76
77
0
0
    binmode STDIN, ":raw";
78
0
0
    binmode STDOUT, ":raw";
79
80
0
0
    while (<>) {
81
0
0
        chomp;
82
0
0
        $self->log(10, "received: $_");
83
0
0
        my @cmd = split();
84
0
0
0
        my $sub = $dispatch{$cmd[0]} || $dispatch{default};
85
0
0
        $self->$sub(@cmd);
86    }
87}
88
89sub list {
90
1
1
0
19
    my ($self, $cmd, $path) = @_;
91
92
1
50
10
    $path = $1 if $path =~ /(.*)/;
93
1
2
    my $fh_out = $self->{fh_out};
94
95
1
50
29
    chdir $path or return;
96    find({
97            preprocess
98                => sub {
99
9
9
4678
                        $self->log(10, "list: in $File::Find::dir");
100
9
50
27
                        if ($self->{prune}{$File::Find::dir}) {
101
0
0
                            return ();
102                        } else {
103                            # not sure if sorting is useful
104
9
351
                            return sort @_;
105                        }
106                    },
107            wanted
108                => sub {
109
22
22
712
                        my $st = lstat($_);
110
22
50
1995
                        return unless $st; # ignore unstattable files.
111
112
22
280
                        my $fn = decode($self->{charset},
113                                        $File::Find::name);
114
22
2371
                        $fn = quote($fn);
115
22
1580
                        $fh_out->print($fn);
116
117
22
428
                        $fh_out->print($self->metastr($File::Find::name, $st));
118
119
22
615
                        $fh_out->print("\n");
120                    },
121
1
74
            no_chdir => 1,
122        },
123        "."
124    );
125
1
23
    $fh_out->flush();
126
1
5
    $self->log(10, "$cmd done");
127}
128
129sub permstr {
130
72
72
0
73
    my ($perm) = @_;
131
132
72
50
100
100
217
    return ($perm & 04 ? 'r' : '-') .
133           ($perm & 02 ? 'w' : '-') .
134           ($perm & 01 ? 'x' : '-');
135}
136
137my %ucache;
138sub uid2name {
139
24
24
0
29
    my ($uid) = @_;
140
24
100
388
    return $ucache{$uid} if ($ucache{$uid});
141
1
503
    my $uname = getpwuid($uid);
142
1
50
4
    if ($uname) {
143
1
25
        $ucache{$uid} = $uname;
144    } else {
145        # no user name - use numeric id
146
0
0
        $ucache{$uid} = $uid;
147    }
148}
149
150
151my %gcache;
152sub gid2name {
153
24
24
0
34
    my ($gid) = @_;
154
24
100
412
    return $gcache{$gid} if ($gcache{$gid});
155
1
84
    my $gname = getgrgid($gid);
156
1
50
4
    if ($gname) {
157
1
22
        $gcache{$gid} = $gname;
158    } else {
159        # no group name - use numeric id
160
0
0
        $gcache{$gid} = $gid;
161    }
162}
163
164sub get {
165
2
2
0
35
    my ($self, $cmd, $path) = @_;
166
167
2
4
    my $fh_out = $self->{fh_out};
168
169    # sanity checks on $path here?
170
171
2
36
    my $fn = encode($self->{charset}, unquote($path));
172
173    # sanity checks on $path here?
174
175
2
140
    my $st = lstat($fn);
176
2
50
180
    if (!$st) {
177
0
0
        $fh_out->printflush("fail $path ($!)\n");
178
0
0
        return;
179    }
180
2
50
0
38
    if (typestr($st->mode) eq 'f') {
181
2
4
        my $fh;
182
2
50
47
        unless (open($fh, '<:raw', $fn)) {
183
0
0
            $fh_out->printflush("fail $path ($!)\n");
184
0
0
            return;
185        }
186
2
9
        $fh_out->print("data $path ", $self->metastr($fn, $st), "\n");
187
2
70
        my $size = $st->size;
188
2
37
        my $err;
189
2
31
        my $sha1 = Digest::SHA->new(1);
190
191
2
88
        while ($size > 0) {
192
2
3
            my $buffer;
193
2
40
            my $rc = read($fh, $buffer, min($size, $BUFSIZE));
194
2
50
50
534
            if (!defined($rc)) {
195                # I/O error
196
0
0
                $err = $!;
197
0
0
                $fh_out->print("\0") for (1 .. $size);
198
0
0
                last;
199            } elsif ($rc == 0) {
200                # premature EOF.
201
0
0
                $err = "file shrunk by $size bytes";
202
0
0
                $fh_out->print("\0") for (1 .. $size);
203
0
0
                last;
204            }
205
2
33
            $fh_out->print($buffer);
206
2
48
            $size -= length($buffer);
207
2
25
            $sha1->add($buffer);
208        }
209
2
31
        $fh_out->print("\n");
210
2
50
42
        if ($err) {
211
0
0
            $fh_out->print("fail ($err)\n");
212        } else {
213
2
75
            $fh_out->print("chk sha1 ", $sha1->hexdigest, "\n");
214        }
215
2
48
        $fh_out->flush();
216
2
9
        $self->log(10, "$fn done");
217    } elsif (typestr($st->mode) eq 'l') {
218
0
0
        my $target = readlink($fn);
219
0
0
0
        if (length($target) == $st->size) {
220
0
0
            $fh_out->print("data $path ", $self->metastr($fn, $st), "\n");
221
0
0
            $fh_out->print("$target\n");
222
0
0
            $fh_out->print("chk sha1 ", sha1_hex($target), "\n");
223        } else {
224
0
0
            $fh_out->print("fail ($!)\n");
225        }
226    } else {
227
0
0
        $fh_out->print("nodata $path ", $self->metastr($fn, $st), "\n");
228    }
229
230}
231
232 - 240
=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
241
242sub metastr {
243
24
24
1
48
    my ($self, $fn, $st) = @_;
244
24
50
40
    $st = lstat($fn) unless defined($st);
245
246
24
30
    my $s = "";
247
248
24
454
    my $mode = $st->mode;
249
24
823
    my $uid = $st->uid;
250
24
804
    my $gid = $st->gid;
251
24
801
    my $rdev = $st->rdev;
252
24
821
    my $size = $st->size;
253
24
798
    my $mtime = $st->mtime;
254
255    # ignoring nlinks for now. We should store hard links somewhere
256    # however.
257
258
24
801
    $s .= " " . 'id=' . $st->dev . ":" . $st->ino;
259
24
879
    $s .= " " . 't=' . typestr($mode);
260
24
46
    $s .= " " . 's=' . $size;
261
24
40
    $s .= " " . 'm=' . $mtime;
262
24
44
    $s .= " " . 'o=' . quote(uid2name($uid));
263
24
1498
    $s .= " " . 'g=' . quote(gid2name($gid));
264
24
1368
    my $acl = 'u::' . permstr(($mode & 0700) >> 6) . ',';
265
24
42
    $acl .= 'g::' . permstr(($mode & 0070) >> 3) . ',';
266
24
38
    $acl .= 'o:' . permstr(($mode & 0007) >> 0);
267
24
354
    $s .= " " . 'acl=' . quote($acl);
268
24
50
1341
    $s .= " " . 'setuid=1' if $mode & 04000;
269
24
50
38
    $s .= " " . 'setgid=1' if $mode & 02000;
270
24
50
33
    $s .= " " . 'sticky=1' if $mode & 01000;
271
24
50
36
    $s .= " " . 'rdev=' . $st->rdev if ($mode & 0120000) == 0020000;
272
273
24
100
355
    if (typestr($mode) eq 'l') {
274
2
9757
        $s .= " " . 'lt=' . quote(decode($self->{charset}, readlink($fn)));
275    }
276
277
24
441
    return $s;
278}
279
280sub fh_out {
281
4
4
0
35259
    my ($self, $fh_out) = @_;
282
4
50
16
    $self->{fh_out} = $fh_out if defined($fh_out);
283
4
24
    return $self->{fh_out};
284}
285
286sub no_such_command {
287
1
1
0
17
    my ($self, $cmd) = @_;
288
1
17
    $self->{fh_out}->print("FAIL: no such command: $cmd\n");
289
1
21
    $self->log(5, "FAIL: no such command: $cmd");
290}
291
292sub log {
293
13
13
0
29
    my ($self, $level, $msg) = @_;
294
13
50
84
    if ($level <= $self->{log_level}) {
295
0
0
0
        $self->{fh_log}->print(strftime("%Y-%m-%dT%H:%M:%S%z", localtime), " $$ [$level]: $msg\n")
296            or die "write to log failed: $!";
297    }
298}
299
300
301sub log_level {
302
1
1
0
410
    my ($self, $log_level) = @_;
303
1
50
4
    $self->{log_level} = $log_level if defined($log_level);
304
1
6
    return $self->{log_level};
305}
306
3071;
308
309# vim: sw=4 expandtab tw=0