#!/usr/bin/perl
# doform - cgi script to save form submission to data file
#
# dave@capella.ithaca.ny.us - Tue Jan  8 20:28:14 EST 2002
#
#	Copyright (c) 2002, Dave W. Capella 	All rights reserved.
#
#	Redistribution and use in source and binary forms, with or without
#	modification, are permitted provided that the following conditions are met:
#
#	 - Redistributions of source code must retain the above copyright notice, this
#		 list of conditions and the following disclaimer. 
#
#	 - Redistributions in binary form must reproduce the above copyright notice,
#		 this list of conditions and the following disclaimer in the documentation
#		 and/or other materials provided with the distribution. 
#
#	 - Neither the name of Dave Capella nor the names of its contributors may be
#		 used to endorse or promote products derived from this software without
#		 specific prior written permission.
#		 
#	THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
#	AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#	IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
#	DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
#	FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#	DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
#	SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
#	CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
#	OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
#	OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# notes:
# 1. relies on Lincoln Stein's venerable CGI.pm module.
# 2. restricts use to list of servers spelled out in script
#     disabled. see below.
# 3. no html is output in any event. on success or failure,
#    redirects to pages specified in form fields.
# 4. data is saved in comma-delim'd format, single record to a line
# 5. path to data file is derived from prefix (/var/www/data, for instance),
#    plus web server host name. this allows for use on multiple sites.
# 6. data file must already exist. must be writable by web server.
#    for 'normal' apache installation, should be owned by user, nobody, or
#    on redhat linux, user apache. suggest special group of users to retrieve
#    data (perhaps www?). permissions would then be 660 for apache.www or
#    for nobody.www
# 7. data file name allows only upper, lower case, numbers and underscore.
# 8. email notification is sent to the webmaster of the web server hosting
#    the script. the sender is web-robot at the same server.
# 9. required fields:
#	  redirect - fully-qualified url of destination on success
#	  error    - fully-qualified url of destination on failure
#	  fields   - list of fields to save. order will be retained.
#	  file     - name of file to save results into. must already exist.
#              name only, no path info.
# dave@capella.ithaca.ny.us - Tue Jan 29 13:28:35 EST 2002
#   notify - netid of person to be notified of new submissions via email.
#
# dave@capella.ithaca.ny.us - Sun Jan 13 22:54:48 EST 2002
# bugfix: file was opening for write, not append 
#
# dave.capella@cornell.edu - Tue Jan 29 13:25:26 EST 2002
# modified for use on www.bscb.cornell.edu
# 1. added field for mail recipient
# 2. changed notification to specify form instead of server
# 3. added global var: domain - domain name of email address
#
# dave@capella.ithaca.ny.us - Mon Feb  4 19:06:23 EST 2002
# disabled referer check. broken if browser blocks referer var.
#
# dave@capella.ithaca.ny.us - Thu Feb 14 12:42:25 EST 2002
# enclose each data field in double quotes. convert incoming
# double quotes to single quotes.
#
# dave@grox.net - march 2002
# added form var for fields that require input
#
############################################################
use CGI ':standard';

############################################################
# Customization Section
############################################################

#
# global variables
#

# list of servers that are allowed to use this script
#
my @servers = (
  "toadstool.bscb.cornell.edu",
  "www.bscb.cornell.edu",
  "www.biom.cornell.edu"
	);
my $datadir = "/var/www/data";      # where the data is saved
$mailer = '/usr/sbin/sendmail';     # location of sendmail program
$domain = "cornell.edu";          # domain name of email address
############################################################
# end: customization
############################################################

# only accept requests from our web serverrs
#
my $server = $ENV{'HTTP_REFERER'};
# dwc
#ckhost($server,@servers) or errexit("request from unauthorized host");

# get error page to use in error messages
$errpage = param('error');
if($errpage ne "") {
	$file =~ /\.\./ and errexit("","Go Away!");
	$errpage = $ENV{'DOCUMENT_ROOT'} . $errpage;
}

# get server name
#
#$server = $ENV{'SERVER_NAME'};
errexit($errpage,"Unable to get server name. Please contact the webmaster.") if $server eq "";

if(!param('fields')) {
	errexit($errpage,"Unable to retrieve form information.");
}

my $fieldstr = param('fields');          # extract the field list
my @fields = split(",",$fieldstr);

# required fields
#
my $reqstr = param('required');
my @required = split(",",$reqstr);

foreach $r (@required) {
	if( param($r) eq "" ) {
		errexit($errpage,"Please complete the $r field.");
	}
}

my $file = param('file');               # file name from field on form

# dwc - keep 'em in the data dir
#
$file =~ /\.\./ and errexit($errpage,"Go Away!");

$file =~ s#[^a-zA-Z0-9_/\.]##g;           # sanitize

