Home
lunch.cgi 

#!/usr/local/bin/perl5
#!/usr/local/bin/perl5 -w
#
#	lunch
#
#	A web based lunch voting program
#
#	Allow people to vote on lunch.  Have a list of places
#	to eat and a list of people on the lunch list.  Allow
#	people to specify where they want to eat.  They can only
#	flick buttons in their category.
#
#	Sort the list of eateries by date of last access.
#	Put # of days since eaten as well as number of total
#	times eaten.
#
#	On Tuesday, about 10:00am send a request to vote
#	to those people who haven't yet.  Then about 11:00
#	mail a message to everybody indicating where lunch is.
#
#	Have a way of indicating where lunch actually took place.
#
#
#	Copyright 1997 by Dave Regan
#	All rights reserved
#	regan@peak.org
#	12 April 1997
#


###
###	Configuration
###
#$Sendmail	= "/usr/lib/sendmail";	# Location of sendmail
$Sendmail	= "/usr/sbin/sendmail";
$Config		= "lunch.config";	# Name of the main config file
$RealMail	= 0;			# Set to 1 in order to actually send mail
$WebC		= "/red/regan/bin/webc";
$VoteOwner	= "regan\@peak.org";
$VoteURL	= "http://www.ao.com/cgi-bin/lunch/~regan/lunch/vote";
$VoteURL	= "http://cgi.peak.org/~regan/lunch/lunch.cgi/~regan/lunch/vote";
$PathTranslated	= "/red/regan/public_html/lunch/cron";
$Checked	= "<img src=\"/~regan/lunch/check_tick.gif\">";
$Office		= "204\.214\.117\.";
# Other choices might be:
#   tick.gif              Tick mark
#   tick_sm.gif           Small tick mark
#   check.gif             Check box (empty)
#   check_tick.gif        Check box (checked)


# Webc control
$InCGI = 1;		# Put webc into CGI mode
$NoLocalcode = 1;	# Don't allow webc to process #localcode directives
require $WebC;		# Get the compiler

###
###	Main program
###

    # Misc setup
    $| = 1;
    $CallFuncs{'printenv'} = 1;
    $CallFuncs{'GenerateFood'} = 1;
    $CallFuncs{'GenerateTable'} = 1;
    $Symbols{'_VERSION_'} = "lunch v0.1";

    if ($ENV{'SERVER_ADMIN'} eq "")
    	{
    	DoCronWork();
    	exit 0;
    	}

    # Note that all of the %Var variables and the %ENV variables
    # are available for use in the compiled program
    ParseFormVariables();

    #	Get the configuration file.
    ReadConfiguration();
    $Symbols{'_CONFIG_'} = $Configuration;
    chdir($Home);

    #	Find the page to be produced
    ($page = $ENV{'PATH_TRANSLATED'}) =~ s#.*/([^/]*)$#$1#;

    #	Execute the appropriate command
    if ($page eq "clear")	{	DoClear();		}
    elsif ($page eq "vote")	{	DoVote();		}
    elsif ($page eq "vote2")	{	DoVote2();		}
    elsif ($page eq "vote3")	{	DoVote3();		}
    else
    	{
	print "Content-type: text/html\n\n";
    	print STDOUT <<"	EOF";
    		<html><head><title>Bad command</title></head>
    		<body>
    		I don't know how to <b>$page</b>.
    		The URL is probably incorrect.
	EOF
	printenv();
	PrintHash(\%Vars);
	exit 0;
    	}

    exit 0;


###
###	CheckDirectory
###
###	See if the specified directory exists.  If not, attempt
###	to create it.  Ensure that an index.html file exists within
###	the directory.
###
###	This all ensures that the directories are accessible and
###	writable by the server.  Note that the directories that these
###	directories are created in must be writable by the web
###	server.
###
sub CheckDirectory
    {
    my($dir) = @_;

    return if (-d $dir && -f "$dir/index.html");

    if (! -d $dir)
    	{
    	if (!mkdir($dir, 0755))
    	    {
	    print "Content-type: text/html\n\n";
	    print STDOUT <<"	EOF";
    		<html><head><title>Cannot create the directory</title></head>
    		<body>
    		I cannot create the directory $dir.
    		This is likely because the directory this is being
    		created in is not writable by the web server.
    		Please open up permissions by first noting the
    		current permissions, then typing "chmod og+rwx dir"
    		for the parent directory.  Once the registration
    		directories are created, you can change the permissions
    		back to their original values.
	EOF
	    exit 0;
    	    }
    	}
    }


