#!/usr/bin/perl
# $File: //depot/OurNet-BBS/bin/bbsboard $ $Author: autrijus $
# $Revision: #7 $ $Change: 1882 $ $DateTime: 2001/09/21 08:30:51 $

$VERSION = '0.02';
$REVISION = "rev$1\[\@$2\]" 
    if ('$Revision: #7 $ $Change: 1882 $' =~ /(\d+)[^\d]+(\d+)/);

=head1 NAME

bbsboard - Internet to BBS email-post handler

=head1 SYNOPSIS

In F</usr/local/etc/bbs.rc> or F</etc/bbs.rc>;

    # $DUMP       = '/tmp/msgdump.tmp';         # Dump message to disk; halt
    $MAIL_LOG   = '/var/logs/bbsmail.log';    # Log of bbsmail
    $BOARD_LOG  = '/var/logs/bbsboard.log';   # Log of bbsboard
    $SIZE_LIMIT = 204800; # size limit of attachments

    # Set virutal hosts; The C<bbs.> prefix of keys should be omitted.
    %DOMAINS = (
        'elixus.org' => {
            BASEURL => 'http://elixus.org',
            WWWHOME => '/srv/www/elixir',
            PARAM   => ['MELIX', '/home/melix'],
            OWNER   => 'melix',
            GROUP   => 'melix',
        },
        'cvic.org'  => {
            BASEURL => 'http://cvic.org',
            WWWHOME => '/srv/www/cvic',
            PARAM   => ['CVIC', '/srv/bbs/cvic',
                         1003, 2500, 1005, 250, 1004, 50000], # needs utmp
            OWNER   => 'cvic',
            GROUP   => 'bbs',
        },
        'm543.com'  => {
            BASEURL => 'http://m543.com',
            WWWHOME => '/srv/www/m543',
            PARAM   => ['CVIC', '/srv/bbs/m543',
                         1103, 2500, 1105, 250, 1104, 50000], # needs utmp
            OWNER   => 'cvic',
            GROUP   => 'bbs',
        },
    );

    # multiple domains, same IP
    $DOMAINS{'m543.org'}    = $DOMAINS{'music543.org'} =
    $DOMAINS{'music543.com'}= $DOMAINS{'m543.com'};

To configure it with sendmail, modify F<sendmail.cf> like this:

    ######################################
    ###   Ruleset 0 -- Parse Address   ###
    ######################################

    R$+.bbs < @ $=w .>		$#bbsmail $: $1		bbs mail gateway
    R$+.board < @ $=w .>	$#bbsboard $: $1	bbs board gateway

    # handle locally delivered names

    R$+.bbs			$#bbsmail $:$1		bbs mail gateway
    R$+.board			$#bbsboard $:$1		bbs board gateway

    ##################################################
    ###   Local and Program Mailer specification   ###
    ##################################################

    Mbbsmail,	P=/usr/local/bin/bbsmail, F=lsSDFMuhP, S=10, R=20,
		A=bbsmail $u
    Mbbsboard,	P=/usr/local/bin/bbsboard, F=lsSDFMuhP, S=10, R=20,
		A=bbsboard $u

To feed it a MIME mail directly at the command line:

    % bbsmail < message.txt

=head1 DESCRIPTION

This script relays e-mails sent to C<*.bbs@domain> as mails to
BBS user mailboxes; it is designed to be a drop-in replacement for
the MAPLE BBS utility of the same name.

This program could be used serve multiple BBS sites, each distinguished
by its domain name. MIME encodings, multipart messages, quoted words
are all handled correctly.

If supplied with a web directory, attachments could be saved for
later download. You could restrict the max. allowed size of each
attachments.

If the optional C<HTML::Parse> and C<HTML::FromText> modules were
installed, HTML-only mails and simple HTML attachments could be
rendered as plain text.

=head1 CAVEATS

Currently this script does not check proper permissions; you could
use the C<OurNet> backend to achieve restricted permission. See
L<bbscomd> for how to run an OurNet node.

However, authentication is currently not implemented; while sending
password via e-mail is easy, the author finds it distasteful. A
proper way to parse PGP-signed mail might be the only viable route,
and any contributions on that front will be most welcomed.

=cut

use MIME::Words ':all';
use MIME::Parser;
use Mail::Internet;
use OurNet::BBS '1.6';
use strict;

our ($SIZE_LIMIT, $DUMP, $LOG, %DOMAINS, $MAIL_LOG, $BOARD_LOG);
our ($Postfix, $Element, $Container, $RCFile);

$Postfix   ||= '.board';
$Element   ||= 'boards';
$Container ||= 'articles';
$RCFile    ||= 'bbs.rc';

foreach my $path ('/etc', '/usr/local/etc', '/usr/local/bin', '.') {
    do "$path/$RCFile" and last if -e "$path/$RCFile";
}

die 'bbs.rc not found!' unless %DOMAINS;

$DOMAINS{"bbs.$_"} = $DOMAINS{$_} for keys(%DOMAINS);

if ($DUMP) { open _, ">$DUMP"; local $/; print _ <STDIN>; close _; exit; }

my $mail = Mail::Internet->new(*STDIN);
my $timeseq = scalar time;

# Extract headers
my ($to, $cc, $received, $date, $bcc, $from, $subject, $replyto, $sender) = (
    map { substr($mail->head->get($_), 0, -1) }
        qw/To Cc Received Date Bcc From Subject Reply-To X-Sender/,
);

# Parse MIME Quoted Words
for ($subject, $from, $to, $sender, $replyto) {
    if (/^=\?\w/) {
        $_ .= '?=' unless index($_, '?=') > -1;
        $_ = decode_mimewords($_);
    }
}

my $DOMAIN;
foreach my $dom (keys(%DOMAINS)) {
    if (index(uc($to), uc("\@".$dom)) > -1) {
        $DOMAIN = $dom; last;
    }
    elsif (index(uc($cc), uc("\@".$dom)) > -1) {
        $to = $cc;
        $DOMAIN = $dom; last;
    }
    elsif (index(uc($bcc), uc("\@".$dom)) > -1) {
        $to = $bcc;
        $DOMAIN = $dom; last;
    }
    elsif (index($received, "$Postfix\@".$dom) > -1) {
        $DOMAIN = $dom; last;
    }
}

die "Cannot find domain in: $received\n $to $cc $bcc!\n" unless $DOMAIN;

my ($BASEURL, $WWWHOME, $OWNER, $GROUP)
    = @{$DOMAINS{$DOMAIN}}{qw/BASEURL WWWHOME OWNER GROUP/};

if ($OWNER) {
    # change ownership / group to the designated id
    my ($uid, $gid) = (getpwnam($OWNER))[2,3] or die "no uid of $OWNER";
    $gid = (getgrnam($GROUP))[2] or die "no gid of $GROUP" if $GROUP;
    ($>, $)) = ($uid, $gid) or die "seteuid/setegid failed: $OWNER, $GROUP";
}

my $BBS = OurNet::BBS->new(@{$DOMAINS{$DOMAIN}{PARAM}});
my $OBJ = $BBS->{$Element};

# Parse sender's address
my ($user, $nick, $email);
($nick, $user) = ($1, $2) if (($user = $from) =~ /"?([^"]+)"? <([^>]+)>/);
$email = $user;
$user =~ s/(?:.bbs)?\@.+$//i;
$nick ||= $user;

# Strip to angled brackets
$to = $1 if $to =~ m/<([^>]+)>/;

my $parser = MIME::Parser->new;
$parser->output_to_core(1);

my $entity = $parser->parse_data([ @{$mail->header}, "\n", @{$mail->body} ]);
my ($parsed, $attach) = (0, 0);
my $body = '';

foreach my $chunk ($entity->parts_DFS) {
    # skip Outlook special case!
    next if $chunk->head->recommended_filename eq 'winmail.dat';

    if ($chunk->head->recommended_filename) {
        $body .= "\n [H: ".$chunk->head->recommended_filename."]\n";
    }

    if ($chunk->effective_type eq 'text/plain') {
        $body .= $chunk->bodyhandle->as_string;
        $parsed++;
    }
    elsif ($chunk->effective_type eq 'text/html'
        and (!$parsed # HTML only! Gasp!
         or  $chunk->head->recommended_filename)
	and eval "use HTML::Parse; use HTML::FormatText; 1"
    ) {
        # Display HTML attachments.
        $body .= HTML::FormatText->new(
            leftmargin => 0, rightmargin => 70
        )->format(HTML::Parse::parse_html(
            $chunk->bodyhandle->as_string
        ));
    }
    elsif ($chunk->bodyhandle and $WWWHOME and $BASEURL) {
        my $file = $chunk->head->recommended_filename
		|| ('file'.(++$attach).'.dat');

        if ($file =~ /^=\?\w/) {
            $file .= '?=' unless index($file, '?=') > -1;
            $file = decode_mimewords($_);
        }

        $file =~ tr/\\\/\:\*\?\"\<\>\|//;

	my $content;

        if ($file !~ /^\.+$/ and $content = $chunk->bodyhandle->as_string) {
	    if (length($content) > $SIZE_LIMIT) {
		$body .= " ([ɮ$fileWLW: $SIZE_LIMIT bytesC)\n";
		next;
	    }

            next unless mkdir "$WWWHOME/$timeseq"
		 and open _, ">$WWWHOME/$timeseq/$file";
            print _ 
            close _;
            $body .= " ([ɮץi$BASEURL/$timeseq/$fileUC)\n";
        }
    }
}

if ($LOG ||= ($0 =~ /bbsmail/i ? $MAIL_LOG : $BOARD_LOG)) {
    open _, ">>$LOG";
    print _ (scalar localtime)." : $to : $from : $subject\n";
    close _;
}

# determine the target
my $target;

if ($to =~ m|^(\w+)(\Q$Postfix\E)?(?:\@.+)?$|i) {
    $target = $1;
}
elsif ($to =~ m|^\w+\-(\w+)|) {
    # block duplication post;
    $target = $1;
    exit 0 if index($sender, $target."$Postfix\@") > -1;
}
else {
    die "cannot parse target: $to";
}

unless (exists $OBJ->{$target}) {
    # do case sensitivity check
    foreach (keys %{$OBJ}) {
	$target = $_ and last if (uc($target) eq uc($_));
    }
}

die "no such target: $target" unless exists $OBJ->{$target};

# do the real work
my $obj = $OBJ->{$target};

$obj->{$Container}{''} = {
    title  => substr($subject, 0, 60),
    body   => $body,
    header => {
        From    => "$email ($nick)",
        Subject => $subject,
        Board   => $target,
        Date    => scalar localtime,
    },
};

1;

__END__

=head1 SEE ALSO

L<OurNet::BBS>, L<bbsmail>.

=head1 AUTHORS

Autrijus Tang E<lt>autrijus@autrijus.org>

=head1 COPYRIGHT

Copyright 2001 by Autrijus Tang E<lt>autrijus@autrijus.org>.

This program is free software; you can redistribute it and/or 
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut
