| 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/&/&/g;
|
| 287 |
$output =~ s/"/"/g;
|
| 288 |
$output =~ s/</</g;
|
| 289 |
$output =~ s/>/>/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:
|