/[echolot]/trunk/Echolot/Stats.pm
ViewVC logotype

Contents of /trunk/Echolot/Stats.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 363 - (show annotations) (download)
Tue Jan 14 05:25:35 2003 UTC (10 years, 4 months ago) by weasel
File size: 27803 byte(s)
First go at sane logging
1 package Echolot::Stats;
2
3 # (c) 2002 Peter Palfrader <peter@palfrader.org>
4 # $Id: Stats.pm,v 1.38 2003/01/14 05:25:35 weasel Exp $
5 #
6
7 =pod
8
9 =head1 Name
10
11 Echolot::Stats - produce Stats, keyrings et al
12
13 =head1 DESCRIPTION
14
15 This package provides functions for generating remailer stats,
16 and keyrings.
17
18 =cut
19
20 use strict;
21 use constant DAYS => 12;
22 use constant SECS_PER_DAY => 24 * 60 * 60;
23 use English;
24 use Echolot::Log;
25
26 use Statistics::Distrib::Normal qw{};
27
28 my $NORMAL = new Statistics::Distrib::Normal;
29 $NORMAL->mu(0);
30 $NORMAL->sigma(1);
31
32 sub make_date() {
33 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime();
34 sprintf("%s %02d %s %4d %02d:%02d:%02d GMT",
35 Echolot::Tools::make_dayname($wday),
36 $mday,
37 Echolot::Tools::make_monthname($mon),
38 $year + 1900,
39 $hour,
40 $min,
41 $sec);
42 };
43
44 sub make_min_hr($$) {
45 my ($sec, $includesec) = @_;
46 my ($s, $m, $h);
47
48 if (defined $sec) {
49 $s = $sec % 60;
50 $m = $sec / 60 % 60;
51 $h = int ($sec / 60 / 60);
52 };
53 if ((! defined $sec) || ($sec < 0) || ($h > 99)) {
54 $h = 99;
55 $m = 59;
56 $s = 59;
57 };
58
59 if ($includesec) {
60 if ($h) { return sprintf ("%2d:%02d:%02d", $h, $m, $s); }
61 elsif ($m) { return sprintf ( " %2d:%02d", $m, $s); }
62 else { return sprintf ( " %2d", $s); };
63 } else {
64 if ($h) { return sprintf ("%2d:%02d", $h, $m); }
65 else { return sprintf ( " :%02d", $m); };
66 };
67 };
68
69 sub build_list1_latencystr($) {
70 my ($lat) = @_;
71
72 my $str = '?' x DAYS;
73 for my $day (0 .. DAYS - 1) {
74 substr($str, DAYS - 1 - $day, 1) =
75 (defined $lat->[$day]) ?
76 ($lat->[$day] < 300 ? '#' :
77 ($lat->[$day] < 3600 ? '*' :
78 ($lat->[$day] < 14400 ? '+' :
79 ($lat->[$day] < 86400 ? '-' :
80 ($lat->[$day] < 172800 ? '.' :
81 '_'
82 )))))
83 : ' ';
84 };
85 return $str;
86 }
87
88 sub build_list2_latencystr($) {
89 my ($lat) = @_;
90
91 my $str = '?' x DAYS;
92 for my $day (0 .. DAYS - 1) {
93 substr($str, DAYS - 1 - $day, 1) =
94 (defined $lat->[$day]) ?
95 ($lat->[$day] < 20*60 ? '0' :
96 ($lat->[$day] < 1*3600 ? '1' :
97 ($lat->[$day] < 2*3600 ? '2' :
98 ($lat->[$day] < 3*3600 ? '3' :
99 ($lat->[$day] < 4*3600 ? '4' :
100 ($lat->[$day] < 5*3600 ? '5' :
101 ($lat->[$day] < 6*3600 ? '6' :
102 ($lat->[$day] < 7*3600 ? '7' :
103 ($lat->[$day] < 8*3600 ? '8' :
104 ($lat->[$day] < 9*3600 ? '9' :
105 ($lat->[$day] < 12*3600 ? 'A' :
106 ($lat->[$day] < 18*3600 ? 'B' :
107 ($lat->[$day] < 24*3600 ? 'C' :
108 ($lat->[$day] < 30*3600 ? 'D' :
109 ($lat->[$day] < 36*3600 ? 'E' :
110 ($lat->[$day] < 42*3600 ? 'F' :
111 ($lat->[$day] < 48*3600 ? 'G' :
112 'H'
113 )))))))))))))))))
114 : '?';
115 };
116 return $str;
117 }
118
119 sub build_list2_reliabilitystr($) {
120 my ($rel) = @_;
121
122 my $str = '?' x DAYS;
123 for my $day (0 .. DAYS - 1) {
124 substr($str, DAYS - 1 - $day, 1) =
125 (defined $rel->[$day]) ?
126 (($rel->[$day] >= 0.9999) ?
127 #(($rel->[$day] == 1) ?
128 '+' :
129 (int ($rel->[$day]*10)))
130 : '?';
131 };
132 return $str;
133 }
134
135 sub build_list2_capsstr($) {
136 my ($caps) = @_;
137
138 my %caps;
139 $caps{'middle'} = ($caps =~ m/\bmiddle\b/i);
140 $caps{'post'} = ($caps =~ m/\bpost\b/i) || ($caps =~ m/\banon-post-to\b/i);
141 $caps{'mix'} = ($caps =~ m/\bmix\b/i);
142 $caps{'remix'} = ($caps =~ m/\bremix\b/i);
143 $caps{'remix2'} = ($caps =~ m/\bremix2\b/i);
144 $caps{'hybrid'} = ($caps =~ m/\bhybrid\b/i);
145 $caps{'repgp2'} = ($caps =~ m/\brepgp2\b/i);
146 $caps{'repgp'} = ($caps =~ m/\brepgp\b/i);
147 $caps{'pgponly'} = ($caps =~ m/\bpgponly\b/i);
148 $caps{'ext'} = ($caps =~ m/\bext\b/i);
149 $caps{'max'} = ($caps =~ m/\bmax\b/i);
150 $caps{'test'} = ($caps =~ m/\btest\b/i);
151 $caps{'latent'} = ($caps =~ m/\blatent\b/i);
152 $caps{'ek'} = ($caps =~ m/\bek\b/i);
153 $caps{'ekx'} = ($caps =~ m/\bekx\b/i);
154 $caps{'esub'} = ($caps =~ m/\besub\b/i);
155 $caps{'inflt'} = ($caps =~ m/\binflt\d+\b/i);
156 $caps{'rhop'} = ($caps =~ m/\brhop\d+\b/i);
157 ($caps{'klen'}) = ($caps =~ m/\bklen(\d+)\b/i);
158
159 my $str =
160 ($caps{'middle'} ? 'D' : ' ') .
161 ($caps{'post'} ? 'P' : ' ') .
162 ($caps{'remix2'} ? '2' : ($caps{'remix'} ? 'R' : ($caps{'mix'} ? 'M' : ' ' ))) .
163 ($caps{'hybrid'} ? 'H' : ' ') .
164 ($caps{'repgp2'} ? '2' : ($caps{'repgp'} ? 'G' : ' ' )) .
165 ($caps{'pgponly'} ? 'O' : ' ') .
166 ($caps{'ext'} ? 'X' : ' ') .
167 ($caps{'max'} ? 'A' : ' ') .
168 ($caps{'test'} ? 'T' : ' ') .
169 ($caps{'latent'} ? 'L' : ' ') .
170 ($caps{'ekx'} ? 'E' : ($caps{'ek'} ? 'e' : ' ' )) .
171 ($caps{'esub'} ? 'U' : ' ') .
172 ($caps{'inflt'} ? 'I' : ' ') .
173 ($caps{'rhop'} ? 'N' : ' ') .
174 (defined $caps{'klen'} ?
175 ($caps{'klen'} >= 900 ? '9' : (
176 $caps{'klen'} >= 800 ? '8' : (
177 $caps{'klen'} >= 700 ? '7' : (
178 $caps{'klen'} >= 600 ? '6' : (
179 $caps{'klen'} >= 500 ? '5' : (
180 $caps{'klen'} >= 400 ? '4' : (
181 $caps{'klen'} >= 300 ? '3' : (
182 $caps{'klen'} >= 200 ? '2' : (
183 $caps{'klen'} >= 100 ? '1' : '0'
184 )))))))))
185 : ' ');
186 return $str;
187 }
188
189
190 sub calculate($$) {
191 my ($addr, $types) = @_;
192 my $now = time();
193
194 my @out;
195 my @done;
196
197 for my $type (@$types) {
198 next unless Echolot::Globals::get()->{'storage'}->has_type($addr, $type);
199 my @keys = Echolot::Globals::get()->{'storage'}->get_keys($addr, $type);
200 for my $key (@keys) {
201 push @out, grep {$_ > $now - DAYS * SECS_PER_DAY} Echolot::Globals::get()->{'storage'}->get_pings($addr, $type, $key, 'out');
202 push @done, grep {$_->[0] > $now - DAYS * SECS_PER_DAY} Echolot::Globals::get()->{'storage'}->get_pings($addr, $type, $key, 'done');
203 };
204 };
205
206 my $latency = 0;
207 my $received = 0;
208 my $sent = 0;
209 my @latency;
210 my @received;
211 my @sent;
212 for my $done (@done) {
213 $latency += $done->[1]; $latency [int(($now - $done->[0]) / SECS_PER_DAY)] += $done->[1];
214 $sent ++; $sent [int(($now - $done->[0]) / SECS_PER_DAY)] ++;
215 $received ++; $received[int(($now - $done->[0]) / SECS_PER_DAY)] ++;
216 };
217 $latency /= (scalar @done) if (scalar @done);
218 $latency = undef unless (scalar @done);
219 for ( 0 .. DAYS - 1 ) {
220 $latency[$_] /= $received[$_] if ($received[$_]);
221 };
222
223 my $variance = 0;
224 $variance += ($latency - $_->[1]) ** 2 for (@done);
225 $variance /= (scalar @done) if (scalar @done);
226
227 my $deviation = sqrt($variance);
228
229 if (scalar @out) {
230 my @p =
231 ($deviation != 0) ?
232 $NORMAL->utp( map { ($now - $_ - $latency) / $deviation } @out ) :
233 map { 0 } @out;
234 for (my $i=0; $i < scalar @out; $i++) {
235 $sent ++; $sent [int(($now - $out[$i]) / SECS_PER_DAY)] ++;
236 $received += $p[$i]; $received[int(($now - $out[$i]) / SECS_PER_DAY)] += $p[$i];
237 };
238 };
239 $received /= $sent if ($sent);
240 for ( 0 .. DAYS - 1 ) {
241 $received[$_] /= $sent[$_] if ($sent[$_]);
242 };
243
244
245
246 return {
247 avr_latency => $latency,
248 avr_reliability => $received,
249 latency_day => \@latency,
250 reliability_day => \@received
251 };
252 };
253
254 sub read_file($;$) {
255 my ($name, $fail_ok) = @_;
256
257 unless (open (F, $name)) {
258 Echolot::Log::warn("Could not open '$name': $!.") unless ($fail_ok);
259 return undef;
260 };
261 local $/ = undef;
262 my $result = <F>;
263 close (F);
264
265 return $result;
266 };
267
268 sub write_file($$$$) {
269 my ($filebasename, $html_template, $expires, $output) = @_;
270
271 my $filename = $filebasename.'.txt';
272 open(F, '>'.$filename) or
273 Echolot::Log::warn("Cannot open $filename: $!."),
274 return 0;
275 print F $output;
276 close (F);
277 if (defined $expires) {
278 Echolot::Tools::write_meta_information($filename,
279 Expires => time + $expires) or
280 Echolot::Log::debug ("Error while writing meta information for $filename."),
281 return 0;
282 };
283 return 1 unless defined $html_template;
284
285 if (defined $output) {
286 $output =~ s/&/&amp;/g;
287 $output =~ s/"/&quot;/g;
288 $output =~ s/</&lt;/g;
289 $output =~ s/>/&gt;/g;
290 };
291 Echolot::Tools::write_HTML_file($filebasename, $html_template, $expires, list => $output);
292
293 return 1;
294 };
295
296 sub build_mlist1($$$$$;$) {
297 my ($rems, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
298
299 my $output = '';
300 $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
301 $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
302 $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
303
304 $output .= sprintf "Last update: %s\n", make_date();
305 $output .= sprintf "mixmaster history latency uptime\n";
306 $output .= sprintf "--------------------------------------------\n";
307
308 for my $remailer (@$rems) {
309 $output .= sprintf "%-14s %-12s %8s %6.2f%%\n",
310 substr($remailer->{'nick'},0,14),
311 build_list1_latencystr($remailer->{'stats'}->{'latency_day'}),
312 make_min_hr($remailer->{'stats'}->{'avr_latency'}, 1),
313 $remailer->{'stats'}->{'avr_reliability'} * 100;
314 };
315
316 write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
317 Echolot::Log::debug("writefile failed."),
318 return 0;
319 return 1;
320 };
321
322 sub build_rlist1($$$$$;$) {
323 my ($rems, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
324
325 my $output = '';
326 for my $remailer (sort {$a->{'caps'} cmp $b->{'caps'}} @$rems) {
327 $output .= $remailer->{'caps'}."\n"
328 }
329
330 $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
331 $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
332 $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
333
334 $output .= sprintf "\n";
335 $output .= sprintf "Last update: %s\n", make_date();
336 $output .= sprintf "remailer email address history latency uptime\n";
337 $output .= sprintf "-----------------------------------------------------------------------\n";
338
339 for my $remailer (@$rems) {
340 $output .= sprintf "%-8s %-32s %-12s %8s %6.2f%%\n",
341 substr($remailer->{'nick'},0,8),
342 substr($remailer->{'address'},0,32),
343 build_list1_latencystr($remailer->{'stats'}->{'latency_day'}),
344 make_min_hr($remailer->{'stats'}->{'avr_latency'}, 1),
345 $remailer->{'stats'}->{'avr_reliability'} * 100;
346 };
347
348
349 write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
350 Echolot::Log::debug("writefile failed."),
351 return 0;
352 return 1;
353 };
354
355
356 sub build_list2($$$$$$;$) {
357 my ($rems, $type, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
358
359 my $output = '';
360
361 $output .= sprintf "Stats-Version: 2.0\n";
362 $output .= sprintf "Generated: %s\n", make_date();
363 $output .= sprintf "%-12s Latent-Hist Latent Uptime-Hist Uptime Options\n", ($type == 1 ? 'Cypherpunk' : $type == 2 ? 'Mixmaster' : "Type $type");
364 $output .= sprintf "------------------------------------------------------------------------\n";
365
366 for my $remailer (@$rems) {
367 $output .= sprintf "%-12s %-12s %6s %-12s %5.1f%% %s\n",
368 substr($remailer->{'nick'},0,12),
369 build_list2_latencystr($remailer->{'stats'}->{'latency_day'}),
370 make_min_hr($remailer->{'stats'}->{'avr_latency'}, 0),
371 build_list2_reliabilitystr($remailer->{'stats'}->{'reliability_day'}),
372 $remailer->{'stats'}->{'avr_reliability'} * 100,
373 build_list2_capsstr($remailer->{'caps'});
374 };
375
376 $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
377 $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
378 $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
379
380 $output .= sprintf "\n\n\nRemailer-Capabilities:\n\n";
381 for my $remailer (sort {$a->{'caps'} cmp $b->{'caps'}} @$rems) {
382 $output .= $remailer->{'caps'}."\n" if defined $remailer->{'caps'};
383 }
384
385 write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
386 Echolot::Log::debug("writefile failed."),
387 return 0;
388 return 1;
389 };
390
391 sub build_clist($$$$$;$) {
392 my ($remhash, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
393
394 my $output = '';
395
396 $output .= sprintf "Stats-Version: 2.0.1\n";
397 $output .= sprintf "Generated: %s\n", make_date();
398 $output .= sprintf "Mixmaster Latent-Hist Latent Uptime-Hist Uptime Options Type\n";
399 $output .= sprintf "------------------------------------------------------------------------------------\n";
400
401 my $all;
402 for my $type (keys %$remhash) {
403 for my $remailer (@{$remhash->{$type}}) {
404 $all->{ $remailer->{'nick'} }->{$type} = $remailer
405 };
406 };
407
408 for my $nick (sort {$a cmp $b} keys %$all) {
409 for my $type (sort {$a cmp $b} keys %{$all->{$nick}}) {
410 $output .= sprintf "%-12s %-12s %6s %-12s %5.1f%% %s %s\n",
411 $nick,
412 build_list2_latencystr($all->{$nick}->{$type}->{'stats'}->{'latency_day'}),
413 make_min_hr($all->{$nick}->{$type}->{'stats'}->{'avr_latency'}, 0),
414 build_list2_reliabilitystr($all->{$nick}->{$type}->{'stats'}->{'reliability_day'}),
415 $all->{$nick}->{$type}->{'stats'}->{'avr_reliability'} * 100,
416 build_list2_capsstr($all->{$nick}->{$type}->{'caps'}),
417 $type;
418 };
419 };
420
421 $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
422 $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
423 $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
424
425 $output .= sprintf "\n\n\nRemailer-Capabilities:\n\n";
426 for my $nick (sort {$a cmp $b} keys %$all) {
427 for my $type (keys %{$all->{$nick}}) {
428 $output .= $all->{$nick}->{$type}->{'caps'}."\n", last if defined $all->{$nick}->{$type}->{'caps'};
429 };
430 }
431
432 write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
433 Echolot::Log::debug("writefile failed."),
434 return 0;
435 return 1;
436 };
437
438
439 sub build_rems($) {
440 my ($types) = @_;
441
442 my %rems;
443 for my $remailer (Echolot::Globals::get()->{'storage'}->get_remailers()) {
444 my $addr = $remailer->{'address'};
445 my $has_type = 0;
446 for my $type (@$types) {
447 $has_type = 1, last if (Echolot::Globals::get()->{'storage'}->has_type($addr, $type));
448 };
449 next unless $has_type;
450
451 my $rem = {
452 'stats' => calculate($addr,$types),
453 'nick' => Echolot::Globals::get()->{'storage'}->get_nick($addr),
454 'caps' => Echolot::Globals::get()->{'storage'}->get_capabilities($addr),
455 'address' => $addr,
456 'showit' => $remailer->{'showit'}
457 };
458 $rem->{'latency'} = $rem->{'stats'}->{'avr_latency'}; # for sorting purposes only
459 $rem->{'latency'} = 9999 unless defined $rem->{'latency'};
460
461 $rems{$addr} = $rem if (defined $rem->{'stats'} && defined $rem->{'nick'} && defined $rem->{'address'} && defined $rem->{'caps'} );
462 };
463
464 my $sort_by_latency = Echolot::Config::get()->{'stats_sort_by_latency'};
465 my @rems =
466 sort {
467 - ($a->{'stats'}->{'avr_reliability'} <=> $b->{'stats'}->{'avr_reliability'}) ||
468 (($a->{'latency'} <=> $b->{'latency'}) * $sort_by_latency) ||
469 ($a->{'nick'} cmp $b->{'nick'})
470 } map { $rems{$_} } keys %rems;
471
472 return \@rems;
473 };
474
475 sub build_lists() {
476
477 my $clist;
478 my $pubclist;
479 my $rems;
480 my $pubrems;
481
482 my %stats;
483 my %addresses;
484
485 my $broken1 = read_file( Echolot::Config::get()->{'broken1'}, 1);
486 my $broken2 = read_file( Echolot::Config::get()->{'broken2'}, 1);
487 my $sameop = read_file( Echolot::Config::get()->{'sameop'}, 1);
488
489 $rems = build_rems(['mix']);
490 @$pubrems = grep { $_->{'showit'} } @$rems;
491 build_mlist1( $rems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'mlist', 'mlist');
492 build_list2( $rems, 2, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'mlist2', 'mlist2');
493 build_mlist1( $pubrems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'mlist', 'mlist');
494 build_list2( $pubrems, 2, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'mlist2', 'mlist2');
495 $stats{'mix_total'} = scalar @$pubrems;
496 $stats{'mix_98'} = scalar grep { $_->{'stats'}->{'avr_reliability'} >= 0.98 } @$pubrems;
497 $addresses{$_->{'address'}}=1 for @$pubrems;
498 if (Echolot::Config::get()->{'combined_list'}) {
499 $clist->{'mix'} = $rems;
500 $pubclist->{'mix'} = $pubrems; $pubrems = undef;
501 };
502
503 $rems = build_rems(['cpunk-rsa', 'cpunk-dsa', 'cpunk-clear']);
504 @$pubrems = grep { $_->{'showit'} } @$rems;
505 build_rlist1( $rems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist', 'rlist');
506 build_list2( $rems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2', 'rlist2');
507 build_rlist1( $pubrems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist', 'rlist');
508 build_list2( $pubrems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2', 'rlist2');
509 $stats{'cpunk_total'} = scalar @$pubrems;
510 $stats{'cpunk_98'} = scalar grep { $_->{'stats'}->{'avr_reliability'} >= 0.98 } @$pubrems;
511 $addresses{$_->{'address'}}=1 for @$pubrems;
512 if (Echolot::Config::get()->{'combined_list'} && ! Echolot::Config::get()->{'separate_rlists'}) {
513 $clist->{'cpunk'} = $rems;
514 $pubclist->{'cpunk'} = $pubrems; $pubrems = undef;
515 };
516
517 if (Echolot::Config::get()->{'separate_rlists'}) {
518 $rems = build_rems(['cpunk-rsa']);
519 @$pubrems = grep { $_->{'showit'} } @$rems;
520 build_rlist1( $rems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist-rsa', 'rlist-rsa');
521 build_list2( $rems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2-rsa', 'rlist2-rsa');
522 build_rlist1( $pubrems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist-rsa', 'rlist-rsa');
523 build_list2( $pubrems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2-rsa', 'rlist2-rsa');
524 if (Echolot::Config::get()->{'combined_list'}) {
525 $clist->{'cpunk-rsa'} = $rems;
526 $pubclist->{'cpunk-rsa'} = $pubrems; $pubrems = undef;
527 };
528
529 $rems = build_rems(['cpunk-dsa']);
530 @$pubrems = grep { $_->{'showit'} } @$rems;
531 build_rlist1( $rems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist-dsa', 'rlist-dsa');
532 build_list2( $rems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2-dsa', 'rlist2-dsa');
533 build_rlist1( $pubrems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist-dsa', 'rlist-dsa');
534 build_list2( $pubrems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2-dsa', 'rlist2-dsa');
535 if (Echolot::Config::get()->{'combined_list'}) {
536 $clist->{'cpunk-dsa'} = $rems;
537 $pubclist->{'cpunk-dsa'} = $pubrems; $pubrems = undef;
538 };
539
540 $rems = build_rems(['cpunk-clear']);
541 @$pubrems = grep { $_->{'showit'} } @$rems;
542 build_rlist1( $rems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist-clear', 'rlist-clear');
543 build_list2( $rems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2-clear', 'rlist2-clear');
544 build_rlist1( $pubrems, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist-clear', 'rlist-clear');
545 build_list2( $pubrems, 1, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2-clear', 'rlist2-clear');
546 if (Echolot::Config::get()->{'combined_list'}) {
547 $clist->{'cpunk-clear'} = $rems;
548 $pubclist->{'cpunk-clear'} = $pubrems; $pubrems = undef;
549 };
550 };
551 if (Echolot::Config::get()->{'combined_list'}) {
552 build_clist( $clist, $broken1, $broken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'clist', 'clist');
553 build_clist( $pubclist, $broken1, $broken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'clist', 'clist');
554 };
555
556 $stats{'unique_addresses'} = scalar keys %addresses;
557 Echolot::Tools::write_HTML_file(
558 Echolot::Config::get()->{'resultdir'}.'/'.Echolot::Config::get()->{'indexfilebasename'},
559 'indexfile',
560 Echolot::Config::get()->{'buildstats'},
561 %stats );
562
563 my $file = Echolot::Config::get()->{'echolot_css'},
564 my $css;
565 {
566 local $/ = undef;
567 open(F, $file) or
568 Echolot::Log::warn("Could not open $file: $!."),
569 return 0;
570 $css = <F>;
571 close (F) or
572 Echolot::Log::warn("Cannot close $file: $!."),
573 return 0;
574 }
575 $file = Echolot::Config::get()->{'resultdir'}.'/echolot.css';
576 open(F, '>'.$file) or
577 Echolot::Log::warn("Cannot open $file: $!."),
578 return 0;
579 print F $css or
580 Echolot::Log::warn("Cannot print to $file: $!."),
581 return 0;
582 close (F) or
583 Echolot::Log::warn("Cannot close $file: $!."),
584 return 0;
585
586 };
587
588
589 sub build_mixring() {
590 my @filenames;
591
592 my $filename = Echolot::Config::get()->{'resultdir'}.'/pubring.mix';
593 push @filenames, $filename;
594 open(F, '>'.$filename) or
595 Echolot::Log::warn("Cannot open $filename: $!."),
596 return 0;
597 $filename = Echolot::Config::get()->{'resultdir'}.'/type2.list';
598 push @filenames, $filename;
599 open(T2L, '>'.$filename) or
600 Echolot::Log::warn("Cannot open $filename: $!."),
601 return 0;
602 $filename = Echolot::Config::get()->{'private_resultdir'}.'/pubring.mix';
603 push @filenames, $filename;
604 open(F_PRIV, '>'.$filename) or
605 Echolot::Log::warn("Cannot open $filename: $!."),
606 return 0;
607 $filename = Echolot::Config::get()->{'private_resultdir'}.'/type2.list';
608 push @filenames, $filename;
609 open(T2L_PRIV, '>'.$filename) or
610 Echolot::Log::warn("Cannot open $filename: $!."),
611 return 0;
612
613 my $data;
614 for my $remailer (Echolot::Globals::get()->{'storage'}->get_remailers()) {
615 my $addr = $remailer->{'address'};
616 next unless Echolot::Globals::get()->{'storage'}->has_type($addr, 'mix');
617
618 my %key;
619 for my $keyid (Echolot::Globals::get()->{'storage'}->get_keys($addr, 'mix')) {
620 my %new_key = Echolot::Globals::get()->{'storage'}->get_key($addr, 'mix', $keyid);
621
622 if (!defined $key{'last_update'} || $key{'last_update'} < $new_key{'last_update'} ) {
623 %key = %new_key;
624 };
625 };
626
627 $key{'showit'} = $remailer->{'showit'};
628 if ( defined Echolot::Globals::get()->{'storage'}->get_nick($addr) ) {
629 $data->{$key{'summary'}} = \%key;
630 $data->{$key{'summary'}} = \%key;
631 };
632 };
633
634 for my $indx (sort {$a cmp $b} keys %$data) {
635 my $key = $data->{$indx};
636 if ($key->{'showit'}) {
637 print F $key->{'summary'}."\n\n";
638 print F $key->{'key'},"\n\n";
639 print T2L $key->{'summary'},"\n";
640 };
641 print F_PRIV $key->{'summary'}."\n\n";
642 print F_PRIV $key->{'key'},"\n\n";
643 print T2L_PRIV $key->{'summary'},"\n";
644 };
645
646 close(F);
647 close(T2L);
648 close(F_PRIV);
649 close(T2L_PRIV);
650
651 for my $filename (@filenames) {
652 Echolot::Tools::write_meta_information($filename,
653 Expires => time + Echolot::Config::get()->{'buildkeys'}) or
654 Echolot::Log::debug ("Error while writing meta information for $filename."),
655 return 0;
656 };
657 };
658
659
660
661 sub build_pgpring_type($$$$) {
662 my ($type, $GnuPG, $keyring, $keyids) = @_;
663
664 for my $remailer (Echolot::Globals::get()->{'storage'}->get_remailers()) {
665 my $addr = $remailer->{'address'};
666 next unless Echolot::Globals::get()->{'storage'}->has_type($addr, $type);
667
668 my %key;
669 my $final_keyid;
670 for my $keyid (Echolot::Globals::get()->{'storage'}->get_keys($addr, $type)) {
671 my %new_key = Echolot::Globals::get()->{'storage'}->get_key($addr, $type, $keyid);
672
673 if (!defined $key{'last_update'} || $key{'last_update'} < $new_key{'last_update'} ) {
674 %key = %new_key;
675 $final_keyid = $keyid;
676 };
677 };
678
679 # only if we have a conf
680 if ( defined Echolot::Globals::get()->{'storage'}->get_nick($addr) ) {
681 my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh )
682 = ( IO::Handle->new(),
683 IO::Handle->new(),
684 IO::Handle->new(),
685 IO::Handle->new(),
686 );
687 my $handles = GnuPG::Handles->new (
688 stdin => $stdin_fh,
689 stdout => $stdout_fh,
690 stderr => $stderr_fh,
691 status => $status_fh
692 );
693 my $pid = $GnuPG->wrap_call(
694 commands => [ '--import' ],
695 command_args => [qw{--no-options --no-secmem-warning --no-default-keyring --fast-list-mode --keyring}, $keyring, '--', '-' ],
696 handles => $handles );
697 print $stdin_fh $key{'key'};
698 close($stdin_fh);
699
700 my $stdout = join '', <$stdout_fh>; close($stdout_fh);
701 my $stderr = join '', <$stderr_fh>; close($stderr_fh);
702 my $status = join '', <$status_fh>; close($status_fh);
703
704 waitpid $pid, 0;
705
706 ($stdout eq '') or
707 Echolot::Log::info("GnuPG returned something in stdout '$stdout' while adding key for '$addr': So what?");
708 unless ($status =~ /^^\[GNUPG:\] IMPORTED /m) {
709 if ($status =~ /^^\[GNUPG:\] IMPORT_RES /m) {
710 Echolot::Log::info("GnuPG status '$status' indicates more than one key for '$addr' imported. Ignoring.");
711 } else {
712 Echolot::Log::info("GnuPG status '$status' didn't indicate key for '$addr' was imported correctly. Ignoring.");
713 };
714 };
715 $keyids->{$final_keyid} = $remailer->{'showit'};
716 };
717 };
718
719 return 1;
720 };
721
722 sub build_pgpring_export($$$$) {
723 my ($GnuPG, $keyring, $file, $keyids) = @_;
724
725 my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh )
726 = ( IO::Handle->new(),
727 IO::Handle->new(),
728 IO::Handle->new(),
729 IO::Handle->new(),
730 );
731 my $handles = GnuPG::Handles->new (
732 stdin => $stdin_fh,
733 stdout => $stdout_fh,
734 stderr => $stderr_fh,
735 status => $status_fh
736 );
737 my $pid = $GnuPG->wrap_call(
738 commands => [ '--export' ],
739 command_args => [qw{--no-options --no-secmem-warning --no-default-keyring --keyring}, $keyring, @$keyids ],
740 handles => $handles );
741 close($stdin_fh);
742
743 my $stdout = join '', <$stdout_fh>; close($stdout_fh);
744 my $stderr = join '', <$stderr_fh>; close($stderr_fh);
745 my $status = join '', <$status_fh>; close($status_fh);
746
747 waitpid $pid, 0;
748
749 open (F, ">$file") or
750 Echolot::Log::warn ("Cannot open '$file': $!."),
751 return 0;
752 print F $stdout;
753 close F;
754
755 Echolot::Tools::write_meta_information($file,
756 Expires => time + Echolot::Config::get()->{'buildkeys'}) or
757 Echolot::Log::debug ("Error while writing meta information for $file."),
758 return 0;
759
760 return 1;
761 };
762
763 sub build_pgpring() {
764 my $GnuPG = new GnuPG::Interface;
765 $GnuPG->call( Echolot::Config::get()->{'gnupg'} ) if (Echolot::Config::get()->{'gnupg'});
766 $GnuPG->options->hash_init(
767 armor => 1,
768 homedir => Echolot::Config::get()->{'gnupghome'} );
769 $GnuPG->options->meta_interactive( 0 );
770
771 my $keyring = Echolot::Config::get()->{'tmpdir'}.'/'.
772 Echolot::Globals::get()->{'hostname'}.".".time.'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internalcounter'}++.'.keyring';
773
774
775 my $keyids = {};
776 build_pgpring_type('cpunk-rsa', $GnuPG, $keyring, $keyids) or
777 Echolot::Log::debug("build_pgpring_type failed."),
778 return undef;
779
780 build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'resultdir'}.'/pgp-rsa.asc', [ grep {$keyids->{$_}} keys %$keyids ]) or
781 Echolot::Log::debug("build_pgpring_export failed."),
782 return undef;
783
784 build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'private_resultdir'}.'/pgp-rsa.asc', [ keys %$keyids ]) or
785 Echolot::Log::debug("build_pgpring_export failed."),
786 return undef;
787
788 build_pgpring_type('cpunk-dsa', $GnuPG, $keyring, $keyids) or
789 Echolot::Log::debug("build_pgpring_type failed."),
790 return undef;
791
792 build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'resultdir'}.'/pgp-all.asc', [ grep {$keyids->{$_}} keys %$keyids ]) or
793 Echolot::Log::debug("build_pgpring_export failed."),
794 return undef;
795
796 build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'private_resultdir'}.'/pgp-all.asc', [ keys %$keyids ]) or
797 Echolot::Log::debug("build_pgpring_export failed."),
798 return undef;
799
800
801 unlink ($keyring) or
802 Echolot::Log::warn("Cannot unlink tmp keyring '$keyring'."),
803 return undef;
804 unlink ($keyring.'~'); # gnupg does those evil backups
805 };
806
807 sub build_stats() {
808 build_lists();
809 };
810 sub build_keys() {
811 build_mixring();
812 build_pgpring();
813 };
814
815 1;
816 # vim: set ts=4 shiftwidth=4:

  ViewVC Help
Powered by ViewVC 1.1.5