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