[comp.lang.perl] Anyone written a mail-server in perl?.

greyham@hades.ausonics.oz.au (Greyham Stoney) (09/26/90)

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.

							thanks,
								Greyham.
-- 
/*  Greyham Stoney:                            Australia: (02) 428 6476
 *  greyham@hades.ausonics.oz.au - Ausonics Pty Ltd, Lane Cove, Sydney, Oz.
 *		Neurone Server: Brain Cell not Responding.
 */

vixie@wrl.dec.com (Paul Vixie) (10/03/90)

In article <1990Sep26.024048.1757@hades.ausonics.oz.au>,
greyham@hades.ausonics.oz.au (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 vixie@vixie.sf.ca.us 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 <vixie@decwrl.dec.com>
X	subscribe <eyal@coyote.stanford.edu> 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 <listserv@vixie.sf.ca.us>.
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	<vixie@wrl.dec.com>
Palo Alto, California		...!decwrl!vixie

shaver@convex.com (Dave Shaver) (10/03/90)

greyham@hades.ausonics.oz.au (Greyham Stoney) requests a mail-server
written in Perl.  vixie@wrl.dec.com (Paul Vixie) posted his, but I'll
just give a pointer to mine.  Look on elroy.cs.iastate.edu
(129.186.3.15) in /pub/servers/csdserv.TZ (it's a compressed tar
file).  The other servers in that directory were written by other
people.  My server in based in great part on the Multihouse Mail Server
written by jv@mh.nl (Johan Vromans).  Thanks go to Johan for sharing
his work!

/\  Dave Shaver
\\  CONVEX Computer Corporation
\/  Internet: shaver@convex.com    UUCP:  uunet!convex!shaver

lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (10/04/90)

In article <1990Oct3.062122.15323@wrl.dec.com> vixie@wrl.dec.com (Paul Vixie) writes:
: if ($headers{"reply-to"} ne undef) {
: 	$reply = $headers{"reply-to"};

Note that this is a bit misleading.  Since ne does *string* comparison,
the above is a fancy way to say

    if ($headers{"reply-to"} ne "") {
    	$reply = $headers{"reply-to"};

To actually check for defined-ness, say

    if (defined $headers{"reply-to"}) {
	$reply = $headers{"reply-to"};

Larry

vixie@wrl.dec.com (Paul Vixie) (10/04/90)

# To actually check for defined-ness, say
# 
#     if (defined $headers{"reply-to"}) {
# 	$reply = $headers{"reply-to"};
# 
# Larry

That's what I meant, obviously :-).  There are a lot of early-isms
in the mail server code worse than that, though.  If I were going to
do it over, it would be very different...  Thanks, Larry...

--
Paul Vixie
DEC Western Research Lab	<vixie@wrl.dec.com>
Palo Alto, California		...!decwrl!vixie

piet@cs.ruu.nl (Piet van Oostrum) (10/04/90)

>>>>> In article <1990Sep26.024048.1757@hades.ausonics.oz.au>,
>>>>> greyham@hades.ausonics.oz.au (Greyham Stoney) (GS) writes:

GS> Perl looks like a totally awesome language to write a mail-server in;
GS> has anyone tried doing it?. If so, could they send me a copy please?.
GS> It doesn't need to be a polished work; anything will do.

Ours (originally the mutihouse mail server) is written in perl. You can get
it from our mail server or by FTP. The one I use is a more elaborate one
than the one in the archive. If interested write me personally for a copy.

How to get mailserv.tar.Z from the archive at
	Dept. of Computer Science, Utrecht University:

NOTE: In the following I have assumed your mail address is john@highbrow.edu.

    Of course you must substitute your own address for this. This should be
    a valid internet or uucp address. For bitnet users name@host.BITNET
    usually works.  

by FTP: (please restrict access to weekends or evening/night (i.e. between
about 20.00 and 0900 UTC).

    ftp archive.cs.ruu.nl [131.211.80.5]
    user name: anonymous or ftp
    password: your own email address (e.g. john@highbrow.edu)
    cd /pub
    don't forget to set binary mode if the file is a tar/arc/zoo archive,
    compressed or in any other way contains binary data.
    get UNIX/mailserv.tar.Z

by mail-server:

send the following message to
mail-server@cs.ruu.nl (or uunet!mcsun!hp4nl!ruuinf):

    begin
    path john@highbrow.edu
    send UNIX/mailserv.tar.Z
    end

The path command can be deleted if we receive a valid from address in your
message. If this is the first time you use our mail server, we suggest you
first issue the request:
    send HELP
--
Piet* van Oostrum, Dept of Computer Science, Utrecht University,
Padualaan 14, P.O. Box 80.089, 3508 TB Utrecht, The Netherlands.
Telephone: +31 30 531806   Uucp:   uunet!mcsun!ruuinf!piet
Telefax:   +31 30 513791   Internet:  piet@cs.ruu.nl   (*`Pete')