summaryrefslogtreecommitdiff
path: root/trunk/Echolot
diff options
context:
space:
mode:
authorPeter Palfrader <peter@palfrader.org>2006-03-06 15:10:03 +0000
committerPeter Palfrader <peter@palfrader.org>2006-03-06 15:10:03 +0000
commit0a27014ee8ba24a3ca3d78cefdeda8ba391e42ba (patch)
tree2d08c30a4ece1139d9f203be2ecc3b25a45bfec4 /trunk/Echolot
parent0468b8a264c429c66a92ff56e012f6f794603f09 (diff)
Tag as release_2_1_8-4, againecholot-2.1.8-4
Diffstat (limited to 'trunk/Echolot')
-rw-r--r--trunk/Echolot/Chain.pm266
-rw-r--r--trunk/Echolot/Commands.pm131
-rw-r--r--trunk/Echolot/Conf.pm531
-rw-r--r--trunk/Echolot/Config.pm344
-rw-r--r--trunk/Echolot/Fromlines.pm126
-rw-r--r--trunk/Echolot/Globals.pm60
-rw-r--r--trunk/Echolot/Log.pm163
-rw-r--r--trunk/Echolot/Mailin.pm252
-rw-r--r--trunk/Echolot/Pinger.pm211
-rw-r--r--trunk/Echolot/Pinger/CPunk.pm205
-rw-r--r--trunk/Echolot/Pinger/Mix.pm139
-rw-r--r--trunk/Echolot/Report.pm70
-rw-r--r--trunk/Echolot/Scheduler.pm196
-rw-r--r--trunk/Echolot/Stats.pm983
-rw-r--r--trunk/Echolot/Storage/File.pm1880
-rw-r--r--trunk/Echolot/Thesaurus.pm144
-rw-r--r--trunk/Echolot/Tools.pm476
17 files changed, 6177 insertions, 0 deletions
diff --git a/trunk/Echolot/Chain.pm b/trunk/Echolot/Chain.pm
new file mode 100644
index 0000000..463adeb
--- /dev/null
+++ b/trunk/Echolot/Chain.pm
@@ -0,0 +1,266 @@
+package Echolot::Chain;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Chain - actual sending and receiving of Chain-Pings.
+
+=head1 DESCRIPTION
+
+This package provides functions for sending out and receiving chain-pings.
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+use Echolot::Pinger::Mix;
+use Echolot::Pinger::CPunk;
+
+my %INTENSIVE_CARE;
+
+sub do_mix_chainping($$$$$$$$) {
+ my ($addr1, $type1, $keyid1, $addr2, $type2, $keyid2, $to, $body) = @_;
+
+ ($type1 eq 'mix' && $type2 eq 'mix') or
+ Echolot::Log::warn("both types should really be mix ($type1, $type2)."),
+ return 0;
+
+ my %key1 = Echolot::Globals::get()->{'storage'}->get_key($addr1, $type1, $keyid1);
+ my %key2 = Echolot::Globals::get()->{'storage'}->get_key($addr2, $type2, $keyid2);
+ Echolot::Pinger::Mix::ping(
+ $body,
+ $to,
+ 0,
+ [ $key1{'nick'} , $key2{'nick'} ],
+ { $keyid1 => \%key1, $keyid2 => \%key2 } ) or
+ return 0;
+
+ return 1;
+};
+
+sub do_cpunk_chainping($$$$$$$$) {
+ my ($addr1, $type1, $keyid1, $addr2, $type2, $keyid2, $to, $body) = @_;
+
+ my $keyhash = {};
+ if ($type1 ne 'cpunk-clear') {
+ my %key = Echolot::Globals::get()->{'storage'}->get_key($addr1, $type1, $keyid1);
+ $keyhash->{$keyid1} = \%key;
+ };
+ if ($type2 ne 'cpunk-clear') {
+ my %key = Echolot::Globals::get()->{'storage'}->get_key($addr2, $type2, $keyid2);
+ $keyhash->{$keyid2} = \%key;
+ };
+ Echolot::Pinger::CPunk::ping(
+ $body,
+ $to,
+ 0,
+ [ { address => $addr1,
+ keyid => $keyid1,
+ encrypt => ($type1 ne 'cpunk-clear'),
+ pgp2compat => ($type1 eq 'cpunk-rsa') },
+ { address => $addr2,
+ keyid => $keyid2,
+ encrypt => ($type2 ne 'cpunk-clear'),
+ pgp2compat => ($type2 eq 'cpunk-rsa') } ],
+ $keyhash ) or
+ return 0;
+
+ return 1;
+};
+
+sub do_chainping($$$$$$$) {
+ my ($chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2) = @_;
+
+ my $now = time();
+ my $token = join(':', $chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2, $now);
+ my $mac = Echolot::Tools::make_mac($token);
+ my $body = "chaintype: $chaintype\n".
+ "remailer1: $addr1\n".
+ "type1: $type1\n".
+ "key1: $key1\n".
+ "remailer2: $addr2\n".
+ "type2: $type2\n".
+ "key2: $key2\n".
+ "sent: $now\n".
+ "mac: $mac\n".
+ Echolot::Tools::make_garbage();
+ $body = Echolot::Tools::crypt_symmetrically($body, 'encrypt');
+
+ my $to = Echolot::Tools::make_address('chainping');
+ if ($chaintype eq 'mix') {
+ do_mix_chainping($addr1, $type1, $key1, $addr2, $type2, $key2, $to, $body);
+ } elsif ($chaintype eq 'cpunk') {
+ do_cpunk_chainping($addr1, $type1, $key1, $addr2, $type2, $key2, $to, $body);
+ } else {
+ Echolot::Log::warn("Don't know how to handle chain ping type $chaintype.");
+ return 0;
+ };
+
+ Echolot::Globals::get()->{'storage'}->register_chainpingout($chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2, $now);
+ return 1;
+};
+
+sub send_pings($;$$) {
+ return 1 unless Echolot::Config::get()->{'do_chainpings'};
+
+ my ($scheduled_for, $which1, $which2) = @_;
+
+ $which1 = '' unless defined $which1;
+ $which2 = '' unless defined $which2;
+
+ my $call_intervall = Echolot::Config::get()->{'chainpinger_interval'};
+ my $send_every_n_calls = Echolot::Config::get()->{'chainping_every_nth_time'};
+
+ my $timemod = int ($scheduled_for / $call_intervall);
+ my $this_call_id = $timemod % $send_every_n_calls;
+ my $session_id = int ($scheduled_for / ($call_intervall * $send_every_n_calls));
+
+ # Same thing for Intensive Care -- yet unknown or already broken chains
+ my $send_every_n_calls_ic = Echolot::Config::get()->{'chainping_ic_every_nth_time'};
+
+ my $timemod_ic = int ($scheduled_for / $call_intervall);
+ my $this_call_id_ic = $timemod_ic % $send_every_n_calls_ic;
+ my $session_id_ic = int ($scheduled_for / ($call_intervall * $send_every_n_calls_ic));
+
+ my @remailers = Echolot::Globals::get()->{'storage'}->get_addresses();
+ for my $chaintype (keys %{Echolot::Config::get()->{'which_chainpings'}}) {
+
+ my @thisrems;
+ for my $rem (@remailers) {
+ next unless $rem->{'pingit'};
+ my $addr = $rem->{'address'};
+ my $type;
+ my %supports = map { $_ => 1 } Echolot::Globals::get()->{'storage'}->get_types($addr);
+ for my $thistype (@{Echolot::Config::get()->{'which_chainpings'}->{$chaintype}}) {
+ $type = $thistype, last if $supports{$thistype};
+ };
+ next unless $type;
+ my $key;
+ my $latest = 0;
+ for my $keyid (Echolot::Globals::get()->{'storage'}->get_keys($addr, $type)) {
+ my %key = Echolot::Globals::get()->{'storage'}->get_key($addr, $type, $keyid);
+ $key = $keyid, $latest = $key{'last_update'} if $latest < $key{'last_update'};
+ };
+ push @thisrems, { addr => $addr, type => $type, key => $key };
+ };
+
+ for my $rem1 (@thisrems) {
+ my $addr1 = $rem1->{'addr'};
+
+ next unless (
+ $which1 eq 'all' ||
+ $which1 eq $addr1 ||
+ $which1 eq '');
+
+ my $type1 = $rem1->{'type'};
+ my $key1 = $rem1->{'key'};
+
+ for my $rem2 (@thisrems) {
+ my $addr2 = $rem2->{'addr'};
+ next if $rem1 eq $rem2 && (! ($which1 eq $addr2 && $which2 eq $addr2));
+
+ next unless (
+ $which2 eq 'all' ||
+ $which2 eq $addr2 ||
+ $which2 eq '');
+
+ my $type2 = $rem2->{'type'};
+ my $key2 = $rem2->{'key'};
+
+ my $call_id = Echolot::Tools::makeShortNumHash($addr1.$addr2.$chaintype.$session_id ) % $send_every_n_calls;
+ my $call_id_ic = Echolot::Tools::makeShortNumHash($addr1.$addr2.$chaintype.$session_id_ic) % $send_every_n_calls_ic;
+ next unless (
+ (($which1 eq $addr1 || $which1 eq 'all' ) && ($which2 eq $addr2 || $which2 eq 'all')) ||
+ (($which1 eq '' && $which2 eq '') && (
+ $this_call_id eq $call_id ||
+ (defined $INTENSIVE_CARE{$chaintype}->{$addr1.' '.$addr2} && $this_call_id_ic eq $call_id_ic))));
+
+ Echolot::Log::debug("chainping calling $chaintype, $addr1 ($type1, $key1) - $addr2 ($type2, $key2)");
+ do_chainping($chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2);
+ };
+ };
+ };
+ return 1;
+};
+
+sub set_intensive_care($@) {
+ my ($chaintype, $intensive_care) = @_;
+
+ %{$INTENSIVE_CARE{$chaintype}} = map { ($_->{'addr1'}.' '.$_->{'addr2'}) => $_->{'reason'} } @$intensive_care;
+ if (scalar @$intensive_care) {
+ Echolot::Log::debug("intensive care $chaintype:\n" . join("\n", sort { $a cmp $b } map { "$_: $INTENSIVE_CARE{$chaintype}->{$_}" } keys %{$INTENSIVE_CARE{$chaintype}} ));
+ } else {
+ Echolot::Log::debug("intensive care $chaintype: (none)");
+ };
+};
+
+sub receive($$$$) {
+ my ($header, $msg, $token, $timestamp) = @_;
+
+ my $now = time();
+
+ my $body;
+ if ($msg =~ /^-----BEGIN PGP MESSAGE-----/m) {
+ # work around borken middleman remailers that have a problem with some
+ # sort of end of line characters and randhopping them through reliable
+ # remailers..
+ # they add an empty line between each usefull line
+ $msg =~ s/(\r?\n)\r?\n/$1/g if ($msg =~ /^-----BEGIN PGP MESSAGE-----\r?\n\r?\n/m);
+ $body = Echolot::Tools::crypt_symmetrically($msg, 'decrypt');
+ };
+ $body = $msg unless defined $body;
+
+ my ($chaintype) = $body =~ /^chaintype: (.*)$/m;
+ my ($addr1) = $body =~ /^remailer1: (.*)$/m;
+ my ($type1) = $body =~ /^type1: (.*)$/m;
+ my ($key1) = $body =~ /^key1: (.*)$/m;
+ my ($addr2) = $body =~ /^remailer2: (.*)$/m;
+ my ($type2) = $body =~ /^type2: (.*)$/m;
+ my ($key2) = $body =~ /^key2: (.*)$/m;
+ my ($sent) = $body =~ /^sent: (.*)$/m;
+ my ($mac) = $body =~ /^mac: (.*)$/m;
+
+ my @values = ($chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2, $sent, $mac);
+ my $cleanstring = join ":", map { defined() ? $_ : "undef" } @values;
+
+ (grep { ! defined() } @values) and
+ Echolot::Log::warn("Received chainping at $timestamp has undefined values: $cleanstring."),
+ return 0;
+
+ pop @values;
+ Echolot::Tools::verify_mac(join(':', @values), $mac) or
+ Echolot::Log::warn("Received chainping at $timestamp has wrong mac; $cleanstring."),
+ return 0;
+
+ Echolot::Globals::get()->{'storage'}->register_chainpingdone($chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2, $sent, $now - $sent) or
+ return 0;
+
+ return 1;
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Commands.pm b/trunk/Echolot/Commands.pm
new file mode 100644
index 0000000..0602bf2
--- /dev/null
+++ b/trunk/Echolot/Commands.pm
@@ -0,0 +1,131 @@
+package Echolot::Commands;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Commands - manage commands like add key, set ttl etc.
+
+=head1 DESCRIPTION
+
+This package provides functions for sending out and receiving pings.
+
+=cut
+
+use strict;
+use Echolot::Log;
+use Fcntl ':flock'; # import LOCK_* constants
+#use Fcntl ':seek'; # import SEEK_* constants
+use POSIX; # import SEEK_* constants (older perls don't have SEEK_ in Fcntl)
+use English;
+
+sub addCommand($) {
+ my ($command) = @_;
+
+ my $filename = Echolot::Config::get()->{'commands_file'};
+ open(FH, ">>$filename" ) or
+ Echolot::Log::warn("Cannot open $filename for appending $!."),
+ return 0;
+ flock(FH, LOCK_EX) or
+ Echolot::Log::warn("Cannot get exclusive lock on $filename: $!."),
+ return 0;
+
+ print FH $command,"\n";
+
+ flock(FH, LOCK_UN) or
+ Echolot::Log::warn("Cannot unlock $filename: $!.");
+ close(FH) or
+ Echolot::Log::warn("Cannot close $filename: $!.");
+};
+
+sub processCommands($) {
+ my $filename = Echolot::Config::get()->{'commands_file'};
+
+ (-e $filename) or
+ return 1;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks)= stat $filename;
+ ($size > 0) or
+ return 1;
+
+ open(FH, "+<$filename" ) or
+ Echolot::Log::warn("Cannot open $filename for reading: $!."),
+ return 0;
+ flock(FH, LOCK_EX) or
+ Echolot::Log::warn("Cannot get exclusive lock on $filename: $!."),
+ return 0;
+
+
+ while (<FH>) {
+ chomp;
+ my ($command, @args) = split;
+
+ if ($command eq 'add') {
+ Echolot::Globals::get()->{'storage'}->add_address(@args);
+ } elsif ($command eq 'set') {
+ Echolot::Globals::get()->{'storage'}->set_stuff(@args);
+ } elsif ($command eq 'getkeyconf') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('getkeyconf', 0, time(), \@args );
+ } elsif ($command eq 'sendpings') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('ping', 0, time(), \@args );
+ } elsif ($command eq 'sendchainpings') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('chainping', 0, time(), \@args );
+ } elsif ($command eq 'buildstats') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('buildstats', 0, time() );
+ } elsif ($command eq 'buildkeys') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('buildkeys', 0, time() );
+ } elsif ($command eq 'buildthesaurus') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('buildthesaurus', 0, time() );
+ } elsif ($command eq 'buildfromlines') {
+ Echolot::Globals::get()->{'scheduler'}->schedule('buildfromlines', 0, time() );
+ } elsif ($command eq 'summary') {
+ @args = ('manual');
+ Echolot::Globals::get()->{'scheduler'}->schedule('summary', 0, time(), \@args );
+ } elsif ($command eq 'delete') {
+ Echolot::Globals::get()->{'storage'}->delete_remailer(@args);
+ } elsif ($command eq 'setremailercaps') {
+ my $addr = shift @args;
+ my $conf = join(' ', @args);
+ Echolot::Conf::set_caps_manually($addr, $conf);
+ } elsif ($command eq 'deleteremailercaps') {
+ Echolot::Globals::get()->{'storage'}->delete_remailercaps(@args);
+ } else {
+ Echolot::Log::warn("Unkown command: '$_'.");
+ };
+ };
+
+ seek(FH, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start '$filename': $!."),
+ return 0;
+ truncate(FH, 0) or
+ Echolot::Log::warn("Cannot truncate '$filename' to zero length: $!."),
+ return 0;
+ flock(FH, LOCK_UN) or
+ Echolot::Log::warn("Cannot unlock '$filename': $!.");
+ close(FH) or
+ Echolot::Log::warn("Cannot close '$filename': $!.");
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Conf.pm b/trunk/Echolot/Conf.pm
new file mode 100644
index 0000000..2bfa582
--- /dev/null
+++ b/trunk/Echolot/Conf.pm
@@ -0,0 +1,531 @@
+package Echolot::Conf;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Conf - remailer Configuration/Capabilities
+
+=head1 DESCRIPTION
+
+This package provides functions for requesting, parsing, and analyzing
+remailer-conf and remailer-key replies.
+
+=head1 CAVEATS
+
+When parsing OpenPGP keys only the address of the primary user id is taken into
+account (This is the one with the latest self signature I think).
+
+=cut
+
+use strict;
+use Echolot::Log;
+use GnuPG::Interface;
+
+
+sub is_not_a_remailer($) {
+ my ($reply) = @_;
+ if ($reply =~ /^\s* not \s+ a \s+ remailer\b/xi) {
+ return 1;
+ } else {
+ return 0;
+ };
+};
+
+sub send_requests($;$) {
+ my ($scheduled_for, $which) = @_;
+
+ $which = '' unless defined $which;
+
+ my $call_intervall = Echolot::Config::get()->{'getkeyconf_interval'};
+ my $send_every_n_calls = Echolot::Config::get()->{'getkeyconf_every_nth_time'};
+
+ my $timemod = int ($scheduled_for / $call_intervall);
+ my $this_call_id = $timemod % $send_every_n_calls;
+ my $session_id = int ($scheduled_for / ($call_intervall * $send_every_n_calls));
+
+ Echolot::Globals::get()->{'storage'}->delay_commit();
+
+ for my $remailer (Echolot::Globals::get()->{'storage'}->get_addresses()) {
+ next unless ($remailer->{'status'} eq 'active');
+ next unless ($remailer->{'fetch'});
+ my $address = $remailer->{'address'};
+
+ next unless (
+ $which eq 'all' ||
+ $which eq $address ||
+ $which eq '');
+
+ for my $type (qw{conf key help stats adminkey}) {
+
+ next unless (
+ $which eq $address ||
+ $which eq 'all' ||
+ (($which eq '') && ($this_call_id == (Echolot::Tools::makeShortNumHash($address.$type.$session_id) % $send_every_n_calls))));
+
+ Echolot::Log::debug("Sending $type request to ".$address.".");
+
+ my $source_text = Echolot::Config::get()->{'remailerxxxtext'};
+ my $template = HTML::Template->new(
+ scalarref => \$source_text,
+ strict => 0,
+ global_vars => 1 );
+ $template->param ( address => $address );
+ $template->param ( operator_address => Echolot::Config::get()->{'operator_address'} );
+ my $body = $template->output();
+
+ Echolot::Tools::send_message(
+ 'To' => $address,
+ 'Subject' => 'remailer-'.$type,
+ 'Token' => $type.'.'.$remailer->{'id'},
+ 'Body' => $body);
+
+ Echolot::Globals::get()->{'storage'}->decrease_ttl($address) if (($type eq 'conf') && ($which eq ''));
+ };
+ };
+ Echolot::Globals::get()->{'storage'}->enable_commit();
+};
+
+sub check_resurrection() {
+ Echolot::Globals::get()->{'storage'}->delay_commit();
+ for my $remailer (Echolot::Globals::get()->{'storage'}->get_addresses()) {
+ next unless ($remailer->{'status'} eq 'ttl timeout');
+ next unless ($remailer->{'fetch'});
+ next unless ($remailer->{'resurrection_ttl'});
+ Echolot::Log::debug("Sending request to ".$remailer->{'address'}." to check for resurrection.");
+ for my $type (qw{conf key help stats adminkey}) {
+ Echolot::Tools::send_message(
+ 'To' => $remailer->{'address'},
+ 'Subject' => 'remailer-'.$type,
+ 'Token' => $type.'.'.$remailer->{'id'})
+ };
+ Echolot::Globals::get()->{'storage'}->decrease_resurrection_ttl($remailer->{'address'});
+ };
+ Echolot::Globals::get()->{'storage'}->enable_commit();
+};
+
+
+sub remailer_caps($$$;$) {
+ my ($conf, $token, $time, $dontexpire) = @_;
+
+ my ($id) = $token =~ /^conf\.(\d+)$/;
+ (defined $id) or
+ Echolot::Log::info("Returned token '$token' has no id at all."),
+ return 0;
+
+ Echolot::Log::info("Could not find id in token '$token'."), return 0 unless defined $id;
+ my ($remailer_type) = ($conf =~ /^\s*Remailer-Type:\s* (.*?) \s*$/imx);
+ Echolot::Log::info("No remailer type found in remailer_caps from '$token'."), return 0 unless defined $remailer_type;
+ my ($remailer_caps) = ($conf =~ /^\s*( \$remailer{".*"} \s*=\s* "<.*@.*>.*"; )\s*$/imx);
+ Echolot::Log::info("No remailer caps found in remailer_caps from '$token'."), return 0 unless defined $remailer_caps;
+ my ($remailer_nick, $remailer_address) = ($remailer_caps =~ /^\s* \$remailer{"(.*)"} \s*=\s* "<(.*@.*)>.*"; \s*$/ix);
+ Echolot::Log::info("No remailer nick found in remailer_caps from '$token': '$remailer_caps'."), return 0 unless defined $remailer_nick;
+ Echolot::Log::info("No remailer address found in remailer_caps from '$token': '$remailer_caps'."), return 0 unless defined $remailer_address;
+
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ Echolot::Log::info("No remailer found for id '$id'."), return 0 unless defined $remailer;
+ if ($remailer->{'address'} ne $remailer_address) {
+ # Address mismatch -> Ignore reply and add $remailer_address to prospective addresses
+ Echolot::Log::info("Remailer address mismatch $remailer->{'address'} vs $remailer_address. Adding latter to prospective remailers.");
+ Echolot::Globals::get()->{'storage'}->add_prospective_address($remailer_address, 'self-capsstring-conf', $remailer_address);
+ } else {
+ Echolot::Log::debug("Setting capabilities for $remailer_address");
+ Echolot::Globals::get()->{'storage'}->restore_ttl( $remailer->{'address'} );
+ Echolot::Globals::get()->{'storage'}->set_caps($remailer_type, $remailer_caps, $remailer_nick, $remailer_address, $time, $dontexpire);
+
+ # if remailer is cpunk and not pgponly
+ if (($remailer_caps =~ /\bcpunk\b/) && !($remailer_caps =~ /\bpgponly\b/)) {
+ Echolot::Globals::get()->{'storage'}->set_key(
+ 'cpunk-clear',
+ $remailer_nick,
+ $remailer->{'address'},
+ 'N/A',
+ 'none',
+ 'N/A',
+ 'N/A',
+ 'N/A',
+ $time);
+ }
+ }
+
+
+ # Fetch prospective remailers from reliable's remailer-conf reply:
+ my @lines = split /\r?\n/, $conf;
+
+ while (1) {
+ my $head;
+ while (@lines) {
+ $head = $lines[0];
+ chomp $head;
+ shift @lines;
+ last if ($head eq 'SUPPORTED CPUNK (TYPE I) REMAILERS' ||
+ $head eq 'SUPPORTED MIXMASTER (TYPE II) REMAILERS');
+ };
+ last unless defined $head;
+ my $wanting = $head eq 'SUPPORTED CPUNK (TYPE I) REMAILERS' ? 1 :
+ $head eq 'SUPPORTED MIXMASTER (TYPE II) REMAILERS' ? 2 :
+ undef;
+ last unless defined $wanting;
+
+ while (@lines) {
+ $head = $lines[0];
+ chomp $head;
+ shift @lines;
+ if ($wanting == 1) {
+ last unless ($head =~ /<(.*?@.*?)>/);
+ Echolot::Globals::get()->{'storage'}->add_prospective_address($1, 'reliable-caps-reply-type1', $remailer_address);
+ } elsif ($wanting == 2) {
+ last unless ($head =~ /\s(.*?@.*?)\s/);
+ Echolot::Globals::get()->{'storage'}->add_prospective_address($1, 'reliable-caps-reply-type2', $remailer_address);
+ } else {
+ Echolot::Log::confess("Shouldn't be here. wanting == $wanting.");
+ };
+ };
+ };
+
+ return 1;
+};
+
+sub remailer_conf($$$) {
+ my ($reply, $token, $time) = @_;
+
+ my ($id) = $token =~ /^conf\.(\d+)$/;
+ (defined $id) or
+ Echolot::Log::info ("Returned token '$token' has no id at all."),
+ return 0;
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ Echolot::Log::info("No remailer found for id '$id'."), return 0 unless defined $remailer;
+ Echolot::Log::debug("Received remailer-conf reply for $remailer."),
+
+ Echolot::Globals::get()->{'storage'}->not_a_remailer($id), return 1
+ if (is_not_a_remailer($reply));
+ Echolot::Thesaurus::save_thesaurus('conf', $id, $reply);
+
+
+ remailer_caps($reply, $token, $time);
+};
+
+sub set_caps_manually($$) {
+ my ($addr, $caps) = @_;
+
+ defined $addr or
+ Echolot::Log::info("Address not defined."),
+ return 0;
+ defined $caps or
+ Echolot::Log::info("Caps not defined."),
+ return 0;
+
+ Echolot::Log::info("Setting caps for $addr manually to $caps.");
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address($addr);
+ defined $remailer or
+ Echolot::Log::info("Remailer address $addr did not give a valid remailer."),
+ return 0;
+ my $id = $remailer->{'id'};
+ defined $id or
+ Echolot::Log::info("Remailer address $addr did not give a remailer with an id."),
+ return 0;
+ my $token = 'conf.'.$id;
+
+ my $conf = "Remailer-Type: set-manually\n$caps";
+ remailer_caps($conf, $token, time, 1);
+
+ return 1;
+};
+
+sub parse_mix_key($$$) {
+ my ($reply, $time, $remailer) = @_;
+
+# -----Begin Mix Key-----
+# 7f6d997678b19ccac110f6e669143126
+# 258
+# AASyedeKiP1/UKyfrBz2K6gIhv4jfXIaHo8dGmwD
+# KqkG3DwytgSySSY3wYm0foT7KvEnkG2aTi/uJva/
+# gymE+tsuM8l8iY1FOiXwHWLDdyUBPbrLjRkgm7GD
+# Y7ogSjPhVLeMpzkSyO/ryeUfLZskBUBL0LxjLInB
+# YBR3o6p/RiT0EQAAAAAAAAAAAAAAAAAAAAAAAAAA
+# AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+# AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+# AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
+# AAAAAAAAAAAAAAAAAAAAAQAB
+# -----End Mix Key-----
+
+ my %mixmasters;
+ # rot26 rot26@mix.uucico.de 7f6d997678b19ccac110f6e669143126 2.9b33 MC
+ my @mix_confs = ($reply =~ /^
+ [a-z0-9]+
+ \s+
+ \S+\@\S+
+ \s+
+ [0-9a-f]{32}
+ .*?$/xmg);
+ my @mix_keys = ($reply =~ /^-----Begin \s Mix \s Key-----\r?\n
+ [0-9a-f]{32}\r?\n
+ \d+\r?\n
+ (?:[a-zA-Z0-9+\/]*\r?\n)+
+ -----End \s Mix \s Key-----$/xmg );
+ for (@mix_confs) {
+ my ($nick, $address, $keyid, $version, $caps, $created, $expires) = /^
+ ([a-z0-9]+)
+ \s+
+ (\S+@\S+)
+ \s+
+ ([0-9a-f]{32})
+ (?: [ \t]+
+ (\S+)
+ (?: [ \t]+
+ (\S+)
+ (?: [ \t]+
+ (\d{4}-\d{2}-\d{2})
+ (?: [ \t]+
+ (\d{4}-\d{2}-\d{2})
+ )?
+ )?
+ )?
+ )? .*?/x;
+ $mixmasters{$keyid} = {
+ nick => $nick,
+ address => $address,
+ version => $version,
+ caps => $caps,
+ created => $created,
+ expires => $expires,
+ summary => $_
+ };
+ };
+ for (@mix_keys) {
+ my ($keyid) = /^-----Begin \s Mix \s Key-----\r?\n
+ ([0-9a-f]{32})\r?\n
+ \d+\r?\n
+ (?:[a-zA-Z0-9+\/]*\r?\n)+
+ -----End \s Mix \s Key-----$/xmg;
+ $mixmasters{$keyid}->{'key'} = $_;
+ };
+
+ for my $keyid (keys %mixmasters) {
+ my $remailer_address = $mixmasters{$keyid}->{'address'};
+ (defined $mixmasters{$keyid}->{'nick'}) or
+ Echolot::Log::info("Could not parse a remailer-key reply."),
+ next;
+ (defined $mixmasters{$keyid}->{'nick'} && ! defined $mixmasters{$keyid}->{'key'}) and
+ Echolot::Log::info("Mixmaster key header without key in reply from $remailer_address."),
+ next;
+ (! defined $mixmasters{$keyid}->{'nick'} && defined $mixmasters{$keyid}->{'key'}) and
+ Echolot::Log::info("Mixmaster key without key header in reply from $remailer_address."),
+ next;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime();
+ my $today = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
+ (defined $mixmasters{$keyid}->{'created'} && ($today lt $mixmasters{$keyid}->{'created'})) and
+ Echolot::Log::info("Mixmaster key for $remailer_address created in the future ($today < ".$mixmasters{$keyid}->{'created'}.")."),
+ next;
+ (defined $mixmasters{$keyid}->{'expires'} && ($mixmasters{$keyid}->{'expires'} lt $today)) and
+ Echolot::Log::info("Mixmaster key for $remailer_address expired (".$mixmasters{$keyid}->{'expires'}." < $today)."),
+ next;
+
+ if ($remailer->{'address'} ne $remailer_address) {
+ # Address mismatch -> Ignore reply and add $remailer_address to prospective addresses
+ Echolot::Log::info("Remailer address mismatch $remailer->{'address'} vs $remailer_address. Adding latter to prospective remailers.");
+ Echolot::Globals::get()->{'storage'}->add_prospective_address($remailer_address, 'self-capsstring-key', $remailer_address);
+ } else {
+ Echolot::Log::debug("Setting mix key for $remailer_address: $keyid");
+ Echolot::Globals::get()->{'storage'}->restore_ttl( $remailer->{'address'} );
+ Echolot::Globals::get()->{'storage'}->set_key(
+ 'mix',
+ $mixmasters{$keyid}->{'nick'},
+ $mixmasters{$keyid}->{'address'},
+ $mixmasters{$keyid}->{'key'},
+ $keyid,
+ $mixmasters{$keyid}->{'version'},
+ $mixmasters{$keyid}->{'caps'},
+ $mixmasters{$keyid}->{'summary'},
+ $time);
+ }
+ };
+
+ return 1;
+};
+
+sub parse_cpunk_key($$$) {
+ my ($reply, $time, $remailer) = @_;
+
+ my $GnuPG = new GnuPG::Interface;
+ $GnuPG->call( Echolot::Config::get()->{'gnupg'} ) if (Echolot::Config::get()->{'gnupg'});
+ $GnuPG->options->hash_init(
+ homedir => Echolot::Config::get()->{'gnupghome'} );
+ $GnuPG->options->meta_interactive( 0 );
+ my %cypherpunk;
+
+ my @pgp_keys = ($reply =~ /^-----BEGIN \s PGP \s PUBLIC \s KEY \s BLOCK-----\r?\n
+ (?:.+\r?\n)*
+ \r?\n
+ (?:[a-zA-Z0-9+\/=]*\r?\n)+
+ -----END \s PGP \s PUBLIC \s KEY \s BLOCK-----$/xmg );
+ for my $key (@pgp_keys) {
+ my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh, $handles ) = Echolot::Tools::make_gpg_fds();
+ my $pid = $GnuPG->wrap_call(
+ commands => [qw{--with-colons}],
+ command_args => [qw{--no-options --no-secmem-warning --no-default-keyring --fast-list-mode}],
+ handles => $handles );
+ my ($stdout, $stderr, $status) = Echolot::Tools::readwrite_gpg($key, $stdin_fh, $stdout_fh, $stderr_fh, $status_fh);
+ waitpid $pid, 0;
+
+ ($stderr eq '') or
+ Echolot::Log::info("GnuPG returned something in stderr: '$stderr' when checking key '$key'; So what?");
+ ($status eq '') or
+ Echolot::Log::info("GnuPG returned something in status '$status' when checking key '$key': So what?");
+
+ my @included_keys = $stdout =~ /^pub:.*$/mg;
+ (scalar @included_keys >= 2) &&
+ # FIXME handle more than one key per block nicely
+ Echolot::Log::debug ("Cannot handle more than one key per block nicely (correctly) yet. Found ".(scalar @included_keys)." in one block from ".$remailer->{'address'}.".");
+ for my $included_key (@included_keys) {
+ my ($type, $keyid, $uid) = $included_key =~ /pub::\d+:(\d+):([0-9A-F]+):[^:]+:[^:]*:::([^:]+):/;
+ (defined $uid) or
+ Echolot::Log::info ("Unexpected format of '$included_key' by ".$remailer->{'address'}."; Skipping."),
+ next;
+ my ($address) = $uid =~ /<(.*?)>/;
+ $cypherpunk{$keyid} = {
+ address => $address,
+ type => $type,
+ key => $key # FIXME handle more than one key per block correctly
+ };
+ };
+ };
+
+ for my $keyid (keys %cypherpunk) {
+ my $remailer_address = $cypherpunk{$keyid}->{'address'};
+
+ if ($remailer->{'address'} ne $remailer_address) {
+ # Address mismatch -> Ignore reply and add $remailer_address to prospective addresses
+ Echolot::Log::info("Remailer address mismatch $remailer->{'address'} vs $remailer_address id key $keyid. Adding latter to prospective remailers.");
+ Echolot::Globals::get()->{'storage'}->add_prospective_address($remailer_address, 'self-capsstring-key', $remailer_address);
+ } else {
+ Echolot::Globals::get()->{'storage'}->restore_ttl( $remailer->{'address'} );
+ # 1 .. RSA
+ # 17 .. DSA
+ if ($cypherpunk{$keyid}->{'type'} == 1 || $cypherpunk{$keyid}->{'type'} == 17 ) {
+ Echolot::Log::debug("Setting cpunk key for $remailer_address: $keyid; type ".$cypherpunk{$keyid}->{'type'});
+ Echolot::Globals::get()->{'storage'}->set_key(
+ (($cypherpunk{$keyid}->{'type'} == 1) ? 'cpunk-rsa' :
+ (($cypherpunk{$keyid}->{'type'} == 17) ? 'cpunk-dsa' :
+ 'ERROR')),
+ $keyid, # as nick
+ $cypherpunk{$keyid}->{'address'},
+ $cypherpunk{$keyid}->{'key'},
+ $keyid,
+ 'N/A',
+ 'N/A',
+ 'N/A',
+ $time);
+ } else {
+ Echolot::Log::info("$keyid from $remailer_address has algoid ".$cypherpunk{$keyid}->{'type'}.". Cannot handle those.");
+ };
+ }
+ };
+
+ return 1;
+};
+
+sub remailer_key($$$) {
+ my ($reply, $token, $time) = @_;
+
+ my $cp_reply = $reply;
+ $cp_reply =~ s/^- -/-/gm; # PGP Signed messages
+
+ my ($id) = $token =~ /^key\.(\d+)$/;
+ (defined $id) or
+ Echolot::Log::info ("Returned token '$token' has no id at all."),
+ return 0;
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ Echolot::Log::info("No remailer found for id '$id'."), return 0 unless defined $remailer;
+ Echolot::Log::debug("Received remailer-keys reply for $remailer."),
+
+ Echolot::Globals::get()->{'storage'}->not_a_remailer($id), return 1
+ if (is_not_a_remailer($reply));
+ Echolot::Thesaurus::save_thesaurus('key', $id, $reply);
+
+ parse_mix_key($cp_reply, $time, $remailer);
+ parse_cpunk_key($cp_reply, $time, $remailer);
+
+ return 1;
+};
+
+sub remailer_stats($$$) {
+ my ($reply, $token, $time) = @_;
+
+ my ($id) = $token =~ /^stats\.(\d+)$/;
+ (defined $id) or
+ Echolot::Log::info ("Returned token '$token' has no id at all."),
+ return 0;
+
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ Echolot::Log::info("No remailer found for id '$id'."), return 0 unless defined $remailer;
+ Echolot::Log::debug("Received remailer-stats reply for $remailer."),
+
+ Echolot::Globals::get()->{'storage'}->not_a_remailer($id), return 1
+ if (is_not_a_remailer($reply));
+ Echolot::Thesaurus::save_thesaurus('stats', $id, $reply);
+};
+
+sub remailer_help($$$) {
+ my ($reply, $token, $time) = @_;
+
+ my ($id) = $token =~ /^help\.(\d+)$/;
+ (defined $id) or
+ Echolot::Log::info ("Returned token '$token' has no id at all."),
+ return 0;
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ Echolot::Log::info("No remailer found for id '$id'."), return 0 unless defined $remailer;
+ Echolot::Log::debug("Received remailer-help reply for $remailer."),
+
+ Echolot::Globals::get()->{'storage'}->not_a_remailer($id), return 1
+ if (is_not_a_remailer($reply));
+ Echolot::Thesaurus::save_thesaurus('help', $id, $reply);
+};
+
+sub remailer_adminkey($$$) {
+ my ($reply, $token, $time) = @_;
+
+ my ($id) = $token =~ /^adminkey\.(\d+)$/;
+ (defined $id) or
+ Echolot::Log::info ("Returned token '$token' has no id at all."),
+ return 0;
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ Echolot::Log::info("No remailer found for id '$id'."), return 0 unless defined $remailer;
+ Echolot::Log::debug("Received remailer-adminkey reply for $remailer."),
+
+ Echolot::Globals::get()->{'storage'}->not_a_remailer($id), return 1
+ if (is_not_a_remailer($reply));
+ Echolot::Thesaurus::save_thesaurus('adminkey', $id, $reply);
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Config.pm b/trunk/Echolot/Config.pm
new file mode 100644
index 0000000..dd3d97e
--- /dev/null
+++ b/trunk/Echolot/Config.pm
@@ -0,0 +1,344 @@
+package Echolot::Config;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Config - echolot configuration
+
+=head1 DESCRIPTION
+
+Sets default configuration options and
+reads configuration from the config file.
+
+=head1 FILES
+
+The configuration file is searched in those places in that order:
+
+=over
+
+=item the file pointed to by the B<ECHOLOT_CONF> environment variable
+
+=item <basedir>/pingd.conf
+
+=item $HOME/echolot/pingd.conf
+
+=item $HOME/pingd.conf
+
+=item $HOME/.pingd.conf
+
+=item /etc/echolot/pingd.conf
+
+=item /etc/pingd.conf
+
+=back
+
+=cut
+
+use strict;
+use Carp;
+use English;
+
+my $CONFIG;
+
+sub init($) {
+ my ($params) = @_;
+
+ die ("Basedir is not defined\n") unless defined $params->{'basedir'};
+
+ my @CONFIG_FILES = ();
+ push(@CONFIG_FILES, $ENV{'ECHOLOT_CONF'}) if defined $ENV{'ECHOLOT_CONF'};
+ push(@CONFIG_FILES, $params->{'basedir'}.'/pingd.conf') if defined $params->{'basedir'};
+ push(@CONFIG_FILES, $ENV{'HOME'}.'/echolot/pingd.conf') if defined $ENV{'HOME'};
+ push(@CONFIG_FILES, $ENV{'HOME'}.'/pingd.conf') if defined $ENV{'HOME'};
+ push(@CONFIG_FILES, $ENV{'HOME'}.'/.pingd.conf') if defined $ENV{'HOME'};
+ push(@CONFIG_FILES, '/etc/echolot/pingd.conf');
+ push(@CONFIG_FILES, '/etc/pingd.conf');
+
+ my $DEFAULT;
+ $DEFAULT = {
+ # System Specific Options
+ recipient_delimiter => '+',
+ dev_random => '/dev/random',
+ dev_urandom => '/dev/urandom',
+ sendmail => '/usr/sbin/sendmail',
+
+ # Magic Numbers
+ hash_len => 8,
+ stats_days => 12,
+ seconds_per_day => 24 * 60 * 60,
+
+ # New Remailers
+ fetch_new => 1,
+ ping_new => 1,
+ show_new => 1,
+
+ # Statistics Generation
+ separate_rlists => 0,
+ combined_list => 0,
+ thesaurus => 1,
+ fromlines => 1,
+ stats_sort_by_latency => 0,
+
+ # Timers and Counters
+ processmail => 60, # process incomng mail every minute
+ buildstats => 5*60, # build statistics every 5 minutes
+ buildkeys => 8*60*60, # build keyring every 8 hours
+ buildthesaurus => 60*60, # hourly
+ buildfromlines => 60*60, # hourly
+ commitprospectives => 8*60*60, # commit prospective addresses every 8 hours
+ expire => 24*60*60, # daily
+ getkeyconf_interval => 5*60, # send out requests every 5 minutes
+ getkeyconf_every_nth_time => 24*60/5, # send out the same request to the same remailer once a day
+ check_resurrection => 7*24*60*60, # weekly
+ summary => 24*60*60, # daily
+
+ metadata_backup => 8*60*60, # make backups of metadata and rotate them every 8 hours
+ metadata_backup_count => 32, # keep 32 rotations of metadata
+
+ pinger_interval => 5*60, # send out pings every 5 minutes
+ ping_every_nth_time => 24, # send out pings to the same remailer every 24 calls, i.e. every 2 hours
+
+ chainpinger_interval => 5*60, # send out pings every 5 minutes
+ chainping_every_nth_time => 2016, # send out pings to the same chain every 2016 calls, i.e. week
+ chainping_ic_every_nth_time => 288, # send out pings to broken or unknown chains every 288 calls, i.e. every day
+ chainping_period => 10*24*60*60, # 12 days
+ chainping_fudge => 0.3, # if less than 0.3 * rel1 * rel2 make it, the chain is really broken
+ chainping_grace => 1.5, # don't count pings sent no longer than 1.5 * (lat1 + lat2) ago
+ chainping_update => 4*60*60, # chain stats should never be older than 4 hours
+ chainping_minsample => 3, # have at least sent 3 pings before judging any chain
+ chainping_allbad_factor => 0.5, # at least 50% of possible chains (A x) need to fail for (A *) to be listed in broken chains
+
+ addresses_default_ttl => 5, # getkeyconf seconds (days)
+ check_resurrection_ttl => 8, # check_resurrection seconds (weeks)
+ prospective_addresses_ttl => 5*24*60*60, # 5 days
+ reliable_auto_add_min => 6, # 6 remailes need to list new address
+
+ expire_keys => 5*24*60*60, # 5 days
+ expire_confs => 5*24*60*60, # 5 days
+ expire_pings => 12*24*60*60, # 12 days
+ expire_thesaurus => 21*24*60*60, # 21 days
+ expire_chainpings => 12*24*60*60, # 12 days
+ expire_fromlines => 5*24*60*60, # 5 days
+ cleanup_tmpdir => 24*60*60, # daily
+
+ random_garbage => 8192,
+
+
+ # Directories and files
+ mailin => 'mail',
+ mailerrordir => 'mail-errors',
+ resultdir => 'results',
+ thesaurusdir => 'results/thesaurus',
+ thesaurusindexfile => 'results/thesaurus/index',
+ fromlinesindexfile => 'results/from',
+ private_resultdir => 'results.private',
+ indexfilebasename => 'echolot',
+ gnupghome => 'gnupghome',
+ gnupg => '',
+ mixhome => 'mixhome',
+ mixmaster => 'mix',
+ tmpdir => 'tmp',
+ broken1 => 'broken1.txt',
+ broken2 => 'broken2.txt',
+ sameop => 'sameop.txt',
+ gzip => 'gzip',
+
+ commands_file => 'commands.txt',
+ pidfile => 'pingd.pid',
+
+ save_errormails => 0,
+ write_meta_files => 1,
+ meta_extension => '.meta',
+
+ storage => {
+ backend => 'File',
+ File => {
+ basedir => 'data'
+ }
+ },
+
+ # logging
+ logfile => 'pingd.log',
+ loglevel => 'info',
+
+
+ # ping types
+ do_pings => {
+ 'cpunk-dsa' => 1,
+ 'cpunk-rsa' => 1,
+ 'cpunk-clear' => 1,
+ 'mix' => 1
+ },
+ do_chainpings => 1,
+ show_chainpings => 1,
+ which_chainpings => {
+ 'cpunk' => [ qw{cpunk-dsa cpunk-rsa cpunk-clear} ],
+ 'mix' => [ qw{mix} ]
+ },
+ pings_weight => [ qw{0.5 1.0 1.0 1.0 1.0 0.9 0.8 0.5 0.3 0.2 0.2 0.1 } ],
+
+ # templates
+ templates => {
+ default => {
+ 'indexfile' => 'templates/echolot.html',
+ 'thesaurusindexfile' => 'templates/thesaurusindex.html',
+ 'fromlinesindexfile' => 'templates/fromlinesindex.html',
+ 'mlist' => 'templates/mlist.html',
+ 'mlist2' => 'templates/mlist2.html',
+ 'rlist' => 'templates/rlist.html',
+ 'rlist-rsa' => 'templates/rlist-rsa.html',
+ 'rlist-dsa' => 'templates/rlist-dsa.html',
+ 'rlist-clear' => 'templates/rlist-clear.html',
+ 'rlist2' => 'templates/rlist2.html',
+ 'rlist2-rsa' => 'templates/rlist2-rsa.html',
+ 'rlist2-dsa' => 'templates/rlist2-dsa.html',
+ 'rlist2-clear' => 'templates/rlist2-clear.html',
+ 'clist' => 'templates/clist.html',
+ },
+ },
+
+ 'echolot_css' => 'templates/echolot.css',
+
+ remailerxxxtext => "Hello,\n".
+ "\n".
+ "This message requests remailer configuration data. The pinging software thinks\n".
+ "<TMPL_VAR NAME=\"address\"> is a remailer. Either it has been told so by the\n".
+ "maintainer of the pinger or it found the address in a remailer-conf or\n".
+ "remailer-key reply of some other remailer.\n".
+ "\n".
+ "If this is _not_ a remailer, you can tell this pinger that and it will stop\n".
+ "sending you those requests immediately (otherwise it will try a few more times).\n".
+ "Just reply and make sure the following is the first line of your message:\n".
+ " not a remailer\n".
+ "\n".
+ "If you want to talk to a human please mail <TMPL_VAR NAME=\"operator_address\">.\n",
+
+ homedir => undef,
+ my_localpart => undef,
+ my_domain => undef,
+ operator_address => undef,
+ sitename => undef,
+ verbose => 0
+ };
+
+
+ my $configfile = undef;
+ for my $filename ( @CONFIG_FILES ) {
+ if ( defined $filename && -e $filename ) {
+ $configfile = $filename;
+ print "Using config file $configfile\n" if ($params->{'verbose'});
+ last;
+ };
+ };
+
+ die ("no Configuration file found\n") unless defined $configfile;
+
+ {
+ local $/ = undef;
+ open(CONFIGCODE, $configfile) or
+ confess("Could not open configfile '$configfile': $!");
+ my $config_code = <CONFIGCODE>;
+ close (CONFIGCODE);
+ ($config_code) = $config_code =~ /^(.*)$/s;
+ eval ($config_code);
+ ($EVAL_ERROR) and
+ confess("Evaling config code from '$configfile' returned error: $EVAL_ERROR");
+ }
+
+
+ for my $key (keys %$CONFIG) {
+ warn("Unkown option: $key\n") unless (exists $DEFAULT->{$key});
+ };
+
+ # Work around spelling bug until 2.0rc3
+ if (exists $CONFIG->{'seperate_rlists'}) {
+ if (exists $CONFIG->{'separate_rlists'}) {
+ warn ("seperate_rlists has been superseded by separate_rlists.");
+ } else {
+ warn ("seperate_rlists has been superseded by separate_rlists, please change it in your config file.\n");
+ $CONFIG->{'separate_rlists'} = $CONFIG->{'seperate_rlists'};
+ };
+ delete $CONFIG->{'seperate_rlists'};
+ }
+
+ # In 2.0.6: thesaurusindexfile and indexfilebasename config values
+ # should not longer have the extension (.html) in them
+ # Handle this gracefully for now:
+ if (exists $CONFIG->{'thesaurusindexfile'}) {
+ $CONFIG->{'thesaurusindexfile'} =~ s/\.html?$// and
+ warn ("thesaurusindexfile no longer should have the .html extension.\n");
+ }
+ if (exists $CONFIG->{'indexfilebasename'}) {
+ $CONFIG->{'indexfilebasename'} =~ s/\.html?$// and
+ warn ("indexfilebasename no longer should have the .html extension.\n");
+ }
+
+ for my $key (keys %$DEFAULT) {
+ $CONFIG->{$key} = $DEFAULT->{$key} unless exists $CONFIG->{$key};
+ };
+ $CONFIG->{'homedir'} = $params->{'basedir'} unless (defined $CONFIG->{'homedir'});
+ $CONFIG->{'verbose'} = $params->{'verbose'} if ($params->{'verbose'});
+
+ for my $key (keys %$CONFIG) {
+ warn ("Config option $key is not defined\n") unless defined $CONFIG->{$key};
+ };
+};
+
+sub check_binaries() {
+ for my $bin (qw{mixmaster}) {
+ my $path = get()->{$bin};
+
+ if ($path =~ m#/#) {
+ Echolot::Log::warn ("$bin binary $path does not exist or is not executeable")
+ unless -x $path;
+ } else {
+ my $found = 0;
+ if (defined $ENV{'PATH'}) {
+ for my $pathelem (split /:/, $ENV{'PATH'}) {
+ $found = $pathelem, last
+ if -e $pathelem.'/'.$path;
+ };
+ };
+ if ($found) {
+ Echolot::Log::warn ("$bin binary $found/$path is not executeable")
+ unless -x $found.'/'.$path;
+ } else {
+ Echolot::Log::warn ("$bin binary $path not found");
+ };
+ };
+ };
+};
+
+sub get() {
+ return $CONFIG;
+};
+
+sub dump() {
+ print Data::Dumper->Dump( [ $CONFIG ], [ 'CONFIG' ] );
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Fromlines.pm b/trunk/Echolot/Fromlines.pm
new file mode 100644
index 0000000..0479a42
--- /dev/null
+++ b/trunk/Echolot/Fromlines.pm
@@ -0,0 +1,126 @@
+package Echolot::Fromlines;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Thesaurus - build from header page
+
+=head1 DESCRIPTION
+
+This package builds the from header page with the information we
+received from pings.
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+
+
+sub build_fromlines() {
+ return 1 unless Echolot::Config::get()->{'fromlines'};
+
+ my $data;
+ my @remailers = Echolot::Globals::get()->{'storage'}->get_addresses();
+
+ for my $remailer (@remailers) {
+ next unless $remailer->{'showit'};
+ my $addr = $remailer->{'address'};
+ my $nick = Echolot::Globals::get()->{'storage'}->get_nick($addr);
+ next unless defined $nick;
+ my $caps = Echolot::Globals::get()->{'storage'}->get_capabilities($addr);
+ next unless defined $caps;
+ next unless $caps !~ m/\btesting\b/i;
+ my $middleman = $caps =~ m/\bmiddle\b/;
+ next if $middleman;
+
+
+ for my $user_supplied (0, 1) {
+ $data->{$user_supplied}->{$addr}->{'nick'} = $nick;
+ $data->{$user_supplied}->{$addr}->{'address'} = $addr;
+
+ my @types = Echolot::Globals::get()->{'storage'}->get_types($addr);
+ my $from_types;
+ for my $type (@types) {
+ my $from_info = Echolot::Globals::get()->{'storage'}->get_fromline($addr, $type, $user_supplied);
+ my $from = $from_info->{'from'};
+ $from = 'Not Available' unless defined $from;
+ $from = 'Middleman Remailer' if $middleman;
+ my $disclaim_top = $from_info->{'disclaim_top'} && ! $middleman ? 1 : 0;
+ my $disclaim_bot = $from_info->{'disclaim_bot'} && ! $middleman ? 1 : 0;
+ #my $last_update = $from_info->{'last_update'};
+ #my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime($last_update);
+ my $frominfo = $disclaim_top.':'.$disclaim_bot.':'.$from;
+ #my $date = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
+ #my $value = $middleman ? $type : ($type." ($date)");
+ my $value = $type;
+ push @{$from_types->{$frominfo}}, $value;
+ };
+ my $types_from;
+ for my $frominfo (sort keys %$from_types) {
+ my $types = join ", ", sort { $a cmp $b } @{$from_types->{$frominfo}};
+ $types_from->{$types} = $frominfo;
+ };
+ my @types_from = map {
+ my ($disclaim_top, $disclaim_bot, $from) = split (/:/, $types_from->{$_}, 3);
+ {
+ nick => $nick,
+ address => $addr,
+ types => $_,
+ disclaim_top => $disclaim_top,
+ disclaim_bot => $disclaim_bot,
+ from => Echolot::Tools::escape_HTML_entities($from)
+ }
+ } sort { $a cmp $b } keys %$types_from;
+ $data->{$user_supplied}->{$addr}->{'data'} = \@types_from;
+ };
+
+ # Remove user supplied if identical
+ my $f0 = join ':', map {
+ $_->{'disclaim_top'}.':'.$_->{'disclaim_bot'}.$_->{'types'}.':'.$_->{'from'}
+ } @{$data->{0}->{$addr}->{'data'}};
+ my $f1 = join ':', map {
+ $_->{'disclaim_top'}.':'.$_->{'disclaim_bot'}.$_->{'types'}.':'.$_->{'from'}
+ } @{$data->{1}->{$addr}->{'data'}};
+ if ($f0 eq $f1) {
+ delete $data->{1}->{$addr};
+ };
+ };
+
+ my @data0 = map {$data->{0}->{$_}} (sort { $data->{0}->{$a}->{'nick'} cmp $data->{0}->{$b}->{'nick'} } keys (%{$data->{0}}));
+ my @data1 = map {$data->{1}->{$_}} (sort { $data->{1}->{$a}->{'nick'} cmp $data->{1}->{$b}->{'nick'} } keys (%{$data->{1}}));
+
+ Echolot::Tools::write_HTML_file(
+ Echolot::Config::get()->{'fromlinesindexfile'},
+ 'fromlinesindexfile',
+ Echolot::Config::get()->{'buildfromlines'},
+ default => \@data0,
+ usersupplied => \@data1);
+};
+
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Globals.pm b/trunk/Echolot/Globals.pm
new file mode 100644
index 0000000..898e5d6
--- /dev/null
+++ b/trunk/Echolot/Globals.pm
@@ -0,0 +1,60 @@
+package Echolot::Globals;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Globals - echolot global variables
+
+=head1 DESCRIPTION
+
+=cut
+
+use strict;
+use Carp;
+
+my $GLOBALS;
+
+sub init(%) {
+ my (%args) = @_;
+
+ my $hostname = `hostname`;
+ $hostname =~ /^([a-zA-Z0-9_.-]*)$/;
+ $hostname = $1 || 'unknown';
+ $GLOBALS->{'hostname'} = $hostname;
+ $GLOBALS->{'internalcounter'} = 1;
+ $GLOBALS->{'version'} = $args{'version'};
+};
+
+sub initStorage {
+ $GLOBALS->{'storage'} = new Echolot::Storage::File ( datadir => Echolot::Config::get()->{'storage'}->{'File'}->{'basedir'} );
+};
+
+sub get() {
+ return $GLOBALS;
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Log.pm b/trunk/Echolot/Log.pm
new file mode 100644
index 0000000..15b5b80
--- /dev/null
+++ b/trunk/Echolot/Log.pm
@@ -0,0 +1,163 @@
+package Echolot::Log;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Globals - echolot global variables
+
+=head1 DESCRIPTION
+
+=cut
+
+use strict;
+use Carp qw{};
+#use Time::HiRes qw( gettimeofday );
+
+my %LOGLEVELS = qw{
+ trace 8
+ debug 7
+ info 6
+ notice 5
+ warn 4
+ warning 4
+ error 3
+ critical 2
+ alert 1
+ emergency 0
+};
+
+my $LOGLEVEL;
+my $LOGFILE;
+my $LOGFH;
+
+my @monnames = qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
+sub header_log($$) {
+ my ($level, $msg) = @_;
+
+ #my ($secs, $msecs) = gettimeofday();
+ #my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime( $secs );
+ #my $time = sprintf("%s %02d %02d:%02d:%02d.%06d",
+ # $monnames[$mon],
+ # $mday,
+ # $hour, $min, $sec, $msecs);
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
+ my $time = sprintf("%s %02d %02d:%02d:%02d",
+ $monnames[$mon],
+ $mday,
+ $hour, $min, $sec);
+ my $prefix = $time.' ['.uc($level).'] ';
+ my $logstring = $msg."\n";
+ my $first = 0;
+ $logstring =~ s/^/ $prefix . ($first++ ? ' ' : '' ) /emg;
+ return $logstring;
+};
+
+sub reopen() {
+ $LOGFH->close() if ($LOGFH->opened());
+
+ open($LOGFH, ">>".$LOGFILE) or
+ warn("Cannot open logfile $LOGFILE: $!");
+};
+
+sub init() {
+ $LOGFILE = Echolot::Config::get()->{'logfile'};
+ $LOGLEVEL = Echolot::Config::get()->{'loglevel'};
+ $LOGFH = new IO::Handle;
+
+ die ("Logfile not defined") unless defined ($LOGFILE);
+ die ("Loglevel not defined") unless defined ($LOGLEVEL);
+ die ("Loglevel $LOGLEVEL unkown") unless defined ($LOGLEVELS{$LOGLEVEL});
+
+ $LOGLEVEL = $LOGLEVELS{$LOGLEVEL};
+
+ reopen();
+};
+
+sub log_message($$) {
+ my ($level, $msg) = @_;
+
+ die("Loglevel $level unkown.") unless defined $LOGLEVELS{$level};
+ return if $LOGLEVELS{$level} > $LOGLEVEL;
+
+ $msg = header_log($level, $msg);
+ print $LOGFH $msg;
+ $LOGFH->flush();
+};
+
+sub trace($) {
+ log_message('trace', $_[0]);
+};
+sub debug($) {
+ log_message('debug', $_[0]);
+};
+sub info($) {
+ log_message('info', $_[0]);
+};
+sub notice($) {
+ log_message('notice', $_[0]);
+};
+sub warn($) {
+ log_message('warn', $_[0]);
+};
+sub warning($) {
+ log_message('warning', $_[0]);
+};
+sub error($) {
+ log_message('error', $_[0]);
+};
+sub critical($) {
+ log_message('critical', $_[0]);
+};
+sub alert($) {
+ log_message('alert', $_[0]);
+};
+sub emergency($) {
+ log_message('emergency', $_[0]);
+};
+
+sub logdie($) {
+ my ($msg) = @_;
+ critical($msg);
+ die($msg);
+};
+sub cluck($) {
+ my ($msg) = @_;
+ my $longmess = Carp::longmess();
+ $longmess =~ s/^/ /mg;
+ $msg .= "\n".$longmess;
+ warning($msg);
+};
+sub confess($) {
+ my ($msg) = @_;
+ my $longmess = Carp::longmess();
+ $longmess =~ s/^/ /mg;
+ $msg .= "\n".$longmess;
+ error($msg);
+ die($msg);
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Mailin.pm b/trunk/Echolot/Mailin.pm
new file mode 100644
index 0000000..a2f2abb
--- /dev/null
+++ b/trunk/Echolot/Mailin.pm
@@ -0,0 +1,252 @@
+package Echolot::Mailin;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Mailin - Incoming Mail Dispatcher for Echolot
+
+=head1 DESCRIPTION
+
+
+=cut
+
+use strict;
+use English;
+use Echolot::Globals;
+use Echolot::Log;
+use Fcntl ':flock'; # import LOCK_* constants
+use POSIX; # import SEEK_* constants (older perls don't have SEEK_ in Fcntl)
+
+
+sub make_sane_name() {
+ my $result = time().'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internal_counter'}++.'.'.Echolot::Globals::get()->{'hostname'};
+ return $result;
+};
+
+sub sane_move($$) {
+ my ($from, $to) = @_;
+
+ my $link_success = link($from, $to);
+ $link_success or
+ Echolot::Log::warn("Cannot link $from to $to: $!."),
+ return 0;
+ #- Trying move"),
+ #rename($from, $to) or
+ # cluck("Renaming $from to $to didn't work either: $!"),
+ # return 0;
+
+ $link_success && (unlink($from) or
+ Echolot::Log::warn("Cannot unlink $from: $!.") );
+ return 1;
+};
+
+sub handle($) {
+ my ($lines) = @_;
+
+ my $i=0;
+ my $body = '';
+ my $header = '';
+ my $to;
+ for ( ; $i < scalar @$lines; $i++) {
+ my $line = $lines->[$i];
+ chomp($line);
+ last if $line eq '';
+ $header .= $line."\n";
+
+ if ($line =~ m/^To:\s*(.*?)\s*$/) {
+ $to = $1;
+ };
+ };
+ for ( ; $i < scalar @$lines; $i++) {
+ $body .= $lines->[$i];
+ };
+
+ (defined $to) or
+ Echolot::Log::info("No To header found in mail."),
+ return 0;
+
+ my $address_result = Echolot::Tools::verify_address_tokens($to) or
+ Echolot::Log::debug("Verifying '$to' failed."),
+ return 0;
+
+ my $type = $address_result->{'token'};
+ my $timestamp = $address_result->{'timestamp'};
+
+ Echolot::Conf::remailer_conf($body, $type, $timestamp), return 1 if ($type =~ /^conf\./);
+ Echolot::Conf::remailer_key($body, $type, $timestamp), return 1 if ($type =~ /^key\./);
+ Echolot::Conf::remailer_help($body, $type, $timestamp), return 1 if ($type =~ /^help\./);
+ Echolot::Conf::remailer_stats($body, $type, $timestamp), return 1 if ($type =~ /^stats\./);
+ Echolot::Conf::remailer_adminkey($body, $type, $timestamp), return 1 if ($type =~ /^adminkey\./);
+
+ Echolot::Pinger::receive($header, $body, $type, $timestamp), return 1 if ($type eq 'ping');
+ Echolot::Chain::receive($header, $body, $type, $timestamp), return 1 if ($type eq 'chainping');
+
+ Echolot::Log::warn("Didn't know what to do with '$to'."),
+ return 0;
+};
+
+sub handle_file($) {
+ my ($file) = @_;
+
+ open (FH, $file) or
+ Echolot::Log::warn("Cannot open file $file: $!,"),
+ return 0;
+ my @lines = <FH>;
+ my $body = join('', <FH>);
+ close (FH) or
+ Echolot::Log::warn("Cannot close file $file: $!.");
+
+ return handle(\@lines);
+};
+
+sub read_mbox($) {
+ my ($file) = @_;
+
+ my @mail;
+ my $mail = [];
+ my $blank = 1;
+
+ open(FH, '+<'. $file) or
+ Echolot::Log::warn("cannot open '$file': $!."),
+ return undef;
+ flock(FH, LOCK_EX) or
+ Echolot::Log::warn("cannot gain lock on '$file': $!."),
+ return undef;
+
+ while(<FH>) {
+ if($blank && /\AFrom .*\d{4}/) {
+ push(@mail, $mail) if scalar(@{$mail});
+ $mail = [ $_ ];
+ $blank = 0;
+ } else {
+ $blank = m#\A\Z# ? 1 : 0;
+ push @$mail, $_;
+ }
+ }
+ push(@mail, $mail) if scalar(@{$mail});
+
+ seek(FH, 0, SEEK_SET) or
+ Echolot::Log::warn("cannot seek to start of '$file': $!."),
+ return undef;
+ truncate(FH, 0) or
+ Echolot::Log::warn("cannot truncate '$file' to zero size: $!."),
+ return undef;
+ flock(FH, LOCK_UN) or
+ Echolot::Log::warn("cannot release lock on '$file': $!."),
+ return undef;
+ close(FH);
+
+ return \@mail;
+}
+
+sub read_maildir($) {
+ my ($dir) = @_;
+
+ my @mail;
+
+ my @files;
+ for my $sub (qw{new cur}) {
+ opendir(DIR, $dir.'/'.$sub) or
+ Echolot::Log::warn("Cannot open direcotry '$dir/$sub': $!."),
+ return undef;
+ push @files, map { $sub.'/'.$_ } grep { ! /^\./ } readdir(DIR);
+ closedir(DIR) or
+ Echolot::Log::warn("Cannot close direcotry '$dir/$sub': $!.");
+ };
+
+ for my $file (@files) {
+ $file =~ /^(.*)$/s or
+ Echolot::Log::confess("I really should match here. ('$file').");
+ $file = $1;
+
+ my $mail = [];
+ open(FH, $dir.'/'.$file) or
+ Echolot::Log::warn("cannot open '$dir/$file': $!."),
+ return undef;
+ @$mail = <FH>;
+ close(FH);
+
+ push @mail, $mail;
+ };
+
+ for my $file (@files) {
+ unlink $dir.'/'.$file or
+ Echolot::Log::warn("cannot unlink '$dir/$file': $!.");
+ };
+
+
+ return \@mail;
+}
+
+sub storemail($$) {
+ my ($path, $mail) = @_;
+
+ my $tmpname = $path.'/tmp/'.make_sane_name();
+ open (F, '>'.$tmpname) or
+ Echolot::Log::warn("Cannot open $tmpname: $!."),
+ return undef;
+ print F join ('', @$mail);
+ close F;
+
+ my $i;
+ for ($i = 0; $i < 5; $i++ ) {
+ my $targetname = $path.'/cur/'.make_sane_name();
+ sane_move($tmpname, $targetname) or
+ sleep 1, next;
+ last;
+ };
+
+ return undef if ($i == 5);
+ return 1;
+};
+
+sub process() {
+ my $inmail = Echolot::Config::get()->{'mailin'};
+ my $mailerrordir = Echolot::Config::get()->{'mailerrordir'};
+
+ my $mails = (-d $inmail) ?
+ read_maildir($inmail) :
+ ( ( -e $inmail ) ? read_mbox($inmail) : [] );
+
+ Echolot::Globals::get()->{'storage'}->delay_commit();
+ for my $mail (@$mails) {
+ unless (handle($mail)) {
+ if (Echolot::Config::get()->{'save_errormails'}) {
+ Echolot::Log::info("Saving mail with unknown destination (probably a bounce) to mail-errordir.");
+ my $name = make_sane_name();
+ storemail($mailerrordir, $mail) or
+ Echolot::Log::warn("Could not store a mail.");
+ } else {
+ Echolot::Log::info("Trashing mail with unknown destination (probably a bounce).");
+ };
+ };
+ };
+ Echolot::Globals::get()->{'storage'}->enable_commit();
+};
+
+1;
+
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Pinger.pm b/trunk/Echolot/Pinger.pm
new file mode 100644
index 0000000..d782edd
--- /dev/null
+++ b/trunk/Echolot/Pinger.pm
@@ -0,0 +1,211 @@
+package Echolot::Pinger;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Pinger - actual sending and receiving of Pings.
+
+=head1 DESCRIPTION
+
+This package provides functions for sending out and receiving pings.
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+use Echolot::Pinger::Mix;
+use Echolot::Pinger::CPunk;
+
+sub do_mix_ping($$$$$$) {
+ my ($address, $type, $keyid, $to, $with_from, $body) = @_;
+
+ ($type eq 'mix') or
+ Echolot::Log::warn("types should really be mix ($type)."),
+ return 0;
+
+ my %key = Echolot::Globals::get()->{'storage'}->get_key($address, $type, $keyid);
+ Echolot::Pinger::Mix::ping(
+ $body,
+ $to,
+ $with_from,
+ [ $key{'nick'} ],
+ { $keyid => \%key } ) or
+ return 0;
+
+ return 1;
+};
+
+sub do_cpunk_ping($$$$$$) {
+ my ($address, $type, $keyid, $to, $with_from, $body) = @_;
+
+ my $keyhash = {};
+ if ($type ne 'cpunk-clear') {
+ my %key = Echolot::Globals::get()->{'storage'}->get_key($address, $type, $keyid);
+ $keyhash->{$keyid} = \%key;
+ };
+ Echolot::Pinger::CPunk::ping(
+ $body,
+ $to,
+ $with_from,
+ [ { address => $address,
+ keyid => $keyid,
+ encrypt => ($type ne 'cpunk-clear'),
+ pgp2compat => ($type eq 'cpunk-rsa') } ],
+ $keyhash ) or
+ return 0;
+
+ return 1;
+};
+
+sub do_ping($$$$) {
+ my ($type, $address, $key, $with_from) = @_;
+
+ my $now = time();
+ my $token = join(':', $address, $type, $key, $with_from, $now);
+ my $mac = Echolot::Tools::make_mac($token);
+ my $body = "remailer: $address\n".
+ "type: $type\n".
+ "key: $key\n".
+ "with_from: $with_from\n".
+ "sent: $now\n".
+ "mac: $mac\n".
+ Echolot::Tools::make_garbage();
+ $body = Echolot::Tools::crypt_symmetrically($body, 'encrypt');
+
+ my $to = Echolot::Tools::make_address('ping');
+ if ($type eq 'mix') {
+ do_mix_ping($address, $type, $key, $to, $with_from, $body);
+ } elsif ($type eq 'cpunk-rsa' || $type eq 'cpunk-dsa' || $type eq 'cpunk-clear') {
+ do_cpunk_ping($address, $type, $key, $to, $with_from, $body);
+ } else {
+ Echolot::Log::warn("Don't know how to handle ping type $type.");
+ return 0;
+ };
+
+ Echolot::Globals::get()->{'storage'}->register_pingout($address, $type, $key, $now);
+ return 1;
+};
+
+sub send_pings($;$) {
+ my ($scheduled_for, $which) = @_;
+
+ $which = '' unless defined $which;
+
+ my $call_intervall = Echolot::Config::get()->{'pinger_interval'};
+ my $send_every_n_calls = Echolot::Config::get()->{'ping_every_nth_time'};
+
+ my $timemod = int ($scheduled_for / $call_intervall);
+ my $this_call_id = $timemod % $send_every_n_calls;
+ my $session_id = int ($scheduled_for / ($call_intervall * $send_every_n_calls));
+
+ my @remailers = Echolot::Globals::get()->{'storage'}->get_addresses();
+ for my $remailer (@remailers) {
+ next unless $remailer->{'pingit'};
+ my $address = $remailer->{'address'};
+
+ next unless (
+ $which eq 'all' ||
+ $which eq $address ||
+ $which eq '');
+
+ for my $type (Echolot::Globals::get()->{'storage'}->get_types($address)) {
+ next unless Echolot::Config::get()->{'do_pings'}->{$type};
+ for my $key (Echolot::Globals::get()->{'storage'}->get_keys($address, $type)) {
+ next unless (
+ $which eq $address ||
+ $which eq 'all' ||
+ (($which eq '') && ($this_call_id eq (Echolot::Tools::makeShortNumHash($address.$type.$key.$session_id) % $send_every_n_calls))));
+
+ my $with_from = (int($timemod / $send_every_n_calls)) % 2;
+ Echolot::Log::debug("ping calling $type, $address, $key, $with_from.");
+ do_ping($type, $address, $key, $with_from);
+ }
+ };
+ };
+ return 1;
+};
+
+
+sub receive($$$$) {
+ my ($header, $msg, $token, $timestamp) = @_;
+
+ my $now = time();
+
+ my $body;
+ my $bot = 0;
+ my $top = 0;
+ # < 2.0beta34 didn't encrypt pings.
+ if ($msg =~ /^-----BEGIN PGP MESSAGE-----/m) {
+ # work around borken middleman remailers that have a problem with some
+ # sort of end of line characters and randhopping them through reliable
+ # remailers..
+ # they add an empty line between each usefull line
+ $msg =~ s/(\r?\n)\r?\n/$1/g if ($msg =~ /^-----BEGIN PGP MESSAGE-----\r?\n\r?\n/m);
+
+ $top = ($msg =~ m/^\S.*-----BEGIN PGP MESSAGE-----/ms) ? 1 : 0;
+ $bot = ($msg =~ m/^-----END PGP MESSAGE-----.*\S/ms) ? 1 : 0;
+
+ $body = Echolot::Tools::crypt_symmetrically($msg, 'decrypt');
+ };
+ $body = $msg unless defined $body;
+
+ my ($addr) = $body =~ /^remailer: (.*)$/m;
+ my ($type) = $body =~ /^type: (.*)$/m;
+ my ($key) = $body =~ /^key: (.*)$/m;
+ my ($sent) = $body =~ /^sent: (.*)$/m;
+ my ($with_from) = $body =~ /^with_from: (.*)$/m;
+ my ($mac) = $body =~ /^mac: (.*)$/m;
+
+ my @values = ($addr, $type, $key, defined $with_from ? $with_from : 'undef', $sent, $mac); # undef was added after 2.0.10
+ my $cleanstring = join ":", map { defined() ? $_ : "undef" } @values;
+ my @values_obsolete = ($addr, $type, $key, $sent, $mac); # <= 2.0.10
+
+ (grep { ! defined() } @values_obsolete) and
+ Echolot::Log::warn("Received ping at $timestamp has undefined values: $cleanstring."),
+ return 0;
+
+ pop @values;
+ pop @values_obsolete;
+ Echolot::Tools::verify_mac(join(':', @values), $mac) or
+ Echolot::Tools::verify_mac(join(':', @values_obsolete), $mac) or # old style without with_from
+ Echolot::Log::warn("Received ping at $timestamp has wrong mac; $cleanstring."),
+ return 0;
+
+ Echolot::Globals::get()->{'storage'}->register_pingdone($addr, $type, $key, $sent, $now - $sent) or
+ return 0;
+
+ if (defined $with_from) { # <= 2.0.10 didn't have with_from
+ my ($from) = $header =~ /From: (.*)/i;
+ $from = 'undefined' unless defined $from;
+ Echolot::Globals::get()->{'storage'}->register_fromline($addr, $type, $with_from, $from, $top, $bot);
+ };
+
+ return 1;
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Pinger/CPunk.pm b/trunk/Echolot/Pinger/CPunk.pm
new file mode 100644
index 0000000..6cac797
--- /dev/null
+++ b/trunk/Echolot/Pinger/CPunk.pm
@@ -0,0 +1,205 @@
+package Echolot::Pinger::CPunk;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Pinger::CPunk - send cypherpunk pings
+
+=head1 DESCRIPTION
+
+This package provides functions for sending cypherpunk (type I) pings.
+
+=cut
+
+use strict;
+use English;
+use GnuPG::Interface;
+use Echolot::Log;
+
+sub encrypt_to($$$$) {
+ my ($msg, $recipient, $keys, $pgp2compat) = @_;
+
+ (defined $keys->{$recipient}) or
+ Echolot::Log::warn("Key for recipient $recipient is not defined."),
+ return undef;
+ (defined $keys->{$recipient}->{'key'}) or
+ Echolot::Log::warn("Key->key for recipient $recipient is not defined."),
+ return undef;
+ my $keyring = Echolot::Config::get()->{'tmpdir'}.'/'.
+ Echolot::Globals::get()->{'hostname'}.".".time.'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internalcounter'}++.'.keyring';
+
+ my $GnuPG = new GnuPG::Interface;
+ $GnuPG->call( Echolot::Config::get()->{'gnupg'} ) if (Echolot::Config::get()->{'gnupg'});
+ $GnuPG->options->hash_init(
+ homedir => Echolot::Config::get()->{'gnupghome'} );
+ $GnuPG->options->meta_interactive( 0 );
+
+ my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh, $handles ) = Echolot::Tools::make_gpg_fds();
+ my $pid = $GnuPG->wrap_call(
+ commands => [ '--import' ],
+ command_args => [qw{--no-options --no-secmem-warning --no-default-keyring --fast-list-mode --keyring}, $keyring, '--', '-' ],
+ handles => $handles );
+ my ($stdout, $stderr, $status) = Echolot::Tools::readwrite_gpg($keys->{$recipient}->{'key'}, $stdin_fh, $stdout_fh, $stderr_fh, $status_fh);
+ waitpid $pid, 0;
+
+ ($stdout eq '') or
+ Echolot::Log::info("GnuPG returned something in stdout '$stdout' while adding key for '$recipient': So what?");
+ #($stderr eq '') or
+ #Echolot::Log::warn("GnuPG returned something in stderr: '$stderr' while adding key for '$recipient'; returning."),
+ #return undef;
+ ($status =~ /^^\[GNUPG:\] IMPORTED $recipient /m) or
+ Echolot::Log::info("GnuPG status '$status' didn't indicate key for '$recipient' was imported correctly."),
+ return undef;
+
+
+
+
+
+
+ #$msg =~ s/\r?\n/\r\n/g;
+
+
+
+
+ $GnuPG->options->hash_init(
+ armor => 1 );
+
+ ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh, $handles ) = Echolot::Tools::make_gpg_fds();
+ my $command_args = [qw{--no-options --no-secmem-warning --always-trust --no-default-keyring --textmode --cipher-algo 3DES --keyring}, $keyring, '--recipient', $recipient];
+ my $plaintextfile;
+
+ #if ($pgp2compat) {
+ # push @$command_args, qw{--pgp2};
+ #};
+ # Files are required for compaitibility with PGP 2.*
+ # we also use files in all other cases since there is a bug in either GnuPG or GnuPG::Interface
+ # that let Echolot die if in certain cases:
+ # If a key is unuseable because it expired and we want to encrypt something to it
+ # pingd dies if there is only enough time between calling encrypt() and printing the message
+ # to GnuPG. (a sleep 1 triggered that reproduceably)
+ $plaintextfile = Echolot::Config::get()->{'tmpdir'}.'/'.
+ Echolot::Globals::get()->{'hostname'}.".".time.'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internalcounter'}++.'.plaintext';
+ open (F, '>'.$plaintextfile) or
+ Echolot::Log::warn("Cannot open $plaintextfile for writing: $!."),
+ return 0;
+ print (F $msg);
+ close (F) or
+ Echolot::Log::warn("Cannot close $plaintextfile."),
+ return 0;
+ push @$command_args, $plaintextfile;
+
+ $pid = $GnuPG->encrypt(
+ command_args => $command_args,
+ handles => $handles );
+ ($stdout, $stderr, $status) = Echolot::Tools::readwrite_gpg('', $stdin_fh, $stdout_fh, $stderr_fh, $status_fh);
+ waitpid $pid, 0;
+
+ #($stderr eq '') or
+ #Echolot::Log::warn("GnuPG returned something in stderr: '$stderr' while encrypting to '$recipient'."),
+ #return undef;
+ ($status =~ /^\[GNUPG:\] KEYEXPIRED (\d+)/m) and
+ Echolot::Log::info("Key $recipient expired at ".scalar gmtime($1)." UTC"),
+ return undef;
+ (($status =~ /^\[GNUPG:\] BEGIN_ENCRYPTION\s/m) &&
+ ($status =~ /^\[GNUPG:\] END_ENCRYPTION\s/m)) or
+ Echolot::Log::info("GnuPG status '$status' didn't indicate message to '$recipient' was encrypted correctly (stderr: $stderr; args: ".join(' ', @$command_args).")."),
+ return undef;
+
+ unlink ($keyring) or
+ Echolot::Log::warn("Cannot unlink tmp keyring '$keyring'."),
+ return undef;
+ unlink ($keyring.'~'); # gnupg does those evil backups
+
+ (defined $plaintextfile) and
+ (unlink ($plaintextfile) or
+ Echolot::Log::warn("Cannot unlink tmp plaintextfile '$plaintextfile'."),
+ return undef);
+
+
+ my $result;
+
+ $plaintextfile .= '.asc';
+ open (F, '<'.$plaintextfile) or
+ Echolot::Log::warn("Cannot open $plaintextfile for reading: $!."),
+ return 0;
+ $result = join '', <F>;
+ close (F) or
+ Echolot::Log::warn("Cannot close $plaintextfile."),
+ return 0;
+
+ (defined $plaintextfile) and
+ (unlink ($plaintextfile) or
+ Echolot::Log::warn("Cannot unlink tmp plaintextfile '$plaintextfile'."),
+ return undef);
+
+ $result =~ s,^Version: .*$,Version: N/A,m;
+ #$result =~ s/\r?\n/\r\n/g;
+ return $result;
+};
+
+sub ping($$$$$) {
+ my ($body, $to, $with_from, $chain, $keys) = @_;
+
+ my $msg = $body;
+
+ for my $hop (reverse @$chain) {
+ my $header = '';
+ if ($with_from) {
+ my $address = Echolot::Config::get()->{'my_localpart'} . '@' .
+ Echolot::Config::get()->{'my_domain'};
+ $header = "##\nFrom: Echolot Pinger <$address>\n\n";
+ $with_from = 0;
+ };
+ # "Latent-Time: +0\n".
+ $msg = "::\n".
+ "Anon-To: $to\n".
+ "\n".
+ $header.
+ $msg;
+
+ if ($hop->{'encrypt'}) {
+ my $encrypted = encrypt_to($msg, $hop->{'keyid'}, $keys, $hop->{'pgp2compat'});
+ (defined $encrypted) or
+ Echolot::Log::debug("Encrypted is undefined."),
+ return undef;
+ $msg = "::\n".
+ "Encrypted: PGP\n".
+ "\n".
+ $encrypted;
+ };
+ $to = $hop->{'address'};
+ }
+
+ Echolot::Tools::send_message(
+ To => $to,
+ Body => $msg
+ );
+
+ return 1;
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Pinger/Mix.pm b/trunk/Echolot/Pinger/Mix.pm
new file mode 100644
index 0000000..66eaf25
--- /dev/null
+++ b/trunk/Echolot/Pinger/Mix.pm
@@ -0,0 +1,139 @@
+package Echolot::Pinger::Mix;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Pinger::Mix - send mix pings
+
+=head1 DESCRIPTION
+
+This package provides functions for sending mixmaster (type II) pings.
+
+=cut
+
+use strict;
+use English;
+use IO::Handle;
+use Echolot::Log;
+
+sub ping($$$$$) {
+ my ($body, $to, $with_from, $chain, $keys) = @_;
+
+ my $chaincomma = join (',', @$chain);
+
+ my $keyring = Echolot::Config::get()->{'mixhome'}.'/pubring.mix';
+ open (F, '>'.$keyring) or
+ Echolot::Log::warn("Cannot open $keyring for writing: $!."),
+ return 0;
+ for my $keyid (keys %$keys) {
+ print (F $keys->{$keyid}->{'summary'}, "\n\n");
+ print (F $keys->{$keyid}->{'key'},"\n\n");
+ };
+ close (F) or
+ Echolot::Log::warn("Cannot close $keyring: $!."),
+ return 0;
+
+ my $type2list = Echolot::Config::get()->{'mixhome'}.'/type2.list';
+ open (F, '>'.$type2list) or
+ Echolot::Log::warn("Cannot open $type2list for writing: $!."),
+ return 0;
+ for my $keyid (keys %$keys) {
+ print (F $keys->{$keyid}->{'summary'}, "\n");
+ };
+ close (F) or
+ Echolot::Log::warn("Cannot close $type2list: $!."),
+ return 0;
+
+ my $mixcfg = Echolot::Config::get()->{'mixhome'}.'/mix.cfg';
+ my $address = Echolot::Config::get()->{'my_localpart'} . '@' .
+ Echolot::Config::get()->{'my_domain'};
+ my $sendmail = Echolot::Config::get()->{'sendmail'};
+ open (F, ">$mixcfg") or
+ Echolot::Log::warn("Cannot open $mixcfg for writing: $!."),
+ return 0;
+ print (F "REMAIL n\n");
+ print (F "NAME Echolot Pinger\n");
+ print (F "ADDRESS $address\n");
+ print (F "PUBRING pubring.mix\n");
+ print (F "TYPE2LIST type2.list\n");
+ print (F "SENDMAIL $sendmail -f $address -t\n");
+ print (F "VERBOSE 0\n");
+ print (F "INDUMMYP 0\n");
+ print (F "OUTDUMMYP 0\n");
+ close (F) or
+ Echolot::Log::warn("Cannot close $mixcfg: $!."),
+ return 0;
+
+ my ($stdinR, $stdinW) = (IO::Handle->new(), IO::Handle->new());
+ my ($stdoutR, $stdoutW) = (IO::Handle->new(), IO::Handle->new());
+ my ($stderrR, $stderrW) = (IO::Handle->new(), IO::Handle->new());
+ pipe $stdinR, $stdinW;
+ pipe $stdoutR, $stdoutW;
+ pipe $stderrR, $stderrW;
+ my $pid = fork();
+ defined $pid or
+ Echolot::Log::warn("Cannot fork for calling mixmaster: $!."),
+ return 0;
+ unless ($pid) { # child
+ $stdinW->close;
+ $stdoutR->close;
+ $stderrR->close;
+ close STDIN;
+ close STDOUT;
+ close STDERR;
+ open (STDIN, "<&".$stdinR->fileno) or Echolot::Log::warn ("Cannot dup stdinR (fd ".$stdinR->fileno.") as STDIN: $!");
+ open (STDOUT, ">&".$stdoutW->fileno) or Echolot::Log::warn ("Cannot dup stdoutW (fd ".$stdoutW->fileno.") as STDOUT: $!");
+ open (STDERR, ">&".$stderrW->fileno) or Echolot::Log::warn ("Cannot dup stderrW (fd ".$stderrW->fileno.") as STDERE: $!");
+ $ENV{'MIXPATH'} = Echolot::Config::get()->{'mixhome'};
+ { exec(Echolot::Config::get()->{'mixmaster'}, qw{-m -S -l}, $chaincomma); };
+ Echolot::Log::warn("Cannot exec mixpinger: $!.");
+ exit(1);
+ };
+ $stdinR->close;
+ $stdoutW->close;
+ $stderrW->close;
+
+ my $msg;
+ $msg .= "From: Echolot Pinger <$address>\n" if $with_from;
+ $msg .= "To: $to\n\n$body\n";
+
+ Echolot::Log::debug("mixping: fds: stdinW $stdinW; stdoutR $stdoutR; stderrR $stderrR."),
+ my ($stdout, $stderr, undef) = Echolot::Tools::readwrite_gpg($msg, $stdinW, $stdoutR, $stderrR, undef);
+ waitpid $pid, 0;
+
+ $stderr =~ s/\n+$//;
+ Echolot::Log::debug("Mixmaster said on unfiltered stderr: $stderr") if ($stderr ne '');
+ $stderr =~ s/^Chain: .*//mg;
+ $stderr =~ s/^Warning: The message has a From: line.*//mg;
+ $stderr =~ s/\n+$//;
+ Echolot::Log::info("Mixmaster said on stdout: $stdout") if ($stdout ne '');
+ Echolot::Log::warn("Mixmaster said on stderr: $stderr") if ($stderr ne '');
+
+ return 1;
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Report.pm b/trunk/Echolot/Report.pm
new file mode 100644
index 0000000..1c2a4ae
--- /dev/null
+++ b/trunk/Echolot/Report.pm
@@ -0,0 +1,70 @@
+package Echolot::Report;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Report - Summarize status of remailers
+
+=head1 DESCRIPTION
+
+This package prints the summary of remailers/addresses.
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+
+sub print_summary(;$) {
+ my ($manual) = @_;
+
+ my @addresses = sort { $a->{'address'} cmp $b->{'address'} } Echolot::Globals::get()->{'storage'}->get_addresses();
+ my $report = "*** Status summary ***\n";
+
+ for my $remailer (@addresses) {
+ my $addr = $remailer->{'address'};
+ $report .= "$addr (ID: $remailer->{'id'}): ".uc($remailer->{'status'})."; ".
+ "Fetch/Ping/Show: ".
+ ($remailer->{'fetch'} ? '1' : '0') .
+ ($remailer->{'pingit'} ? '1' : '0') .
+ ($remailer->{'showit'} ? '1' : '0') .
+ "; TTL: $remailer->{'ttl'}\n";
+ $report .= " Resurection TTL: $remailer->{'resurrection_ttl'}\n" if (defined $remailer->{'resurrection_ttl'} && ($remailer->{'status'} eq 'ttl timeout'));
+ for my $type (Echolot::Globals::get()->{'storage'}->get_types($addr)) {
+ $report .= " Type: $type: ".join(', ', Echolot::Globals::get()->{'storage'}->get_keys($addr, $type))."\n";
+ };
+ };
+ if (defined $manual) {
+ Echolot::Log::notice($report);
+ } else {
+ Echolot::Log::info($report);
+ }
+
+ return 1;
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Scheduler.pm b/trunk/Echolot/Scheduler.pm
new file mode 100644
index 0000000..32d859f
--- /dev/null
+++ b/trunk/Echolot/Scheduler.pm
@@ -0,0 +1,196 @@
+package Echolot::Scheduler;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Scheduler - Task selector/scheduler for echolot
+
+=head1 DESCRIPTION
+
+This package provides several functions for scheduling tasks within
+the ping daemon.
+
+=over
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+
+my $ORDER = 1;
+
+=item B<new> ()
+
+Creates a new scheduler object.
+
+=cut
+sub new {
+ my ($class, %params) = @_;
+ my $self = {};
+ bless $self, $class;
+ return $self;
+};
+
+=item B<add> (I<name>, I<interval>, I<offset>, I<missok>, I<what>)
+
+Adds a task with I<name> to the list of tasks. Every I<interval> seconds
+I<what> is called. If for example I<interval> is 3600 - meaning I<what>
+should be executed hourly - setting I<offset> to 600 would mean that
+it get's called 10 minutes after the hour.
+
+I<missok> indicates that it is ok to miss one run of this job. This can happen
+if we run behind schedule for instance.
+
+=cut
+sub add($$$$$$) {
+ my ($self, $name, $interval, $offset, $missok, $what) = @_;
+
+ Echolot::Log::logdie("Must not add zero intervall for job $name.")
+ unless $interval;
+
+ if (defined $self->{'tasks'}->{$name}) {
+ @{ $self->{'schedule'} } = grep { $_->{'name'} ne $name } @{ $self->{'schedule'} };
+ };
+
+ $self->{'tasks'}->{$name} =
+ {
+ interval => $interval,
+ offset => $offset,
+ what => $what,
+ order => $ORDER++,
+ missok => $missok,
+ };
+
+ $self->schedule($name, 1);
+
+ return 1;
+};
+
+=item B<schedule> (I<name>, I<reschedule>, [ I<for>, [I<arguments>]] )
+
+Schedule execution of I<name> for I<for>. If I<for> is not given it is calculated
+from I<interval> and I<offset> passed to B<new>. if I<reschedule> is set
+the task will be rescheduled when it's done (according to its interval).
+You may also give arguments to passed to the task.
+
+=cut
+sub schedule($$$;$$) {
+ my ($self, $name, $reschedule, $for, $arguments) = @_;
+
+ (defined $self->{'tasks'}->{$name}) or
+ Echolot::Log::warn("Task $name is not defined."),
+ return 0;
+
+ my $interval = $self->{'tasks'}->{$name}->{'interval'};
+ my $offset = $self->{'tasks'}->{$name}->{'offset'};
+
+
+ unless (defined $for) {
+ ($interval < 0) and
+ return 1;
+ my $now = time();
+ $for = $now - $now % $interval + $offset;
+ ($for <= $now) and $for += $interval;
+ my $cnt = 0;
+ while ($self->{'tasks'}->{$name}->{'missok'} && ($for <= $now)) {
+ $for += $interval;
+ $cnt ++;
+ };
+ Echolot::Log::debug("Skipping $cnt runs of $name.") if $cnt;
+ };
+
+ $arguments = [] unless defined $arguments;
+
+ push @{ $self->{'schedule'} },
+ {
+ start => $for,
+ order => $self->{'tasks'}->{$name}->{'order'},
+ name => $name,
+ arguments => $arguments,
+ reschedule => $reschedule
+ };
+
+ @{ $self->{'schedule'} } = sort { $a->{'start'} <=> $b->{'start'} or $a->{'order'} <=> $b->{'order'} }
+ @{ $self->{'schedule'} };
+
+ return 1;
+};
+
+=item B<run> ()
+
+Start the scheduling run.
+
+It will run forever or until a task with I<what> == 'exit' is executed.
+
+=cut
+sub run($) {
+ my ($self) = @_;
+
+ (defined $self->{'schedule'}->[0]) or
+ Echolot::Log::warn("Scheduler is empty."),
+ return 0;
+
+ while(1) {
+ my $now = time();
+ my $task = $self->{'schedule'}->[0];
+ if ($task->{'start'} < $now) {
+ Echolot::Log::warn("Task $task->{'name'} could not be started on time.")
+ unless ($task->{'start'} == 0);
+ } else {
+ Echolot::Log::debug("zZzZZzz.");
+ $PROGRAM_NAME = "pingd [sleeping]";
+ sleep ($task->{'start'} - $now);
+ };
+
+ (time() < $task->{'start'}) and
+ next;
+
+ $now = $task->{'start'};
+ do {
+ $task = shift @{ $self->{'schedule'} };
+ my $name = $task->{'name'};
+ $PROGRAM_NAME = "pingd [executing $name]";
+ (defined $self->{'tasks'}->{$name}) or
+ Echolot::Log::cluck("Task $task->{'name'} is not defined.");
+
+ my $what = $self->{'tasks'}->{$name}->{'what'};
+ Echolot::Log::debug("Running $name (was scheduled for ".(time()-$now)." seconds ago).");
+ last if ($what eq 'exit');
+ &$what( $now, @{ $task->{'arguments'} } );
+ $self->schedule($name, 1, $now + $self->{'tasks'}->{$name}->{'interval'}) if
+ ($task->{'reschedule'} && $self->{'tasks'}->{$name}->{'interval'} > 0);
+
+ (defined $self->{'schedule'}->[0]) or
+ Echolot::Log::warn("Scheduler is empty."),
+ return 0;
+ } while ($now >= $self->{'schedule'}->[0]->{'start'});
+ };
+
+ return 1;
+};
+
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Stats.pm b/trunk/Echolot/Stats.pm
new file mode 100644
index 0000000..852b11b
--- /dev/null
+++ b/trunk/Echolot/Stats.pm
@@ -0,0 +1,983 @@
+package Echolot::Stats;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Stats - produce Stats, keyrings et al
+
+=head1 DESCRIPTION
+
+This package provides functions for generating remailer stats,
+and keyrings.
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+
+my $STATS_DAYS;
+my $SECONDS_PER_DAY;
+my $WEIGHT;
+
+my %LAST_BROKENCHAIN_RUN;
+my %BROKEN_CHAINS;
+
+sub make_date() {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime();
+ sprintf("%s %02d %s %4d %02d:%02d:%02d GMT",
+ Echolot::Tools::make_dayname($wday),
+ $mday,
+ Echolot::Tools::make_monthname($mon),
+ $year + 1900,
+ $hour,
+ $min,
+ $sec);
+};
+
+sub make_min_hr($$) {
+ my ($sec, $includesec) = @_;
+ my ($s, $m, $h);
+
+ if (defined $sec) {
+ $s = $sec % 60;
+ $m = $sec / 60 % 60;
+ $h = int ($sec / 60 / 60);
+ };
+ if ((! defined $sec) || ($sec < 0) || ($h > 99)) {
+ $h = 99;
+ $m = 59;
+ $s = 59;
+ };
+
+ if ($includesec) {
+ if ($h) { return sprintf ("%2d:%02d:%02d", $h, $m, $s); }
+ elsif ($m) { return sprintf ( " %2d:%02d", $m, $s); }
+ else { return sprintf ( " %2d", $s); };
+ } else {
+ if ($h) { return sprintf ("%2d:%02d", $h, $m); }
+ else { return sprintf ( " :%02d", $m); };
+ };
+};
+
+sub build_list1_latencystr($) {
+ my ($lat) = @_;
+
+ my $str = '?' x $STATS_DAYS;
+ for my $day (0 .. $STATS_DAYS - 1) {
+ substr($str, $STATS_DAYS - 1 - $day, 1) =
+ (defined $lat->[$day]) ?
+ ($lat->[$day] < 300 ? '#' :
+ ($lat->[$day] < 3600 ? '*' :
+ ($lat->[$day] < 14400 ? '+' :
+ ($lat->[$day] < 86400 ? '-' :
+ ($lat->[$day] < 172800 ? '.' :
+ '_'
+ )))))
+ : ' ';
+ };
+ return $str;
+}
+
+sub build_list2_latencystr($) {
+ my ($lat) = @_;
+
+ my $str = '?' x $STATS_DAYS;
+ for my $day (0 .. $STATS_DAYS - 1) {
+ substr($str, $STATS_DAYS - 1 - $day, 1) =
+ (defined $lat->[$day]) ?
+ ($lat->[$day] < 20*60 ? '0' :
+ ($lat->[$day] < 1*3600 ? '1' :
+ ($lat->[$day] < 2*3600 ? '2' :
+ ($lat->[$day] < 3*3600 ? '3' :
+ ($lat->[$day] < 4*3600 ? '4' :
+ ($lat->[$day] < 5*3600 ? '5' :
+ ($lat->[$day] < 6*3600 ? '6' :
+ ($lat->[$day] < 7*3600 ? '7' :
+ ($lat->[$day] < 8*3600 ? '8' :
+ ($lat->[$day] < 9*3600 ? '9' :
+ ($lat->[$day] < 12*3600 ? 'A' :
+ ($lat->[$day] < 18*3600 ? 'B' :
+ ($lat->[$day] < 24*3600 ? 'C' :
+ ($lat->[$day] < 30*3600 ? 'D' :
+ ($lat->[$day] < 36*3600 ? 'E' :
+ ($lat->[$day] < 42*3600 ? 'F' :
+ ($lat->[$day] < 48*3600 ? 'G' :
+ 'H'
+ )))))))))))))))))
+ : '?';
+ };
+ return $str;
+}
+
+sub build_list2_reliabilitystr($) {
+ my ($rel) = @_;
+
+ my $str = '?' x $STATS_DAYS;
+ for my $day (0 .. $STATS_DAYS - 1) {
+ substr($str, $STATS_DAYS - 1 - $day, 1) =
+ (defined $rel->[$day]) ?
+ (($rel->[$day] >= 0.9999) ?
+ #(($rel->[$day] == 1) ?
+ '+' :
+ (int ($rel->[$day]*10)))
+ : '?';
+ };
+ return $str;
+}
+
+sub build_list2_capsstr($) {
+ my ($caps) = @_;
+
+ my %caps;
+ $caps{'middle'} = ($caps =~ m/\bmiddle\b/i);
+ $caps{'post'} = ($caps =~ m/\bpost\b/i) || ($caps =~ m/\banon-post-to\b/i);
+ $caps{'mix'} = ($caps =~ m/\bmix\b/i);
+ $caps{'remix'} = ($caps =~ m/\bremix\b/i);
+ $caps{'remix2'} = ($caps =~ m/\bremix2\b/i);
+ $caps{'hybrid'} = ($caps =~ m/\bhybrid\b/i);
+ $caps{'repgp2'} = ($caps =~ m/\brepgp2\b/i);
+ $caps{'repgp'} = ($caps =~ m/\brepgp\b/i);
+ $caps{'pgponly'} = ($caps =~ m/\bpgponly\b/i);
+ $caps{'ext'} = ($caps =~ m/\bext\b/i);
+ $caps{'max'} = ($caps =~ m/\bmax\b/i);
+ $caps{'test'} = ($caps =~ m/\btest\b/i);
+ $caps{'latent'} = ($caps =~ m/\blatent\b/i);
+ $caps{'ek'} = ($caps =~ m/\bek\b/i);
+ $caps{'ekx'} = ($caps =~ m/\bekx\b/i);
+ $caps{'esub'} = ($caps =~ m/\besub\b/i);
+ $caps{'inflt'} = ($caps =~ m/\binflt\d+\b/i);
+ $caps{'rhop'} = ($caps =~ m/\brhop\d+\b/i);
+ ($caps{'klen'}) = ($caps =~ m/\bklen(\d+)\b/i);
+
+ my $str =
+ ($caps{'middle'} ? 'D' : ' ') .
+ ($caps{'post'} ? 'P' : ' ') .
+ ($caps{'remix2'} ? '2' : ($caps{'remix'} ? 'R' : ($caps{'mix'} ? 'M' : ' ' ))) .
+ ($caps{'hybrid'} ? 'H' : ' ') .
+ ($caps{'repgp2'} ? '2' : ($caps{'repgp'} ? 'G' : ' ' )) .
+ ($caps{'pgponly'} ? 'O' : ' ') .
+ ($caps{'ext'} ? 'X' : ' ') .
+ ($caps{'max'} ? 'A' : ' ') .
+ ($caps{'test'} ? 'T' : ' ') .
+ ($caps{'latent'} ? 'L' : ' ') .
+ ($caps{'ekx'} ? 'E' : ($caps{'ek'} ? 'e' : ' ' )) .
+ ($caps{'esub'} ? 'U' : ' ') .
+ ($caps{'inflt'} ? 'I' : ' ') .
+ ($caps{'rhop'} ? 'N' : ' ') .
+ (defined $caps{'klen'} ?
+ ($caps{'klen'} >= 900 ? '9' : (
+ $caps{'klen'} >= 800 ? '8' : (
+ $caps{'klen'} >= 700 ? '7' : (
+ $caps{'klen'} >= 600 ? '6' : (
+ $caps{'klen'} >= 500 ? '5' : (
+ $caps{'klen'} >= 400 ? '4' : (
+ $caps{'klen'} >= 300 ? '3' : (
+ $caps{'klen'} >= 200 ? '2' : (
+ $caps{'klen'} >= 100 ? '1' : '0'
+ )))))))))
+ : ' ');
+ return $str;
+}
+
+sub median($) {
+ my ($arr) = @_;
+
+ my $cnt = scalar @$arr;
+ if ($cnt == 0) {
+ return undef;
+ } elsif ($cnt % 2 == 0) {
+ return (($arr->[ int(($cnt - 1 ) / 2) ] + $arr->[ int($cnt / 2) ] ) / 2);
+ } else {
+ return $arr->[ int(($cnt - 1 ) / 2) ];
+ };
+};
+
+# how many % (0-1) values of @$lats are greater than $lat.
+# $@lats needs to be sorted
+sub percentile($$) {
+ my ($lat, $lats) = @_;
+
+ my $num = scalar @$lats;
+ my $i;
+ for ($i=0; $i < $num; $i++) {
+ last if $lat < $lats->[$i];
+ }
+ return ($num - $i) / $num;
+}
+
+sub calculate($$) {
+ my ($addr, $types) = @_;
+ my $now = time();
+
+ my $SKEW_ABS = 15*60;
+ my $SKEW_PERCENT = 0.80;
+
+ my @out;
+ my @done;
+
+ for my $type (@$types) {
+ next unless Echolot::Globals::get()->{'storage'}->has_type($addr, $type);
+ my @keys = Echolot::Globals::get()->{'storage'}->get_keys($addr, $type);
+ for my $key (@keys) {
+ push @out, grep {$_ > $now - $STATS_DAYS * $SECONDS_PER_DAY} Echolot::Globals::get()->{'storage'}->get_pings($addr, $type, $key, 'out');
+ push @done, grep {$_->[0] > $now - $STATS_DAYS * $SECONDS_PER_DAY} Echolot::Globals::get()->{'storage'}->get_pings($addr, $type, $key, 'done');
+ };
+ };
+
+ my @latency_total = map { $_->[1] } @done;
+ my @latency_day;
+ my $sent_total;
+ my $received_total = 0;
+ my @sent_day;
+ my @received_day;
+ for my $done (@done) {
+ push @{ $latency_day [int(($now - $done->[0]) / $SECONDS_PER_DAY)] }, $done->[1];
+ my $day = int(($now - $done->[0]) / $SECONDS_PER_DAY);
+ my $weight = $WEIGHT->[$day];
+ $sent_total += $weight; $sent_day [$day] ++;
+ $received_total += $weight; $received_day[$day] ++;
+ };
+
+ @latency_total = sort { $a <=> $b } @latency_total;
+ my $latency_median = median (\@latency_total);
+ my @latency_median_day;
+ for ( 0 .. $STATS_DAYS - 1 ) {
+ @{$latency_day[$_]} = defined $latency_day[$_] ? (sort { $a <=> $b } @{$latency_day[$_]}) : ();
+ $latency_median_day[$_] = median ( $latency_day[$_] );
+ }
+
+ if (scalar @out) {
+ my @p = ( scalar @latency_total ) ?
+ map { #printf(STDERR "($now - $_ - $SKEW_ABS)/$SKEW_PERCENT ".
+ #"%s in (%s): %s\n", ($now - $_ - $SKEW_ABS)/$SKEW_PERCENT, join(',', @latency_total),
+ #percentile( ($now - $_ - $SKEW_ABS)/$SKEW_PERCENT , \@latency_total ));
+ percentile( ($now - $_ - $SKEW_ABS)/$SKEW_PERCENT , \@latency_total ) } @out :
+ map { 0 } @out;
+ for (my $i=0; $i < scalar @out; $i++) {
+ my $day = int(($now - $out[$i]) / $SECONDS_PER_DAY);
+ my $weight = $WEIGHT->[$day];
+ $sent_total += $weight; $sent_day [$day] ++;
+ $received_total += $weight * $p[$i]; $received_day[$day] += $p[$i];
+ };
+ };
+ #printf STDERR "$received_total / %s\n", (defined $sent_total ? $sent_total : 'n/a');
+ $received_total /= $sent_total if ($sent_total);
+ for ( 0 .. $STATS_DAYS - 1 ) {
+ $received_day[$_] /= $sent_day[$_] if ($sent_day[$_]);
+ };
+
+
+
+ return {
+ avr_latency => $latency_median,
+ avr_reliability => $received_total,
+ latency_day => \@latency_median_day,
+ reliability_day => \@received_day
+ };
+};
+
+sub write_file($$$$) {
+ my ($filebasename, $html_template, $expires, $output) = @_;
+
+ my $filename = $filebasename.'.txt';
+ open(F, '>'.$filename) or
+ Echolot::Log::warn("Cannot open $filename: $!."),
+ return 0;
+ print F $output;
+ close (F);
+ if (defined $expires) {
+ Echolot::Tools::write_meta_information($filename,
+ Expires => time + $expires) or
+ Echolot::Log::debug ("Error while writing meta information for $filename."),
+ return 0;
+ };
+ return 1 unless defined $html_template;
+
+ if (defined $output) {
+ $output =~ s/&/&amp;/g;
+ $output =~ s/"/&quot;/g;
+ $output =~ s/</&lt;/g;
+ $output =~ s/>/&gt;/g;
+ };
+ Echolot::Tools::write_HTML_file($filebasename, $html_template, $expires, list => $output);
+
+ return 1;
+};
+
+sub build_mlist1($$$$$;$) {
+ my ($rems, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
+
+ my $output = '';
+ $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
+ $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
+ $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
+
+ $output .= sprintf "Last update: %s\n", make_date();
+ $output .= sprintf "mixmaster history latency uptime\n";
+ $output .= sprintf "--------------------------------------------\n";
+
+ for my $remailer (@$rems) {
+ $output .= sprintf "%-14s %-12s %8s %6.2f%%\n",
+ substr($remailer->{'nick'},0,14),
+ build_list1_latencystr($remailer->{'stats'}->{'latency_day'}),
+ make_min_hr($remailer->{'stats'}->{'avr_latency'}, 1),
+ $remailer->{'stats'}->{'avr_reliability'} * 100;
+ };
+
+ write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
+ Echolot::Log::debug("writefile failed."),
+ return 0;
+ return 1;
+};
+
+sub build_rlist1($$$$$;$) {
+ my ($rems, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
+
+ my $output = '';
+ for my $remailer (sort {$a->{'caps'} cmp $b->{'caps'}} @$rems) {
+ $output .= $remailer->{'caps'}."\n"
+ }
+
+ $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
+ $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
+ $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
+
+ $output .= sprintf "\n";
+ $output .= sprintf "Last update: %s\n", make_date();
+ $output .= sprintf "remailer email address history latency uptime\n";
+ $output .= sprintf "-----------------------------------------------------------------------\n";
+
+ for my $remailer (@$rems) {
+ $output .= sprintf "%-8s %-32s %-12s %8s %6.2f%%\n",
+ substr($remailer->{'nick'},0,8),
+ substr($remailer->{'address'},0,32),
+ build_list1_latencystr($remailer->{'stats'}->{'latency_day'}),
+ make_min_hr($remailer->{'stats'}->{'avr_latency'}, 1),
+ $remailer->{'stats'}->{'avr_reliability'} * 100;
+ };
+
+
+ write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
+ Echolot::Log::debug("writefile failed."),
+ return 0;
+ return 1;
+};
+
+
+sub build_list2($$$$$$;$) {
+ my ($rems, $type, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
+
+ my $output = '';
+
+ $output .= sprintf "Stats-Version: 2.0\n";
+ $output .= sprintf "Generated: %s\n", make_date();
+ $output .= sprintf "%-12s Latent-Hist Latent Uptime-Hist Uptime Options\n", ($type == 1 ? 'Cypherpunk' : $type == 2 ? 'Mixmaster' : "Type $type");
+ $output .= sprintf "------------------------------------------------------------------------\n";
+
+ for my $remailer (@$rems) {
+ $output .= sprintf "%-12s %-12s %6s %-12s %5.1f%% %s\n",
+ substr($remailer->{'nick'},0,12),
+ build_list2_latencystr($remailer->{'stats'}->{'latency_day'}),
+ make_min_hr($remailer->{'stats'}->{'avr_latency'}, 0),
+ build_list2_reliabilitystr($remailer->{'stats'}->{'reliability_day'}),
+ $remailer->{'stats'}->{'avr_reliability'} * 100,
+ build_list2_capsstr($remailer->{'caps'});
+ };
+
+ $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
+ $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
+ $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
+
+ $output .= sprintf "\n\n\nRemailer-Capabilities:\n\n";
+ for my $remailer (sort {$a->{'caps'} cmp $b->{'caps'}} @$rems) {
+ $output .= $remailer->{'caps'}."\n" if defined $remailer->{'caps'};
+ }
+
+ write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
+ Echolot::Log::debug("writefile failed."),
+ return 0;
+ return 1;
+};
+
+sub build_clist($$$$$;$) {
+ my ($remhash, $broken1, $broken2, $sameop, $filebasename, $html_template) = @_;
+
+ my $output = '';
+
+ $output .= sprintf "Stats-Version: 2.0.1\n";
+ $output .= sprintf "Generated: %s\n", make_date();
+ $output .= sprintf "Mixmaster Latent-Hist Latent Uptime-Hist Uptime Options Type\n";
+ $output .= sprintf "------------------------------------------------------------------------------------\n";
+
+ my $all;
+ for my $type (keys %$remhash) {
+ for my $remailer (@{$remhash->{$type}}) {
+ $all->{ $remailer->{'nick'} }->{$type} = $remailer
+ };
+ };
+
+ for my $nick (sort {$a cmp $b} keys %$all) {
+ for my $type (sort {$a cmp $b} keys %{$all->{$nick}}) {
+ $output .= sprintf "%-12s %-12s %6s %-12s %5.1f%% %s %s\n",
+ $nick,
+ build_list2_latencystr($all->{$nick}->{$type}->{'stats'}->{'latency_day'}),
+ make_min_hr($all->{$nick}->{$type}->{'stats'}->{'avr_latency'}, 0),
+ build_list2_reliabilitystr($all->{$nick}->{$type}->{'stats'}->{'reliability_day'}),
+ $all->{$nick}->{$type}->{'stats'}->{'avr_reliability'} * 100,
+ build_list2_capsstr($all->{$nick}->{$type}->{'caps'}),
+ $type;
+ };
+ };
+
+ $output .= sprintf "\nGroups of remailers sharing a machine or operator:\n$sameop\n" if (defined $sameop);
+ $output .= sprintf "\nBroken type-I remailer chains:\n$broken1\n" if (defined $broken1);
+ $output .= sprintf "\nBroken type-II remailer chains:\n$broken2\n" if (defined $broken2);
+
+ $output .= sprintf "\n\n\nRemailer-Capabilities:\n\n";
+ for my $nick (sort {$a cmp $b} keys %$all) {
+ for my $type (keys %{$all->{$nick}}) {
+ $output .= $all->{$nick}->{$type}->{'caps'}."\n", last if defined $all->{$nick}->{$type}->{'caps'};
+ };
+ }
+
+ write_file($filebasename, $html_template, Echolot::Config::get()->{'buildstats'}, $output) or
+ Echolot::Log::debug("writefile failed."),
+ return 0;
+ return 1;
+};
+
+
+sub build_rems($) {
+ my ($types) = @_;
+
+ my %rems;
+ for my $remailer (Echolot::Globals::get()->{'storage'}->get_addresses()) {
+ my $addr = $remailer->{'address'};
+ my $has_type = 0;
+ for my $type (@$types) {
+ $has_type = 1, last if (Echolot::Globals::get()->{'storage'}->has_type($addr, $type));
+ };
+ next unless $has_type;
+
+ my $rem = {
+ 'stats' => calculate($addr,$types),
+ 'nick' => Echolot::Globals::get()->{'storage'}->get_nick($addr),
+ 'caps' => Echolot::Globals::get()->{'storage'}->get_capabilities($addr),
+ 'address' => $addr,
+ };
+ $rem->{'list-it'} = $remailer->{'showit'} && defined $rem->{'caps'} && ($rem->{'caps'} !~ m/\btesting\b/i);
+ $rem->{'latency'} = $rem->{'stats'}->{'avr_latency'}; # for sorting purposes only
+ $rem->{'latency'} = 9999 unless defined $rem->{'latency'};
+
+ $rems{$addr} = $rem if (defined $rem->{'stats'} && defined $rem->{'nick'} && defined $rem->{'address'} && defined $rem->{'caps'} );
+ };
+
+ my $sort_by_latency = Echolot::Config::get()->{'stats_sort_by_latency'};
+ my @rems =
+ sort {
+ - ($a->{'stats'}->{'avr_reliability'} <=> $b->{'stats'}->{'avr_reliability'}) ||
+ (($a->{'latency'} <=> $b->{'latency'}) * $sort_by_latency) ||
+ ($a->{'nick'} cmp $b->{'nick'})
+ } map { $rems{$_} } keys %rems;
+
+ return \@rems;
+};
+
+sub compress_broken_chain($@) {
+ my ($num, @list) = @_;
+
+ my %unique = ();
+ @list = sort { $a cmp $b} grep { ! $unique{$_}++; } @list;
+
+ my %bad_left;
+ my %bad_right;
+ for my $chain (@list) {
+ chomp $chain;
+ my ($left, $right) = $chain =~ m/\((\S+) \s (\S+)\)/x or
+ Echolot::Log::warn("Could not parse bad chain '$chain'."),
+ next;
+ $bad_right{$right}++;
+ $bad_right{$right} += $num if ($left eq '*');
+ $bad_left {$left }++;
+ $bad_left {$left } += $num if ($right eq '*');
+ };
+
+
+ my $threshold = $num * Echolot::Config::get()->{'chainping_allbad_factor'};
+ my @result = ();
+ for my $key (keys %bad_right) {
+ delete $bad_right{$key}, next if $bad_right{$key} < $threshold;
+ push @result, "(* $key)";
+ };
+ for my $key (keys %bad_left) {
+ delete $bad_left{$key}, next if $bad_left{$key} < $threshold;
+ push @result, "($key *)";
+ };
+
+ for my $chain (@list) {
+ chomp $chain;
+ my ($left, $right) = $chain =~ m/\((\S+) \s (\S+)\)/x or
+ # Echolot::Log::warn("Could not parse bad chain '$chain'."), -- don't warn again
+ push(@result, $chain),
+ next;
+ next if defined $bad_right{$right};
+ next if defined $bad_left {$left };
+ push(@result, $chain),
+ };
+
+ %unique = ();
+ @result = sort { $a cmp $b} grep { ! $unique{$_}++; } @result;
+
+ return @result;
+};
+
+sub find_broken_chains($$$) {
+ my ($chaintype, $rems, $hard) = @_;
+
+ if (!defined $LAST_BROKENCHAIN_RUN{$chaintype} ||
+ $LAST_BROKENCHAIN_RUN{$chaintype} < time() - Echolot::Config::get()->{'chainping_update'} ||
+ ! defined $BROKEN_CHAINS{$chaintype} ) {
+ Echolot::Log::debug ("Broken Chains $chaintype need generating."),
+ $LAST_BROKENCHAIN_RUN{$chaintype} = time();
+
+ my $pings = Echolot::Globals::get()->{'storage'}->get_chainpings($chaintype);
+ my @intensive_care = ();
+ my %remailers = map { $_->{'address'} => $_ } @$rems;
+
+ my $stats;
+ my %received;
+ my @broken_chains;
+ for my $status (qw{done out}) {
+ my $status_done = $status eq 'done';
+ my $status_out = $status eq 'out';
+ for my $ping (@{$pings->{$status}}) {
+ my $addr1 = $ping->{'addr1'};
+ my $addr2 = $ping->{'addr2'};
+ my $sent = $ping->{'sent'};
+ next if $sent < (time() - Echolot::Config::get()->{'chainping_period'});
+ next unless defined $remailers{$addr1};
+ next unless defined $remailers{$addr2};
+
+ if ($status_done) {
+ $received{$addr1.':'.$addr2.':'.$sent} = 1;
+ };
+ if ($status_out && !defined $received{$addr1.':'.$addr2.':'.$sent}) {
+ my $lat1 = $remailers{$addr1}->{'stats'}->{'avr_latency'};
+ my $lat2 = $remailers{$addr2}->{'stats'}->{'avr_latency'};
+ $lat1 = 0 unless defined $lat1;
+ $lat2 = 0 unless defined $lat2;
+ my $theoretical_lat = $lat1 + $lat2;
+ $theoretical_lat = 0 unless defined $theoretical_lat;
+ my $latency = time() - $ping->{'sent'};
+ # print ("lat helps $latency < ".int($theoretical_lat * Echolot::Config::get()->{'chainping_grace'})." $addr1 $addr2\n"),
+ next if ($latency < $theoretical_lat * Echolot::Config::get()->{'chainping_grace'});
+ };
+
+ # print "Having $addr1 $addr2 $status at $sent\n";
+ $stats->{$addr1}->{$addr2}->{$status}++;
+ };
+ };
+ # require Data::Dumper;
+ # print Data::Dumper->Dump([$stats]);
+ for my $addr1 (keys %$stats) {
+ for my $addr2 (keys %{$stats->{$addr1}}) {
+ my $theoretical_rel = $remailers{$addr1}->{'stats'}->{'avr_reliability'} *
+ $remailers{$addr2}->{'stats'}->{'avr_reliability'};
+ my $out = $stats->{$addr1}->{$addr2}->{'out'};
+ my $done = $stats->{$addr1}->{$addr2}->{'done'};
+ $done = 0 unless defined $done;
+ ($out < Echolot::Config::get()->{'chainping_minsample'} && $done == 0) and
+ push (@intensive_care, { addr1 => $addr1, addr2 => $addr2, reason => "only $out sample".($out>1?'s':'').", none returned so far" }),
+ next;
+ ($out > 0) or
+ Echolot::Log::debug("Should not devide through zero ($done/$out) for $addr1, $addr2."),
+ next;
+ my $real_rel = $done / $out;
+ # print "$addr1 $addr2 $done / $out == $real_rel ($theoretical_rel)\n";
+ next if ($real_rel > $theoretical_rel * Echolot::Config::get()->{'chainping_fudge'});
+ my $nick1 = $remailers{$addr1}->{'nick'};
+ my $nick2 = $remailers{$addr2}->{'nick'};
+ push @broken_chains,
+ { public => $remailers{$addr1}->{'list-it'} && $remailers{$addr2}->{'list-it'},
+ chain => "($nick1 $nick2)" };
+ push @intensive_care, { addr1 => $addr1, addr2 => $addr2, reason => "bad: $done/$out" };
+ };
+ };
+ $BROKEN_CHAINS{$chaintype} = \@broken_chains;
+ Echolot::Chain::set_intensive_care($chaintype, \@intensive_care);
+ } else {
+ Echolot::Log::debug ("Broken Chains $chaintype are up to date."),
+ };
+
+ my @hard = defined $hard ? (split /\n/, $hard) : ();
+ my @pub = @hard;
+ my @priv = @hard;
+ push @pub, map { $_->{'chain'} } grep { $_->{'public'} } @{ $BROKEN_CHAINS{$chaintype} };
+ push @priv, map { $_->{'chain'} } @{ $BROKEN_CHAINS{$chaintype} };
+
+ my $pub = join "\n", compress_broken_chain(scalar @$rems, @pub);
+ my $priv = join "\n", compress_broken_chain(scalar @$rems, @priv);
+
+ return ($pub, $priv);
+};
+
+sub build_lists() {
+
+ my $clist;
+ my $pubclist;
+ my $rems;
+ my $pubrems;
+
+ my %stats;
+ my %addresses;
+
+ my $hardbroken1 = Echolot::Tools::read_file( Echolot::Config::get()->{'broken1'}, 1);
+ my $hardbroken2 = Echolot::Tools::read_file( Echolot::Config::get()->{'broken2'}, 1);
+ my $sameop = Echolot::Tools::read_file( Echolot::Config::get()->{'sameop'}, 1);
+ my $pubbroken1;
+ my $pubbroken2;
+ my $privbroken1;
+ my $privbroken2;
+
+ my $mixrems = build_rems(['mix']);
+ my $cpunkrems = build_rems(['cpunk-rsa', 'cpunk-dsa', 'cpunk-clear']);
+
+ if (Echolot::Config::get()->{'do_chainpings'}) {
+ ($pubbroken1, $privbroken1) = find_broken_chains('cpunk', $cpunkrems, $hardbroken1);
+ ($pubbroken2, $privbroken2) = find_broken_chains('mix' , $mixrems , $hardbroken2);
+ } else {
+ $pubbroken1 = $privbroken1 = $hardbroken1;
+ $pubbroken2 = $privbroken2 = $hardbroken2;
+ };
+
+ unless (Echolot::Config::get()->{'show_chainpings'}) {
+ $pubbroken1 = $hardbroken1;
+ $pubbroken2 = $hardbroken2;
+ };
+
+ $rems = $mixrems;
+ $mixrems = undef;
+ @$pubrems = grep { $_->{'list-it'} } @$rems;
+ build_mlist1( $rems, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'mlist', 'mlist');
+ build_list2( $rems, 2, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'mlist2', 'mlist2');
+ build_mlist1( $pubrems, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'mlist', 'mlist');
+ build_list2( $pubrems, 2, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'mlist2', 'mlist2');
+ $stats{'mix_total'} = scalar @$pubrems;
+ $stats{'mix_98'} = scalar grep { $_->{'stats'}->{'avr_reliability'} >= 0.98 } @$pubrems;
+ $addresses{$_->{'address'}}=1 for @$pubrems;
+ if (Echolot::Config::get()->{'combined_list'}) {
+ $clist->{'mix'} = $rems;
+ $pubclist->{'mix'} = $pubrems; $pubrems = undef;
+ };
+
+ $rems = $cpunkrems;
+ $cpunkrems = undef;
+ @$pubrems = grep { $_->{'list-it'} } @$rems;
+ build_rlist1( $rems, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist', 'rlist');
+ build_list2( $rems, 1, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2', 'rlist2');
+ build_rlist1( $pubrems, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist', 'rlist');
+ build_list2( $pubrems, 1, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2', 'rlist2');
+ $stats{'cpunk_total'} = scalar @$pubrems;
+ $stats{'cpunk_98'} = scalar grep { $_->{'stats'}->{'avr_reliability'} >= 0.98 } @$pubrems;
+ $addresses{$_->{'address'}}=1 for @$pubrems;
+ if (Echolot::Config::get()->{'combined_list'} && ! Echolot::Config::get()->{'separate_rlists'}) {
+ $clist->{'cpunk'} = $rems;
+ $pubclist->{'cpunk'} = $pubrems; $pubrems = undef;
+ };
+
+ if (Echolot::Config::get()->{'separate_rlists'}) {
+ $rems = build_rems(['cpunk-rsa']);
+ @$pubrems = grep { $_->{'list-it'} } @$rems;
+ build_rlist1( $rems, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist-rsa', 'rlist-rsa');
+ build_list2( $rems, 1, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2-rsa', 'rlist2-rsa');
+ build_rlist1( $pubrems, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist-rsa', 'rlist-rsa');
+ build_list2( $pubrems, 1, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2-rsa', 'rlist2-rsa');
+ if (Echolot::Config::get()->{'combined_list'}) {
+ $clist->{'cpunk-rsa'} = $rems;
+ $pubclist->{'cpunk-rsa'} = $pubrems; $pubrems = undef;
+ };
+
+ $rems = build_rems(['cpunk-dsa']);
+ @$pubrems = grep { $_->{'list-it'} } @$rems;
+ build_rlist1( $rems, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist-dsa', 'rlist-dsa');
+ build_list2( $rems, 1, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2-dsa', 'rlist2-dsa');
+ build_rlist1( $pubrems, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist-dsa', 'rlist-dsa');
+ build_list2( $pubrems, 1, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2-dsa', 'rlist2-dsa');
+ if (Echolot::Config::get()->{'combined_list'}) {
+ $clist->{'cpunk-dsa'} = $rems;
+ $pubclist->{'cpunk-dsa'} = $pubrems; $pubrems = undef;
+ };
+
+ $rems = build_rems(['cpunk-clear']);
+ @$pubrems = grep { $_->{'list-it'} } @$rems;
+ build_rlist1( $rems, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist-clear', 'rlist-clear');
+ build_list2( $rems, 1, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'rlist2-clear', 'rlist2-clear');
+ build_rlist1( $pubrems, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist-clear', 'rlist-clear');
+ build_list2( $pubrems, 1, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'rlist2-clear', 'rlist2-clear');
+ if (Echolot::Config::get()->{'combined_list'}) {
+ $clist->{'cpunk-clear'} = $rems;
+ $pubclist->{'cpunk-clear'} = $pubrems; $pubrems = undef;
+ };
+ };
+ if (Echolot::Config::get()->{'combined_list'}) {
+ build_clist( $clist, $privbroken1, $privbroken2, $sameop, Echolot::Config::get()->{'private_resultdir'}.'/'.'clist', 'clist');
+ build_clist( $pubclist, $pubbroken1, $pubbroken2, $sameop, Echolot::Config::get()->{'resultdir'}.'/'.'clist', 'clist');
+ };
+
+ $stats{'unique_addresses'} = scalar keys %addresses;
+ Echolot::Tools::write_HTML_file(
+ Echolot::Config::get()->{'resultdir'}.'/'.Echolot::Config::get()->{'indexfilebasename'},
+ 'indexfile',
+ Echolot::Config::get()->{'buildstats'},
+ %stats );
+
+ my $file = Echolot::Config::get()->{'echolot_css'},
+ my $css;
+ {
+ local $/ = undef;
+ open(F, $file) or
+ Echolot::Log::warn("Could not open $file: $!."),
+ return 0;
+ $css = <F>;
+ close (F) or
+ Echolot::Log::warn("Cannot close $file: $!."),
+ return 0;
+ }
+ $file = Echolot::Config::get()->{'resultdir'}.'/echolot.css';
+ open(F, '>'.$file) or
+ Echolot::Log::warn("Cannot open $file: $!."),
+ return 0;
+ print F $css or
+ Echolot::Log::warn("Cannot print to $file: $!."),
+ return 0;
+ close (F) or
+ Echolot::Log::warn("Cannot close $file: $!."),
+ return 0;
+
+};
+
+
+sub build_mixring() {
+ my @filenames;
+
+ my $filename = Echolot::Config::get()->{'resultdir'}.'/pubring.mix';
+ push @filenames, $filename;
+ open(F, '>'.$filename) or
+ Echolot::Log::warn("Cannot open $filename: $!."),
+ return 0;
+ $filename = Echolot::Config::get()->{'resultdir'}.'/type2.list';
+ push @filenames, $filename;
+ open(T2L, '>'.$filename) or
+ Echolot::Log::warn("Cannot open $filename: $!."),
+ return 0;
+ $filename = Echolot::Config::get()->{'private_resultdir'}.'/pubring.mix';
+ push @filenames, $filename;
+ open(F_PRIV, '>'.$filename) or
+ Echolot::Log::warn("Cannot open $filename: $!."),
+ return 0;
+ $filename = Echolot::Config::get()->{'private_resultdir'}.'/type2.list';
+ push @filenames, $filename;
+ open(T2L_PRIV, '>'.$filename) or
+ Echolot::Log::warn("Cannot open $filename: $!."),
+ return 0;
+
+ my $data;
+ for my $remailer (Echolot::Globals::get()->{'storage'}->get_addresses()) {
+ my $addr = $remailer->{'address'};
+ next unless Echolot::Globals::get()->{'storage'}->has_type($addr, 'mix');
+
+ my %key;
+ for my $keyid (Echolot::Globals::get()->{'storage'}->get_keys($addr, 'mix')) {
+ my %new_key = Echolot::Globals::get()->{'storage'}->get_key($addr, 'mix', $keyid);
+
+ if (!defined $key{'last_update'} || $key{'last_update'} < $new_key{'last_update'} ) {
+ %key = %new_key;
+ };
+ };
+
+ my $caps = Echolot::Globals::get()->{'storage'}->get_capabilities($addr);
+ $key{'list-it'} = $remailer->{'showit'} && defined $caps && ($caps !~ m/\btesting\b/i);
+ if ( defined Echolot::Globals::get()->{'storage'}->get_nick($addr) ) {
+ $data->{$key{'summary'}} = \%key;
+ $data->{$key{'summary'}} = \%key;
+ };
+ };
+
+ for my $indx (sort {$a cmp $b} keys %$data) {
+ my $key = $data->{$indx};
+ if ($key->{'list-it'}) {
+ print F $key->{'summary'}."\n\n";
+ print F $key->{'key'},"\n\n";
+ print T2L $key->{'summary'},"\n";
+ };
+ print F_PRIV $key->{'summary'}."\n\n";
+ print F_PRIV $key->{'key'},"\n\n";
+ print T2L_PRIV $key->{'summary'},"\n";
+ };
+
+ close(F);
+ close(T2L);
+ close(F_PRIV);
+ close(T2L_PRIV);
+
+ for my $filename (@filenames) {
+ Echolot::Tools::write_meta_information($filename,
+ Expires => time + Echolot::Config::get()->{'buildkeys'}) or
+ Echolot::Log::debug ("Error while writing meta information for $filename."),
+ return 0;
+ };
+};
+
+
+
+sub build_pgpring_type($$$$) {
+ my ($type, $GnuPG, $keyring, $keyids) = @_;
+
+ for my $remailer (Echolot::Globals::get()->{'storage'}->get_addresses()) {
+ my $addr = $remailer->{'address'};
+ next unless Echolot::Globals::get()->{'storage'}->has_type($addr, $type);
+
+ my %key;
+ my $final_keyid;
+ for my $keyid (Echolot::Globals::get()->{'storage'}->get_keys($addr, $type)) {
+ my %new_key = Echolot::Globals::get()->{'storage'}->get_key($addr, $type, $keyid);
+
+ if (!defined $key{'last_update'} || $key{'last_update'} < $new_key{'last_update'} ) {
+ %key = %new_key;
+ $final_keyid = $keyid;
+ };
+ };
+
+ # only if we have a conf
+ if ( defined Echolot::Globals::get()->{'storage'}->get_nick($addr) ) {
+ my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh, $handles ) = Echolot::Tools::make_gpg_fds();
+ my $pid = $GnuPG->wrap_call(
+ commands => [ '--import' ],
+ command_args => [qw{--no-options --no-secmem-warning --no-default-keyring --fast-list-mode --keyring}, $keyring, '--', '-' ],
+ handles => $handles );
+ my ($stdout, $stderr, $status) = Echolot::Tools::readwrite_gpg($key{'key'}, $stdin_fh, $stdout_fh, $stderr_fh, $status_fh);
+ waitpid $pid, 0;
+
+ ($stdout eq '') or
+ Echolot::Log::info("GnuPG returned something in stdout '$stdout' while adding key for '$addr': So what?");
+ # See DETAIL.gz in GnuPG's doc directory for syntax of GnuPG status
+ my ($count, $count_imported) = $status =~ /^\[GNUPG:\] IMPORT_RES (\d+) \d+ (\d+)/m;
+ if ($count_imported > 1) {
+ Echolot::Log::info("GnuPG status '$status' indicates more than one key for '$addr' imported. Ignoring.");
+ } elsif ($count_imported < 1) {
+ Echolot::Log::info("GnuPG status '$status' didn't indicate key for '$addr' was imported correctly. Ignoring.");
+ };
+ my $caps = Echolot::Globals::get()->{'storage'}->get_capabilities($addr);
+ $keyids->{$final_keyid} = $remailer->{'showit'} && defined $caps && ($caps !~ m/\btesting\b/i);
+ };
+ };
+
+ return 1;
+};
+
+sub build_pgpring_export($$$$) {
+ my ($GnuPG, $keyring, $file, $keyids) = @_;
+
+ my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh, $handles ) = Echolot::Tools::make_gpg_fds();
+ my $pid = $GnuPG->wrap_call(
+ commands => [ '--export' ],
+ command_args => [qw{--no-options --no-secmem-warning --no-default-keyring --keyring}, $keyring, @$keyids ],
+ handles => $handles );
+ my ($stdout, $stderr, $status) = Echolot::Tools::readwrite_gpg('', $stdin_fh, $stdout_fh, $stderr_fh, $status_fh);
+ waitpid $pid, 0;
+
+ open (F, ">$file") or
+ Echolot::Log::warn ("Cannot open '$file': $!."),
+ return 0;
+ print F $stdout;
+ close F;
+
+ Echolot::Tools::write_meta_information($file,
+ Expires => time + Echolot::Config::get()->{'buildkeys'}) or
+ Echolot::Log::debug ("Error while writing meta information for $file."),
+ return 0;
+
+ return 1;
+};
+
+sub build_pgpring() {
+ my $GnuPG = new GnuPG::Interface;
+ $GnuPG->call( Echolot::Config::get()->{'gnupg'} ) if (Echolot::Config::get()->{'gnupg'});
+ $GnuPG->options->hash_init(
+ armor => 1,
+ homedir => Echolot::Config::get()->{'gnupghome'} );
+ $GnuPG->options->meta_interactive( 0 );
+
+ my $keyring = Echolot::Config::get()->{'tmpdir'}.'/'.
+ Echolot::Globals::get()->{'hostname'}.".".time.'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internalcounter'}++.'.keyring';
+
+
+ my $keyids = {};
+ build_pgpring_type('cpunk-rsa', $GnuPG, $keyring, $keyids) or
+ Echolot::Log::debug("build_pgpring_type failed."),
+ return undef;
+
+ build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'resultdir'}.'/pgp-rsa.asc', [ grep {$keyids->{$_}} keys %$keyids ]) or
+ Echolot::Log::debug("build_pgpring_export failed."),
+ return undef;
+
+ build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'private_resultdir'}.'/pgp-rsa.asc', [ keys %$keyids ]) or
+ Echolot::Log::debug("build_pgpring_export failed."),
+ return undef;
+
+ build_pgpring_type('cpunk-dsa', $GnuPG, $keyring, $keyids) or
+ Echolot::Log::debug("build_pgpring_type failed."),
+ return undef;
+
+ build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'resultdir'}.'/pgp-all.asc', [ grep {$keyids->{$_}} keys %$keyids ]) or
+ Echolot::Log::debug("build_pgpring_export failed."),
+ return undef;
+
+ build_pgpring_export($GnuPG, $keyring, Echolot::Config::get()->{'private_resultdir'}.'/pgp-all.asc', [ keys %$keyids ]) or
+ Echolot::Log::debug("build_pgpring_export failed."),
+ return undef;
+
+
+ unlink ($keyring) or
+ Echolot::Log::warn("Cannot unlink tmp keyring '$keyring'."),
+ return undef;
+ unlink ($keyring.'~'); # gnupg does those evil backups
+};
+
+sub build_stats() {
+ $STATS_DAYS = Echolot::Config::get()->{'stats_days'};
+ $SECONDS_PER_DAY = Echolot::Config::get()->{'seconds_per_day'};
+ $WEIGHT = Echolot::Config::get()->{'pings_weight'};
+ build_lists();
+};
+sub build_keys() {
+ build_mixring();
+ build_pgpring();
+};
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Storage/File.pm b/trunk/Echolot/Storage/File.pm
new file mode 100644
index 0000000..1f6d21d
--- /dev/null
+++ b/trunk/Echolot/Storage/File.pm
@@ -0,0 +1,1880 @@
+package Echolot::Storage::File;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Storage::File - Storage backend for echolot
+
+=head1 DESCRIPTION
+
+This package provides several functions for data storage for echolot.
+
+=over
+
+=cut
+
+use strict;
+use Data::Dumper;
+use IO::Handle;
+use English;
+use Carp;
+use Fcntl ':flock'; # import LOCK_* constants
+#use Fcntl ':seek'; # import SEEK_* constants
+use POSIX; # import SEEK_* constants (older perls don't have SEEK_ in Fcntl)
+use Echolot::Tools;
+use Echolot::Log;
+
+
+
+my $CONSTANTS = {
+ 'metadatafile' => 'metadata'
+};
+
+delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
+
+my $METADATA_VERSION = 1;
+
+
+=item B<new> (I<%args>)
+
+Creates a new storage backend object.
+args keys:
+
+=over
+
+=item I<datadir>
+
+The basedir where this module may store it's configuration and pinging
+data.
+
+=back
+
+=cut
+sub new {
+ my ($class, %params) = @_;
+ my $self = {};
+ bless $self, $class;
+
+ $self->{'METADATA_FILE_IS_NEW'} = 0;
+
+ defined($params{'datadir'}) or
+ confess ('No datadir option passed to new');
+ $self->{'datadir'} = $params{'datadir'};
+ $self->{'DELAY_COMMIT'} = 0;
+
+ $self->delay_commit();
+ $self->metadata_open() or
+ confess ('Opening Metadata failed. Exiting');
+ $self->metadata_read() or
+ confess ('Reading Metadata from Storage failed. Exiting');
+ $self->pingdata_open() or
+ confess ('Opening Ping files failed. Exiting');
+ $self->chainpingdata_open() or
+ confess ('Opening Ping files failed. Exiting');
+ $self->enable_commit();
+
+ return $self;
+};
+
+=item $storage->B<commit>( )
+
+Write metadata unless B<delay_commt> is set.
+
+=cut
+sub commit($) {
+ my ($self) = @_;
+
+ if ($self->{'DELAY_COMMIT'}) {
+ $self->{'COMMIT_PENDING'} = 1;
+ return;
+ };
+ $self->metadata_write();
+ $self->{'COMMIT_PENDING'} = 0;
+};
+
+=item $storage->B<delay_commit>( )
+
+Increase B<delay_commit> by one.
+
+=cut
+sub delay_commit($) {
+ my ($self) = @_;
+
+ $self->{'DELAY_COMMIT'}++;
+};
+
+=item $storage->B<enable_commit>( I<$set_> )
+
+Decrease B<delay_commit> by one and call C<commit> if B<delay_commit> is zero
+and I<$set_pending> is true.
+
+=cut
+sub enable_commit($;$) {
+ my ($self, $set_pending) = @_;
+
+ $self->{'DELAY_COMMIT'}--;
+ $self->commit() if (($self->{'COMMIT_PENDING'} || (defined $set_pending && $set_pending)) && ! $self->{'DELAY_COMMIT'});
+};
+
+=item $storage->B<finish>( )
+
+Shut down cleanly.
+
+=cut
+sub finish($) {
+ my ($self) = @_;
+
+ $self->pingdata_close();
+ $self->chainpingdata_close();
+ $self->metadata_write();
+ $self->metadata_close();
+};
+
+
+
+
+=item $storage->B<metadata_open>( )
+
+Open metadata.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub metadata_open($) {
+ my ($self) = @_;
+
+ $self->{'METADATA_FH'} = new IO::Handle;
+ my $filename = $self->{'datadir'} .'/'. $CONSTANTS->{'metadatafile'};
+
+ if ( -e $filename ) {
+ open($self->{'METADATA_FH'}, '+<' . $filename) or
+ Echolot::Log::warn("Cannot open $filename for reading: $!."),
+ return undef;
+ } else {
+ $self->{'METADATA_FILE_IS_NEW'} = 1;
+ open($self->{'METADATA_FH'}, '+>' . $filename) or
+ Echolot::Log::warn("Cannot open $filename for reading: $!."),
+ return undef;
+ };
+ flock($self->{'METADATA_FH'}, LOCK_EX) or
+ Echolot::Log::warn("Cannot get exclusive lock on $filename: $!."),
+ return undef;
+ return 1;
+};
+
+=item $storage->B<metadata_close>( )
+
+Close metadata.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub metadata_close($) {
+ my ($self) = @_;
+
+ flock($self->{'METADATA_FH'}, LOCK_UN) or
+ Echolot::Log::warn("Error when releasing lock on metadata file: $!."),
+ return undef;
+ close($self->{'METADATA_FH'}) or
+ Echolot::Log::warn("Error when closing metadata file: $!."),
+ return undef;
+ return 1;
+};
+
+
+=item $storage->B<metadata_read>( )
+
+Write metadata.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub metadata_read($) {
+ my ($self) = @_;
+
+ if ($self->{'METADATA_FILE_IS_NEW'}) {
+ $self->{'METADATA'}->{'version'} = $METADATA_VERSION;
+ $self->{'METADATA'}->{'addresses'} = {};
+ $self->{'METADATA'}->{'remailers'} = {};
+
+ $self->{'METADATA_FILE_IS_NEW'} = 0;
+ $self->commit();
+ } else {
+ $self->{'METADATA'} = ();
+ seek($self->{'METADATA_FH'}, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of metadata file: $!."),
+ return 0;
+ {
+ local $/ = undef;
+ my $fh = $self->{'METADATA_FH'};
+ my $metadata_code = <$fh>;
+ ($metadata_code) = $metadata_code =~ /^(.*)$/s;
+ my $METADATA;
+ eval ($metadata_code);
+ $self->{'METADATA'} = $METADATA;
+ };
+ $EVAL_ERROR and
+ confess("Error when reading from metadata file: $EVAL_ERROR"),
+ return undef;
+
+ defined($self->{'METADATA'}->{'version'}) or
+ confess("Stored data lacks version header"),
+ return undef;
+ ($self->{'METADATA'}->{'version'} == ($METADATA_VERSION)) or
+ Echolot::Log::warn("Metadata version mismatch ($self->{'METADATA'}->{'version'} vs. $METADATA_VERSION)."),
+ return undef;
+ };
+
+ defined($self->{'METADATA'}->{'secret'}) or
+ $self->{'METADATA'}->{'secret'} = Echolot::Tools::make_random ( 16, armor => 1 ),
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<metadata_write>( )
+
+Write metadata.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub metadata_write($) {
+ my ($self) = @_;
+
+ my $data = Data::Dumper->Dump( [ $self->{'METADATA'} ], [ 'METADATA' ] );
+ my $fh = $self->{'METADATA_FH'};
+
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of metadata file: $!."),
+ return undef;
+ truncate($fh, 0) or
+ Echolot::Log::warn("Cannot truncate metadata file to zero length: $!."),
+ return undef;
+ print($fh "# vim:set syntax=perl:\n") or
+ Echolot::Log::warn("Error when writing to metadata file: $!."),
+ return undef;
+ print($fh $data) or
+ Echolot::Log::warn("Error when writing to metadata file: $!."),
+ return undef;
+ $fh->flush();
+
+ return 1;
+};
+
+=item $storage->B<metadata_backup>( )
+
+Rotate metadata files and create a backup.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub metadata_backup($) {
+ my ($self) = @_;
+
+ my $filename = $self->{'datadir'} .'/'. $CONSTANTS->{'metadatafile'};
+ for (my $i=Echolot::Config::get()->{'metadata_backup_count'} - 1; $i>=0; $i--) {
+ rename ($filename.'.'.($i) , $filename.'.'.($i+1));
+ rename ($filename.'.'.($i).'.gz', $filename.'.'.($i+1).'.gz');
+ };
+ $filename .= '.1';
+
+
+ my $data = Data::Dumper->Dump( [ $self->{'METADATA'} ], [ 'METADATA' ] );
+ my $fh = new IO::Handle;
+ open ($fh, '>'.$filename) or
+ Echolot::Log::warn("Cannot open $filename for writing: $!."),
+ return undef;
+ print($fh "# vim:set syntax=perl:\n") or
+ Echolot::Log::warn("Error when writing to metadata file: $!."),
+ return undef;
+ print($fh $data) or
+ Echolot::Log::warn("Error when writing to metadata file: $!."),
+ return undef;
+ $fh->flush();
+ close($fh) or
+ Echolot::Log::warn("Error when closing metadata file: $!."),
+ return undef;
+
+ if (Echolot::Config::get()->{'gzip'}) {
+ system(Echolot::Config::get()->{'gzip'}, $filename) and
+ Echolot::Log::warn("Gziping $filename failed."),
+ return undef;
+ };
+
+ return 1;
+};
+
+
+
+
+=item $storage->B<pingdata_open_one>( I<$remailer_addr>, I<$type>, I<$key> )
+
+Open the pingdata file for the I<$remailer_addr>, I<$type>, and I<$key>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub pingdata_open_one($$$$) {
+ my ($self, $remailer_addr, $type, $key) = @_;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}) or
+ Echolot::Log::cluck ("$remailer_addr does not exist in Metadata."),
+ return undef;
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}) or
+ Echolot::Log::cluck ("$remailer_addr has no keys in Metadata."),
+ return undef;
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}) or
+ Echolot::Log::cluck ("$remailer_addr type $type does not exist in Metadata."),
+ return undef;
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key}) or
+ Echolot::Log::cluck ("$remailer_addr type $type key $key does not exist in Metadata."),
+ return undef;
+
+
+ my $basename = $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key}->{'stats'};
+ defined($basename) or
+ $basename = $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key}->{'stats'} = $remailer_addr.'.'.$type.'.'.$key.'.'.time.'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internalcounter'}++,
+ $self->commit();
+
+ my $filename = $self->{'datadir'} .'/'. $basename;
+
+ for my $direction ('out', 'done') {
+ my $fh = new IO::Handle;
+ if ( -e $filename.'.'.$direction ) {
+ open($fh, '+<' . $filename.'.'.$direction) or
+ Echolot::Log::warn("Cannot open $filename.$direction for reading: $!."),
+ return undef;
+ $self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key}->{$direction} = $fh;
+ } else {
+ open($fh, '+>' . $filename.'.'.$direction) or
+ Echolot::Log::warn("Cannot open $filename.$direction for reading: $!."),
+ return undef;
+ $self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key}->{$direction} = $fh;
+ };
+ flock($fh, LOCK_EX) or
+ Echolot::Log::warn("Cannot get exclusive lock on $remailer_addr $type $key $direction pings: $!."),
+ return undef;
+ };
+
+ return 1;
+};
+
+=item $storage->B<pingdata_open>( )
+
+Open all pingdata files.
+
+Returns 1.
+
+=cut
+sub pingdata_open($) {
+ my ($self) = @_;
+
+ for my $remailer_addr ( keys %{$self->{'METADATA'}->{'remailers'}} ) {
+ for my $type ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}} ) {
+ for my $key ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}} ) {
+ $self->pingdata_open_one($remailer_addr, $type, $key);
+ };
+ };
+ };
+ return 1;
+};
+
+=item $storage->B<get_ping_fh>( I<$remailer_addr>, I<$type>, I<$key>, I<$direction>, I<$oknodo> )
+
+Return the FH for the pingdata file of I<$remailer_addr>, I<$type>, I<$key>, and I<$direction>.
+
+If $<oknodo> is set, the absense of a defined filehandle does not cause it to
+be opened/created. Instead -1 is returned.
+
+Returns undef on error;
+
+=cut
+sub get_ping_fh($$$$$;$) {
+ my ($self, $remailer_addr, $type, $key, $direction, $oknodo) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$remailer_addr}) or
+ Echolot::Log::cluck("$remailer_addr does not exist in Metadata."),
+ return undef;
+
+ my $fh = $self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key}->{$direction};
+
+ unless (defined $fh) {
+ return -1 if (defined $oknodo && $oknodo);
+
+ $self->pingdata_open_one($remailer_addr, $type, $key),
+ $fh = $self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key}->{$direction};
+ defined ($fh) or
+ Echolot::Log::warn ("$remailer_addr; type=$type; key=$key has no assigned filehandle for $direction pings."),
+ return undef;
+ }
+
+ return $fh;
+};
+
+=item $storage->B<pingdata_close_one>( I<$remailer_addr>, I<$type>, I<$key> )
+
+Close the pingdata file for the I<$remailer_addr>, I<$type>, and I<$key>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub pingdata_close_one($$$$;$) {
+ my ($self, $remailer_addr, $type, $key, $delete) = @_;
+
+ for my $direction ( keys %{$self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key}} ) {
+ my $fh = $self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key}->{$direction};
+
+ flock($fh, LOCK_UN) or
+ Echolot::Log::warn("Error when releasing lock on $remailer_addr type $type key $key direction $direction pings: $!."),
+ return undef;
+ close ($fh) or
+ Echolot::Log::warn("Error when closing $remailer_addr type $type key $key direction $direction pings: $!."),
+ return undef;
+
+ if ((defined $delete) && ($delete eq 'delete')) {
+ my $basename = $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key}->{'stats'};
+ my $filename = $self->{'datadir'} .'/'. $basename;
+ unlink ($filename.'.'.$direction) or
+ carp ("Cannot unlink $filename.'.'.$direction: $!");
+ };
+ };
+
+ delete $self->{'PING_FHS'}->{$remailer_addr}->{$type}->{$key};
+
+ delete $self->{'PING_FHS'}->{$remailer_addr}->{$type}
+ unless (scalar keys %{$self->{'PING_FHS'}->{$remailer_addr}->{$type}});
+ delete $self->{'PING_FHS'}->{$remailer_addr}
+ unless (scalar keys %{$self->{'PING_FHS'}->{$remailer_addr}});
+
+
+ return 1;
+};
+
+=item $storage->B<pingdata_close>( )
+
+Close all pingdata files.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub pingdata_close($) {
+ my ($self) = @_;
+
+ for my $remailer_addr ( keys %{$self->{'PING_FHS'}} ) {
+ for my $type ( keys %{$self->{'PING_FHS'}->{$remailer_addr}} ) {
+ for my $key ( keys %{$self->{'PING_FHS'}->{$remailer_addr}->{$type}} ) {
+ $self->pingdata_close_one($remailer_addr, $type, $key) or
+ Echolot::Log::debug("Error when calling pingdata_close_one with $remailer_addr type $type key $key."),
+ return undef;
+ };
+ };
+ };
+ return 1;
+};
+
+=item $storage->B<get_pings>( I<$remailer_addr>, I<$type>, I<$key>, I<$direction> )
+
+Return an array of ping data for I<$remailer_addr>, I<$type>, I<$key>, and I<$direction>.
+
+If direction is B<out> then it's an array of scalar (the send timestamps).
+
+If direction is B<done> then it's an array of array references each having two
+items: the send time and the latency.
+
+Returns undef on error;
+
+=cut
+sub get_pings($$$$$) {
+ my ($self, $remailer_addr, $type, $key, $direction) = @_;
+
+ my @pings;
+
+ my $fh = $self->get_ping_fh($remailer_addr, $type, $key, $direction, 1);
+ (defined $fh) or
+ Echolot::Log::cluck ("$remailer_addr; type=$type; key=$key has no assigned filehandle for out pings.");
+ ($fh == -1) and
+ Echolot::Log::info ("$remailer_addr; type=$type; key=$key has no assigned filehandle for $direction pings (key has expired, or not available yet)."),
+ return ();
+
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of $remailer_addr type $type key $key direction $direction pings: $! ($fh)."),
+ return undef;
+
+ if ($direction eq 'out') {
+ @pings = map {chomp; $_; } <$fh>;
+ } elsif ($direction eq 'done') {
+ @pings = map {chomp; my @arr = split (/\s+/, $_, 2); \@arr; } <$fh>;
+ } else {
+ confess("What the hell am I doing here? $remailer_addr; $type; $key; $direction"),
+ return undef;
+ };
+ return @pings;
+};
+
+
+
+
+
+=item $storage->B<register_pingout>( I<$remailer_addr>, I<$type>, I<$key>, I<$sent_time> )
+
+Register a ping sent to I<$remailer_addr>, I<$type>, I<$key> and I$<sent_time>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub register_pingout($$$$$) {
+ my ($self, $remailer_addr, $type, $key, $sent_time) = @_;
+
+ my $fh = $self->get_ping_fh($remailer_addr, $type, $key, 'out') or
+ Echolot::Log::cluck ("$remailer_addr; type=$type; key=$key has no assigned filehandle for out pings."),
+ return undef;
+
+ seek($fh, 0, SEEK_END) or
+ Echolot::Log::warn("Cannot seek to end of $remailer_addr; type=$type; key=$key; out pings: $!."),
+ return undef;
+ print($fh $sent_time."\n") or
+ Echolot::Log::warn("Error when writing to $remailer_addr; type=$type; key=$key; out pings: $!."),
+ return undef;
+ $fh->flush();
+ Echolot::Log::debug("registering pingout for $remailer_addr ($type; $key).");
+
+ return 1;
+};
+
+=item $storage->B<register_pingdone>( I<$remailer_addr>, I<$type>, I<$key>, I<$sent_time>, I<$latency> )
+
+Register that the ping sent to I<$remailer_addr>, I<$type>, I<$key> at
+I$<sent_time> has returned with latency I<$latency>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub register_pingdone($$$$$$) {
+ my ($self, $remailer_addr, $type, $key, $sent_time, $latency) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$remailer_addr}) or
+ Echolot::Log::warn ("$remailer_addr does not exist in Metadata."),
+ return undef;
+
+ my @outpings = $self->get_pings($remailer_addr, $type, $key, 'out');
+ my $origlen = scalar (@outpings);
+ @outpings = grep { $_ != $sent_time } @outpings;
+ ($origlen == scalar (@outpings)) and
+ Echolot::Log::info("No ping outstanding for $remailer_addr, $key, ".(scalar localtime $sent_time)."."),
+ return 1;
+
+ # write ping to done
+ my $fh = $self->get_ping_fh($remailer_addr, $type, $key, 'done') or
+ Echolot::Log::cluck ("$remailer_addr; type=$type; key=$key has no assigned filehandle for done pings."),
+ return undef;
+ seek($fh, 0, SEEK_END) or
+ Echolot::Log::warn("Cannot seek to end of $remailer_addr done pings: $!."),
+ return undef;
+ print($fh $sent_time." ".$latency."\n") or
+ Echolot::Log::warn("Error when writing to $remailer_addr done pings: $!."),
+ return undef;
+ $fh->flush();
+
+ # rewrite outstanding pings
+ $fh = $self->get_ping_fh($remailer_addr, $type, $key, 'out') or
+ Echolot::Log::cluck ("$remailer_addr; type=$type; key=$key has no assigned filehandle for out pings."),
+ return undef;
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of outgoing pings file for remailer $remailer_addr; key=$key: $!."),
+ return undef;
+ truncate($fh, 0) or
+ Echolot::Log::warn("Cannot truncate outgoing pings file for remailer $remailer_addr; key=$key file to zero length: $!."),
+ return undef;
+ print($fh (join "\n", @outpings), (scalar @outpings ? "\n" : '') ) or
+ Echolot::Log::warn("Error when writing to outgoing pings file for remailer $remailer_addr; key=$key file: $!."),
+ return undef;
+ $fh->flush();
+ Echolot::Log::debug("registering pingdone from ".(scalar localtime $sent_time)." with latency $latency for $remailer_addr ($type; $key).");
+
+ return 1;
+};
+
+
+
+
+
+
+=item $storage->B<chainpingdata_open_one>( I<$chaintype> )
+
+Open the pingdata file for I<$chaintype> type chain pings.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub chainpingdata_open_one($$) {
+ my ($self, $type) = @_;
+
+ my $filename = $self->{'datadir'} .'/chainpings.'.$type;
+
+ for my $direction ('out', 'done') {
+ my $fh = new IO::Handle;
+ if ( -e $filename.'.'.$direction ) {
+ open($fh, '+<' . $filename.'.'.$direction) or
+ Echolot::Log::warn("Cannot open $filename.$direction for reading: $!."),
+ return undef;
+ $self->{'CHAINPING_FHS'}->{$type}->{$direction} = $fh;
+ } else {
+ open($fh, '+>' . $filename.'.'.$direction) or
+ Echolot::Log::warn("Cannot open $filename.$direction for reading: $!."),
+ return undef;
+ $self->{'CHAINPING_FHS'}->{$type}->{$direction} = $fh;
+ };
+ flock($fh, LOCK_EX) or
+ Echolot::Log::warn("Cannot get exclusive lock on $filename.$direction pings: $!."),
+ return undef;
+ };
+
+ return 1;
+};
+
+=item $storage->B<chainpingdata_open>( )
+
+Open all chainpingdata files.
+
+Returns 1.
+
+=cut
+sub chainpingdata_open($) {
+ my ($self) = @_;
+
+ for my $type ( keys %{Echolot::Config::get()->{'which_chainpings'}} ) {
+ $self->chainpingdata_open_one($type);
+ };
+
+ return 1;
+};
+
+
+=item $storage->B<get_chainping_fh>( I<$type>, I<$direction> )
+
+Return the FH for the chainpingdata file of I<$type>, and I<$direction>.
+
+Returns undef on error;
+
+=cut
+sub get_chainping_fh($$$) {
+ my ($self, $type, $direction) = @_;
+
+ my $fh = $self->{'CHAINPING_FHS'}->{$type}->{$direction};
+
+ defined ($fh) or
+ $self->chainpingdata_open_one($type),
+ $fh = $self->{'CHAINPING_FHS'}->{$type}->{$direction};
+ defined ($fh) or
+ Echolot::Log::warn ("chainping $type has no assigned filehandle for $direction chainpings."),
+ return undef;
+
+ return $fh;
+};
+
+=item $storage->B<chainpingdata_close_one>( I<$type> )
+
+Close the chainpingdata file for I<$type>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub chainpingdata_close_one($) {
+ my ($self, $type) = @_;
+
+ for my $direction ( keys %{$self->{'CHAINPING_FHS'}->{$type}} ) {
+ my $fh = $self->{'CHAINPING_FHS'}->{$type}->{$direction};
+
+ flock($fh, LOCK_UN) or
+ Echolot::Log::warn("Error when releasing lock on $type direction $direction chainpings: $!."),
+ return undef;
+ close ($fh) or
+ Echolot::Log::warn("Error when closing $type direction $direction chainpings: $!."),
+ return undef;
+ };
+
+ delete $self->{'CHAINPING_FHS'}->{$type};
+
+ return 1;
+};
+
+=item $storage->B<chainpingdata_close>( )
+
+Close all chainpingdata files.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub chainpingdata_close($) {
+ my ($self) = @_;
+
+ for my $type ( keys %{$self->{'CHAINPING_FHS'}} ) {
+ $self->chainpingdata_close_one($type) or
+ Echolot::Log::debug("Error when calling chainpingdata_close_one with type $type."),
+ return undef;
+ };
+ return 1;
+};
+
+
+
+=item $storage->B<get_chainpings>( I<$chaintype> )
+
+Return chainping data for I<$chaintype>.
+
+The result is a reference to a hash having two entries: out and done.
+
+Each of them is a reference to an array of single pings. Each ping is a hash
+reference with the hash having the keys B<sent>, B<addr1>, B<type1>, B<key1>,
+B<addr2>, B<type2>, B<key2>, and in case of received pings B<lat>.
+
+Out currently includes all sent pings - also those that allready arrived.
+This is different from the get_pings() function above.
+
+Returns undef on error.
+
+=cut
+sub get_chainpings($$) {
+ my ($self, $chaintype) = @_;
+
+ my $fh = $self->get_chainping_fh($chaintype, 'out') or
+ Echolot::Log::warn ("have no assigned filehandle for $chaintype out chainpings."),
+ return undef;
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of $chaintype out chainpings $!."),
+ return undef;
+ my @out =
+ map {
+ chomp;
+ my @a = split;
+ Echolot::Log::warn("'$_' has not 7 fields") if (scalar @a < 7);
+ { sent => $a[0],
+ addr1 => $a[1],
+ type1 => $a[2],
+ key1 => $a[3],
+ addr2 => $a[4],
+ type2 => $a[5],
+ key2 => $a[6]
+ }
+ } <$fh>;
+ my %sent = map {
+ my $a = $_;
+ my $key = join (' ', map ({ $a->{$_} } qw{sent addr1 type1 key1 addr2 type2 key2}));
+ $key => 1
+ } @out;
+
+ $fh = $self->get_chainping_fh($chaintype, 'done') or
+ Echolot::Log::warn ("assigned filehandle for $chaintype done chainpings."),
+ return undef;
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of $chaintype done chainpings $!."),
+ return undef;
+ my @done =
+ grep {
+ # Only list things that actually got sent - and only once
+ my $a = $_;
+ my $key = join (' ', map ({ $a->{$_} } qw{sent addr1 type1 key1 addr2 type2 key2}));
+ my $exists = exists $sent{$key};
+ delete $sent{$key};
+ $exists
+ }
+ map {
+ chomp;
+ my @a = split;
+ { sent => $a[0],
+ addr1 => $a[1],
+ type1 => $a[2],
+ key1 => $a[3],
+ addr2 => $a[4],
+ type2 => $a[5],
+ key2 => $a[6],
+ lat => $a[7]
+ }
+ } <$fh>;
+
+ return {
+ out => \@out,
+ done => \@done
+ };
+};
+
+
+=item $storage->B<register_chainpingout>( I<$chaintype>, I<$addr1>, I<$type1>, I<$key1>, I<$addr2>, I<$type2>, I<$key2>, I<$sent_time> >
+
+Register a chain ping of type I<$chaintype> sent through I<$addr1> (I<$type1>, I<$key1>)
+and I<$addr2> (I<$type2>, I<$key2>) at I$<sent_time>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub register_chainpingout($$$$$$$$$) {
+ my ($self, $chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2, $sent_time) = @_;
+
+ my $fh = $self->get_chainping_fh($chaintype, 'out') or
+ Echolot::Log::cluck ("chaintype $chaintype/out has no assigned filehandle."),
+ return undef;
+
+ seek($fh, 0, SEEK_END) or
+ Echolot::Log::warn("Cannot seek to end of chaintype $chaintype out pings: $!."),
+ return undef;
+ print($fh join(' ', $sent_time, $addr1, $type1, $key1, $addr2, $type2, $key2)."\n") or
+ Echolot::Log::warn("Error when writing to chaintype $chaintype out pings: $!."),
+ return undef;
+ $fh->flush();
+ Echolot::Log::debug("registering chainping $chaintype out through $addr1 ($type1; $key1) to $addr2 ($type2; $key2).");
+
+ return 1;
+};
+
+=item $storage->B<register_chainpingdone>( I<$chaintype>, I<$addr1>, I<$type1>, I<$key1>, I<$addr2>, I<$type2>, I<$key2>, I<$sent_time>, I<$latency> )
+
+Register that the chain ping of type I<$chaintype> sent through I<$addr1> (I<$type1>, I<$key1>)
+and I<$addr2> (I<$type2>, I<$key2>) at I$<sent_time>
+has returned with latency I<$latency>.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub register_chainpingdone($$$$$$$$$$) {
+ my ($self, $chaintype, $addr1, $type1, $key1, $addr2, $type2, $key2, $sent_time, $latency) = @_;
+
+ # write ping to done
+ my $fh = $self->get_chainping_fh($chaintype, 'done') or
+ Echolot::Log::cluck ("chaintype $chaintype/done has no assigned filehandle."),
+ return undef;
+ seek($fh, 0, SEEK_END) or
+ Echolot::Log::warn("Cannot seek to end of $chaintype/done pings: $!."),
+ return undef;
+ print($fh join(' ', $sent_time, $addr1, $type1, $key1, $addr2, $type2, $key2, $latency)."\n") or
+ Echolot::Log::warn("Error when writing to $chaintype/done pings: $!."),
+ return undef;
+ $fh->flush();
+ Echolot::Log::debug("registering chainpingdone from ".(scalar localtime $sent_time)." with latency $latency chainping $chaintype out through $addr1 ($type1; $key1) to $addr2 ($type2; $key2).");
+
+ return 1;
+};
+
+=item $storage->B<add_prospective_address>( I<$addr>, I<$reason>, I<$additional> )
+
+Add I<$addr> to the list of prospective remailers with I<$reason> and
+I<$additional> information.
+
+Returns 1.
+
+=cut
+sub add_prospective_address($$$$) {
+ my ($self, $addr, $reason, $additional) = @_;
+
+ return 1 if defined $self->{'METADATA'}->{'addresses'}->{$addr};
+ push @{ $self->{'METADATA'}->{'prospective_addresses'}{$addr} }, time().'; '. $reason. '; '. $additional;
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<commit_prospective_address>( )
+
+Commit prospective remailers to the list of remailers we know.
+
+Returns 1.
+
+=cut
+sub commit_prospective_address($) {
+ my ($self) = @_;
+
+ $self->delay_commit();
+ for my $addr (keys %{$self->{'METADATA'}->{'prospective_addresses'}}) {
+ if (defined $self->{'METADATA'}->{'addresses'}->{$addr}) {
+ delete $self->{'METADATA'}->{'prospective_addresses'}->{$addr};
+ next;
+ };
+
+ # expire old prospective addresses
+ while (@{ $self->{'METADATA'}->{'prospective_addresses'}->{$addr} }) {
+ my ($time, $reason, $additional) = split(/;\s*/, $self->{'METADATA'}->{'prospective_addresses'}->{$addr}->[0] );
+ if ($time < time() - Echolot::Config::get()->{'prospective_addresses_ttl'} ) {
+ shift @{ $self->{'METADATA'}->{'prospective_addresses'}->{$addr} };
+ } else {
+ last;
+ };
+ };
+
+ unless (scalar @{ $self->{'METADATA'}->{'prospective_addresses'}->{$addr} }) {
+ delete $self->{'METADATA'}->{'prospective_addresses'}->{$addr};
+ next;
+ };
+
+ my %reasons;
+ for my $line ( @{ $self->{'METADATA'}->{'prospective_addresses'}->{$addr} } ) {
+ my ($time, $reason, $additional) = split(/;\s*/, $line);
+ push @{ $reasons{$reason} }, $additional;
+ };
+
+ # got prospective by reply to own remailer-conf or remailer-key request
+ if ( defined $reasons{'self-capsstring-conf'} || defined $reasons{'self-capsstring-key'} ) {
+ Echolot::Log::notice("$addr is used because of direct conf or key reply");
+ $self->add_address($addr);
+ delete $self->{'METADATA'}->{'prospective_addresses'}->{$addr};
+ next;
+ }
+
+ # was listed in reliable's remailer-conf reply; @adds holds suggestors
+ my @adds;
+ push @adds, @{ $reasons{'reliable-caps-reply-type1'} } if defined $reasons{'reliable-caps-reply-type1'};
+ push @adds, @{ $reasons{'reliable-caps-reply-type2'} } if defined $reasons{'reliable-caps-reply-type2'};
+ if (scalar @adds) {
+ my %unique;
+ @adds = grep { ! $unique{$_}++; } @adds;
+ if (scalar @adds >= Echolot::Config::get()->{'reliable_auto_add_min'} ) {
+ Echolot::Log::notice("$addr is recommended by ". join(', ', @adds) . ".");
+ $self->add_address($addr);
+ delete $self->{'METADATA'}->{'prospective_addresses'}->{$addr};
+ next;
+ };
+ };
+ };
+
+ $self->enable_commit(1);
+
+ return 1;
+};
+
+=item $storage->B<get_address>( I<$addr> )
+
+Get a reference to a hash of information of the remailers with address
+I<$addr>.
+
+The hash has the following keys:
+
+=over
+
+=item status
+
+=item id
+
+=item address
+
+=item fetch
+
+=item showit
+
+=item pingit
+
+=item ttl
+
+=item resurrection_ttl
+
+=back
+
+Returns undef on errors.
+
+=cut
+sub get_address($$) {
+ my ($self, $addr) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$addr}) or
+ Echolot::Log::cluck ("$addr does not exist in Metadata."),
+ return undef;
+
+ my $result = {
+ status => $self->{'METADATA'}->{'addresses'}->{$addr}->{'status'},
+ id => $self->{'METADATA'}->{'addresses'}->{$addr}->{'id'},
+ address => $_,
+ fetch => $self->{'METADATA'}->{'addresses'}->{$addr}->{'fetch'},
+ showit => $self->{'METADATA'}->{'addresses'}->{$addr}->{'showit'},
+ pingit => $self->{'METADATA'}->{'addresses'}->{$addr}->{'pingit'},
+ ttl => $self->{'METADATA'}->{'addresses'}->{$addr}->{'ttl'},
+ resurrection_ttl => $self->{'METADATA'}->{'addresses'}->{$addr}->{'resurrection_ttl'},
+ };
+
+ return $result;
+};
+
+=item $storage->B<get_addresses>( )
+
+Get an array of all remailers we know about. Each element in this array is a
+hash reference as returned by C<get_address>.
+
+=cut
+sub get_addresses($) {
+ my ($self) = @_;
+
+ my @addresses = keys %{$self->{'METADATA'}->{'addresses'}};
+ my @return_data = map { $self->get_address($_); } @addresses;
+ return @return_data;
+};
+
+=item $storage->B<add_address>( I<$addr> )
+
+Adds a remailer with address I<$addr>. B<fetch>, B<pingit>, and B<shoit> are
+set to the values configured for new remailers.
+
+Assign the remailer status B<active> and a new unique ID.
+
+See L<pingd.conf(5)> for more information on this.
+
+Returns 1.
+
+=cut
+sub add_address($$) {
+ my ($self, $addr) = @_;
+
+ my @all_addresses = $self->get_addresses();
+ my $maxid = $self->{'METADATA'}->{'addresses_maxid'};
+ unless (defined $maxid) {
+ $maxid = 0;
+ for my $addr (@all_addresses) {
+ if ($addr->{'id'} > $maxid) {
+ $maxid = $addr->{'id'};
+ };
+ };
+ };
+
+
+
+ Echolot::Log::notice("Adding address $addr.");
+
+ my $remailer = {
+ id => $maxid + 1,
+ status => 'active',
+ ttl => Echolot::Config::get()->{'addresses_default_ttl'},
+ fetch => Echolot::Config::get()->{'fetch_new'},
+ pingit => Echolot::Config::get()->{'ping_new'},
+ showit => Echolot::Config::get()->{'show_new'},
+ };
+ $self->{'METADATA'}->{'addresses'}->{$addr} = $remailer;
+ $self->{'METADATA'}->{'addresses_maxid'} = $maxid+1;
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<set_stuff>( I<@args> )
+
+@args is supposed to have two elements: I<$address>, and I<$setting>.
+
+Set verious options for the remailer with address $I<$address>.
+
+I<$setting> has to be of the form C<key=value>. Recognised keys are B<pingit>,
+B<fetch>, and B<showit>. Acceptable values are B<on> and B<off>.
+
+See L<pingd(1)> for the meaning of these settings.
+
+Returns 1, undef on error.
+
+=cut
+sub set_stuff($@) {
+ my ($self, @args) = @_;
+
+ my ($addr, $setting) = @args;
+ my $args = join(', ', @args);
+
+ defined ($addr) or
+ Echolot::Log::cluck ("Could not get address for '$args'."),
+ return undef;
+ defined ($setting) or
+ Echolot::Log::cluck ("Could not get setting for '$args'."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$addr}) or
+ Echolot::Log::warn ("Address $addr does not exist."),
+ return undef;
+
+
+ if ($setting =~ /^(pingit|fetch|showit)=(on|off)$/) {
+ my $option = $1;
+ my $value = $2;
+ Echolot::Log::info("Setting $option to $value for $addr");
+ $self->{'METADATA'}->{'addresses'}->{$addr}->{$option} = ($value eq 'on');
+ } else {
+ Echolot::Log::warn ("Don't know what to do with '$setting' for $addr."),
+ return undef;
+ }
+
+ $self->commit();
+ return 1;
+};
+
+
+=item $storage->B<get_address_by_id>( I<$id> )
+
+Return the address for the remailer with id I<$id>.
+
+Return undef if there is no remailer with that id.
+
+=cut
+sub get_address_by_id($$) {
+ my ($self, $id) = @_;
+
+ my @addresses = grep {$self->{'METADATA'}->{'addresses'}->{$_}->{'id'} == $id}
+ keys %{$self->{'METADATA'}->{'addresses'}};
+ return undef unless (scalar @addresses);
+ if (scalar @addresses >= 2) {
+ Echolot::Log::cluck("Searching for address by id '$id' gives more than one result.");
+ };
+ my %return_data = %{$self->{'METADATA'}->{'addresses'}->{$addresses[0]}};
+ $return_data{'address'} = $addresses[0];
+ return \%return_data;
+};
+
+=item $storage->B<decrease_resurrection_ttl>( I<$address> )
+
+Decrease the TTL (Time To Live) for remailer with address I<$address> by one.
+
+If it hits zero the remailer's status is set to B<ttl timeout>.
+
+Returns 1, undef on error.
+
+=cut
+sub decrease_ttl($$) {
+ my ($self, $address) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$address}) or
+ Echolot::Log::cluck ("$address does not exist in Metadata address list."),
+ return undef;
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'ttl'} --;
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'status'} = 'ttl timeout',
+ Echolot::Log::info("Remailer $address disabled: ttl expired."),
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'resurrection_ttl'} = Echolot::Config::get()->{'check_resurrection_ttl'}
+ if ($self->{'METADATA'}->{'addresses'}->{$address}->{'ttl'} <= 0);
+ $self->commit();
+ return 1;
+};
+
+=item $storage->B<decrease_resurrection_ttl>( I<$address> )
+
+Decrease the resurrection TTL (Time To Live) for remailer with address
+I<$address> by one.
+
+If it hits zero the remailer's status is set to B<dead>.
+
+Returns 1, undef on error.
+
+=cut
+sub decrease_resurrection_ttl($$) {
+ my ($self, $address) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$address}) or
+ Echolot::Log::cluck ("$address does not exist in Metadata address list."),
+ return 0;
+ ($self->{'METADATA'}->{'addresses'}->{$address}->{'status'} eq 'ttl timeout') or
+ Echolot::Log::cluck ("$address is not in ttl timeout status."),
+ return 0;
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'resurrection_ttl'} --;
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'status'} = 'dead',
+ Echolot::Log::info("Remailer $address is dead."),
+ if ($self->{'METADATA'}->{'addresses'}->{$address}->{'resurrection_ttl'} <= 0);
+ $self->commit();
+ return 1;
+};
+
+=item $storage->B<restore_ttl>( I<$address> )
+
+Restore the TTL (Time To Live) for remailer with address I<$address> to the
+value configured with I<addresses_default_ttl>
+
+See L<pingd.conf(5)> for more information on this settings.
+
+Returns 1, undef on error.
+
+=cut
+sub restore_ttl($$) {
+ my ($self, $address) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$address}) or
+ Echolot::Log::cluck ("$address does not exist in Metadata address list."),
+ return undef;
+ defined ($self->{'METADATA'}->{'addresses'}->{$address}->{'status'}) or
+ Echolot::Log::cluck ("$address does exist in Metadata address list but does not have status defined."),
+ return undef;
+ Echolot::Log::info("Remailer $address is alive and active again.")
+ unless ($self->{'METADATA'}->{'addresses'}->{$address}->{'status'} eq 'active');
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'ttl'} = Echolot::Config::get()->{'addresses_default_ttl'};
+ delete $self->{'METADATA'}->{'addresses'}->{$address}->{'resurrection_ttl'};
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'status'} = 'active' if
+ ($self->{'METADATA'}->{'addresses'}->{$address}->{'status'} eq 'ttl timeout' ||
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'status'} eq 'dead');
+ $self->commit();
+ return 1;
+};
+
+
+=item $storage->B<not_a_remaielr>( I<$id> )
+
+Set the remailer whoise id is I<$id> to B<disabled by user reply: is not a
+remailer>.
+
+Returns 1, undef on error.
+
+=cut
+sub not_a_remailer($$) {
+ my ($self, $id) = @_;
+
+ my $remailer = $self->get_address_by_id($id);
+ defined $remailer or
+ Echolot::Log::cluck("No remailer found for id '$id'."),
+ return undef;
+ my $address = $remailer->{'address'};
+ defined ($self->{'METADATA'}->{'addresses'}->{$address}) or
+ Echolot::Log::cluck ("$address does not exist in Metadata address list."),
+ return undef;
+ $self->{'METADATA'}->{'addresses'}->{$address}->{'status'} = 'disabled by user reply: is not a remailer';
+
+ Echolot::Log::info("Setting $id, $address to disabled by user reply.");
+
+ $self->commit();
+ return 1;
+};
+
+=item $storage->B<set_caps>( I<$type>, I<$caps>, I<$nick>, I<$address>, I<$timestamp> [, I<$dont_expire> ])
+
+Sets the capabilities for remailer with address I<$address> to the given
+information (I<$nick>, I<$type>, I<$caps>, I<$timestamp>).
+
+Type here means the software used (Mixmaster, Reliable) as given by the
+remailer-conf reply or something like B<set manually>.
+
+If there already is newer information about that key than I<$timestamp> the
+update is disregarded.
+
+If I<$dont_expire> is defined the setting is copied to the remailers metadata
+as well.
+
+Returns 1.
+
+=cut
+sub set_caps($$$$$$;$) {
+ my ($self, $type, $caps, $nick, $address, $timestamp, $dont_expire) = @_;
+
+ (defined $address) or
+ Echolot::Log::cluck ("$address not defined in set_key.");
+
+ if (! defined $self->{'metadata'}->{'remailers'}->{$address} ) {
+ $self->{'metadata'}->{'remailers'}->{$address} = {};
+ };
+
+ if (! defined $self->{'METADATA'}->{'remailers'}->{$address}->{'conf'}) {
+ $self->{'METADATA'}->{'remailers'}->{$address}->{'conf'} =
+ {
+ nick => $nick,
+ type => $type,
+ capabilities => $caps,
+ last_update => $timestamp
+ };
+ } else {
+ my $conf = $self->{'METADATA'}->{'remailers'}->{$address}->{'conf'};
+ if ($conf->{'last_update'} >= $timestamp) {
+ Echolot::Log::info("Stored data is already newer for remailer $nick.");
+ return 1;
+ };
+ $conf->{'last_update'} = $timestamp;
+ if ($conf->{'nick'} ne $nick) {
+ Echolot::Log::info($conf->{'nick'}." was renamed to $nick.");
+ $conf->{'nick'} = $nick;
+ };
+ if ($conf->{'capabilities'} ne $caps) {
+ Echolot::Log::info("$nick has a new caps string '$caps' old: '".$conf->{'capabilities'}."'.");
+ $conf->{'capabilities'} = $caps;
+ };
+ if ($conf->{'type'} ne $type) {
+ Echolot::Log::info("$nick has a new type string '$type'.");
+ $conf->{'type'} = $type;
+ };
+ };
+
+ if (defined $dont_expire) {
+ $self->{'METADATA'}->{'remailers'}->{$address}->{'conf'}->{'dont_expire'} = $dont_expire;
+ };
+
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<set_key>( I<$type>, I<$nick>, I<$address>, I<$key>, I<$keyid>, I<$version>, I<$caps>, I<$summary>, I<$timestamp>)
+
+Sets the I<$type> key I<$keyid> for remailer with address I<$address> to the
+given information (I<$nick>, I<$key>, I<$caps>, I<$summary>, I<$timestamp>).
+
+If there already is newer information about that key than I<$timestamp> the
+update is disregarded.
+
+Returns 1.
+
+=cut
+sub set_key($$$$$$$$$) {
+ my ($self, $type, $nick, $address, $key, $keyid, $version, $caps, $summary, $timestamp) = @_;
+
+ (defined $address) or
+ Echolot::Log::cluck ("$address not defined in set_key.");
+
+ if (! defined $self->{'metadata'}->{'remailers'}->{$address} ) {
+ $self->{'metadata'}->{'remailers'}->{$address} = {};
+ };
+
+ if (! defined $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}) {
+ $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'} = {};
+ };
+ if (! defined $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}->{$type}) {
+ $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}->{$type} = {};
+ };
+
+ if (! defined $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}->{$type}->{$keyid}) {
+ $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}->{$type}->{$keyid} =
+ {
+ key => $key,
+ summary => $summary,
+ nick => $nick,
+ last_update => $timestamp
+ };
+ } else {
+ my $keyref = $self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}->{$type}->{$keyid};
+ if ($keyref->{'last_update'} >= $timestamp) {
+ Echolot::Log::info("Stored data is already newer for remailer $nick.");
+ return 1;
+ };
+ $keyref->{'last_update'} = $timestamp;
+ if ($keyref->{'nick'} ne $nick) {
+ Echolot::Log::info("$nick has a new key nick string '$nick' old: '".$keyref->{'nick'}."'.");
+ $keyref->{'nick'} = $nick;
+ };
+ if ($keyref->{'summary'} ne $summary) {
+ Echolot::Log::info("$nick has a new key summary string '$summary' old: '".$keyref->{'summary'}."'.");
+ $keyref->{'summary'} = $summary;
+ };
+ if ($keyref->{'key'} ne $key) {
+ #Echolot::Log::info("$nick has a new key string '$key' old: '".$keyref->{'key'}."' - This probably should not happen.");
+ Echolot::Log::info("$nick has a new key string for same keyid $keyid.");
+ $keyref->{'key'} = $key;
+ };
+ };
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<get_secret>( )
+
+Return our secret (Used in Message Authentication Codes).
+
+=cut
+sub get_secret($) {
+ my ($self) = @_;
+
+ return $self->{'METADATA'}->{'secret'};
+};
+
+=item $storage->B<get_types>( I<$remailer> )
+
+Get an array of types supported by remailer with address I<$remailer>.
+
+Returns undef on errors.
+
+¿ It may be possible that a type is returned but then has no keys. This may be
+a bug, I'm not sure.
+
+=cut
+sub get_types($$) {
+ my ($self, $remailer) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$remailer}) or
+ Echolot::Log::cluck ("$remailer does not exist in Metadata remailer list."),
+ return undef;
+
+ return () unless defined $self->{'METADATA'}->{'remailers'}->{$remailer};
+ return () unless defined $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'};
+ my @types = keys %{$self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}};
+ return @types;
+};
+
+
+=item $storage->B<has_type>( I<$remailer>, I<$type> )
+
+Checks if the remailer with address I<$remailer> has type I<$type> keys.
+
+Returns 1 if it has, 0 if not, undef on errors.
+
+=cut
+sub has_type($$$) {
+ my ($self, $remailer, $type) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$remailer}) or
+ Echolot::Log::cluck ("$remailer does not exist in Metadata remailer list."),
+ return undef;
+
+ return 0 unless defined $self->{'METADATA'}->{'remailers'}->{$remailer};
+ return 0 unless defined $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'};
+ return 0 unless defined $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type};
+ return 0 unless scalar keys %{$self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}};
+ return 1;
+};
+
+
+=item $storage->B<get_keys>( I<$remailer>, I<$type> )
+
+Returns an array listing all keyids of type I<$type> of remailer with address
+I<$remailer>.
+
+Returns undef on errors.
+
+=cut
+sub get_keys($$$) {
+ my ($self, $remailer, $type) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$remailer}) or
+ Echolot::Log::cluck ("$remailer does not exist in Metadata address list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}) or
+ Echolot::Log::cluck ("$remailer does not exist in Metadata remailer list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}) or
+ Echolot::Log::cluck ("$remailer does not have keys in Metadata remailer list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}) or
+ Echolot::Log::cluck ("$remailer does not have type '$type' in Metadata remailer list."),
+ return undef;
+
+ my @keys = keys %{$self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}};
+ return @keys;
+};
+
+
+
+=item $storage->B<get_key>( I<$remailer>, I<$type>, I<$key> )
+
+Returns a hash having they keys C<summary>, C<key>, C<nick>, and
+C<last_updated> of the I<$type> key with id I<$key> of remailer with address
+I<$remailer>.
+
+Returns undef on errors.
+
+=cut
+sub get_key($$$$) {
+ my ($self, $remailer, $type, $key) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$remailer}) or
+ Echolot::Log::cluck ("$remailer does not exist in Metadata address list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}) or
+ Echolot::Log::cluck ("$remailer does not exist in Metadata remailer list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}) or
+ Echolot::Log::cluck ("$remailer does not have keys in Metadata remailer list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}) or
+ Echolot::Log::cluck ("$remailer does not have type '$type' in Metadata remailer list."),
+ return undef;
+
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}->{$key}) or
+ Echolot::Log::cluck ("$remailer does not have key '$key' in type '$type' in Metadata remailer list."),
+ return undef;
+
+ my %result = (
+ summary => $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}->{$key}->{'summary'},
+ key => $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}->{$key}->{'key'},
+ nick => $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}->{$key}->{'nick'},
+ last_update => $self->{'METADATA'}->{'remailers'}->{$remailer}->{'keys'}->{$type}->{$key}->{'last_update'}
+ );
+
+ return %result;
+};
+
+
+=item $storage->B<get_capabilities>( I<$remailer> )
+
+Return the capabilities on file for remailer with address I<$remailer>. This
+is probably the one we got from remailer-conf or set manually.
+
+Returns undef on errors.
+
+=cut
+sub get_capabilities($$) {
+ my ($self, $remailer) = @_;
+
+ return undef unless defined $self->{'METADATA'}->{'remailers'}->{$remailer};
+ return undef unless defined $self->{'METADATA'}->{'remailers'}->{$remailer}->{'conf'};
+ return $self->{'METADATA'}->{'remailers'}->{$remailer}->{'conf'}->{'capabilities'};
+};
+
+
+=item $storage->B<get_capabilities>( I<$remailer> )
+
+Return the capabilities on file for remailer with address I<$remailer>. This
+is probably the one we got from remailer-conf or set manually.
+
+Returns undef on errors.
+
+=cut
+sub get_nick($$) {
+ my ($self, $remailer) = @_;
+
+ defined $remailer or
+ Echolot::Log::cluck ("Undefined remailer passed to get_nick()."),
+ return undef;
+ return undef unless defined $self->{'METADATA'}->{'remailers'}->{$remailer};
+ return undef unless defined $self->{'METADATA'}->{'remailers'}->{$remailer}->{'conf'};
+ return $self->{'METADATA'}->{'remailers'}->{$remailer}->{'conf'}->{'nick'};
+};
+
+
+=item $storage->B<expire>( )
+
+Expires old keys, confs and pings from the Storage as configured by
+I<expire_keys>, I<expire_confs>, and I<expire_pings>.
+
+See L<pingd.conf(5)> for more information on these settings.
+
+Returns 1 on success, undef on errors.
+
+=cut
+sub expire($) {
+ my ($self) = @_;
+
+ my $now = time();
+ my $expire_keys = $now - Echolot::Config::get()->{'expire_keys'};
+ my $expire_conf = $now - Echolot::Config::get()->{'expire_confs'};
+ my $expire_pings = $now - Echolot::Config::get()->{'expire_pings'};
+ my $expire_chainpings = $now - Echolot::Config::get()->{'expire_chainpings'};
+ my $expire_fromlines = $now - Echolot::Config::get()->{'expire_fromlines'};
+
+ # Remailer Information and pings
+ for my $remailer_addr ( keys %{$self->{'METADATA'}->{'remailers'}} ) {
+ if (exists $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}) {
+ for my $type ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}} ) {
+ if (exists $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}) {
+ for my $key ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}} ) {
+ if ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key}->{'last_update'} < $expire_keys) {
+ Echolot::Log::info("Expiring $remailer_addr, key, $type, $key.");
+ $self->pingdata_close_one($remailer_addr, $type, $key, 'delete');
+ delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key};
+ };
+ };
+ delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}
+ unless (scalar keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}});
+ };
+ };
+ delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}
+ unless (scalar keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}});
+ }
+
+ if (exists $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'conf'}) {
+ delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'conf'}
+ if (defined $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'conf'} &&
+ ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'conf'}->{'last_update'} < $expire_conf) &&
+ ! ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'conf'}->{'dont_expire'}));
+ }
+
+ delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr},
+ next
+ unless ( defined ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'conf'}) ||
+ defined ($self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}));
+
+
+ next unless exists $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'};
+ for my $type ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}} ) {
+ next unless exists $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type};
+ for my $key ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}} ) {
+ my @out = grep {$_ > $expire_pings} $self->get_pings($remailer_addr, $type, $key, 'out');
+ my @done = grep {$_->[0] > $expire_pings} $self->get_pings($remailer_addr, $type, $key, 'done');
+
+
+ # write ping to done
+ my $fh = $self->get_ping_fh($remailer_addr, $type, $key, 'done') or
+ Echolot::Log::cluck ("$remailer_addr; type=$type; key=$key has no assigned filehandle for done pings."),
+ return undef;
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of $remailer_addr out pings: $!."),
+ return undef;
+ truncate($fh, 0) or
+ Echolot::Log::warn("Cannot truncate done pings file for remailer $remailer_addr; key=$key file to zero length: $!."),
+ return undef;
+ for my $done (@done) {
+ print($fh $done->[0]." ".$done->[1]."\n") or
+ Echolot::Log::warn("Error when writing to $remailer_addr out pings: $!."),
+ return undef;
+ };
+ $fh->flush();
+
+ # rewrite outstanding pings
+ $fh = $self->get_ping_fh($remailer_addr, $type, $key, 'out') or
+ Echolot::Log::cluck ("$remailer_addr; type=$type; key=$key has no assigned filehandle for out pings."),
+ return undef;
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of outgoing pings file for remailer $remailer_addr; key=$key: $!."),
+ return undef;
+ truncate($fh, 0) or
+ Echolot::Log::warn("Cannot truncate outgoing pings file for remailer $remailer_addr; key=$key file to zero length: $!."),
+ return undef;
+ print($fh (join "\n", @out), (scalar @out ? "\n" : '') ) or
+ Echolot::Log::warn("Error when writing to outgoing pings file for remailer $remailer_addr; key=$key file: $!."),
+ return undef;
+ $fh->flush();
+ };
+ };
+ };
+
+ # Chainpings
+ for my $type ( keys %{$self->{'CHAINPING_FHS'}} ) {
+ my $pings = $self->get_chainpings($type);
+
+ @{ $pings->{'out'} } = map {
+ my $a = $_;
+ join (' ', map ({ $a->{$_} } qw{sent addr1 type1 key1 addr2 type2 key2}))
+ } grep {
+ $_->{'sent'} > $expire_chainpings
+ }
+ @{ $pings->{'out'} };
+ @{ $pings->{'done'} } = map {
+ my $a = $_;
+ join (' ', map ({ $a->{$_} } qw{sent addr1 type1 key1 addr2 type2 key2 lat}))
+ } grep {
+ $_->{'sent'} > $expire_chainpings
+ }
+ @{ $pings->{'done'} };
+
+ for my $dir (qw{out done}) {
+ my $fh = $self->get_chainping_fh($type, $dir) or
+ Echolot::Log::warn ("have no assigned filehandle for $type $dir chainpings."),
+ return undef;
+ seek($fh, 0, SEEK_SET) or
+ Echolot::Log::warn("Cannot seek to start of $dir chainpings $type $!."),
+ return undef;
+ truncate($fh, 0) or
+ Echolot::Log::warn("Cannot truncate $dir chainpings $type file to zero length: $!."),
+ return undef;
+ print($fh (join "\n", @{$pings->{$dir}}), (scalar @{$pings->{$dir}} ? "\n" : '') ) or
+ Echolot::Log::warn("Error when writing to $dir chainpings $type file: $!."),
+ return undef;
+ $fh->flush();
+ };
+ };
+
+ # From Header lines
+ for my $remailer_addr ( keys %{$self->{'METADATA'}->{'fromlines'}} ) {
+ for my $type ( keys %{$self->{'METADATA'}->{'fromlines'}->{$remailer_addr}} ) {
+ for my $user_supplied ( keys %{$self->{'METADATA'}->{'fromlines'}->{$remailer_addr}->{$type}} ) {
+ delete $self->{'METADATA'}->{'fromlines'}->{$remailer_addr}->{$type}->{$user_supplied}
+ if ($self->{'METADATA'}->{'fromlines'}->{$remailer_addr}->{$type}->{$user_supplied}->{'last_update'} < $expire_fromlines);
+ };
+ delete $self->{'METADATA'}->{'fromlines'}->{$remailer_addr}->{$type}
+ unless (scalar keys %{$self->{'METADATA'}->{'fromlines'}->{$remailer_addr}->{$type}});
+ };
+ delete $self->{'METADATA'}->{'fromlines'}->{$remailer_addr}
+ unless (scalar keys %{$self->{'METADATA'}->{'fromlines'}->{$remailer_addr}});
+ };
+
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<delete_remailer>( I<$address> )
+
+Delete all data on the remailer with I<$address>. This includes stored conf
+and key information, pings and the remailer's settings like I<pingit> et al.
+
+If this remailer is still referenced by other remailers' remailer-conf reply it
+is likely to get picked up again.
+
+Returns 1.
+
+=cut
+sub delete_remailer($$) {
+ my ($self, $address) = @_;
+
+ Echolot::Log::notice("Deleting remailer $address.");
+
+ if (defined $self->{'METADATA'}->{'addresses'}->{$address}) {
+ delete $self->{'METADATA'}->{'addresses'}->{$address}
+ } else {
+ Echolot::Log::cluck("Remailer $address does not exist in addresses.")
+ };
+
+ if (defined $self->{'METADATA'}->{'remailers'}->{$address}) {
+ for my $type ( keys %{$self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}} ) {
+ for my $key ( keys %{$self->{'METADATA'}->{'remailers'}->{$address}->{'keys'}->{$type}} ) {
+ $self->pingdata_close_one($address, $type, $key, 'delete');
+ };
+ };
+
+ delete $self->{'METADATA'}->{'remailers'}->{$address}
+ };
+
+ delete $self->{'METADATA'}->{'fromlines'}->{$address}
+ if (defined $self->{'METADATA'}->{'fromlines'}->{$address});
+
+ $self->commit();
+
+ return 1;
+};
+
+=item $storage->B<delete_remailercaps>( I<$address> )
+
+Delete conf data of the remailer with I<$address>.
+
+Returns 1.
+
+=cut
+sub delete_remailercaps($$) {
+ my ($self, $address) = @_;
+
+ Echolot::Log::info("Deleting conf for remailer $address.");
+
+ if (defined $self->{'METADATA'}->{'remailers'}->{$address}) {
+ delete $self->{'METADATA'}->{'remailers'}->{$address}->{'conf'}
+ if defined $self->{'METADATA'}->{'remailers'}->{$address}->{'conf'};
+ } else {
+ Echolot::Log::cluck("Remailer $address does not exist in remailers.")
+ };
+ $self->commit();
+
+ return 1;
+};
+
+
+=item $storage->B<register_fromline>( I<$address>, I<$with_from>, I<$from>, $I<disclaimer_top>, $I<disclaimer_bot> )
+
+Register that the remailer I<$address> returned the From header
+line I<$from>. If I<$with_from> is 1 we had tried to supply our own
+From, otherwise not.
+
+$I<disclaimer_top> and $I<disclaimer_bot> are boolean variables indicating
+presence or absense of any disclaimer.
+
+Returns 1, undef on error.
+
+=cut
+
+sub register_fromline($$$$$$$) {
+ my ($self, $address, $type, $with_from, $from, $top, $bot) = @_;
+
+ defined ($self->{'METADATA'}->{'addresses'}->{$address}) or
+ Echolot::Log::cluck ("$address does not exist in Metadata address list."),
+ return undef;
+ defined ($from) or
+ Echolot::Log::cluck ("from is not defined in register_fromline."),
+ return undef;
+ defined ($with_from) or
+ Echolot::Log::cluck ("from is not defined in register_fromline."),
+ return undef;
+ ($with_from == 0 || $with_from == 1) or
+ Echolot::Log::cluck ("with_from has evil value $with_from in register_fromline."),
+ return undef;
+
+ Echolot::Log::debug("registering fromline $address, $type, $with_from, $from, $top, $bot.");
+
+ $self->{'METADATA'}->{'fromlines'}->{$address}->{$type}->{$with_from} = {
+ last_update => time(),
+ from => $from,
+ disclaim_top => $top,
+ disclaim_bot => $bot,
+ };
+ $self->commit();
+
+ return 1;
+};
+
+
+=item $storage->B<get_fromline>( I<$addr>, I<$type>, I<$user_supplied> )
+
+Return a hash reference with header From line information.
+
+The hash has two keys, B<last_update> and B<from>, which holds the actual information.
+
+If there is no from line registered for the given combination, undef is returned.
+
+On Error, also undef is returned.
+
+=cut
+
+sub get_fromline($$$$) {
+ my ($self, $addr, $type, $user_supplied) = @_;
+
+ defined $self->{'METADATA'}->{'fromlines'}->{$addr} or
+ return undef;
+ defined $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type} or
+ return undef;
+ defined $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied} or
+ return undef;
+
+ defined $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied}->{'last_update'} or
+ Echolot::Log::cluck ("last_update is undefined with $addr $type $user_supplied."),
+ return undef;
+ defined $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied}->{'from'} or
+ Echolot::Log::cluck ("from is undefined with $addr $type $user_supplied."),
+ return undef;
+
+ return { last_update => $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied}->{'last_update'},
+ from => $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied}->{'from'},
+ disclaim_top => $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied}->{'disclaim_top'},
+ disclaim_bot => $self->{'METADATA'}->{'fromlines'}->{$addr}->{$type}->{$user_supplied}->{'disclaim_bot'} };
+}
+
+
+# sub convert($) {
+# my ($self) = @_;
+#
+# for my $remailer_addr ( keys %{$self->{'METADATA'}->{'remailers'}} ) {
+# for my $type ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}} ) {
+# for my $key ( keys %{$self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}} ) {
+# if (defined $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'stats'}->{$type}->{$key}) {
+# $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'keys'}->{$type}->{$key}->{'stats'} =
+# $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'stats'}->{$type}->{$key};
+# };
+# };
+# };
+# delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'stats'};
+# };
+#
+# $self->commit();
+# };
+#
+# sub convert($) {
+# my ($self) = @_;
+#
+# for my $remailer_addr ( keys %{$self->{'METADATA'}->{'addresses'}} ) {
+# $self->{'METADATA'}->{'addresses'}->{$remailer_addr}->{'fetch'} = 1;
+# $self->{'METADATA'}->{'addresses'}->{$remailer_addr}->{'pingit'} = 1;
+# $self->{'METADATA'}->{'addresses'}->{$remailer_addr}->{'showit'} = 0;
+# delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'pingit'};
+# delete $self->{'METADATA'}->{'remailers'}->{$remailer_addr}->{'showit'};
+# };
+#
+# $self->commit();
+# };
+
+=back
+
+=cut
+
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Thesaurus.pm b/trunk/Echolot/Thesaurus.pm
new file mode 100644
index 0000000..0ff207a
--- /dev/null
+++ b/trunk/Echolot/Thesaurus.pm
@@ -0,0 +1,144 @@
+package Echolot::Thesaurus;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Thesaurus - build thesaurus pages
+
+=head1 DESCRIPTION
+
+This package provides necessary functions for the thesaurus.
+
+=cut
+
+use strict;
+use English;
+use Echolot::Log;
+
+
+sub save_thesaurus($$$) {
+ my ($otype, $oid, $data) = @_;
+
+ return 1 unless Echolot::Config::get()->{'thesaurus'};
+
+ my ($type) = $otype =~ /^([a-z-]+)$/;
+ Echolot::Log::cluck("type '$otype' is not clean in save_thesaurus."), return 0 unless defined $type;
+ my ($id) = $oid =~ /^([0-9]+)$/;
+ Echolot::Log::cluck("id '$oid' is not clean in save_thesaurus."), return 0 unless defined $id;
+
+ my $file = Echolot::Config::get()->{'thesaurusdir'}.'/'.$id.'.'.$type;
+ open (F, ">$file") or
+ Echolot::Log::warn ("Cannot open '$file': $!."),
+ return 0;
+ print F $data;
+ close (F);
+
+ return 1;
+};
+
+sub build_thesaurus() {
+ return 1 unless Echolot::Config::get()->{'thesaurus'};
+
+ my $dir = Echolot::Config::get()->{'thesaurusdir'};
+ opendir(DIR, $dir) or
+ Echolot::Log::warn ("Cannot open '$dir': $!."),
+ return 0;
+ my @files = grep { ! /^\./ } readdir(DIR);
+ closedir(DIR);
+
+
+ my $expire_date = time() - Echolot::Config::get()->{'expire_thesaurus'};
+
+ my $data;
+ for my $filename (@files) {
+ my ($id, $what) = $filename =~ /^(\d+)\.(adminkey|conf|help|key|stats)$/;
+ next unless (defined $id && defined $what);
+
+ my $remailer = Echolot::Globals::get()->{'storage'}->get_address_by_id($id);
+ next unless defined $remailer;
+ next unless $remailer->{'showit'};
+ my $caps = Echolot::Globals::get()->{'storage'}->get_capabilities($remailer->{'address'});
+ next unless defined $caps;
+ next unless $caps !~ m/\btesting\b/i;
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = stat($dir.'/'.$filename);
+
+ if ($mtime < $expire_date) {
+ unlink ($dir.'/'.$filename) or
+ Echolot::Log::warn("Cannot unlink expired $filename.");
+ Echolot::Log::info("Expired thesaurus file $filename.");
+ next;
+ };
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday)
+ = gmtime($mtime);
+
+ my $date = sprintf("%04d-%02d-%02d", $year+1900, $mon+1, $mday);
+ my $time = sprintf("%02d:%02d", $hour, $min);
+
+
+ $data->{$remailer->{'address'}}->{$what.'_href'} = $filename;
+ $data->{$remailer->{'address'}}->{$what.'_date'} = $date;
+ $data->{$remailer->{'address'}}->{$what.'_time'} = $time;
+ $data->{$remailer->{'address'}}->{'id'} = $id;
+ };
+
+
+ for my $addr (keys (%$data)) {
+ my $nick = Echolot::Globals::get()->{'storage'}->get_nick($addr);
+ if (defined $nick) {
+ $data->{$addr}->{'nick'} = $nick;
+ $data->{$addr}->{'address'} = $addr;
+ } else {
+ delete $data->{$addr};
+ };
+ };
+
+ my @data = map {$data->{$_}} (sort { $data->{$a}->{'nick'} cmp $data->{$b}->{'nick'} } keys (%$data));
+
+
+ Echolot::Tools::write_HTML_file(
+ Echolot::Config::get()->{'thesaurusindexfile'},
+ 'thesaurusindexfile',
+ Echolot::Config::get()->{'buildthesaurus'},
+ remailers => \@data);
+
+ open(F, ">$dir/index.txt") or
+ Echolot::Log::warn ("Cannot open '$dir/index.txt': $!."),
+ return 0;
+ for my $remailer (@data) {
+ printf F "%s\t%s\t%s\n", $remailer->{'nick'}, $remailer->{'id'}, $remailer->{'address'};
+ };
+ close(F) or
+ Echolot::Log::warn ("Cannot close '$dir/index.txt': $!."),
+ return 0;
+};
+
+
+1;
+# vim: set ts=4 shiftwidth=4:
diff --git a/trunk/Echolot/Tools.pm b/trunk/Echolot/Tools.pm
new file mode 100644
index 0000000..59d887f
--- /dev/null
+++ b/trunk/Echolot/Tools.pm
@@ -0,0 +1,476 @@
+package Echolot::Tools;
+
+#
+# $Id$
+#
+# This file is part of Echolot - a Pinger for anonymous remailers.
+#
+# Copyright (c) 2002, 2003, 2004 Peter Palfrader <peter@palfrader.org>
+#
+# This program is free software. you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+#
+
+=pod
+
+=head1 Name
+
+Echolot::Tools - Tools for echolot
+
+=head1 DESCRIPTION
+
+
+=cut
+
+use strict;
+use HTML::Template;
+use Digest::MD5 qw{};
+use IO::Select;
+use IO::Handle;
+use GnuPG::Interface;
+use Echolot::Log;
+use English;
+
+sub hash($) {
+ my ($data) = @_;
+ ($data) = $data =~ m/(.*)/s; # untaint
+ my $hash = Digest::MD5::md5_hex($data);
+ return $hash;
+};
+
+sub make_random($;%) {
+ my ($length, %args) = @_;
+
+ my $random;
+
+ open (FH, Echolot::Config::get()->{'dev_random'}) or
+ Echolot::Log::warn("Cannot open ".Echolot::Config::get()->{'dev_random'}." for reading: $!."),
+ return 0;
+ read(FH, $random, $length) or
+ Echolot::Log::warn("Cannot read from ".Echolot::Config::get()->{'dev_random'}.": $!."),
+ return 0;
+ close (FH) or
+ Echolot::Log::warn("Cannot close ".Echolot::Config::get()->{'dev_random'}.": $!."),
+ return 0;
+
+ $random = unpack('H*', $random)
+ if ($args{'armor'} == 1);
+
+ return $random;
+};
+
+sub make_mac($) {
+ my ($token) = @_;
+
+ my $mac = hash($token . Echolot::Globals::get()->{'storage'}->get_secret() );
+ return $mac;
+};
+
+sub makeShortNumHash($) {
+ my ($text) = @_;
+
+ my $hash = Echolot::Tools::make_mac($text);
+ $hash = substr($hash, 0, 4);
+ my $sum = hex($hash);
+ return $sum;
+};
+
+sub verify_mac($$) {
+ my ($token, $mac) = @_;
+
+ return (hash($token . Echolot::Globals::get()->{'storage'}->get_secret() ) eq $mac);
+};
+
+sub make_address($) {
+ my ($subsystem) = @_;
+
+ my $token = $subsystem.'='.time();
+ my $hash = hash($token . Echolot::Globals::get()->{'storage'}->get_secret() );
+ my $cut_hash = substr($hash, 0, Echolot::Config::get()->{'hash_len'});
+ my $complete_token = $token.'='.$cut_hash;
+ my $address = Echolot::Config::get()->{'recipient_delimiter'} ne ''?
+ Echolot::Config::get()->{'my_localpart'}.
+ Echolot::Config::get()->{'recipient_delimiter'}.
+ $complete_token.
+ '@'.
+ Echolot::Config::get()->{'my_domain'}
+ :
+ Echolot::Config::get()->{'my_localpart'}.
+ '@'.
+ Echolot::Config::get()->{'my_domain'}.
+ '('.
+ $complete_token.
+ ')';
+
+ return $address;
+};
+
+sub verify_address_tokens($) {
+ my ($address) = @_;
+
+ my ($type, $timestamp, $received_hash);
+ if (Echolot::Config::get()->{'recipient_delimiter'} ne '') {
+ my $delimiter = quotemeta( Echolot::Config::get()->{'recipient_delimiter'});
+ ($type, $timestamp, $received_hash) = $address =~ /$delimiter (.*) = (\d+) = ([0-9a-f]+) @/x or
+ ($type, $timestamp, $received_hash) = $address =~ /\( (.*) = (\d+) = ([0-9a-f]+) \)/x or
+ Echolot::Log::debug("Could not parse to header '$address'."),
+ return undef;
+ } else {
+ ($type, $timestamp, $received_hash) = $address =~ /\( (.*) = (\d+) = ([0-9a-f]+) \)/x or
+ Echolot::Log::debug("Could not parse to header '$address'."),
+ return undef;
+ };
+
+ my $token = $type.'='.$timestamp;
+ my $hash = Echolot::Tools::hash($token . Echolot::Globals::get()->{'storage'}->get_secret() );
+ my $cut_hash = substr($hash, 0, Echolot::Config::get()->{'hash_len'});
+
+ ($cut_hash eq $received_hash) or
+ Echolot::Log::info("Hash mismatch in '$address'."),
+ return undef;
+
+ return
+ { timestamp => $timestamp,
+ token => $type };
+};
+
+sub send_message(%) {
+ my (%args) = @_;
+
+ defined($args{'To'}) or
+ Echolot::Log::cluck ('No recipient address given.'),
+ return 0;
+ $args{'Subject'} = '(no subject)' unless (defined $args{'Subject'});
+ $args{'Body'} = '' unless (defined $args{'Body'});
+ $args{'From_'} =
+ Echolot::Config::get()->{'my_localpart'}.
+ '@'.
+ Echolot::Config::get()->{'my_domain'};
+ if (defined $args{'Token'}) {
+ $args{'From'} = make_address( $args{'Token'} );
+ } else {
+ $args{'From'} = $args{'From_'};
+ };
+ $args{'Subject'} = 'none' unless (defined $args{'Subject'});
+
+ my @lines = map { $_."\n" } split (/\r?\n/, $args{'Body'});
+
+ open(SENDMAIL, '|'.Echolot::Config::get()->{'sendmail'}.' -f '.$args{'From_'}.' -t')
+ or Echolot::Log::warn("Cannot run sendmail: $!."),
+ return 0;
+ printf SENDMAIL "From: %s\n", $args{'From'};
+ printf SENDMAIL "To: %s\n", $args{'To'};
+ printf SENDMAIL "Subject: %s\n", $args{'Subject'};
+ printf SENDMAIL "\n";
+ for my $line (@lines) {
+ print SENDMAIL $line;
+ };
+ close SENDMAIL;
+
+ return 1;
+};
+
+sub make_monthname($) {
+ my ($month) = @_;
+ my @MON = qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
+ return $MON[$month];
+};
+
+sub make_dayname($) {
+ my ($day) = @_;
+ my @WDAY = qw{Sun Mon Tue Wed Thu Fri Sat};
+ return $WDAY[$day];
+};
+
+sub date822($) {
+ my ($date) = @_;
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime($date);
+ # 14 Aug 2002 17:11:12 +0100
+ return sprintf("%s, %02d %s %d %02d:%02d:%02d +0000",
+ make_dayname($wday),
+ $mday,
+ make_monthname($mon),
+ $year + 1900,
+ $hour,
+ $min,
+ $sec);
+};
+
+sub write_meta_information($%) {
+ my ($file, %data) = @_;
+
+ return 1 unless Echolot::Config::get()->{'write_meta_files'};
+
+ $file .= Echolot::Config::get()->{'meta_extension'};
+ open (F, ">$file") or
+ Echolot::Log::warn ("Cannot open $file: $!."),
+ return 0;
+ if (defined $data{'Expires'}) {
+ my $date = date822($data{'Expires'});
+ print F "Expires: $date\n";
+ };
+ close(F);
+ return 1;
+};
+
+sub escape_HTML_entities($) {
+ my ($in) = @_;
+
+ $in =~ s/&/&amp;/;
+ $in =~ s/"/&quot;/;
+ $in =~ s/</&lt;/;
+ $in =~ s/>/&gt;/;
+
+ return $in;
+};
+
+sub write_HTML_file($$;$%) {
+ my ($origfile, $template_file, $expire, %templateparams) = @_;
+
+ my $operator = Echolot::Config::get()->{'operator_address'};
+ $operator =~ s/@/./;
+
+ for my $lang ( keys %{Echolot::Config::get()->{'templates'}} ) {
+ my $template = HTML::Template->new(
+ filename => Echolot::Config::get()->{'templates'}->{$lang}->{$template_file},
+ strict => 0,
+ die_on_bad_params => 0,
+ global_vars => 1 );
+ $template->param ( %templateparams );
+ $template->param ( CURRENT_TIMESTAMP => scalar gmtime() );
+ $template->param ( SITE_NAME => Echolot::Config::get()->{'sitename'} );
+ $template->param ( separate_rlist => Echolot::Config::get()->{'separate_rlists'} );
+ $template->param ( combined_list => Echolot::Config::get()->{'combined_list'} );
+ $template->param ( thesaurus => Echolot::Config::get()->{'thesaurus'} );
+ $template->param ( fromlines => Echolot::Config::get()->{'fromlines'} );
+ $template->param ( version => Echolot::Globals::get()->{'version'} );
+ $template->param ( operator => $operator );
+ $template->param ( expires => date822( time + $expire ));
+
+ my $file = $origfile;
+ $file .= '.'.$lang unless ($lang eq 'default');
+ $file .= '.html';
+
+ open(F, '>'.$file) or
+ Echolot::Log::warn("Cannot open $file: $!."),
+ return 0;
+ print F $template->output() or
+ Echolot::Log::warn("Cannot print to $file: $!."),
+ return 0;
+ close (F) or
+ Echolot::Log::warn("Cannot close $file: $!."),
+ return 0;
+
+ if (defined $expire) {
+ write_meta_information($file,
+ Expires => time + $expire) or
+ Echolot::Log::debug ("Error while writing meta information for $file."),
+ return 0;
+ };
+ };
+
+ return 1;
+};
+
+sub make_gpg_fds() {
+ my %fds = (
+ stdin => IO::Handle->new(),
+ stdout => IO::Handle->new(),
+ stderr => IO::Handle->new(),
+ status => IO::Handle->new() );
+ my $handles = GnuPG::Handles->new( %fds );
+ return ($fds{'stdin'}, $fds{'stdout'}, $fds{'stderr'}, $fds{'status'}, $handles);
+};
+
+sub readwrite_gpg($$$$$) {
+ my ($in, $inputfd, $stdoutfd, $stderrfd, $statusfd) = @_;
+
+ Echolot::Log::trace("Entering readwrite_gpg.");
+
+ local $INPUT_RECORD_SEPARATOR = undef;
+ my $sout = IO::Select->new();
+ my $sin = IO::Select->new();
+ my $offset = 0;
+
+ Echolot::Log::trace("input is $inputfd; output is $stdoutfd; err is $stderrfd; status is ".(defined $statusfd ? $statusfd : 'undef').".");
+
+ $inputfd->blocking(0);
+ $stdoutfd->blocking(0);
+ $statusfd->blocking(0) if defined $statusfd;
+ $stderrfd->blocking(0);
+ $sout->add($stdoutfd);
+ $sout->add($stderrfd);
+ $sout->add($statusfd) if defined $statusfd;
+ $sin->add($inputfd);
+
+ my ($stdout, $stderr, $status) = ("", "", "");
+
+ my ($readyr, $readyw);
+ while ($sout->count() > 0 || (defined($sin) && ($sin->count() > 0))) {
+ Echolot::Log::trace("select waiting for ".($sout->count())." fds.");
+ ($readyr, $readyw, undef) = IO::Select::select($sout, $sin, undef, 42);
+ Echolot::Log::trace("ready: write: ".(defined $readyw ? scalar @$readyw : 'none')."; read: ".(defined $readyr ? scalar @$readyr : 'none'));
+ for my $wfd (@$readyw) {
+ Echolot::Log::trace("writing to $wfd.");
+ my $written = 0;
+ if ($offset != length($in)) {
+ $written = $wfd->syswrite($in, length($in) - $offset, $offset);
+ }
+ unless (defined ($written)) {
+ Echolot::Log::warn("Error while writing to GnuPG: $!");
+ close $wfd;
+ $sin->remove($wfd);
+ $sin = undef;
+ } else {
+ $offset += $written;
+ if ($offset == length($in)) {
+ Echolot::Log::trace("writing to $wfd done.");
+ close $wfd;
+ $sin->remove($wfd);
+ $sin = undef;
+ }
+ }
+ }
+
+ next unless (defined(@$readyr)); # Wait some more.
+
+ for my $rfd (@$readyr) {
+ if ($rfd->eof) {
+ Echolot::Log::trace("reading from $rfd done.");
+ $sout->remove($rfd);
+ close($rfd);
+ next;
+ }
+ Echolot::Log::trace("reading from $rfd.");
+ if ($rfd == $stdoutfd) {
+ $stdout .= <$rfd>;
+ next;
+ }
+ if (defined $statusfd && $rfd == $statusfd) {
+ $status .= <$rfd>;
+ next;
+ }
+ if ($rfd == $stderrfd) {
+ $stderr .= <$rfd>;
+ next;
+ }
+ }
+ }
+ Echolot::Log::trace("readwrite_gpg done.");
+ return ($stdout, $stderr, $status);
+};
+
+sub crypt_symmetrically($$) {
+ my ($msg, $direction) = @_;
+
+ ($direction eq 'encrypt' || $direction eq 'decrypt') or
+ Echolot::Log::cluck("Wrong argument direction '$direction' passed to crypt_symmetrically."),
+ return undef;
+
+ my $GnuPG = new GnuPG::Interface;
+ $GnuPG->call( Echolot::Config::get()->{'gnupg'} ) if (Echolot::Config::get()->{'gnupg'});
+ $GnuPG->options->hash_init(
+ armor => 1,
+ homedir => Echolot::Config::get()->{'gnupghome'} );
+ $GnuPG->options->meta_interactive( 0 );
+ $GnuPG->passphrase( Echolot::Globals::get()->{'storage'}->get_secret() );
+
+ my ( $stdin_fh, $stdout_fh, $stderr_fh, $status_fh, $handles ) = make_gpg_fds();
+ my $pid =
+ $direction eq 'encrypt' ?
+ $GnuPG->encrypt_symmetrically( handles => $handles ) :
+ $GnuPG->decrypt( handles => $handles );
+ my ($stdout, $stderr, $status) = readwrite_gpg($msg, $stdin_fh, $stdout_fh, $stderr_fh, $status_fh);
+ waitpid $pid, 0;
+
+ if ($direction eq 'encrypt') {
+ (($status =~ /^\[GNUPG:\] BEGIN_ENCRYPTION\s/m) &&
+ ($status =~ /^\[GNUPG:\] END_ENCRYPTION\s/m)) or
+ Echolot::Log::info("GnuPG status '$status' didn't indicate message was encrypted correctly (stderr: $stderr). Returning."),
+ return undef;
+ } elsif ($direction eq 'decrypt') {
+ (($status =~ /^\[GNUPG:\] BEGIN_DECRYPTION\s/m) &&
+ ($status =~ /^\[GNUPG:\] DECRYPTION_OKAY\s/m) &&
+ ($status =~ /^\[GNUPG:\] END_DECRYPTION\s/m)) or
+ Echolot::Log::info("GnuPG status '$status' didn't indicate message was decrypted correctly (stderr: $stderr). Returning."),
+ return undef;
+ };
+
+ my $result = $stdout;
+ $result =~ s,^Version: .*$,Version: N/A,m;
+ return $result;
+};
+
+sub make_garbage() {
+
+ my $file = Echolot::Config::get()->{'dev_urandom'};
+ open(FH, $file) or
+ Echolot::Log::warn("Cannot open $file: $!."),
+ return "";
+ my $random = '';
+ my $want = int(rand(int(Echolot::Config::get()->{'random_garbage'} / 2)));
+ my $i = 0;
+ while ($want > 0) {
+ my $buf;
+ $want -= read(FH, $buf, $want);
+ $random .= $buf;
+ ($i++ > 15 && $want > 0) and
+ Echolot::Log::warn("Could not get enough garbage (still missing $want."),
+ last;
+ };
+ close (FH) or
+ Echolot::Log::warn("Cannot close $file: $!.");
+
+ $random = unpack("H*", $random);
+ $random = join "\n", grep { $_ ne '' } (split /(.{64})/, $random);
+ $random = "-----BEGIN GARBAGE-----\n".
+ $random."\n".
+ "-----END GARBAGE-----\n";
+
+ return $random;
+};
+
+sub read_file($;$) {
+ my ($name, $fail_ok) = @_;
+
+ unless (open (F, $name)) {
+ Echolot::Log::warn("Could not open '$name': $!.") unless ($fail_ok);
+ return undef;
+ };
+ local $/ = undef;
+ my $result = <F>;
+ close (F);
+
+ return $result;
+};
+
+sub cleanup_tmp() {
+ my $tmpdir = Echolot::Config::get()->{'tmpdir'};
+
+ opendir(DIR, $tmpdir) or
+ Echolot::Log::warn("Could not open '$tmpdir': $!."),
+ return undef;
+ my @files = grep { ! /^[.]/ } readdir(DIR);
+ closedir(DIR);
+
+ for my $file (@files) {
+ unlink($tmpdir.'/'.$file) or
+ Echolot::Log::warn("Could not unlink '$tmpdir/$file': $!.");
+ };
+};
+
+1;
+
+# vim: set ts=4 shiftwidth=4: