Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/usenet/altsrcs/1/1894

Text File | 1990-12-28 | 12.2 KB | 439 lines

Newsgroups: comp.lang.perl,alt.sources
From: [e-mail] (Paul Vixie)
Subject: Re: Anyone written a mail-server in perl?.
Message-ID: <[e-mail]>
Date: Wed, 3 Oct 90 06:21:22 GMT

In article <[e-mail]>,
[e-mail] (Greyham Stoney) writes:
# Perl looks like a totally awesome language to write a mail-server in; has
# anyone tried doing it?. If so, could they send me a copy please?. It doesn't
# need to be a polished work; anything will do.

Well, since it doesn't have to be polished, here's mine.  It's three files:
    archivist    - collects a mail message, stashes it in an MH folder
              runs out of sendmail's /usr/lib/aliases, as in:
                <|/usr/lib/mail/archivist listandfoldername>
    listserv    - stupid name, no relation to BITnet program; collects
              commands on stdin and executes them.  intended to
              access archive built by "archivist"
    listserv.help    - what "listserv" says if you send it a "help" command

A larger mail server, based on this one but with the intent of letting people
remotely FTP files and have them mailed back to them, is in final testing now.
It will appear here and elsewhere when it's done.

Paul Vixie
DEC WRL

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of shell archive."
# Contents:  listserv listserv.help archivist
# Wrapped by [e-mail] on Tue Oct  2 23:15:24 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'listserv' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'listserv'\"
else
echo shar: Extracting \"'listserv'\" \(5857 characters\)
sed "s/^X//" >'listserv' <<'END_OF_FILE'
X#! /usr/local/bin/perl
X
X$| = 1;
X$mhdir = "/usr/new/mh";
X$listservdir = "/usr/lib/mail";
X$sendmail = "/usr/lib/sendmail -oi";
chop($hostname = `/bin/hostname`);
X
X# this is where the real archive is, we'll just symlink into it
X$archivedir = "/var/mail-archive";
X
X# silly way to get last argument
X$folder = "nonspecific";
foreach (@ARGV) {
X    $folder = $_;
X}
X
X# this is our fake home directory, where MH can put its goop
X$dir = "/tmp/listserv.$$";
X
X# these are the valid args to an MH command and the number of subargs for each
X$mh_argc{"-and"} = 1;
X$mh_argc{"-or"} = 1;
X$mh_argc{"-not"} = 1;
X$mh_argc{"-lbrace"} = 1;
X$mh_argc{"-rbrace"} = 1;
X$mh_argc{"-cc"} = 2;
X$mh_argc{"-date"} = 2;
X$mh_argc{"-from"} = 2;
X$mh_argc{"-search"} = 2;
X$mh_argc{"-subject"} = 2;
X$mh_argc{"-after"} = 2;
X$mh_argc{"-before"} = 2;
X
X#
X# make a place to work.  MH will mess it up, then we'll nuke it.
X#
system("mkdir $dir");
chdir($dir) || die "couldn't chdir $dir: $!";;
X$ENV{"HOME"} = $dir;
symlink("$archivedir/$folder", "$folder") || die "symlink $folder: $!";
open(context, ">context") || die "context: $!";
print context "Current-Folder: $folder\n";
close(context);
open(profile, ">.mh_profile") || die ".mh_profile: $!";
print profile "Path: .\n";
close(profile);
X
X#
X# grab headers. this is standard code that ought to be in a library
X#
X$full_header = "";
X$prev_header = "";
while (<stdin>) {
X    if (/^\n$/) { last; }        # blank line ends headers
X    $full_header .= $_;
X    if (/^[ \t]/) {
X        # leading whitespace means continuation
X        $header = $prev_header;
X        $value = $_;
X    } else {
X        /^([\w-]*):(.*\n)$/;
X        $header = $1;
X        $value = $2;
X    }
X    $prev_header = $header;
X    $header =~ tr/A-Z/a-z/;        # make header lower-case
X    $headers{$header} .= $value;
X}
X#
X# got headers, next line read will be first body line, blank line was eaten
X#
X
X# --- find default reply address ---
X#
X$reply = "owner-$folder";
if ($headers{"reply-to"} ne undef) {
X    $reply = $headers{"reply-to"};
X} elsif ($headers{"from"} ne undef) {
X    $reply = $headers{"from"};
X} elsif ($headers{"sender"} ne undef) {
X    $reply = $headers{"sender"};
X}
chop $reply;  $reply =~ s/^[ ]+//;
X
X# if ($headers{"subject"} ne undef) {
X#     do command($headers{"subject"});
X# }
X
while (<stdin>) {
X    do command($_);
X}
X
X#
X# session is over, send the transcript to the reply address
X#
open(sm, "|$sendmail '-f$reply' -t -v")
X    || die "can't start sendmail: !$\n";
print sm "From: $folder list server on $hostname <listserv@$hostname>\n";
print sm "To: $reply\n";
print sm "Cc: $folder-request\n";
print sm "Subject: results of your request\n";
foreach $hdr ("date", "from", "message-id") {
X    if ($headers{$hdr} ne undef) {
X        print sm "X-orig-".$hdr.":".$headers{$hdr};
X    }
X}
print sm "\n";
open(xs,"<transcript") || die "can't reopen transcript: $!\n";
while (read(xs,$buf,2048)) {
X    print sm $buf;
X}
close(sm);
close(xs);
X
unlink "transcript", "context", ".mh_profile", $folder;
chdir "/tmp";  rmdir $dir;
X
exit 0;
X
sub command {
X    local($_) = @_;
X
X    chop;  s/^[ ]+//;
X    return if (/^$/ || /^#/);
X
X    open(xs, ">>transcript") || die "can't open transcript: $!";
X    select(xs); $| = 1; select(stdout);
X
X    ($cmd, @args) = split;
X    $cmd =~ y/A-Z/a-z/;
X    print xs "<<< $_\n";
X    if ($cmd eq "scan") {
X        if ($#args < $[) {
X            @args = ("last:10");
X        }
X        do mh("scan", @args);
X    } elsif ($cmd eq "show") {
X        if ($#args < $[) {
X            @args = ("last");
X        }
X        do mh("show", @args);
X    } elsif ($cmd eq "reply") {
X        $reply = join(" ", @args);
X        $reply =~ s/^[ <]+//;
X        $reply =~ s/[ >]+$//;
X        print xs ">>> OK, will reply to <$reply>\n";
X    } elsif ($cmd eq "listsubs") {
X        system("cat $listservdir/lists/$folder >>transcript");
X    } elsif ($cmd eq "subscribe" || $cmd eq "unsubscribe") {
X        open(sm, "|".$sendmail." -t") || die "can't run sendmail";
X        print sm "From: listserv for $folder <".$folder."-listserv>\n";
X        print sm "To: ".$folder."-request (list maintainer)\n";
X        print sm "Subject: subscription-related request\n";
X        print sm "\n";
X        print sm $cmd." ".join(" ",@args)."\n";
X        close(sm);
X        print xs ">>> request forwarded to list maintainer\n";
X    } elsif ($cmd eq "help") {
X        system("cat $listservdir/listserv.help >>transcript");
X    } else {
X        print xs ">>> command unrecognized, try 'help'.\n";
X    }
X    close(xs);
X}
X
sub mh {
X    local($cmd, @args) = @_;
X    local(@picks) = ();
X    local($search) = "";
X
X    for ($n = $]; $n <= $#args; $n++) {
X        $arg = $args[$n];
X        if (!($arg =~ /^-/)) {
X            push(@picks, do mh_msgsel($arg));
X            next;
X        }
X        if ($mh_argc{$arg} == undef) {
X            print xs ">>> unrecognized argument: '$arg'\n";
X            return;
X        }
X        $search .= $arg." ";
X        for ($nn = 1; $nn < $mh_argc{$arg}; $nn++) {
X            $search .= $args[++$n]." ";
X        }
X    }
X    if (length($search) > 0) {
X        chop $search;
X        push(@picks, $search);
X    }
X
X    # 'tis time
X    local($zero, $pick, $pickcmd, $npicks) = ("-zero", "", "", 0);
X    foreach $pick (@picks) {
X        next if (length($pick) == 0);
X        do syscmd($mhdir."/pick ".$pick." ".$zero." -sequence listserv");
X        $zero = "-nozero";
X        $npicks++;
X    }
X    if ($npicks > 0) {
X        do syscmd($mhdir."/".$cmd." listserv");
X    }
X}
X
sub syscmd {
X    local($cmd) = @_;
X    local($_);
X
X    $cmd =~ y/~/ /;
X    print xs ">>> ".$cmd."\n";
X    close(xs);
X    if (fork() == 0) {
X        open(STDOUT, ">>transcript");    # output straight to xs
X        open(STDERR, ">&STDOUT");    # make it follow pipe
X        exec split(/[ \t]+/, $cmd);    # don't use sh -c
X    }
X    wait();
X    open(xs,">>transcript") || die "can't reopen transcript: $!\n";
X}
X
sub mh_msgsel {
X    local($sel) = @_;
X    local(@sel) = split(/,/, $sel);
X    local(@ret) = ();
X    local($errors) = 0;
X    local($_);
X
X    foreach $_ (@sel) {
X        if (/(first|last|\d+)-(first|last|\d+)/) {
X            push(@ret, "$1-$2");
X        } elsif (/(first|last|\d+):([\+\-])(\d+)/) {
X            push(@ret, "$1:$2$3");
X        } elsif (/(first|last|\d+)/) {
X            push(@ret, "$1");
X        } else {
X            print xs ">>> bad message selector: '$_'\n";
X            $errors++;
X        }
X    }
X    if ($errors) {
X        print xs ">>> $errors errors in '$sel'\n";
X        return ();
X    }
X    return @sel;
X}
END_OF_FILE
if test 5857 -ne `wc -c <'listserv'`; then
    echo shar: \"'listserv'\" unpacked with wrong size!
fi
chmod +x 'listserv'
# end of 'listserv'
fi
if test -f 'listserv.help' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'listserv.help'\"
else
echo shar: Extracting \"'listserv.help'\" \(2104 characters\)
sed "s/^X//" >'listserv.help' <<'END_OF_FILE'
Welcome to listserv!        $Date$  $Revision$
X
X=========================================================================
X                                COMMANDS
X
general
X-------------------------------------------------------------------------
help        you're reading it
reply ADDR    server should reply to ADDR instead of guessing. (recommended)
X
subscription utilities
X-------------------------------------------------------------------------
listsubs        list the subscribers of the mailing list
subscribe ADDR        subscribe to the mailing list
unsubscribe ADDR    unsubscribe from the mailing list
X
archive utilities
X-------------------------------------------------------------------------
scan ARGS    show summary of messages, one message per line (def: 'last:5')
show ARGS    show text of messages, can be a lot of text (def: 'last')
X
X=========================================================================
X                                DETAILS
X
ARGS is passed more or less directly to an MH "pick" command:
X
X    -and                -cc  PATTERN
X    -or                -date  PATTERN
X    -not                -from  PATTERN
X    -lbrace                -search  PATTERN
X    -rbrace                -subject  PATTERN
X    START-END            -to  PATTERN
X    BASE:-OFFSET            -after  DATE
X    BASE:+OFFSET            -before  DATE
X
X=========================================================================
X                                EXAMPLES
X
X    reply <[e-mail]>
X    subscribe <[e-mail]> Eyal Moses
X    scan -from eyal
X    scan -from eyal -or -from mehuld
X    scan -after 1dec89 -and -before 1jan90 -and -subject liability
X    scan first:100, 100-104, 110:5
X    show -from mehuld -and -subject killing
X    show 1,3-40,last:10
X
X=========================================================================
X                                NOTES
X
Note that a selector (such as "last:100") is mixed with any of the search
operands (such as "-from eyal"), the effect is "or" rather than the more
intuitive "and".  Your best bet is to use one or the other exclusively, and
to experiement liberally with "scan" before you start using "show".
X
X"show first-last" is almost certainly a mistake, but the server will let you
do it -- so be careful!
X
Comments on this list server are welcome, send to <[e-mail]>.
END_OF_FILE
if test 2104 -ne `wc -c <'listserv.help'`; then
    echo shar: \"'listserv.help'\" unpacked with wrong size!
