snapshot-2003-02-17/Echolot/Mailin.pm

package Echolot::Mailin;

# (c) 2002 Peter Palfrader <peter@palfrader.org>
# $Id: Mailin.pm,v 1.14 2003/02/16 03:06:51 weasel Exp $
#

=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 $to;
        for ( ; $i < scalar @$lines; $i++) {
                my $line = $lines->[$i];
                chomp($line);
                last if $line eq '';

                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($body, $type, $timestamp), return 1 if ($type eq 'ping');
        Echolot::Chain::receive($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:
1	package Echolot::Mailin;
2
3	# (c) 2002 Peter Palfrader <peter@palfrader.org>
4	# $Id: Mailin.pm,v 1.14 2003/02/16 03:06:51 weasel Exp $
5	#
6
7	=pod
8
9	=head1 Name
10
11	Echolot::Mailin - Incoming Mail Dispatcher for Echolot
12
13	=head1 DESCRIPTION
14
15
16	=cut
17
18	use strict;
19	use English;
20	use Echolot::Globals;
21	use Echolot::Log;
22	use Fcntl ':flock'; # import LOCK_* constants
23	use POSIX; # import SEEK_* constants (older perls don't have SEEK_ in Fcntl)
24
25
26	sub make_sane_name() {
27	my $result = time().'.'.$PROCESS_ID.'_'.Echolot::Globals::get()->{'internal_counter'}++.'.'.Echolot::Globals::get()->{'hostname'};
28	return $result;
29	};
30
31	sub sane_move($$) {
32	my ($from, $to) = @_;
33
34	my $link_success = link($from, $to);
35	$link_success or
36	Echolot::Log::warn("Cannot link $from to $to: $!."),
37	return 0;
38	#- Trying move"),
39	#rename($from, $to) or
40	# cluck("Renaming $from to $to didn't work either: $!"),
41	# return 0;
42
43	$link_success && (unlink($from) or
44	Echolot::Log::warn("Cannot unlink $from: $!.") );
45	return 1;
46	};
47
48	sub handle($) {
49	my ($lines) = @_;
50
51	my $i=0;
52	my $body = '';
53	my $to;
54	for ( ; $i < scalar @$lines; $i++) {
55	my $line = $lines->[$i];
56	chomp($line);
57	last if $line eq '';
58
59	if ($line =~ m/^To:\s(.?)\s*$/) {
60	$to = $1;
61	};
62	};
63	for ( ; $i < scalar @$lines; $i++) {
64	$body .= $lines->[$i];
65	};
66
67	(defined $to) or
68	Echolot::Log::info("No To header found in mail."),
69	return 0;
70
71	my $address_result = Echolot::Tools::verify_address_tokens($to) or
72	Echolot::Log::debug("Verifying '$to' failed."),
73	return 0;
74
75	my $type = $address_result->{'token'};
76	my $timestamp = $address_result->{'timestamp'};
77
78	Echolot::Conf::remailer_conf($body, $type, $timestamp), return 1 if ($type =~ /^conf\./);
79	Echolot::Conf::remailer_key($body, $type, $timestamp), return 1 if ($type =~ /^key\./);
80	Echolot::Conf::remailer_help($body, $type, $timestamp), return 1 if ($type =~ /^help\./);
81	Echolot::Conf::remailer_stats($body, $type, $timestamp), return 1 if ($type =~ /^stats\./);
82	Echolot::Conf::remailer_adminkey($body, $type, $timestamp), return 1 if ($type =~ /^adminkey\./);
83
84	Echolot::Pinger::receive($body, $type, $timestamp), return 1 if ($type eq 'ping');
85	Echolot::Chain::receive($body, $type, $timestamp), return 1 if ($type eq 'chainping');
86
87	Echolot::Log::warn("Didn't know what to do with '$to'."),
88	return 0;
89	};
90
91	sub handle_file($) {
92	my ($file) = @_;
93
94	open (FH, $file) or
95	Echolot::Log::warn("Cannot open file $file: $!,"),
96	return 0;
97	my @lines = <FH>;
98	my $body = join('', <FH>);
99	close (FH) or
100	Echolot::Log::warn("Cannot close file $file: $!.");
101
102	return handle(\@lines);
103	};
104
105	sub read_mbox($) {
106	my ($file) = @_;
107
108	my @mail;
109	my $mail = [];
110	my $blank = 1;
111
112	open(FH, '+<'. $file) or
113	Echolot::Log::warn("cannot open '$file': $!."),
114	return undef;
115	flock(FH, LOCK_EX) or
116	Echolot::Log::warn("cannot gain lock on '$file': $!."),
117	return undef;
118
119	while(<FH>) {
120	if($blank && /\AFrom .*\d{4}/) {
121	push(@mail, $mail) if scalar(@{$mail});
122	$mail = [ $_ ];
123	$blank = 0;
124	} else {
125	$blank = m#\A\Z# ? 1 : 0;
126	push @$mail, $_;
127	}
128	}
129	push(@mail, $mail) if scalar(@{$mail});
130
131	seek(FH, 0, SEEK_SET) or
132	Echolot::Log::warn("cannot seek to start of '$file': $!."),
133	return undef;
134	truncate(FH, 0) or
135	Echolot::Log::warn("cannot truncate '$file' to zero size: $!."),
136	return undef;
137	flock(FH, LOCK_UN) or
138	Echolot::Log::warn("cannot release lock on '$file': $!."),
139	return undef;
140	close(FH);
141
142	return \@mail;
143	}
144
145	sub read_maildir($) {
146	my ($dir) = @_;
147
148	my @mail;
149
150	my @files;
151	for my $sub (qw{new cur}) {
152	opendir(DIR, $dir.'/'.$sub) or
153	Echolot::Log::warn("Cannot open direcotry '$dir/$sub': $!."),
154	return undef;
155	push @files, map { $sub.'/'.$_ } grep { ! /^\./ } readdir(DIR);
156	closedir(DIR) or
157	Echolot::Log::warn("Cannot close direcotry '$dir/$sub': $!.");
158	};
159
160	for my $file (@files) {
161	$file =~ /^(.*)$/s or
162	Echolot::Log::confess("I really should match here. ('$file').");
163	$file = $1;
164
165	my $mail = [];
166	open(FH, $dir.'/'.$file) or
167	Echolot::Log::warn("cannot open '$dir/$file': $!."),
168	return undef;
169	@$mail = <FH>;
170	close(FH);
171
172	push @mail, $mail;
173	};
174
175	for my $file (@files) {
176	unlink $dir.'/'.$file or
177	Echolot::Log::warn("cannot unlink '$dir/$file': $!.");
178	};
179
180
181	return \@mail;
182	}
183
184	sub storemail($$) {
185	my ($path, $mail) = @_;
186
187	my $tmpname = $path.'/tmp/'.make_sane_name();
188	open (F, '>'.$tmpname) or
189	Echolot::Log::warn("Cannot open $tmpname: $!."),
190	return undef;
191	print F join ('', @$mail);
192	close F;
193
194	my $i;
195	for ($i = 0; $i < 5; $i++ ) {
196	my $targetname = $path.'/cur/'.make_sane_name();
197	sane_move($tmpname, $targetname) or
198	sleep 1, next;
199	last;
200	};
201
202	return undef if ($i == 5);
203	return 1;
204	};
205
206	sub process() {
207	my $inmail = Echolot::Config::get()->{'mailin'};
208	my $mailerrordir = Echolot::Config::get()->{'mailerrordir'};
209
210	my $mails = (-d $inmail) ?
211	read_maildir($inmail) :
212	( ( -e $inmail ) ? read_mbox($inmail) : [] );
213
214	Echolot::Globals::get()->{'storage'}->delay_commit();
215	for my $mail (@$mails) {
216	unless (handle($mail)) {
217	if (Echolot::Config::get()->{'save_errormails'}) {
218	Echolot::Log::info("Saving mail with unknown destination (probably a bounce) to mail-errordir.");
219	my $name = make_sane_name();
220	storemail($mailerrordir, $mail) or
221	Echolot::Log::warn("Could not store a mail.");
222	} else {
223	Echolot::Log::info("Trashing mail with unknown destination (probably a bounce).");
224	};
225	};
226	};
227	Echolot::Globals::get()->{'storage'}->enable_commit();
228	};
229
230	1;
231
232	# vim: set ts=4 shiftwidth=4: