#!/usr/bin/perl
#
# majordomo2
#
# This is the completion routine for signing up for a majordomo list.
# Check the variables for sanity, and then send e-mail to sign up for
# a list.
#
# Written by Dave Regan
# 24 June 1996
# This program is in the Public Domain.
# Do what you want with it.
#
# Packages which deal with the same sort of topic:
# http://iquest.com/~fitz/www/mailserv/
# http://hellfire.hare.net.au/cgi-bin/MailServ/majordomo
# http://www.vv.com.au/cgi-bin/vv/mailserv/majordomo-admin
#
#
# 24 Jun 1996 Dave Regan regan@peak.org
# Initial hack.
#
# 12 Jul 1996 Dave Regan regan@peak.org
# Changed background color.
#
# 13 Feb 1997 Dave Regan regan@peak.org
# Close an awful hole pointed out by Patrick Fitzgerald
# (fitz@iquest.com).
#
# 24 Apr 1997 Dave Regan regan@peak.org
# Add parameters to do automatic signup. Note that this
# feature is of dubious utility as it is easy to send
# mail directly.
# http://....../majordomo2?email=name@domain&mlist=list&host=domain&subscribe=1
# Other options are accepted, but the above are the major ones.
#
# 12 May 1997 Dave Regan regan@peak.org
# Log accesses to the program.
# Add a hot list of sources not to honor.
#
###
### Configuration
###
# $DefaultHost = "seul.org"; # no longer used -- arma 8/10/98
$Mail = "/usr/sbin/sendmail";
$LogFile = "/home/seul/logs/majordomo";
$HotList = "/home/seul/etc/hotlist";
###
### Main program
###
# CheckSanePost();
HTMLhead("Account Validation");
# print "\n";
print "\n";
$| = 1;
# printenv();
ParseFormVariables();
ParseQueryParameters();
# printvars();
ReadHotList();
if (CheckData() == 0)
{
print "Please use the back button of your browser and correct the form.\n";
print "Once the data is corrected, resubmit the data.
\n";
}
elsif (CheckHotList())
{
print "This program has been disabled from your site. Sorry.\n";
LogAccess(0);
}
else
{
print "Your request has been sent. Expect to see results in your e-mail soon.\n";
LogAccess(1);
SendMail();
}
HTMLterm();
exit 0;
###
### CheckData
###
### See if the data looks reasonable.
###
sub CheckData
{
local($retval);
$retval = 1;
# We need an e-mail address to do anything
if ($Vars{'email'} eq "")
{
print "You must specify a valid e-mail address to do much of anything ";
print "with majordomo.
\n";
$retval = 0;
}
# $Vars{'email'} = "$Vars{'email'}\@$DefaultHost" if ($Vars{'email'} !~ /\@/);
# this area changed by arma, 8/10/98 (and I commented the above line)
if ($Vars{'email'} !~ /\@/ or
$Vars{'email'} =~ /\@seul.org/i or
$Vars{'email'} =~ /\@majordomo.seul.org/i)
{ # bad plan
print "The email address you supplied looks fishy.
\n";
$retval = 0;
}
# end of area changed by arma
# # subscribe and unsubscribe really want a real name
# if ( ($Vars{'subscribe'} ne "" || $Vars{'unsubscribe'} ne "") && $Vars{'name'} eq "")
# {
# print "Subscriptions and unsubscriptions require your name.
\n";
# $retval = 0;
# }
# For some of the operations, a mailing list and host must be specified
if ( ($Vars{'mlist'} eq "" || $Vars{'host'} eq "") &&
($Vars{'subscribe'} ne "" ||
$Vars{'unsubscribe'} ne "" ||
$Vars{'info'} ne "" ||
$Vars{'index'} ne "" ||
$Vars{'who'} ne "" ||
$Vars{'get'} ne ""))
{
print "The options you have selected require that you specify a mailing list name\n";
print "as well as a host name.
\n";
$retval = 0;
}
# Cannot both subscribe and unsubscribe
if ($Vars{'subscribe'} ne "" && $Vars{'unsubscribe'} ne "")
{
print "Cannot subscribe and unsubscribe at the same time.
\n";
$retval = 0;
}
# Cannot specify "get" unless there is a filename
if ($Vars{'get'} ne "" && $Vars{'fname'} eq "")
{
print "Please specify a filename when using the \"GET\" option.
\n";
$retval = 0;
}
return $retval;
}
###
### CheckHotList
###
### See if either the REMOTE_HOST or REMOTE_ADDR match any
### of the hot list patterns.
###
sub CheckHotList
{
my($pat);
for $pat (@HotPattern)
{
return 1 if ($ENV{'REMOTE_HOST'} =~ /$pat/);
return 1 if ($ENV{'REMOTE_ADDR'} =~ /$pat/);
}
return 0;
}
####
#### CheckSanePost
####
#### See that this is a legitimate POST request. Die if not.
#### This assumes that the initial Content-type message has *not*
#### been sent.
####
#sub CheckSanePost
# {
# ###
# ### Ensure that the form of the request looks valid.
# ###
# if ($ENV{'REQUEST_METHOD'} ne "POST")
# {
# HTMLhead("Bad method");
# print "This script should be referenced with a METHOD of POST.\n";
# print "If you don't understand this, see this:\n";
# print "forms overview.\n";
# HTMLterm();
# exit 0;
# }
#
# if ($ENV{'CONTENT_TYPE'} ne "application/x-www-form-urlencoded")
# {
# HTMLhead("Bad encoding");
# print "This script can only be used to decode form results.\n";
# HTMLterm();
# exit 1;
# }
# }
###
### HTMLhead
###
### Put out a HTML header
###
sub HTMLhead
{
local($title) = @_;
print "Content-type: text/html\n\n";
print "$title\n";
print "\n";
}
###
### HTMLterm
###
### Put out the end of an HTML body.
###
sub HTMLterm
{
print "\n";
}
###
### LogAccess
###
### Write some information out into a log file.
###
sub LogAccess
{
my($honor) = @_;
my($email, $host, $key, $mlist);
$email = $Vars{'email'};
$host = $Vars{'host'};
$host =~ s/[^-_.A-Za-z0-9]//g; # Restrict the host name.
# It may be necessary to expand this to include
# other characters. Do so if needed.
$mlist = $Vars{'mlist'};
if (open(LOG, ">>$LogFile") == 0)
{
print STDERR "Cannot open $LogFile\n";
return;
}
print LOG scalar localtime;
if ($honor == 0) { $honor = " NOT"; }
else { $honor = ""; }
print LOG "\nRequest$honor honored\n";
print LOG "From: $email\n";
print LOG "To: majordomo\@$host\n";
print LOG "\n";
print LOG "subscribe $mlist $email\n" if ($Vars{'subscribe'} ne "");
print LOG "unsubscribe $mlist $email\n" if ($Vars{'unsubscribe'} ne "");
print LOG "help\n" if ($Vars{'help'} ne "");
print LOG "info $mlist\n" if ($Vars{'info'} ne "");
print LOG "index $mlist\n" if ($Vars{'index'} ne "");
print LOG "which $email\n" if ($Vars{'which'} ne "");
print LOG "who $mlist\n" if ($Vars{'who'} ne "");
print LOG "lists\n" if ($Vars{'lists'} ne "");
print LOG "get $mlist $Vars{'fname'}\n" if ($Vars{'get'} ne "");
print LOG "\nVariables passed into majordomo2\n";
for $key (sort(keys %Vars))
{
printf LOG " %-20.20s %s\n", $key, $Vars{$key};
}
print LOG "Environment variables\n";
for $key (sort(keys %ENV))
{
next if ($key =~ /^SERVER_|PATH|SCRIPT_|CONTENT_|DOCUMENT_ROOT|GATEWAY_INTERFACE/);
next if ($key =~ /^HTTP_ACCEPT|HTTP_CONNECTION|HTTP_HOST/);
printf LOG " %-20.20s %s\n", $key, $ENV{$key};
}
print LOG "\n\n";
close LOG;
}
###
### ParseInfo
###
### The work routines for parsing data.
###
sub ParseInfo
{
my($data) = @_;
my($item, $name, @table, $value);
$data =~ s/\&*\s*$//; # Remove trailing garbage
@table = split(/&/, $data); # Variables split at "&"
for $item (@table)
{
$item = unquote($item);
($name = $item) =~ s/\n//mg;
$name =~ s/=.*//m;
($value = $item) =~ s/^.*?=//;
$Vars{$name} = $value;
}
}
###
### ParseQueryParameters
###
### Read the query string and bust it up just as if it came
### from a form.
###
sub ParseQueryParameters
{
ParseInfo($ENV{'QUERY_STRING'});
}
###
### ParseFormVariables
###
### The variables from a CGI FORM come in on standard input.
### Read this string, and break it up into the Vars associative
### array.
###
sub ParseFormVariables
{
local($data, @tbl, $val, $var);
$data = <>;
# print "The raw data is $data
\n";
$data =~ s/query..=//g;
$data =~ s/&*\s*$//;
@tbl = split(/&/, $data); # Vars separated by &
for ($[ .. $#tbl)
{
# Process the variables. Be careful to avoid removing needed characters.
$tbl[$_] = unquote($tbl[$_]);
# print "$tbl[$_]
\n" if ($tbl[$_] !~ /^$/);
# Set up an associative array of name/value pairs.
$var = $tbl[$_];
$val = $tbl[$_];
$* = 1;
$var =~ s/\n//g;
$var =~ s/=.*//;
$val =~ s/^[^=]*=//;
$Vars{$var} = $val;
}
}
###
### printvars
###
### Print the contents of the Vars variable.
###
sub printvars
{
local($key);
print "Variables:
\n";
for $key (sort(keys(%Vars)))
{
print "$key = $Vars{$key}
\n";
}
}
###
### printenv
###
### Display the environment.
### This assumes that we can write on stdout. This may not
### be true if we haven't written the header line yet.
###
sub printenv
{
local(@env, $var);
@env = `printenv`;
for $var (@env)
{
print "$var
\n";
}
}
###
### ReadHotList
###
### Read in a list of Perl regular expressions to compare against the address.
###
sub ReadHotList
{
if (open(HOT, "<$HotList"))
{
while ()
{
chomp;
s/\s*#.*//;
next if (/^\s*$/);
s/^\s*//;
push(@HotPattern, $_);
}
close HOT;
}
}
###
### SendMail
###
### Send mail to the majordomo server.
###
### The mail needs to appear as if it is from the specified user.
### This is not as needed for the subscribe/unsubscribe, but is
### absolutely required for most commands to get information back
### to the user.
###
### The host is can be specified by the user. Make sure that it doesn't
### have any shell metacharacters.
###
sub SendMail
{
local($email, $host, $mlist);
$email = $Vars{'email'};
$host = $Vars{'host'};
$host =~ s/[^-_.A-Za-z0-9]//g; # Restrict the host name.
# It may be necessary to expand this to include
# other characters. Do so if needed.
$mlist = $Vars{'mlist'};
if (open(MAIL, "|$Mail majordomo\@$host") == 0)
{
print "Cannot start mailer\n";
return;
}
print MAIL "From: $email\n";
print MAIL "To: majordomo\@$host\n";
print MAIL "\n";
print MAIL "subscribe $mlist $email\n" if ($Vars{'subscribe'} ne "");
print MAIL "unsubscribe $mlist $email\n" if ($Vars{'unsubscribe'} ne "");
print MAIL "help\n" if ($Vars{'help'} ne "");
print MAIL "info $mlist\n" if ($Vars{'info'} ne "");
print MAIL "index $mlist\n" if ($Vars{'index'} ne "");
print MAIL "which $email\n" if ($Vars{'which'} ne "");
print MAIL "who $mlist\n" if ($Vars{'who'} ne "");
print MAIL "lists\n" if ($Vars{'lists'} ne "");
print MAIL "get $mlist $Vars{'fname'}\n" if ($Vars{'get'} ne "");
print MAIL ".\n";
close MAIL;
}
###
### unquote
###
### Unescape a CGI form variable.
###
sub unquote
{
local($raw) = @_;
local($code, @pieces, $piece);
$* = 1;
$raw =~ s/\+/ /g;
$raw =~ s/%0D//g;
@pieces = split(/%/, $raw);
for ($piece = 1; $piece <= $#pieces; $piece++)
{
$pieces[$piece] =~ s/^%//;
$code = substr($pieces[$piece], 0, 2);
$code = hex($code);
$pieces[$piece] = sprintf("%c%s", $code, substr($pieces[$piece], 2));
}
return join("", @pieces);
}