File Coverage

blib/lib/Yars/Routes.pm
Criterion Covered Total %
statement 207 231 89.6
branch 72 104 69.2
condition 19 26 73.0
subroutine 26 27 96.3
pod n/a
total 324 388 83.5


line stmt bran cond sub pod time code
1             package Yars::Routes;
2              
3             # ABSTRACT: set up the routes for Yars.
4             our $VERSION = '1.31'; # VERSION
5              
6              
7 23     23   9642 use strict;
  23         68  
  23         657  
8 23     23   124 use warnings;
  23         85  
  23         833  
9 23     23   131 use Mojo::ByteStream qw/b/;
  23         47  
  23         1108  
10 23     23   135 use Clustericious::Log;
  23         48  
  23         182  
11 23     23   16767 use File::Path qw/mkpath/;
  23         47  
  23         1008  
12 23     23   124 use File::Temp;
  23         48  
  23         1562  
13 23     23   492 use Clustericious::RouteBuilder;
  23         43776  
  23         163  
14 23     23   6007 use if $^O ne 'MSWin32', 'Filesys::Df' => qw/df/;
  23         58  
  23         191  
15 23     23   30124 use List::Util qw/ shuffle uniq /;
  23         54  
  23         1321  
16 23     23   217 use Digest::file qw/digest_file_hex/;
  23         23219  
  23         1097  
17 23     23   141 use File::Basename qw/basename/;
  23         49  
  23         1085  
18 23     23   193 use JSON::MaybeXS qw( encode_json );
  23         71  
  23         947  
19 23     23   441 use Yars::Util qw( format_tx_error );
  23         50  
  23         2316  
20              
21             BEGIN {
22 23 50   23   100408 if($^O eq 'MSWin32')
23             {
24             # Filesys::Df is not available for MSWin32,
25             # so we use Filesys::DfPortable on that platform
26 0         0 require Filesys::DfPortable;
27             *df = sub {
28 0         0 my $df = Filesys::DfPortable::dfportable(@_);
29 0         0 $df->{used} = $df->{bused};
30 0         0 $df;
31 0         0 };
32             }
33             }
34              
35              
36             get '/' => sub { shift->render(text => "welcome to Yars", format => 'txt', status => 200 ) } => 'index';
37              
38              
39             get '/file/#filename/:md5' => [ md5 => qr/[a-f0-9]{32}/ ] => \&_get;
40             get '/file/:md5/#filename' => [ md5 => qr/[a-f0-9]{32}/ ] => \&_get => "file";
41             sub _get {
42 663     663   2082150 my $c = shift;
43 663         2562 my $filename = $c->stash("filename");
44 663         7596 my $md5 = $c->stash("md5");
45              
46 663 100       5441 return _head($c, @_) if $c->req->method eq 'HEAD';
47              
48 562         10915 my $url = $c->tools->server_for($md5);
49 562 100       2840 if ($url ne $c->tools->server_url) {
50 157         1066 TRACE "$md5 should be on $url";
51             # but check our local stash first, just in case.
52 157 100       77822 _get_from_local_stash($c,$filename,$md5) and return;
53 113         545 $c->res->headers->add("X-Yars-Cache" => 0);
54 113         4290 return $c->render_moved("$url/file/$md5/$filename");
55             }
56              
57 405         1589 my $dir = $c->tools->storage_path($md5);
58 405 100       11857 -r "$dir/$filename" or do {
59             return
60 25   66     116 _get_from_local_stash( $c, $filename, $md5 )
61             || _redirect_to_remote_stash( $c, $filename, $md5 )
62             || $c->reply->not_found;
63             };
64              
65 380 100 100     2507 if($c->config->download_md5_verify(default => 1) || !$c->req->headers->header('X-Yars-Skip-Verify')) {
66 379         23226 my $computed = digest_file_hex("$dir/$filename",'MD5');
67 379 100       67221 unless($computed eq $md5) {
68 2         19 WARN "Content mismatch, possible disk corruption ($filename), $md5 != $computed";
69 2         1902 return $c->render(text => "content-mismatch", status => 500);
70             }
71             }
72              
73 378 100       1593 if ($c->req->headers->header('X-Yars-Use-X-Accel')) {
74 1         45 return _x_accel_redirect($c, "$dir/$filename", $md5);
75             }
76              
77 377         10542 $c->res->headers->add("Content-MD5", $c->tools->hex2b64($md5));
78 377         5443 $c->app->static->paths([$dir])->serve($c,$filename);
79 377         156570 _set_static_headers($c,"$dir/$filename");
80 377         1264 $c->rendered;
81             };
82              
83             sub _x_accel_redirect
84             {
85 1     1   4 my ($c, $localfile, $md5) = @_;
86              
87 1         7 my $b64 = $c->tools->hex2b64($md5);
88 1         6 $c->res->headers->add("Content-MD5", $b64);
89 1         38 my $types = $c->app->types;
90 1 50       21 my $type = $localfile =~ /\.(\w+)$/ ? $types->type($1) : undef;
91 1   33     21 $c->res->headers->content_type($type || $types->type('bin'));
92 1         23 $c->res->headers->add('X-Accel-Redirect', "/static$localfile");
93              
94 1         26 return $c->render(status => 200, text => '');
95             }
96              
97             sub _set_static_headers {
98             # Based on Mojolicious::Static. Probably should support if-modified..?
99 402     402   815 my $c = shift;
100 402         670 my $filepath = shift;
101 402         6043 my ($size, $modified) = (stat $filepath)[7, 9];
102 402         1558 my $rsh = $c->res->headers;
103 402         6014 $rsh->content_length($size);
104 402         2706 $rsh->last_modified(Mojo::Date->new($modified));
105 402         9091 $rsh->accept_ranges('bytes');
106 402         2380 my $types = $c->app->types;
107 402 100       3421 my $type = $filepath =~ /\.(\w+)$/ ? $types->type($1) : undef;
108 402   66     1292 $c->res->headers->content_type($type || $types->type('bin'));
109 402         10948 return 1;
110             }
111              
112              
113              
114             sub _head {
115 101     101   1591 my $c = shift;
116 101         261 my $filename = $c->stash("filename");
117 101         857 my $md5 = $c->stash("md5");
118              
119             # Just check the local stash and return?
120 101 100       825 my $check_stash = $c->req->headers->header("X-Yars-Check-Stash") ? 1 : 0;
121 101         2455 my $url;
122 101 100       550 $url = $c->tools->server_for($md5) unless $check_stash;
123              
124             # Check the local stash if we are asked to, or if it doesn't belong here.
125 101 100 100     526 if ($check_stash or $url ne $c->tools->server_url) {
126 71 100       493 if (my $found_dir = $c->tools->local_stashed_dir($filename,$md5)) {
127 9         57 _set_static_headers($c,"$found_dir/$filename");
128 9         42 return $c->render(status => 200, text => 'found');
129             }
130 62 100       466 return $c->reply->not_found if $check_stash;
131 15         167 return $c->render_moved("$url/file/$md5/$filename");
132             }
133              
134             # It belongs here. But it might still be stashed locally or remotely.
135 30         141 my $dir = $c->tools->storage_path($md5);
136 30 100       881 my $found_dir = -r "$dir/$filename" ? $dir : undef;
137 30   66     176 $found_dir ||= $c->tools->local_stashed_dir( $filename, $md5 );
138 30 100       119 return if _redirect_to_remote_stash($c, $filename, $md5 );
139 28 100       150 return $c->reply->not_found unless $found_dir;
140 16         109 _set_static_headers($c,"$found_dir/$filename");
141 16         72 $c->render( status => 200, text => 'found' );
142             }
143              
144             sub _get_from_local_stash {
145 182     182   648 my ($c,$filename,$md5) = @_;
146             # If this is stashed locally, serve it and return true.
147             # Otherwise return false.
148 182 100       1081 my $dir = $c->tools->local_stashed_dir($filename,$md5) or return 0;
149              
150 44 50 33     313 if($c->config->download_md5_verify(default => 1) || !$c->req->headers->header('X-Yars-Skip-Verify')) {
151 44         3113 my $computed = digest_file_hex("$dir/$filename",'MD5');
152 44 50       5528 unless($computed eq $md5) {
153 0         0 WARN "Content mismatch, possible disk corruption ($filename), $md5 != $computed";
154 0         0 return $c->render(text => "content-mismatch", status => 500);
155             }
156             }
157              
158 44 50       189 if ($c->req->headers->header('X-Yars-Use-X-Accel')) {
159 0         0 return _x_accel_redirect($c, "$dir/$filename", $md5);
160             }
161              
162 44         1450 $c->res->headers->add("Content-MD5", $c->tools->hex2b64($md5));
163 44         705 $c->app->static->paths([$dir])->serve($c,$filename);
164 44         21120 $c->rendered;
165 44         53243 return 1;
166             }
167              
168             sub _redirect_to_remote_stash {
169 55     55   185 my ($c,$filename,$digest) = @_;
170 55         201 DEBUG "Checking remote stashes";
171 55 100       51709 if (my $server = $c->tools->remote_stashed_server($filename,$digest)) {
172 5         21 $c->res->headers->location("$server/file/$digest/$filename");
173 5         125 $c->res->headers->content_length(0);
174 5         83 $c->rendered(307);
175 5         5839 return 1;
176             };
177 50         436 return 0;
178             }
179              
180              
181             put '/file/#filename/:md5' => { md5 => 'calculate' } => sub {
182             my $c = shift;
183             my $filename = $c->stash('filename');
184             my $md5 = $c->stash('md5');
185              
186             my $asset = $c->req->content->asset;
187             my $digest;
188             if ($asset->isa("Mojo::Asset::File")) {
189             TRACE "Received file asset with size ".$asset->size;
190             $digest = digest_file_hex($asset->path,'MD5');
191             TRACE "Md5 of ".$asset->path." is $digest";
192             } else {
193             TRACE "Received memory asset with size ".$asset->size;
194             $digest = b($asset->slurp)->md5_sum->to_string;
195             }
196              
197             $md5 = $digest if $md5 eq 'calculate';
198              
199             if ($digest ne $md5) {
200             WARN "md5 mismatch : $md5 != $digest for $filename which isa ".(ref $asset);
201             return $c->render(text => "incorrect digest, $md5!=$digest", status => 400);
202             }
203              
204             if ($c->req->headers->header('X-Yars-Stash')) {
205             DEBUG "Stashing a file that is not ours : $digest $filename";
206             _stash_locally($c, $filename, $digest, $asset) and return;
207             return $c->reply->exception("Cannot stash $filename locally");
208             }
209              
210             DEBUG "Received NoStash for $filename" if $c->req->headers->header('X-Yars-NoStash');
211              
212             my $assigned_server = $c->tools->server_for($digest);
213              
214             if ( $assigned_server ne $c->tools->server_url ) {
215             TRACE "assigned $assigned_server != ".$c->tools->server_url;
216             return _proxy_to( $c, $assigned_server, $filename, $digest, $asset, 0 )
217             || _stash_locally( $c, $filename, $digest, $asset )
218             || _stash_remotely( $c, $filename, $digest, $asset )
219             || $c->render(status => 507, text => "Unable to proxy or stash");
220             }
221              
222             my $assigned_disk = $c->tools->disk_for($digest);
223              
224             DEBUG "Received $filename assigned to $assigned_server ($assigned_disk), this is ".$c->tools->server_url;
225              
226             unless (-d $assigned_disk) {
227             INFO "$assigned_disk does not exist, creating it now";
228             mkdir $assigned_disk or WARN "Failed to mkdir $assigned_disk : $!";
229             }
230             if ( $c->tools->disk_is_up($assigned_disk) ) {
231             my $assigned_path = $c->tools->storage_path($digest, $assigned_disk);
232             my $abs_path = join '/', $assigned_path, $filename;
233             my $location = $c->url_for("file", md5 => $digest, filename => $filename)->to_abs;
234             if (-e $abs_path) {
235             TRACE "Found another file at $abs_path, comparing content";
236             my $old_md5 = digest_file_hex($abs_path,"MD5");
237             if ($old_md5 eq $digest) {
238             if ($c->tools->content_is_same($abs_path,$asset)) {
239             $c->res->headers->location($location);
240             return $c->render(status => 200, text => 'exists');
241             } else {
242             WARN "Same md5, but different content for $filename";
243             return $c->render(status => 409, text => 'md5 collision');
244             }
245             }
246             DEBUG "md5 of content in $abs_path was incorrect; replacing corrupt file"
247             }
248             if (my $existing = _other_files_in_path( $assigned_path ) ) {
249             if (_make_link($existing,"$assigned_path/$filename")) {
250             $c->res->headers->location($location);
251             return $c->render(status => 201, text => 'ok'); # CREATED
252             }
253             }
254             if (_atomic_write( $assigned_path , $filename, $asset ) ) {
255             # Normal situation.
256             $c->res->headers->location($location);
257             return $c->render(status => 201, text => 'ok'); # CREATED
258             }
259             } else {
260             DEBUG "Disk $assigned_disk is not up";
261             }
262              
263             # Local designated disk is down.
264             _stash_locally( $c, $filename, $digest, $asset )
265             or _stash_remotely( $c, $filename, $digest, $asset )
266             or $c->render(status => 507, text => "Unable to proxy or stash");
267             };
268              
269             sub _other_files_in_path {
270 218     218   485 my $path = shift;
271 218 100       2432 opendir( DR, $path ) or return;
272 1         2 my $found;
273 1         16 while ( $_ = readdir DR ) {
274 1 50       5 next if /^\.\.?$/;
275 1         3 $found = $_;
276 1         2 last;
277             }
278 1         8 closedir DR;
279 1 50       3 return unless $found;
280 1         6 return "$path/$found";
281             }
282              
283             sub _make_link {
284 1     1   3 my ($old,$new) = @_;
285 1         4 DEBUG "Making a hard link for $new";
286 1         1119 my $status = link($old,$new);
287 1 50       6 WARN "Failed to link $old to $new : $!" unless $status;
288 1         4 return $status;
289             }
290              
291             sub _proxy_to {
292 107     107   446 my ($c, $url,$filename,$digest,$asset,$temporary) = @_;
293             # Proxy a file to another url.
294             # On success, render the response and return true.
295             # On failure, return false.
296 107         220 my $res;
297 107 50       1197 DEBUG "Proxying file $filename with md5 $digest to $url/file/$filename/$digest"
298             . ( $temporary ? " temporarily" : "" );
299 107 50       96989 my $headers = $temporary ? { 'X-Yars-Stash' => 1 } : {};
300 107         824 $headers->{"Content-MD5"} = $c->tools->hex2b64($digest);
301 107         334 $headers->{Connection} = "Close";
302 107         562 my $tx = $c->tools->_ua->build_tx(PUT => "$url/file/$filename/$digest", $headers );
303 107         29831 $tx->req->content->asset($asset);
304 107         1717 $tx = $c->tools->_ua->start($tx);
305 107 100       396262 if ($res = $tx->success) {
306 63         1624 my $headers = $c->res->headers;
307 63         1184 $headers->location($tx->res->headers->location);
308 63 50       1501 $headers->add("X-Yars-Cache" => 0) unless $temporary;
309 63         868 $c->render(status => $tx->res->code, text => 'ok');
310 63         90758 return 1;
311             }
312 44         1219 ERROR "failed to proxy $filename to $url : " . format_tx_error($tx->error);
313 44         27976 return 0;
314             }
315              
316             sub _atomic_write {
317 276     276   745 my ($dir, $filename, $asset) = @_;
318 276         1523 TRACE "Writing $dir/$filename";
319             # Write a file atomically. Return 1 on success, 0 on failure.
320 276         145339 my $failed;
321 276         527 eval {
322 276         244369 mkpath $dir; # dies on error
323 276 50       2748 $asset->move_to("$dir/$filename") or LOGDIE "failed to write $dir/$filename: $!";
324 276 50       38807 }; if($@) {
325 0         0 WARN "Could not write $dir/$filename : $@";
326 0         0 $failed = 1;
327             };
328 276 50       804 return 0 if $failed;
329 276         1544 TRACE "Wrote $dir/$filename";
330 276         146875 return 1;
331             }
332              
333             sub _stash_locally {
334 59     59   283 my ($c, $filename,$digest, $asset) = @_;
335             # Stash this file on a local disk.
336             # Returns false or renders the response.
337              
338 59 50       275 return 0 if $c->req->headers->header('X-Yars-NoStash');
339              
340 59         2039 DEBUG "Stashing $filename locally";
341 59         58610 my $assigned_root = $c->tools->disk_for($digest);
342 59   100     387 $assigned_root //= '';
343 59         93 my $wrote;
344 59         435 for my $root (shuffle($c->tools->disk_roots)) {
345 78         484 TRACE "Trying $root (assigned : $assigned_root)";
346 78 100 100     40923 next if $assigned_root && ($root eq $assigned_root);
347 71 100       492 unless ($c->tools->disk_is_up($root)) {
348 12         87 DEBUG "local disk $root is down, cannot stash $filename there.";
349 12         13106 next;
350             }
351 59         11454 my $dir = $c->tools->storage_path( $digest, $root );
352 59 50       360 _atomic_write( $dir, $filename, $asset ) and do {
353 59         140 $wrote = $root;
354 59         158 last;
355             };
356 0         0 TRACE "write failed";
357             }
358 59 50       230 WARN "Help, all my disks are unwriteable!" unless $wrote;
359             # I'm not dead yet! It's only a flesh wound!
360 59 50       199 return 0 unless $wrote;
361 59         437 my $location = $c->url_for("file", md5 => $digest, filename => $filename)->to_abs;
362 59         43623 $c->res->headers->location($location);
363 59         1989 $c->render(status => 201, text => 'ok'); # CREATED
364 59         92305 DEBUG "Stashed $filename ($digest) locally on $wrote";
365 59         56585 return 1;
366             }
367              
368             sub _stash_remotely {
369 0     0   0 my ($c, $filename,$digest,$asset) = @_;
370             # Stash this file on a remote disk.
371             # Returns false or renders the response.
372              
373 0 0       0 return 0 if $c->req->headers->header('X-Yars-NoStash');
374              
375 0         0 DEBUG "Stashing $filename remotely.";
376 0         0 my $assigned_server = $c->tools->server_for($digest);
377 0         0 for my $server (shuffle($c->tools->server_urls)) {
378 0 0       0 next if $server eq $c->tools->server_url;
379 0 0       0 next if $server eq $assigned_server;
380 0 0       0 _proxy_to( $c, $server, $filename, $digest, $asset, 1 ) and return 1;
381             }
382 0         0 return 0;
383             }
384              
385              
386             del '/file/#filename/:md5' => [ md5 => qr/[a-f0-9]{32}/ ] => \&_del;
387             del '/file/:md5/#filename' => [ md5 => qr/[a-f0-9]{32}/ ] => \&_del;
388              
389             sub _del {
390 30     30   111946 my $c = shift;
391 30         135 my $md5 = $c->stash("md5");
392 30         349 my $filename = $c->stash('filename');
393 30         355 TRACE "Delete request for $filename, $md5";
394              
395             # Delete locally or proxy the delete if it is stashed somewhere else.
396              
397 30         17775 my $server = $c->tools->server_for($md5);
398 30 100       148 if ($server eq $c->tools->server_url) {
399 20         78 DEBUG "This is our file, we will delete it.";
400 20         18622 my $dir = $c->tools->storage_path( $md5 );
401 20 100       782 if (-r "$dir/$filename") {
402 19 50       1461 unlink "$dir/$filename" or return $c->reply->exception($!);
403 19         161 $c->tools->cleanup_tree($dir);
404 19         109 return $c->render(status => 200, text =>'ok');
405             }
406              
407 1         7 $server = $c->tools->remote_stashed_server($filename, $md5);
408 1 50       6 return $c->reply->not_found unless $server;
409             # otherwise fall through...
410             }
411              
412 11 100       50 if (my $dir = $c->tools->local_stashed_dir($filename,$md5)) {
413 2 50       128 unlink "$dir/$filename" or return $c->reply->exception($!);
414 2         26 $c->tools->cleanup_tree($dir);
415 2         11 return $c->render(status => 200, text =>'ok');
416             }
417              
418 9         45 DEBUG "Proxying delete to $server";
419 9         7989 my $tx = $c->tools->_ua->delete("$server/file/$md5/$filename");
420 9 50       32254 if (my $res = $tx->success) {
421 9         206 return $c->render(status => 200, text => "ok");
422             } else {
423 0           my $error = $tx->error;
424 0           my ($msg,$code) = ($error->{message}, $error->{code});
425 0 0         return $c->render(status => $code, text => $msg) if $code;
426 0           return $c->reply->exception("Error deleting from $server ".format_tx_error($tx->error));
427             }
428             };
429              
430              
431             get '/disk/usage' => sub {
432             my $c = shift;
433             my $count = $c->param("count") ? 1 : 0;
434             if ( my $server = $c->param('server') ) {
435             if ( $c->tools->server_exists($server)
436             and $c->tools->server_url ne $server ) {
437             return $c->redirect_to("$server/disk/usage?count=$count");
438             }
439             }
440              
441             my %r;
442             for my $disk ($c->tools->disk_roots) {
443             if (defined( my $df = df($disk))) {
444             $r{$disk} = {
445             '1K-blocks' => $df->{blocks},
446             blocks_used => $df->{used},
447             blocks_avail => $df->{bavail},
448             space => $c->tools->human_size($df->{blocks}*1024),
449             space_used => $c->tools->human_size($df->{used}*1024),
450             space_avail => $c->tools->human_size($df->{bavail}*1024),
451             percent_used => sprintf('%02d',(100*($df->{blocks} - $df->{bavail})/($df->{blocks}))).'%',
452             };
453             } else {
454             WARN "Error getting usage for disk $disk" if -d $disk;
455             DEBUG "$disk does not exist" unless -d $disk;
456             }
457             $r{$disk}{count} = $c->tools->count_files($disk) if $count;
458             }
459             return $c->render(autodata => \%r) unless $c->param('all');
460             my %all = ( $c->tools->server_url => \%r );
461             for my $server ($c->tools->server_urls) {
462             next if exists $all{$server};
463             my $tx = $c->tools->_ua->get("$server/disk/usage?count=$count");
464             my $res = $tx->success or do {
465             $all{$server} = 'down';
466             next;
467             };
468             $all{$server} = $res->json;
469             }
470             return $c->render(autodata => \%all);
471             };
472              
473              
474             post '/disk/status' => sub {
475             my $c = shift;
476             my $got = $c->parse_autodata;
477             my $root = $got->{root} || $got->{disk};
478             my $state = $got->{state} or return $c->reply->exception("no state found in request");
479             my $server = $got->{server};
480             if ($server && $server ne $c->tools->server_url) {
481             unless ($c->tools->server_exists($server)) {
482             return $c->render( status => 400, text => "Server $server does not exist" );
483             }
484             WARN "Sending ".$c->req->body;
485             my $tx = $c->tools->_ua->post("$server/disk/status", $c->req->headers->to_hash, ''.$c->req->body );
486             return $c->render( text => $tx->success ? $tx->res->body : 'failed '.format_tx_error($tx->error) );
487             }
488             $c->tools->disk_is_local($root) or return $c->render->exception("Disk $root is not on ".$c->tools->server_url);
489             my $success;
490             for ($state) {
491             /down/ and $success = $c->tools->mark_disk_down($root);
492             /up/ and $success = $c->tools->mark_disk_up($root);
493             }
494             $c->render(text => $success ? "ok" : "failed" );
495             };
496              
497              
498             post '/check/manifest' => sub {
499             my $c = shift;
500             my $got = $c->parse_autodata;
501             my $files = $got->{files} || [];
502             if (my $manifest = $got->{manifest}) {
503             for my $line (split /\n/, $manifest) {
504             my ($md5,$filename) = split /\s+/, $line;
505             push @$files, +{ md5 => $md5, filename => $filename };
506             }
507             }
508             my %ret = ( missing => [], found => [] );
509             my %remote;
510             for my $entry (@$files) {
511             my ($filename,$md5) = @$entry{qw/filename md5/};
512             next unless $md5 && $md5 =~ /^[0-9a-fA-F]+$/;
513             next unless $filename && $filename =~ /\w/;
514             $filename = basename($filename);
515             next if $filename =~ m[/];
516             TRACE "checking for $md5 and $filename";
517             my $server = $c->tools->server_for($md5);
518             if ($server eq $c->tools->server_url) {
519             my $dir = $c->tools->storage_path($md5);
520             my $which = -r "$dir/$filename" ? "found" : "missing";
521              
522             if ($which eq 'found' && $c->param('show_corrupt')) {
523             # Check md5, and maybe set $which to "corrupt".
524             my $computed_md5 = digest_file_hex("$dir/$filename",'MD5');
525             if ($computed_md5 ne $md5) {
526             $which = 'corrupt';
527             $md5 = $computed_md5;
528             }
529             }
530              
531             push @{ $ret{$which} }, { filename => $filename, md5 => $md5 };
532             } else {
533             push @{ $remote{$server} }, { filename => $filename, md5 => $md5 };
534             }
535             }
536              
537             for my $server (keys %remote) {
538             TRACE "Looking for manifest files on $server";
539             my $content = encode_json { files => $remote{$server} };
540             my $tx = $c->tools->_ua->post(
541             "$server/check/manifest?show_found=1&show_corrupt=".($c->param("show_corrupt")//''),
542             { "Content-type" => "application/json", "Connection" => "Close" }, $content );
543             if (my $res = $tx->success) {
544             my $got = $res->json;
545             push @{ $ret{missing} }, @{ $got->{missing} };
546             push @{ $ret{found} }, @{ $got->{found} };
547             push @{ $ret{corrupt} }, @{ $got->{corrupt} || [] } if $c->param("show_corrupt");
548             } else {
549             ERROR "Failed to connect to $server";
550             push @{ $ret{missing} }, @{ $remote{$server} };
551             }
552             }
553              
554             # Check stashes for missing ones to be sure.
555             my $missing = $ret{missing};
556             my @are_missing;
557             my @not_missing;
558             for my $m (@$missing) {
559             my $found = $c->tools->local_stashed_dir( $m->{filename}, $m->{md5} )
560             || $c->tools->remote_stashed_server( $m->{filename}, $m->{md5} );
561             if ($found) {
562             push @not_missing, $m;
563             } else {
564             push @are_missing, $m;
565             }
566             }
567             if (@not_missing) {
568             push @{ $ret{found} }, @not_missing;
569             $ret{missing} = \@are_missing;
570             }
571              
572             $ret{found} = scalar @{ $ret{found} } unless $c->param("show_found");
573             $c->render(autodata => \%ret);
574             };
575              
576              
577             get '/servers/status' => sub {
578             my $c = shift;
579             my %disks =
580             map { $_ => $c->tools->disk_is_up_verified($_) ? "up" : "down" }
581             $c->tools->disk_roots;
582             my %all;
583             $all{$c->tools->server_url} = \%disks;
584             for my $server ($c->tools->server_urls) {
585             next if exists($all{$server});
586             my $tx = $c->tools->_ua->get("$server/server/status");
587             if (my $res = $tx->success) {
588             $all{$server} = $res->json;
589             } else {
590             WARN "Could not reach $server : ".format_tx_error($tx->error);
591             $all{$server} = "down";
592             }
593             }
594             $c->render(autodata => \%all);
595             };
596              
597              
598             get '/server/status' => sub {
599             my $c = shift;
600             my %disks =
601             map { $_ => $c->tools->disk_is_up_verified($_) ? "up" : "down" }
602             $c->tools->disk_roots;
603             $c->render(autodata => \%disks);
604             };
605              
606              
607             get '/bucket_map' => sub {
608             my $c = shift;
609             $c->render(autodata => $c->tools->bucket_map)
610             };
611              
612              
613             get '/bucket/usage' => sub {
614             my $c = shift;
615             if ( my $server = $c->param('server') ) {
616             if ( $c->tools->server_exists($server)
617             and $c->tools->server_url ne $server ) {
618             return $c->redirect_to("$server/bucket/usage");
619             }
620             }
621             my %used;
622             my %assigned = $c->tools->local_buckets;
623              
624             # NB: this assumes homogeneous buckets and doesn't
625             # work for > 256 buckets.
626             my $bucket_size = 1;
627             for (keys %assigned) {
628             for (@{ $assigned{$_} }) {
629             $bucket_size = length($_) if length($_) > $bucket_size;
630             }
631             }
632              
633             for my $disk ($c->tools->disk_roots) {
634             my @dirs = map /\/([0-9a-f]+)$/, glob "$disk/*";
635             my @buckets = uniq map substr($_,0,$bucket_size), @dirs;
636             $used{$disk} = \@buckets;
637             }
638             $c->render(autodata => { used => \%used, assigned => \%assigned } );
639             };
640              
641              
642             1;
643              
644             __END__
645              
646             =pod
647              
648             =encoding UTF-8
649              
650             =head1 NAME
651              
652             Yars::Routes - set up the routes for Yars.
653              
654             =head1 VERSION
655              
656             version 1.31
657              
658             =head1 SYNOPSIS
659              
660             % curl http://localhost:9001/file/764efa883dda1e11db47671c4a3bbd9e/test_file1
661              
662             =head1 DESCRIPTION
663              
664             This document provides information on the Yars specific REST API (the
665             HTTP "routes") provided by Yars servers. For a Perl interface to this
666             API, see L<Yars::Client>. For a command line interface see
667             L<yarsclient>. For the generic L<Clustericious> REST API that comes
668             with all L<Clustericious> services, see
669             L<Clustericious::RouteBuilder::Common>.
670              
671             =head1 ROUTES
672              
673             =head2 GET /
674              
675             Get a welcome message. This is usually simply the text string "welcome
676             to Yars".
677              
678             =head2 GET /file/#filename/:md5, GET /:md5/#filename
679              
680             Retrieve a file with the given name and md5.
681              
682             You can also make a HEAD request on the same route to determine if the
683             file is available without making the yars server send the file.
684              
685             =head2 PUT /file/#filename/#md5
686              
687             PUT a file with the given name and md5.
688              
689             =head2 DELETE /file/#filename/:md5, /file/:md5/#filename
690              
691             Delete a file with the given name and md5.
692              
693             =head2 GET /disk/usage
694              
695             Get a summary of the disk usage.
696              
697             Send the CGI parameters count=1 to also count the files.
698              
699             =head2 POST /disk/status
700              
701             Mark disks up or down. Send the disk root and state (up or down)
702             as JSON encoded in the body.
703              
704             =head2 POST /check/manifest
705              
706             Given JSON with 'manifest' which is a return-delimited string of
707             filenames and md5s (like the output of md5sum), check each file for
708             existence on the server (or proxy to the right server)
709              
710             =head2 GET /servers/status
711              
712             Get the status of all the disks on all the servers/
713              
714             =head2 GET /server/status
715              
716             Get the status of just this server.
717              
718             =head2 GET /bucket_map
719              
720             Get a mapping from buckets to hosts.
721              
722             =head2 GET /bucket/usage
723              
724             Find the disk usage per bucket.
725              
726             =head1 SEE ALSO
727              
728             L<Yars>, L<Yars::Client>, L<yarsclient>, L<Clustericious>
729              
730             =head1 AUTHOR
731              
732             Original author: Marty Brandon
733              
734             Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
735              
736             Contributors:
737              
738             Brian Duggan
739              
740             Curt Tilmes
741              
742             =head1 COPYRIGHT AND LICENSE
743              
744             This software is copyright (c) 2013 by NASA GSFC.
745              
746             This is free software; you can redistribute it and/or modify it under
747             the same terms as the Perl 5 programming language system itself.
748              
749             =cut