File Coverage

blib/lib/Yars/Tools.pm
Criterion Covered Total %
statement 245 305 80.3
branch 56 100 56.0
condition 22 44 50.0
subroutine 47 53 88.6
pod 27 27 100.0
total 397 529 75.0


line stmt bran cond sub pod time code
1             package Yars::Tools;
2              
3 24     24   12468 use strict;
  24         58  
  24         848  
4 24     24   144 use warnings;
  24         60  
  24         836  
5 24     24   149 use Clustericious::Config;
  24         57  
  24         712  
6 24     24   232 use List::Util qw/ shuffle uniq /;
  24         57  
  24         2042  
7 24     24   921 use Hash::MoreUtils qw/safe_reverse/;
  24         38579  
  24         1536  
8 24     24   533 use Clustericious::Log;
  24         7564  
  24         246  
9 24     24   21756 use File::Find::Rule;
  24         161750  
  24         238  
10 24     24   1606 use File::Basename qw/dirname/;
  24         82  
  24         1485  
11 24     24   162 use File::Path qw/mkpath/;
  24         55  
  24         1032  
12 24     24   146 use File::Temp;
  24         54  
  24         1798  
13 24     24   938 use File::Compare;
  24         30956  
  24         1179  
14 24     24   179 use JSON::MaybeXS ();
  24         61  
  24         504  
15             # TODO: rm dep on stat
16 24     24   504 use File::stat qw/stat/;
  24         8183  
  24         201  
17 24     24   1825 use Mojo::ByteStream qw/b/;
  24         53  
  24         1000  
18 24     24   149 use File::Spec;
  24         44  
  24         564  
19 24     24   616 use Mojo::UserAgent;
  24         181507  
  24         256  
20 24     24   604 use File::Spec;
  24         59  
  24         464  
21 24     24   462 use Yars::Util qw( format_tx_error );
  24         58  
  24         1050  
22 24     24   139 use File::Glob qw( bsd_glob );
  24         55  
  24         29082  
