1#!/usr/bin/perl -T
2# $File: //depot/libOurNet/BBS/script/bbsboard $ $Author: autrijus $
3# $Revision: #1 $ $Change: 3790 $ $DateTime: 2003/01/24 19:08:46 $
4
5$VERSION = '0.05';
6$REVISION = "rev$1\[\@$2\]"
7    if ('$Revision: #1 $ $Change: 3790 $' =~ /(\d+)[^\d]+(\d+)/);
8
9use strict;
10
11use MIME::Words ':all';
12use MIME::Parser;
13use Mail::Internet;
14use OurNet::BBS '1.6';
15
16=head1 NAME
17
18bbsboard - Internet to BBS email-post handler
19
20=head1 SYNOPSIS
21
22In F</usr/local/etc/bbs.rc> or F</etc/bbs.rc>;
23
24    # $DUMP     = '/tmp/msgdump.tmp';		# Dump message to disk; halt
25    $MAIL_LOG   = '/var/log/bbsmail.log';	# Log of bbsmail
26    $BOARD_LOG  = '/var/log/bsboard.log';	# Log of bbsboard
27    $SIZE_LIMIT = 204800;			# Size limit of attachments
28    $NO_ATTACH	= '\.(?i-xsm:exe|scr|pif|bat)$';# Block matched attachments
29
30    # Set virutal hosts; The C<bbs.> prefix of keys should be omitted.
31    %DOMAINS = (
32        'elixus.org' => {
33            BASEURL => 'http://elixus.org',
34            WWWHOME => '/srv/www/elixir',
35            PARAM   => ['MELIX', '/home/melix'],
36            OWNER   => 'melix',
37            GROUP   => 'melix',
38        },
39        'cvic.org'  => {
40            BASEURL => 'http://cvic.org',
41            WWWHOME => '/srv/www/cvic',
42            PARAM   => ['CVIC', '/srv/bbs/cvic',
43                         1003, 2500, 1005, 250, 1004, 50000], # needs utmp
44            OWNER   => 'cvic',
45            GROUP   => 'bbs',
46	    PERMIT  => 1, # 'permit' file required to post
47        },
48        'm543.com'  => {
49            BASEURL => 'http://m543.com',
50            WWWHOME => '/srv/www/m543',
51            PARAM   => ['CVIC', '/srv/bbs/m543',
52                         1103, 2500, 1105, 250, 1104, 50000], # needs utmp
53            OWNER   => 'cvic',
54            GROUP   => 'bbs',
55        },
56    );
57
58    # multiple domains, same IP
59    $DOMAINS{'m543.org'}       = $DOMAINS{'music543.org'} =
60    $DOMAINS{'music543.com'}   = $DOMAINS{'m543.com'};
61
62    # fallback using the 'true' hostname
63    $DOMAINS{'geb.elixus.org'} = $DOMAINS{'elixus.org'};
64
65    # default domain for in-site mails
66    $DEFAULT_DOMAIN = 'elixus.org'
67
68To configure it with sendmail, modify F<sendmail.cf> like this:
69
70    ######################################
71    ###   Ruleset 0 -- Parse Address   ###
72    ######################################
73
74    R$+.bbs < @ $=w .>		$#bbsmail $: $1		bbs mail gateway
75    R$+.board < @ $=w .>	$#bbsboard $: $1	bbs board gateway
76
77    # handle locally delivered names
78
79    R$+.bbs			$#bbsmail $:$1		bbs mail gateway
80    R$+.board			$#bbsboard $:$1		bbs board gateway
81
82    ##################################################
83    ###   Local and Program Mailer specification   ###
84    ##################################################
85
86    Mbbsmail,	P=/usr/local/bin/bbsmail, F=lsSDFMuhP, S=10, R=20,
87		A=bbsmail $u
88    Mbbsboard,	P=/usr/local/bin/bbsboard, F=lsSDFMuhP, S=10, R=20,
89		A=bbsboard $u
90
91To feed it a MIME mail directly at the command line:
92
93    % bbsmail < message.txt
94
95=head1 DESCRIPTION
96
97This script relays e-mails sent to C<*.bbs@domain> as mails to
98BBS user mailboxes; it is designed to be a drop-in replacement for
99the MAPLE BBS utility of the same name.
100
101This program could be used serve multiple BBS sites, each distinguished
102by its domain name. MIME encodings, multipart messages, quoted words
103are all handled correctly.
104
105If supplied with a web directory, attachments could be saved for
106later download. You could restrict the max. allowed size of each
107attachments.
108
109If the optional C<HTML::Parse> and C<HTML::FromText> modules were
110installed, HTML-only mails and simple HTML attachments could be
111rendered as plain text.
112
113=head1 CAVEATS
114
115Currently this script does not check proper permissions; you could
116use the C<OurNet> backend to achieve restricted permission. See
117L<bbscomd> for how to run an OurNet node.
118
119However, authentication is currently not implemented; while sending
120password via e-mail is easy, the author finds it distasteful. A
121proper way to parse PGP-signed mail might be the only viable route,
122and any contributions on that front will be most welcomed.
123
124=cut
125
126our ($SIZE_LIMIT, $DUMP, $LOG, $MAIL_LOG, $BOARD_LOG, $NO_ATTACH);
127our (%DOMAINS, $DEFAULT_DOMAIN);
128our ($Postfix, $Element, $Container, $RCFile);
129our ($MsgAttach, $MsgTooLarge, $MsgDownload);
130
131$Postfix	||= '.board';
132$Element	||= 'boards';
133$Container	||= 'articles';
134$RCFile		||= 'bbs.rc';
135$MsgAttach	||= "\n�� [�H����: %s]\n";
136$MsgTooLarge	||= "�� (���[�ɮ� %s �W�L�W��: %s �줸�աC)\n";
137$MsgDownload	||= "�� (���[�ɮץi�� %s �U���C)\n";
138
139foreach my $path ('/etc', '/usr/local/etc', '/usr/local/bin', '.') {
140    do "$path/$RCFile" and last if -e "$path/$RCFile";
141}
142
143die 'bbs.rc not found!' unless %DOMAINS;
144
145$DOMAINS{"bbs.$_"} = $DOMAINS{$_} for keys(%DOMAINS);
146
147if ($DUMP) { open _, ">$DUMP"; local $/; print _ <STDIN>; close _; exit 0; }
148
149my $mail = Mail::Internet->new(*STDIN);
150my $timeseq = scalar time;
151
152# Extract headers
153my ($to, $cc, $received, $date, $bcc, $from,
154    $subject, $replyto, $sender, $xorig) = ( map {
155	substr($mail->head->get($_), 0, -1)
156    } qw/To Cc Received Date Bcc From Subject Reply-To X-Sender X-Originator/,
157);
158
159# Parse MIME Quoted Words
160for ($subject, $from, $to, $sender, $replyto) {
161    if (/=\?\w/) {
162        $_ .= '?=' unless index($_, '?=') > -1;
163        $_ = decode_mimewords($_);
164    }
165}
166
167my $DOMAIN;
168foreach my $dom (keys(%DOMAINS)) {
169    if (index(uc($to), uc("\@".$dom)) > -1) {
170        $DOMAIN = $dom; last;
171    }
172    elsif (index(uc($cc), uc("\@".$dom)) > -1) {
173        $to = $cc;
174        $DOMAIN = $dom; last;
175    }
176    elsif (index(uc($bcc), uc("\@".$dom)) > -1) {
177        $to = $bcc;
178        $DOMAIN = $dom; last;
179    }
180    elsif (index(uc($received), uc("$Postfix\@".$dom)) > -1) {
181	$to = $received;
182	$to =~ s/.* for //s; $to =~ s/;.*//s;
183        $DOMAIN = $dom; last;
184    }
185    elsif (index($received, "-owner\@".$dom) > -1) { # mailing list
186	$to = $received;
187	$to =~ s/.* for //s; $to =~ s/;.*//s;
188        $DOMAIN = $dom; last;
189    }
190    elsif (index($received, "contact\@".$dom) > -1) { # special case
191        $to = 'General.board'; $DOMAIN = $dom; last;
192    }
193    else {
194	$DOMAIN = $DEFAULT_DOMAIN;
195    }
196}
197
198die "Cannot find domain in: $received\n $to $cc $bcc!\n"
199    unless defined($DOMAIN);
200
201my ($BASEURL, $WWWHOME, $OWNER, $GROUP, $PERMIT) =
202    @{$DOMAINS{$DOMAIN}}{qw/BASEURL WWWHOME OWNER GROUP PERMIT/};
203
204if ($OWNER) {
205    # change ownership / group to the designated id
206    my ($uid, $gid) = (getpwnam($OWNER))[2,3] or die "no uid of $OWNER";
207    $gid = (getgrnam($GROUP))[2] or die "no gid of $GROUP" if $GROUP;
208    ($>, $)) = ($uid, $gid) or die "seteuid/setegid failed: $OWNER, $GROUP";
209}
210
211my $BBS = OurNet::BBS->new(map { untaint($_) } @{$DOMAINS{$DOMAIN}{PARAM}});
212my $OBJ = $BBS->{untaint($Element)};
213
214# Parse sender's address
215my ($user, $nick, $email);
216($nick, $user) = ($1, $2) if (($user = $from) =~ /"?([^"]+)"? <([^>]+)>/);
217$email = $user;
218$user =~ s/(?:.bbs)?\@.+$//i;
219$nick ||= $user;
220
221# Strip to angled brackets
222$to = $1 if $to =~ m/<([^>]+)>/;
223
224my $parser = MIME::Parser->new;
225$parser->output_to_core(1);
226
227my $entity = $parser->parse_data([ @{$mail->header}, "\n", @{$mail->body} ]);
228my ($parsed, $attach) = (0, 0);
229my $body = '';
230
231if ($LOG ||= ($0 =~ /bbsmail/i ? $MAIL_LOG : $BOARD_LOG)) {
232    open _, ">>$LOG";
233    print _ (scalar localtime)." : $to : $from : $subject\n";
234    close _;
235}
236
237# determine the target
238
239die "cannot parse target: $to" unless $to =~ m|^([\w\-]+)(\Q$Postfix\E)?(?:\@.+)?$|i;
240
241my $target = $1;
242
243unless (exists $OBJ->{$target}) {
244    # do case sensitivity check
245    foreach (keys %{$OBJ}) {
246	$target = untaint($_) and last
247	    if (uc($target) eq uc($_) and exists $OBJ->{$_});
248    }
249}
250
251# blocks duplication
252exit 0 if index($xorig, "$target$Postfix\@") > -1;
253
254# check for existence
255die "no such target: $target" unless exists $OBJ->{$target};
256
257my $obj = $OBJ->{$target};
258
259die "no permission settings in $target" if (
260    $PERMIT and ($Container ne 'mailbox') and (
261	!exists($obj->{permit}) or	# no permission file
262	$obj->{permit} =~ /^\s*$/	# empty permission file
263    )
264);
265
266# check {permit} if there's one
267die "no permission to post: $target from $email" unless (
268    not exists($obj->{permit}) or		# 1) no permission
269    $obj->{permit} =~ /^\s*$/ or (		# 2) it's empty
270	grep { $email =~ /^$_$/i } 		# 3) email matches
271	grep { length }				#    nonempty
272	map { s/\\\*/.*/g; s/\\\?/./g; $_ }	#    wildcard-expanded
273	map { quotemeta }			#    escaped
274	map { s/^\s+//; s/\s+$//; $_ }		#    trimmed
275	split(/(?:\015?\012)+/, $obj->{permit})	#    entries
276    )
277);
278
279# post permitted -- handle attachments
280foreach my $chunk ($entity->parts_DFS) {
281    # skip Outlook special case!
282    next if $chunk->head->recommended_filename eq 'winmail.dat';
283
284    if ($chunk->head->recommended_filename) {
285        $body .= sprintf($MsgAttach, $chunk->head->recommended_filename);
286    }
287
288    if ($chunk->effective_type eq 'text/plain' or
289	$chunk->effective_type eq 'message/rfc822') {
290        $body .= eval { $chunk->bodyhandle->as_string };
291        $parsed++;
292    }
293    elsif ($chunk->effective_type eq 'application/pgp-signature') {
294	# ignore signatures for now
295    }
296    elsif ($chunk->effective_type eq 'text/html'
297        and (!$parsed # HTML only! Gasp!
298         or  $chunk->head->recommended_filename)
299	and eval "use HTML::Parse; use HTML::FormatText; 1"
300    ) {
301        # Display HTML attachments.
302        $body .= HTML::FormatText->new(
303            leftmargin => 0, rightmargin => 70
304        )->format(HTML::Parse::parse_html(
305            $chunk->bodyhandle->as_string
306        ));
307    }
308    elsif ($chunk->bodyhandle and $WWWHOME and $BASEURL) {
309        my $file = $chunk->head->recommended_filename
310		|| ('file'.(++$attach).'.dat');
311	exit if defined $NO_ATTACH and $file =~ /$NO_ATTACH/i;
312
313        if ($file =~ /^=\?\w/) {
314            $file .= '?=' unless index($file, '?=') > -1;
315            $file = decode_mimewords($_);
316        }
317
318        $file =~ tr/\\\/\:\*\?\"\<\>\|//;
319
320	my $content;
321
322        if ($file !~ /^\.+$/ and $content = $chunk->bodyhandle->as_string) {
323	    if (length($content) > $SIZE_LIMIT) {
324		$body .= sprintf($MsgTooLarge, $file, $SIZE_LIMIT);
325		next;
326	    }
327
328            next unless mkdir "$WWWHOME/$timeseq"
329		 and open _, ">$WWWHOME/$timeseq/$file";
330            print _ $content;
331            close _;
332
333            $body .= sprintf($MsgDownload, "$BASEURL/$timeseq/$file");
334	}
335    }
336}
337
338$subject =~ s/^\[$target\]\s?//i; # strip mailing list header tag
339
340# do the real work
341$obj->{$Container}{''} = {
342    title  => substr($subject, 0, 60),
343    body   => $body,
344    header => {
345	(map { $_ => substr($mail->head->get($_), 0, -1) } $mail->head->tags),
346        From    => "$email ($nick)",
347        Subject => $subject,
348        Board   => $target,
349        Date    => scalar localtime,
350    },
351};
352
353sub untaint {
354    $_[0] =~ m/(.*)/s; return $1;
355}
356
3571;
358
359__END__
360
361=head1 SEE ALSO
362
363L<OurNet::BBS>, L<bbsmail>.
364
365=head1 AUTHORS
366
367Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
368
369=head1 COPYRIGHT
370
371Copyright 2001-2002 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>.
372
373This program is free software; you can redistribute it and/or
374modify it under the same terms as Perl itself.
375
376See L<http://www.perl.com/perl/misc/Artistic.html>
377
378=cut
379