###
###	CheckPermissions
###
###	The various files and directories specified in the configuration
###	file must be in a directory owned by the owner of the configuration
###	file itself.
###
###	This is a security issue to help control abuse of the program.
###
sub CheckPermissions
    {
    my($fname) = @_;
    my($dir);

    ($dir = $fname) =~ s#/[^/]*$##;
    if ((stat($dir))[4] != (stat("$Home/$Config"))[4])
    	{
    	print STDOUT <<"	EOF";
    		<head><title>Bad permissions</title></head>
    		<body>
    		The directory containing $fname does have the
    		same owner as the configuration file $Home/$Config.
	EOF
	exit 0;
	}
    }


###
###	DoClear
###
###	Clear all results.
###	Record where we ate.
###
sub DoClear
    {
    my(%food, @montab, @tm, $user, %user, @users);

    @montab = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
    		"Jul", "Aug", "Sep", "Oct", "Nov", "Dev" );

    print "Content-type: text/html\n\n";

    if ($ENV{'REMOTE_ADDR'} =~ /$Office/)
	{
	# Remove the vote for each of the people
	@users = glob("$Configuration/*.user");
	for $user (@users)
	    {
	    %user = ReadFile($user);
	    undef($user{'food'});
	    WriteFile($user, \%user);
	    }

	# Set the last visited date
	%food = ReadFile("$Configuration/$Vars{'wentto'}.food");
	@tm = localtime;
	$food{'Visit'} = sprintf("%02d-%s-%02d", $tm[3], $montab[$tm[4]], $tm[5] % 100);
	WriteFile("$Configuration/$Vars{'wentto'}.food", \%food);
	}
    Compile("$Template/votedone.wc");
    }


###
###	DoCronWork
###
###	If this is called from cron (or by hand) a number of
###	environment variables will not be set up.  This is good
###	as it lets me know that it is cron.
###
###	If ARGV[0] is "warning", send out a warning message to
###	all email addresses.  If ARGV[0] is "final", tell people
###	what the final vote is.
###
sub DoCronWork
    {
    my(%user, $user, @users);
    my(%food, $food, @food);
    my($bestvote, $bestname, %votes);

    $ENV{'PATH_TRANSLATED'} = $PathTranslated;
    ReadConfiguration();
    if ($ARGV[0] eq "warning")
    	{
	@users = glob("$Configuration/*.user");
	for $user (@users)
	    {
	    print "Examine user $user\n";
	    %user = ReadFile($user);
	    if ($user{'food'} eq "")
	    	{
	    	print "Mail to $user{'email'}\n";
	    	OpenMail($VoteOwner, $user{'email'},
	    					"Time to vote for lunch");
	    	print MAIL "You haven't selected where to have lunch.\n";
	    	print MAIL "Please check out:\n";
	    	print MAIL "\t$VoteURL\n";
	    	close MAIL;
	    	}
	    }
    	}
    elsif ($ARGV[0] eq "final")
    	{
	@users = glob("$Configuration/*.user");
	@food = glob("$Configuration/*.food");

	for $user (@users)
	    {
	    %user = ReadFile($user);
	    for $food (@food)
		{
		$fname = $food;
		$fname =~ s#.*/(.*?)\.food#$1#;
		if ($fname eq $user{'food'})
		    {
		    if (++$votes{$food} > $bestvote)
		    	{
			$bestvote = $votes{$food};
			$bestname = $food;
		    print "Best is $bestname\n";
			}
		    }
		}
	    }

	%food = ReadFile($bestname);
	$bestname = $food{'Name'};

	for $user (@users)
	    {
	    %user = ReadFile($user);
	    OpenMail($VoteOwner, $user{'email'}, "Time for lunch");
	    print MAIL "It appears that $bestname won with $bestvote votes\n";
	    print MAIL "Please check out:\n";
	    print MAIL "\t$VoteURL\n";
	    close MAIL;
	    }
    	}
    else
    	{
    	print "Usage: lunch warning|final\n";
    	exit 1;
    	}
    }


###
###	DoVote
###
###	See if we know who this person is based upon the connection
###	they have.  If so, move onto DoVote2 otherwise present a
###	request for name and it will start DoVote2.  Don't worry
###	about passwords as that would require being able to change
###	passwords, and I don't want to bother.
###
sub DoVote
    {
    my($file, %map);

    print "Content-type: text/html\n\n";
    %map = ReadFile("$Home/user.map");
    $Symbols{'_REMOTE_HOST_'} = $ENV{'REMOTE_HOST'};
    $Symbols{'_REMOTE_ADDR_'} = $ENV{'REMOTE_ADDR'};
    if ($map{$ENV{'REMOTE_HOST'}} ne "")
    	{
	$Symbols{'_user_'} = $map{$ENV{'REMOTE_HOST'}};
    	Compile("$Template/vote.wc");
    	}
    elsif ($map{$ENV{'REMOTE_ADDR'}} ne "")
    	{
	$Symbols{'_user_'} = $map{$ENV{'REMOTE_ADDR'}};
    	Compile("$Template/vote.wc");
    	}
    else
    	{
	Compile("$Template/whoareyou.wc");
	}
    }


###
###	DoVote2
###
###	If we are here, then the person filled out the form
###	specifing their user name.
###
sub DoVote2
    {
    my($file, %map);

    print "Content-type: text/html\n\n";
    $Vars{'user'} =~ s/[\/\'\"\;]//g;
    $Symbols{'_user_'} = $Vars{'user'};
    if ($Vars{'user'} ne "")
	{
	$file = "vote.wc";
	WriteFile("$Configuration/$Vars{'user'}.user", \%Vars)
		if (! -f "$Configuration/$Vars{'user'}.user");
	}
    else
	{
	$file = "baduser.wc";
	}
    Compile("$Template/$file");
    }


###
###	DoVote3
###
###	Record the vote.  Display the current record.
###
sub DoVote3
    {
    my($file, %map, %user);

    print "Content-type: text/html\n\n";
    $Vars{'user'} =~ s/[\/\'\"\;]//g;
    $Symbols{'_user_'} = $Vars{'user'};
    %user = ReadFile("$Configuration/$Vars{'user'}.user");
    $user{'food'} = $Vars{'vote'};
    $user{'comment'} = $Vars{'comment'};
    WriteFile("$Configuration/$Vars{'user'}.user", \%user);
    Compile("$Template/votedone.wc");
    }


###
###	GenerateFood
###
###	Generate a table of eating places
###
sub GenerateFood
    {
    my($fname, @food, $food, %food);

    @food = glob("$Configuration/*.food");

    print "<table>\n";
    print "<tr><td>Name";
    for $food (@food)
	{
	%food = ReadFile($food);
	$fname = $food;
	$fname =~ s#.*/(.*?)\.food#$1#;
	print "<td><input name=\"wentto\" type=\"radio\" value=\"$fname\">";
	print "<td>$food{'Name'}\n";
	}
    print "\n</table>\n";
    }


###
###	GenerateTable
###
###	Generate a table for voting.
###
sub GenerateTable
    {
    my($user) = @_;
    my($bestvote, $bestname, $fname, @food, $food, %food, $tie);
    my($u, %user, @users, %votes);

    @users = glob("$Configuration/*.user");
    @food = glob("$Configuration/*.food");

    # First put out headings for each of the food places
    print "<table>\n";
    print "<tr><th>Name";
    for $food (@food)
	{
	%food = ReadFile($food);
	print "<th>$food{'Name'}";
	}
    print "<th>Comments\n";

    if ($user ne "")
	{
	# For this user, print out a bunch of radio buttons
	%user = ReadFile("$Configuration/$user.user");
	print "<tr><td>$user{'name'}";
	for $food (@food)
	    {
	    $fname = $food;
	    $fname =~ s#.*/(.*?)\.food#$1#;
	    print "<td><center>" .
		  "<input name=\"vote\" type=\"radio\" value=\"$fname\"";
	    if ($user{'food'} eq $fname)
	    	{
		$votes{$food}++;
		print " checked";
		}
	    print "></center>";
	    }
	print "<td><input name=\"comment\" type=\"text\" value=\"$user{'comment'}\">\n";
	}

    # For all users except this user, print out a bunch of choices.
    for $u (@users)
	{
	next if ($u eq "$Configuration/$user.user");
	%user = ReadFile($u);
	print "<tr><td>$user{'name'}";
	for $food (@food)
	    {
	    $fname = $food;
	    $fname =~ s#.*/(.*?)\.food#$1#;
	    print "<td>";
	    if ($fname eq $user{'food'})
		{
		print "<center>$Checked</center>";
		$votes{$food}++;
		}
	    }
	print "<td>$user{'comment'}\n";
	}

    # Print the last date visited for each place
    print "<tr><td><hr>";
    for $food (@food)
	{
	print "<td><hr>";
	}
    print "<td><hr>\n";
    print "<tr><td>Last visit";
    for $food (@food)
	{
	%food = ReadFile($food);
	print "<td><center>$food{'Visit'}</center>";
	}
    print "\n";

    # Print the number of votes for each place
    print "<tr><td>Votes";
    for $food (@food)
	{
	print "<td><center>$votes{$food}</center>";
	if ($votes{$food} > 0 && $votes{$food} > $bestvote)
	    {
	    $tie = "";
	    $bestvote = $votes{$food};
	    %food = ReadFile($food);
	    $bestname = $food{'Name'};
	    }
	elsif ($votes{$food} > 0 && $votes{$food} == $bestvote)
	    {
	    $tie = " (tie)";
	    }
	}
    print "<td>$bestname$tie\n";

    print "</table>\n";
    }


###
###	OpenMail
###
###	Send mail to the opponent indicating that there is a game to play.
###	The user writes to MAIL, and when done closes MAIL.
###
sub OpenMail
    {
    my($from, $to, $subject) = @_;

    if (($RealMail && !open(MAIL, "|$Sendmail $to")) ||
        (!$RealMail && !open(MAIL, ">>/tmp/mail")))
    	{
    	print "Cannot open sendmail.  Check permissions.\n";
    	exit 0;
    	}
    print MAIL "From: $from\n";
    print MAIL "To: $to\n";
    print MAIL "Subject: $subject\n";
    print MAIL "\n";
    }


###
###	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 = <STDIN>;
#   print "The raw data is $data<br>\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[$_]<br>\n" if ($tbl[$_] !~ /^$/);

    	# Set up an associative array of name/value pairs.
    	$var = $tbl[$_];
    	$val = $tbl[$_];
    	$var =~ s/\n//mg;
    	$var =~ s/=.*//m;
    	$val =~ s/^[^=]*=//m;
    	$Vars{$var} = $val;
    	}
    }