23              
24             # ABSTRACT: various utility functions dealing with servers, hosts, etc
25             our $VERSION = '1.30'; # VERSION
26              
27              
28             sub new
29             {
30 32     32 1 637 my($class, $config) = @_;
31 32 100       99 WARN "No url found in config file" unless eval { $config->url };
  32         162  
32 32         855 my $self = bless {
33             bucket_to_url => { }, # map buckets to server urls
34             bucket_to_root => { }, # map buckets to disk roots
35             disk_is_local => { }, # our disk roots (values are just 1)
36             servers => { }, # all servers
37             our_url => '', # our server url
38             state_file => '', # name of file with disk states
39             ua => '', # UserAgent
40             server_status_cache => {},
41             server_status_cache_lifetime => 3,
42             default_dir => '',
43             }, $class;
44 32         196 $self->refresh_config($config);
45 32         160 $self;
46             }
47              
48             sub _set_ua
49             {
50 14     14   38 my($self, $ua) = @_;
51 14         39 $self->{ua} = $ua;
52 14         165 return;
53             }
54              
55             sub _ua
56             {
57 278     278   839 my($self) = @_;
58 278 100       1966 my $ua = $self->{ua} ? $self->{ua}->() : Mojo::UserAgent->new;
59 278         641439 $ua->max_redirects(30);
60 278         3783 $ua;
61             }
62              
63              
64             sub refresh_config {
65 1110     1110 1 18675 my $self = shift;
66 1110         2504 my $config = shift;
67 1110 100 66     6574 return 1 if defined($self->{our_url}) && keys %{ $self->{bucket_to_root} } > 0 && keys %{ $self->{bucket_to_url} } > 0;
  1110   66     8948  
  1076         7252  
68 34   66     148 $config ||= Clustericious::Config->new("Yars");
69 34 50 66     392 $self->{our_url} ||= $config->url or WARN "No url found in config file";
70 34         750 TRACE "Our url is " . $self->{our_url};
71 34         28220 for my $server ($config->servers) {
72 59         1618 $self->{servers}->{$server->{url}} = 1;
73 59         120 for my $disk (@{ $server->{disks} }) {
  59         181  
74 102         153 for my $bucket (@{ $disk->{buckets} }) {
  102         256  
75 528         1230 $self->{bucket_to_url}->{$bucket} = $server->{url};
76 528 100       1081 next unless $server->{url} eq $self->{our_url};
77 352         614 $self->{bucket_to_root}->{$bucket} = $disk->{root};
78 352 50       671 LOGDIE "Disk root not given" unless defined($disk->{root});
79 352         674 $self->{disk_is_local}->{$disk->{root}} = 1;
80             }
81             }
82             }
83 34         1402 my $default_dir = $self->{default_dir} = bsd_glob("~/var/run/yars");
84            
85 34         406 my $state_file = $self->{state_file} = $config->state_file(default => "$default_dir/state.txt");
86 34 100       2243 -e $state_file or do {
87 32         245 INFO "Writing new state file ($state_file)";
88 32         34952 my %disks = map { ($_ => "up") } keys %{ $self->{disk_is_local} };
  60         212  
  32         152  
89 32         227 $self->_write_state({disks => \%disks});
90             };
91 34 50       1864 -e $state_file or LOGDIE "Could not write state file $state_file";
92             #TRACE "bucket2url : ".Dumper($self->{bucket_to_url});
93             }
94              
95             sub _dir_is_empty {
96             # stolen from File::Find::Rule::DirectoryEmpty
97 341     341   694 my $dir = shift;
98 341 50       6103 opendir( DIR, $dir ) or return;
99 341         2949 while ( $_ = readdir DIR ) {
100 669 100       4014 if ( !/^\.\.?$/ ) {
101 13         86 closedir DIR;
102 13         79 return 0;
103             }
104             }
105 328         1878 closedir DIR;
106 328         946 return 1;
107             }
108              
109              
110             sub disk_for {
111 940     940 1 2412 my $self = shift;
112 940         2350 my $digest = shift;
113 940 50       2080 unless (keys %{ $self->{bucket_to_root} }) {
  940         5285  
114 0         0 $self->refresh_config;
115 0 0       0 LOGDIE "No config data" unless keys %{ $self->{bucket_to_root} } > 0;
  0         0  
116             }
117 940         2375 my ($bucket) = grep { $digest =~ /^$_/i } keys %{ $self->{bucket_to_root} };
  8596         75513  
  940         6427  
118 940 100       4621 TRACE "no local disk for $digest in ".(join ' ', keys %{ $self->{bucket_to_root} }) unless defined($bucket);
  87         861  
119 940 100       67213 return unless defined($bucket);
120 853         5300 return $self->{bucket_to_root}->{$bucket};
121             }
122              
123              
124             sub local_buckets {
125 0     0 1 0 my($self) = @_;
126 0 0       0 $self->refresh_config unless keys %{ $self->{bucket_to_root} };
  0         0  
127 0         0 my %r = safe_reverse $self->{bucket_to_root};
128 0 0       0 do {$_ = [ $_ ] unless ref $_} for values %r;
  0         0  
129 0         0 return %r;
130             }
131              
132             sub _state {
133 324     324   687 my $self = shift;
134 324 50 33     4069 $self->refresh_config() unless $self->{state_file} && -e $self->{state_file};
135             # TODO: rm dep on File::stat
136 324 100 66     3347 return $self->{_state}->{cached} if $self->{_state}->{mod_time} && $self->{_state}->{mod_time} == stat($self->{state_file})->mtime;
137 24   33     102 our $j ||= JSON::MaybeXS->new;
138 24 50       221 -e $self->{state_file} or LOGDIE "Missing state file " . $self->{state_file};
139 24         279 $self->{_state}->{cached} = $j->decode(Mojo::Asset::File->new(path => $self->{state_file})->slurp);
140             # TODO: rm dep on File::stat
141 24         6335 $self->{_state}->{mod_time} = stat($self->{state_file})->mtime;
142 24         7592 return $self->{_state}->{cached};
143             }
144              
145             sub _write_state {
146 35     35   99 my $self = shift;
147 35         78 my $state = shift;
148 35         2054 my $dir = dirname($self->{state_file});
149 35   66     452 our $j ||= JSON::MaybeXS->new;
150 35         2521 mkpath $dir;
151 35         452 my $temp = File::Temp->new(DIR => $dir, UNLINK => 0);
152 35         119155 print $temp $j->encode($state);
153 35         329 $temp->close;
154 35 50       100225 rename "$temp", $self->{state_file} or return 0;
155 35         2193 return 1;
156             }
157              
158              
159             sub disk_is_up {
160 321     321 1 857 my $class = shift;
161 321         723 my $root = shift;
162 321 50 66     6993 return 0 if -d $root && ! -w $root;
163 321 100 50     1450 return 1 if ($class->_state->{disks}{$root} || 'up') eq 'up';
164 29         5118 return 0;
165             }
166              
167              
168             sub disk_is_up_verified
169             {
170 12     12 1 29 my($self, $root) = @_;
171 12 100       37 return unless $self->disk_is_up($root);
172 10         1167 my $tmpdir = File::Spec->catdir($root, 'tmp');
173 10         24 my $temp;
174 10         66 eval {
175 24     24   198 use autodie;
  24         51  
  24         260  
176 10 100       125 unless(-d $tmpdir)
177             {
178 7         920 mkpath $tmpdir;
179 7         38 chmod 0777, $tmpdir;
180             };
181 10         1113 $temp = File::Temp->new("disk_is_up_verifiedXXXXX", DIR => $tmpdir, SUFFIX => '.txt');
182 10         3308 print $temp "test";
183 10         43 close $temp;
184 10 50       3032 die "file has zero size" if -z $temp->filename;
185 10         195 unlink $temp->filename;
186             };
187 10 50       1437 if(my $error = $@)
188             {
189 0         0 INFO "Create temp file in $tmpdir FAILED: $error";
190 0         0 return;
191             }
192             else
193             {
194 10         33 INFO "created temp file to test status: " . $temp->filename;
195 10         11240 return 1;
196             }
197             }
198              
199              
200             sub disk_is_down {
201 3     3 1 13 return not shift->disk_is_up(@_);
202             }
203              
204              
205             sub disk_is_local {
206 3     3 1 6 my $self = shift;
207 3         7 my $root = shift;
208 3         14 return $self->{disk_is_local}->{$root};
209             }
210              
211              
212             sub server_is_up {
213             # TODO use state file for this
214 0     0 1 0 my $self = shift;
215 0         0 my $server_url = shift;
216 0 0 0     0 if (exists($self->{server_status_cache}->{$server_url}) && $self->{server_status_cache}->{$server_url}{checked} > time - $self->{server_status_cache_lifetime}) {
217 0         0 return $self->{server_status_cache}->{$server_url}{result};
218             }
219 0         0 TRACE "Checking $server_url/status";
220 0         0 my $tx = $self->_ua->get( "$server_url/status" );
221 0         0 $self->{server_status_cache}->{$server_url}{checked} = time;
222 0 0       0 if (my $res = $tx->success) {
223 0         0 my $got = $res->json;
224 0 0 0     0 if (defined($got->{server_version}) && length($got->{server_version})) {
225 0         0 return ($self->{server_status_cache}->{$server_url}{result} = 1);
226             }
227 0         0 TRACE "/status did not return version, got : ". JSON::MaybeXS::encode_json($got);
228 0         0 return ($self->{server_status_cache}->{$server_url}{result} = 0);
229             }
230 0         0 TRACE "Server $server_url is not up : response was ".format_tx_error($tx->error);
231 0         0 return ($self->{server_status_cache}->{$server_url}{result} = 0);
232             }
233             sub server_is_down {
234 0     0 1 0 return not shift->server_is_up(@_);
235             }
236              
237             sub _touch {
238 0     0   0 my $path = shift;
239 0         0 my $dir = dirname($path);
240 0 0       0 -d $dir or do {
241 0         0 my $ok;
242 0         0 eval { mkpath($dir); $ok = 1; };
  0         0  
  0         0  
243 0 0       0 if($@) { WARN "mkpath $dir failed : $@;"; $ok = 0; };
  0         0  
  0         0  
244 0 0       0 return 0 unless $ok;
245             };
246 0 0       0 open my $fp, ">>$path" or return 0;
247 0         0 close $fp;
248 0         0 return 1;
249             }
250              
251              
252             sub mark_disk_down {
253 3     3 1 5 my $class = shift;
254 3         6 my $root = shift;
255 3 50       11 return 1 if $class->disk_is_down($root);
256 3         497 my $state = $class->_state;
257 3         388 INFO "Marking disk $root down";
258 3 50       2910 exists($state->{disks}{$root}) or WARN "$root not present in state file";
259 3         8 $state->{disks}{$root} = 'down';
260 3 50       9 $class->_write_state($state) and return 1;
261 0         0 ERROR "Could not mark disk $root down";
262 0         0 return 0;
263             }
264              
265             sub mark_disk_up {
266 0     0 1 0 my $class = shift;
267 0         0 my $root = shift;
268 0 0       0 return 1 if $class->disk_is_up($root);
269 0         0 my $state = $class->_state;
270 0         0 INFO "Marking disk $root up";
271 0         0 $state->{disks}{$root} = 'up';
272 0 0       0 $class->_write_state($state) and return 1;
273 0         0 ERROR "Could not mark disk up";
274 0         0 return 0;
275             }
276              
277              
278             sub server_for {
279 1101     1101 1 3439 my $self = shift;
280 1101         2496 my $digest = shift;
281 1101         2513 my $found;
282 1101 50       2158 $self->refresh_config unless keys %{ $self->{bucket_to_url} } > 0;
  1101         6173  
283 1101         5503 for my $i (0..length($digest)) {
284 2202 100       10734 last if $found = $self->{bucket_to_url}->{ uc substr($digest,0,$i) };
285 1172 100       5663 last if $found = $self->{bucket_to_url}->{ lc substr($digest,0,$i) };
286             }
287 1101         4164 return $found;
288             }
289              
290              
291             sub bucket_map {
292 9     9 1 66 return shift->{bucket_to_url};
293             }
294              
295              
296             sub storage_path {
297 1217     1217 1 3277 my $class = shift;
298 1217         2802 my $digest = shift;
299 1217   33     6505 my $root = shift || $class->disk_for($digest) || LOGDIE "No local disk for $digest";
300 1217         35153 return join "/", $root, ( grep length, split /(..)/, $digest );
301             }
302              
303              
304             sub remote_stashed_server {
305 69     69 1 181 my $self = shift;
306 69         241 my ($filename,$digest) = @_;
307              
308 69         267 my $assigned_server = $self->server_for($digest);
309             # TODO broadcast these requests all at once
310 69         191 for my $server (shuffle(keys %{ $self->{servers} })) {
  69         448  
311 120 100       1905 next if $server eq $self->{our_url};
312 52 50       197 next if $server eq $assigned_server;
313 52         450 DEBUG "Checking remote $server for $filename";
314 52         79921 my $tx = $self->_ua->head( "$server/file/$filename/$digest", { "X-Yars-Check-Stash" => 1, "Connection" => "Close" } );
315 52 100       435751 if (my $res = $tx->success) {
316             # Found it!
317 6         378 return $server;
318             }
319             }
320 63         1823 return '';
321             }
322              
323              
324             sub local_stashed_dir {
325 290     290 1 784 my $self = shift;
326 290         919 my ($filename,$md5) = @_;
327 290         700 for my $root ( shuffle(keys %{ $self->{disk_is_local} })) {
  290         2220  
328 440         1947 my $dir = $self->storage_path($md5,$root);
329 440         5167 TRACE "Checking for $dir/$filename";
330 440 100       376962 return $dir if -r "$dir/$filename";
331             }
332 235         2086 return '';
333             }
334              
335              
336             sub server_exists {
337 1     1 1 3 my $self = shift;
338 1         2 my $server_url = shift;
339 1 50       8 return exists($self->{servers}->{$server_url}) ? 1 : 0;
340             }
341              
342              
343             sub server_url {
344 1378     1378 1 8269 return shift->{our_url};
345             }
346              
347              
348             sub disk_roots {
349 67     67 1 178 return keys %{ shift->{disk_is_local} };
  67         620  
350             }
351              
352              
353             sub server_urls {
354 3     3 1 8 return keys %{ shift->{servers} }
  3         18  
355             }
356              
357              
358             sub cleanup_tree {
359 21     21 1 60 my $self = shift;
360 21         72 my ($dir) = @_;
361 21         97 while (_dir_is_empty($dir)) {
362 328 100       1123 last if $self->{disk_is_local}->{$dir};
363 320 50       10233 rmdir $dir or do { warn "cannot rmdir $dir : $!"; last; };
  0         0  
  0         0  
364 320         3948 $dir =~ s[/[^/]+$][];
365             }
366             }
367              
368              
369             sub count_files {
370 12     12 1 19 my $class = shift;
371 12         18 my $dir = shift;
372 12 50       130 -d $dir or return 0;
373 12         367 my @list = File::Find::Rule->file->in($dir);
374 12         53613 return scalar @list;
375             }
376              
377              
378             sub human_size {
379 36     36 1 50 my $class = shift;
380 36         43 my $val = shift;
381 36         70 my @units = qw/B K M G T P/;
382 36         48 my $unit = shift @units;
383 36   66     41 do {
384 108         120 $unit = shift @units;
385 108         293 $val /= 1024;
386             } until $val < 1024 || !@units;
387 36         280 return sprintf( "%.0f%s", $val + 0.5, $unit );
388             }
389              
390              
391             sub content_is_same {
392 2     2 1 6 my $class = shift;
393 2         5 my ($filename,$asset) = @_;
394 2         5 my $check;
395 2 50       22 if ($asset->isa("Mojo::Asset::File")) {
396 0         0 $asset->handle->flush;
397 0         0 $check = ( compare($filename,$asset->path) == 0 );
398             } else {
399             # Memory asset. Assume that if one can fit in memory, two can, too.
400 2         10 my $existing = Mojo::Asset::File->new(path => $filename);
401 2   66     23 $check = ( $existing->size == $asset->size && $asset->slurp eq $existing->slurp );
402             }
403 2         488 return $check;
404             }
405              
406              
407             sub hex2b64 {
408 529     529 1 1663 my $class = shift;
409 529         1282 my $hex = shift;
410 529         7185 my $b64 = b(pack 'H*', $hex)->b64_encode;
411 529         19654 local $/="\n";
412 529         3009 chomp $b64;
413 529         8732 return $b64;
414             }
415              
416             sub b642hex {
417 0     0 1   my $class = shift;
418 0           my $b64 = shift;
419 0           return unpack 'H*', b($b64)->b64_decode;
420             }
421              
422              
423             1;
424              
425             __END__
426              
427             =pod
428              
429             =encoding UTF-8
430              
431             =head1 NAME
432              
433             Yars::Tools - various utility functions dealing with servers, hosts, etc
434              
435             =head1 VERSION
436              
437             version 1.30
438              
439             =head1 DESCRIPTION
440              
441             This module is largely used internally by L<Yars>. Documentation for
442             some of its capabilities are provided here for the understanding of how
443             the rest of the L<Yars> server works, but they should not be considered
444             to be a public interface and they may change in the future, though
445             probably not for a good reason.
446              
447             =head1 FUNCTIONS
448              
449             =head2 new
450              
451             Create a new instance of Yars::Tools
452              
453             =head2 refresh_config
454              
455             Refresh the configuration data cached in memory.
456              
457             =head2 disk_for
458              
459             Given an md5 digest, calculate the root directory of this file. Undef is
460             returned if this file does not belong on the current host.
461              
462             =head2 local_buckets
463              
464             Get a hash from disk to list of buckets for this server.
465              
466             =head2 disk_is_up
467              
468             Given a disk root, return true unless the disk is marked down. A disk is
469             down if the state file indicates it, or if it exists but is unwriteable.
470              
471             =head2 disk_is_up_verified
472              
473             This is the same as disk_is_up, but doesn't trust the operating system,
474             and tries to write a file to the disk's temp directory and verify that
475             the file is not of zero size.
476              
477             =head2 disk_is_down
478              
479             Disk is not up.
480              
481             =head2 disk_is_local
482              
483             Return true if the disk is on this server.
484              
485             =head2 server_is_up, server_is_down
486              
487             Check to see if a remote server is up or down.
488              
489             =head2 mark_disk_down, mark_disk_up
490              
491             Mark a disk as up or down.
492              
493             =head2 server_for
494              
495             Given an md5, return the url for the server for this file.
496              
497             =head2 bucket_map
498              
499             Return a map from bucket prefix to server url.
500              
501             =head2 storage_path
502              
503             Calculate the directory of an md5 on disk. Optionally pass a second
504             parameter to force it onto a particular disk.
505              
506             =head2 remote_stashed_server
507              
508             Find a server which is stashing this file, if one exists.
509             Parameters :
510             $c - controller
511             $filename - filename
512             $digest - digest
513              
514             =head2 local_stashed_dir
515              
516             Find a local directory stashing this file, if one exists.
517             Parameters :
518             $filename - filename
519             $digest - digest
520             Returns :
521             The directory or false.
522              
523             =head2 server_exists
524              
525             Does this server exist?
526              
527             =head2 server_url
528              
529             Returns the url of the current server.
530              
531             =head2 disk_roots
532              
533             Return all the local directory roots, in a random order.
534              
535             =head2 server_urls
536              
537             Return all the other urls, in a random order.
538              
539             =head2 cleanup_tree
540              
541             Given a directory, traverse upwards until encountering a local disk root
542             or a non-empty directory, and remove all empty directories.
543              
544             =head2 count_files
545              
546             Count the number of files in a directory tree.
547              
548             =head2 human_size
549              
550             Given a size, format it like df -kh
551              
552             =head2 content_is_same
553              
554             Given a filename and an Asset, return true if the content is the same
555             for both.
556              
557             =head2 hex2b64, b642hex
558              
559             Convert from hex to base 64.
560              
561             =head1 SEE ALSO
562              
563             L<Yars>, L<Yars::Client>
564              
565             =head1 AUTHOR
566              
567             Original author: Marty Brandon
568              
569             Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
570              
571             Contributors:
572              
573             Brian Duggan
574              
575             Curt Tilmes
576              
577             =head1 COPYRIGHT AND LICENSE
578              
579             This software is copyright (c) 2013 by NASA GSFC.
580              
581             This is free software; you can redistribute it and/or modify it under
582             the same terms as the Perl 5 programming language system itself.
583              
584             =cut