fi
# end of 'listserv.help'
fi
if test -f 'archivist' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'archivist'\"
else
echo shar: Extracting \"'archivist'\" \(1250 characters\)
sed "s/^X//" >'archivist' <<'END_OF_FILE'
X#! /usr/local/bin/perl
X
X$ENV{"HOME"} = "/var/mail-archive";
X$rcvstore = "/usr/new/lib/mh/rcvstore";
X
X# cheap and silly way to get last argument
X$folder = "nonspecific";
foreach $x (@ARGV) {
X    $folder = $x;
X}
X
X$full_header = "";
X$prev_header = "";
while (<stdin>) {
X    if (/^\n$/) { last; }        # blank line ends headers
X    $full_header .= $_;
X    if (/^[ \t]/) {
X        # leading whitespace means continuation
X        $header = $prev_header;
X        $value = $_;
X    } else {
X        /^([\w-]*):(.*\n)$/;
X        $header = $1;
X        $value = $2;
X    }
X    $prev_header = $header;
X    $header =~ tr/A-Z/a-z/;        # make header lower-case
X    $headers{$header} .= $value;
X}
X
X#
X# got headers, next line read will be first body line, blank line eaten
X#
X
if ($headers{"date"} =~ /[ \t]+(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d:\d\d:\d\d) 19(\d\d)/) {
X    $headers{"date"} = "$1, $3 $2 $5 $4 GMT";
X}
X
open(rcv, "|".$rcvstore." +".$folder) || die "rcvstore";
X
print rcv "Date:    " . $headers{"date"};
print rcv "From:    " . $headers{"from"};
print rcv "To:      " . $headers{"to"};
if ($headers{"cc"}) {
X    print rcv "Cc:      " . $headers{"cc"};
X}
print rcv "Subject: " . $headers{"subject"};
X
print rcv "\n";
while (<stdin>) {
X    print rcv $_;
X}
close(rcv);
X
exit 0;
END_OF_FILE
if test 1250 -ne `wc -c <'archivist'`; then
    echo shar: \"'archivist'\" unpacked with wrong size!
fi
chmod +x 'archivist'
# end of 'archivist'
fi
echo shar: End of shell archive.
exit 0
--
Paul Vixie
DEC Western Research Lab    <[e-mail]>
Palo Alto, California        ...!decwrl!vixie