# construct full path - must already exist
#
my $datafile = $datadir . "/" . $file;

# debug
#errexit($errpage,"filename: $datafile");

# build email recipient address from form field
# if unable, default to webmaster
#
$email = param('notify');
if($email eq "") {
	$email = "webmaster\@" . $server;
} else {
	$email = $email . "\@" . $domain;
}

dosave($datafile,@fields);

$url = param('redirect');

# sanity check. make sure we have *somewhere* to go!
#
if($url eq "") {
	$url = $ENV{'HTTP_REFERER'};
}

# 1/29/02 - added arg for mail recipient
#           doesn't send full path
#
notify($email,$ENV{'HTTP_REFERER'},$file);     # notify webmaster of submission

# errors will jump to error page with errexit
#
doredirect($url);        # redirect to success page

exit;

############################################################
# subroutines
############################################################

############################################################
# ckhost - check that request came from allowed host
# args:
#   $host - host submitting request
#   @allowed - array of allowed host names
# returns: 1 on success, 0 on failure
#
sub ckhost {
	my($host,@allowed) = @_;
	return 0 if ! $host;
	$host =~ s#.*//(.*)/.*#$1#;
	foreach(@allowed) {
		return 1 if $host eq $_;
	}
	return 0;
}

############################################################
# dosave - save submission in a csv file
# args: 
# $file - full path spec of file name
# @fields - hash of field keys/value pairs
# notes: file must already exist. each field wrapped in double
#        quotes.
#
sub dosave {
	my($file,@fields) = @_;

	my $quot = '"';
	my $count = 1;
	my $line = "";

	foreach $f (@fields) {
		if($f eq "file" or $f eq "redirect" or $f eq "error") {
			next;
		}

		$count += 1;
		$val = param($f);
		# escape double quotes - change to single quotes
		$val =~ s/"/'/g;
		# enclose in double quotes
		$val = $quot . $val . $quot;

		if($count < 2) {
			$line = $val;
		} else {
			$line .= ",";
			$line .= $val;
		}
	}
	$line .= "\n";

#	open(OUT,">>$file") or return 0;
#	open(OUT,">$file") or errexit($errpage,"Cannot open: $file");
	open(OUT,">>$file") or
		errexit($errpage,"Cannot save the information. Please contact the webmaster.");
	print OUT $line;
	close(OUT);
}

############################################################
# notify - notify webmaster of form submission via mail
# args: 
# $host - name of web server
# $file - name of data file (full path)
# $ok   - status of submission. 1=ok, 0=failure
# returns: nothing
# notes: creates to/from addresses based on web server name
#
sub notify {
	my ($to,$url,$file) = @_;

#	if($ok == 1) {
#		$subject = "Successful submission to $url";
#	} else {
#		$subject = "ERROR: submission to $url";
#	}

	$subject = "Successful submission to $url";

	my $from = "web-robot\@" . $host;
	my $msg = "Output appended to: $file\n";
    
	open (SENDMAIL, "| $mailer -t") || die $!;
	print SENDMAIL "From: $from\n";
	print SENDMAIL "To: $to\n";
	print SENDMAIL "Subject: $subject\n\n";
	print SENDMAIL $msg;
	close (SENDMAIL);
}

############################################################
# doredirect - send client browser to another url
# args: $url - new page
# returns: nothing
#
sub doredirect {
	my ($url) = @_;
	print <<"EndResponse";
Status: 302 Redirected
Content-type: text/html
Location: $url 

<HTML><HEAD>
<TITLE>Client Redirected</TITLE>
</HEAD><BODY>
Please continue to <A HREF="$url">this location</A>.
</BODY></HTML>
EndResponse
}


############################################################
# shoenv - display current environment in user's browser
# args: $srvr - web server name
# returns: nothing
#
sub shoenv {
	my ($srvr) = @_;
	print "content-type: text/html

	<html><body>
	<h3>$srvr is $ok</h3>
	";
	while (($key,$value) = each %ENV) {
		print "<h3>$key=$value</h3>\n";
	}

	print "</body></html>";
}

############################################################
# errexit - display error and exit
# args: $msg - error to display 
# returns: nothing
#
sub errexit {
	my ($errfile,$msg) = @_;

	if($errfile eq "") {
		print "content-type: text/html

		<html><head><title>ERROR</title></head>
		<body>
		<h3>ERROR</h3>
		<h5>
		$msg
		</h5>
		</body></html>
		";
	} else {
		print "content-type: text/html

		";
		open(FILE,$errfile) or errexit("",$msg);
		while(<FILE>) {
			if( /INSERT ERROR MESSAGE HERE/ ) {
				print "<h4>$msg</h4>\n";
			} else {
				print;
			}
		}
		fclose(FILE);

	}
	exit;
}

# eof: server