###
###	PrintHash
###
###	Print the contents of a hash.
###
sub PrintHash
    {
    my($hash) = @_;
    local($key);

    print "Variables:<br>\n";
    for $key (sort(keys(%$hash)))
    	{
    	print "$key = $$hash{$key}<br>\n";
    	}
    }


###
###     printenv
###
###     Display the environment.
###
sub printenv
    {
    PrintHash(\%ENV);
    }


###
###	ReadConfiguration
###
###	The configuration file has a number of parameters
###	which are needed to tell where files go.  Also, the
###	presence of this file indicates that the user isn't
###	attempting to do something weird.
###
###	If this is general perl code installed by an arbitrary
###	user run at CGI time as the web server user, then a malicious
###	local user can do *anything* running as the web server.
###	We cannot allow this, so we must actually parse the file.
###
###	For similar reasons, we cannot just specify where the webc
###	processor is, as the user could specify anything.  Thus
###	the webc compiler must be specified in this file.
###
###	There still is a problem in that this specifies a number of
###	filenames.  Thus the user can get to any file that the web
###	server can get to.  A possible fix is to stare at the URL
###	information and if it is a ~user or public_html, then the
###	files must exist under that users directory.  If it is not
###	user specific, then all is open.  This still doesn't sew up
###	all holes, but makes it better.
###
sub ReadConfiguration
    {
    my(%validvar);

    # Get the $Home directory.  This is the virtual page minus
    # the last segment.  Lots of places use the $Home directory.
    ($Home = $ENV{'PATH_TRANSLATED'}) =~ s#/[^/]*$##;

    if (!open(CONFIG, "<$Home/$Config"))
    	{
	print "Content-type: text/html\n\n";
    	print STDOUT <<"	EOF";
    		<html><head><title>Cannot find config file</title></head>
    		<body>
    		There is no $Config file at $Home.  This may indicate
    		that you have a bad URL, or that the registration system
		is not yet configured.
	EOF
	exit 0;
    	}

    %validvar =
    	(
    		'$Template'	=>	1,
    		'$Configuration' =>	1,
	);

    while (<CONFIG>)
    	{
    	chomp;
    	next if (/^\s*#/ || /^\s*$/);
    	if (/^\s*(\$\w+)\s*=\s*("[^"]*")\s*;/)
    	    {
    	    eval("$1 = $2;") if ($validvar{$1} ne "");
    	    }
    	}
#   require "$Home/$Config";	# Get the configuration file

    CheckPermissions($Template);
    CheckPermissions($Configuration);
    CheckDirectory($Configuration);
    }


###
###	unquote
###
###	Unescape a CGI form variable.
###
sub unquote
    {
    local($raw) = @_;
    local($code, @pieces, $piece);

    $raw =~ s/\+/ /mg;
    $raw =~ s/%0D//mg;
    @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);
    }


######
######	Configuration file utilities
######
######	The following routines are used to store name/value pairs
######	in files.
######

###
###	ReadFile
###
###	Read a file of name/value pairs.  The value can be of any
###	length.  If the value contains newline characters, an initial
###	tab character was prepended to ensure that the line didn't
###	look like a name item.
###
###	If the file is not found, return an empty string, otherwise
###	return an associative array with the information.
###
sub ReadFile
    {
    my($fname) = @_;
    my(%hash, $key);

    return undef if (! open(FILE, "<$fname"));
    $key = "bozo_catch";
    while (<FILE>)
    	{
    	if (/^\t/)
    	    {
    	    s/^\t//;
    	    $hash{$key} .= $_;
    	    }
	else
	    {
	    ($key = $_) =~ s/\s.*//;
	    chomp $key;
	    ($hash{$key} = $_) =~ s/^\S*\s+//;
	    }
    	}
    close FILE;

    for $key (keys %hash)
    	{
    	chomp $hash{$key};
    	}

    return %hash;
    }


###
###	WriteFile
###
###	Write a file of name/value pairs.  The value can be of any
###	length.  If the value contains newline characters, an initial
###	tab character is prepended to ensure that the line didn't
###	look like a name item.
###
sub WriteFile
    {
    my($fname, $hash) = @_;
    my($key, $value);

    $fname =~ s#\.\./##;		# Bozo trap
    if (!open(FILE, ">$fname"))
    	{
	print STDOUT <<"	EOF";
	    <html><head><title>Cannot open $fname</title></head>
	    <body>
	    I cannot create the file $fname.
	    The file permissions are probably wrong.
	EOF
	exit 0;
    	}
    for $key (sort(keys(%$hash)))
    	{
    	next if ($key =~ /password/);		# Don't write cleartext passwds
    	($value = $$hash{$key}) =~ s/\n/\n\t/gm;
    	print FILE "$key\t$value\n";
    	}
    close FILE;
    }
PEAK


Last modified 15 Feb 1998
Dave Regan
http://www.peak.org/~regan
Resume / Biography