#!/usr/local/bin/perl  
##############################################################################
# Postcard.cgi Free version! Bewley Internet Solutions <dale@bewley.net>
my $VERSION='Postcard.cgi v1.0b6'; #03-11-97  
#-----------------------------------------------------------------------------
# This script and others found at http://www.bewley.net/perl/
#
# BETA VERSION 
# Yet to be cleaned up into final form, but seems to work well.
#
#  This is a free version of the BIS Postcard.cgi. It uses a flat file
#  pseudo database to store the cards. A pay version is forthcoming
#  which will have more features and a database backend. Either dbm or mysql.
#
# INSTALLATION INSTRUCTIONS.
#
# 1. This program requires you to have CGI.pm installed on your system. 
# 	See: http://www-genome.wi.mit.edu/ftp/pub/software/WWW/#installation
#
# 2. Make sure the line at the top points to perl on your system. 
#    You might find out if you type "which perl" on the UNIX command line.
#
# 3. Edit the user configurable variables near the top of the script.
#
# 4. Ask your ISP where you can run CGI from. Sometimes you must call it 
#    through a wrapper and locate it in a cgi-bin directory. Sometimes it
#    is sufficient to give it a name ending in .cgi. This is the case on 
#    bewley.net. Install as they direct.
#
# 5. Make sure the CGI has write permission to $DATA_FILE. If you use a
#    wrapper it will. If not you may have to make the file and directory
#    containing it to world writable. Ask your ISP for help.
#
# 6. Create your index page. Sample at:
#    http://www.bewley.net/postcard/ 
#
# Todo:
#     o Add option to remove card when viewed, overriding $CARD_LIFE.
#
#     o Add a feature that will automatically create the thumbmail index
#	so you can just drop postcard.cgi into a dir of graphics and fly.
#
#     o Create a dbm version.
#
#     o Add template support for postcard output.
#
#     o Clean up.
#
#
# Copyright (C) 1997 Dale Bewley, Bewley Internet Solutions <dale@bewley.net>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
##############################################################################

#- User Configurable Variables ----------------------------------------------#
# experimenting right now. broken...                                         #
# Change these values to fit your site.                     #
 
# full URL to postcard homepage
my $BASE_REF  = 'http://www.bewley.net/postcard/';
 
# Number of days to keep card around before removing it.
my $CARD_LIFE  = 7;

# full path to postcard data file. The program will create this file.
my $DATA_FILE = '/httpd/htdocs/bewley/postcard/postcard.dat'; 
 
# full or relative URL location of images 
my $IMG_URL   = '/photos/';	
 
# this is the return address users get their postcard notice from.
my $MAIL_FROM = 'postcard@bewley.net';

# most likely this is correct
my $MAIL_PROG  = '/usr/lib/sendmail -i -t';

# full URL to pickup postcard. "?code=____" will be added automatically.
my $PICKUP_URL  = 'http://bewley.net/postcard/postcard.cgi';

# subject of email notifications
my $SUBJECT = 'Bewley.net Postcard for you!';

# location of thumbnails relative to images. This is unused right now.
my $THUMB_DIR  = 'thumbs/';	
 
# That's it!                                                                 #
#                                                                            #
#- End User Config ----------------------------------------------------------#


#- Main Program -------------------------------------------------------------#
# uncoment following display errors to the browser for debugging help
#   BEGIN {
#     use CGI::Carp qw(carpout);
#     carpout(STDOUT);
#   }

use CGI;
# This will put more useful information in your error_log
use CGI::Carp; 

my $create_time = time();

$FORM = new CGI;

if ($FORM->param('code')) {
	print $FORM->header;
	(&selectCard($FORM->param('code')) && &displayCard) || &console;
	print "<p><a href=$BASE_REF>Send your own postcard to someone!</a></p>";
} elsif (! $FORM->param('rcpt')) {
	print $FORM->header;
	&solicitMsg;
} else {
	&makeCard;
	&notifyRcpt;
	print $FORM->redirect($PICKUP_URL . "?code=$create_time" . 
		$FORM->param('rcpt'));
}

# please leave these 3 lines intact!
print "<font size=-1>\n <a href=\"http://www.bewley.net/perl/postcard.html\">";
print "$VERSION</a>\n by <a href=\"http://www.bewley.net/\">Bewley Internet ";
print "Solutions</a>.\n</font>";

print $FORM->end_html;

# if sub selectCard discovers an expired card it gets put on @death_row
if (@death_row) {
	&executeCards(@death_row);
}

#- End Main Program ----------------------------------------------------------#



sub solicitMsg {
	# Ask what they want on their tombstone... I mean postcard!
	print $FORM->start_html(-title=>'Fill in your postcard.',
		-author=>'dale@bewley.net',
		-BGCOLOR=>"#ffffff");

	# this will be filled if user forgets to supply a To: email
	$photo = $FORM->param('img');
	# otherwise...
	if (! $photo) {
		# filename comes in like this
		# big.jpg.x=23&big.jpg.y=122 so pull it from input
		# since we don't know the image filename, we don't know
		# the field name, so search them all
		@fields = $FORM->param();
		foreach $field (@fields) {
			if ($field =~ s/\.x$//) {
				$photo = $field; 
			}
		}
	}

	print "<h2>Please fill in your postcard.</h2>\n\n";

	print $FORM->startform(-method=>'POST');
	print "<center>\n<table border=5>\n";
	print "<tr><td>\n";
	print "<dl>\n";
	print "<dt><b>Email To:</b>\n<dd>";
	print $FORM->textfield(-name=>'rcpt');
	print "\n<dt><b>Email From:</b>\n<dd>";
	print $FORM->textfield(-name=>'from'), "<p>\n";
	print "<dt><b>Message:</b>\n<dd>";
	print $FORM->textarea(-name=>'msg',
		-rows=>10,
		-cols=>30);

	print "<br>\n", $FORM->submit, "</dl>\n";
	print "</td>\n<td>\n";
	print "<table border=1><tr><td>";
	print "<img src=", $IMG_URL, $photo, ">";
	print $FORM->hidden(-name=>'img',
			-value=>$photo), "<br>\n";
	print "</td></tr></table>\n";
	print "</td></tr>\n</table>\n</center>";
	print $FORM->endform;
	print "</center>\n\n";
}

sub makeCard {
	# Write card to DATA_FILE
	my $msg = $FORM->param('msg');
	# URL encode the message
	$msg =~ s/(\W)/ sprintf("%%%02x",ord($1))/eg;
	$FORM->param('msg',$msg); 

	open (FH, ">>$DATA_FILE") || die "Can't open $DATA_FILE for write. $!";
	# code, recipient, sender, image, message. 
	print FH $create_time, "\0";
	print FH $FORM->param('rcpt'), "\0";
	print FH $FORM->param('from'), "\0";
	print FH $FORM->param('img'), "\0";
	print FH $FORM->param('msg'), "\n";
	close FH;
}

sub notifyRcpt {
        # Let the recipient know they have a postcard waiting.
	open(MAIL, "|$MAIL_PROG") || die "Can't open $MAIL_PROG. $!";
	print MAIL "From: ", $MAIL_FROM, "\n";
	print MAIL "To: ", $FORM->param('rcpt'), "\n";
	print MAIL "Subject: $SUBJECT\n\n";
	print MAIL "Greetings!\n\nSomeone has filled out a postcard in your ";
	print MAIL "name!\n\nYou have $CARD_LIFE days to pick it up from:\n";
	print MAIL " $PICKUP_URL?code=$create_time" . $FORM->param('rcpt');
	print MAIL "\n\nYour postcard pal,\n $MAIL_FROM\n\n";
	close MAIL;
}

sub selectCard {
	# given a code, find the realcode in DATA_FILE
        # real pickup code is $create_time . rcpt
        my $check_code = shift; # something like 87531122dale@bewley.net
	my $apocolypse = $create_time - (86400 * $CARD_LIFE); 

	open (FH, "<$DATA_FILE") || die $!;
	while (<FH>) {
		# check for expired cards here
		($realcode,$rcpt) = split(/\0/,$_,2);
		if ($realcode < $apocolypse) { push(@death_row, $realcode); }

		# might this be a match? Most likely.
		if ($check_code =~ /^$realcode/) {
			($realcode,$rcpt,$from,$img,$msg) = split(/\0/);
			($sec, $min, $hour, $mday, $mon, $year) = 
				localtime($check_code);
			$date = sprintf ("%02s/%02d/%02d %02d:%02d:%02d", 
		                ++$mon, $mday, $year, $hour, $min, $sec);
			#$date = ++$mon ."/$mday/$year $hour:$min:$sec";
			$msg =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
			$realcode .= $rcpt;
			if ($check_code eq $realcode) { return 1; } # bingo!
		}
	}
	return 0;
}

sub displayCard {
	# later add support to pull in a template here instead of hard code
        print $FORM->start_html(-title=>'Here is your postcard. Thank you!',
               -author=>'dale@bewley.net',
               -BGCOLOR=>"#ffffff");
	print "<h1>Your Postcard:</h1>\n\n";
	print "<center>\n<table border=5>\n";
	print "<tr><td valign=top cellpadding=3>\n";
	print "<b>From:</b> <a href=mailto:$from>$from</a><br>\n";
	print "<b>To:</b> $rcpt<br>\n";
	print "<b>Date:</b> $date<p>\n";
	print "<p><b>Message:</b></p>\n";
	print "<blockquote>$msg</blockquote>\n";
	print "</td>\n<td>\n";
	print "<table border=1><tr><td><img src=";
	print $IMG_URL, $img, "></td></tr></table>\n";
	print "</td></tr>\n</table>\n</center>";
}

sub console {
        print $FORM->start_html(-title=>'Sorry!',
               -author=>'dale@bewley.net',
               -BGCOLOR=>"#ffffff");
	print "<h1>Sorry!</h1> Either your code is invalid ";
	print "or your card has expired.<p>\n";
}

sub executeCards {
	# remove expired cards from data file
	my @death_row = @_;

	open(OLD, "<$DATA_FILE") || 
		die "Can't open $DATA_FILE input. $!";
	&lockFile(OLD);

	open(NEW, ">$DATA_FILE.tmp") || 
		die "Can't open $DATA_FILE.tmp ouput. $!";
	&lockFile(NEW);

	my $good_as_dead = join('|',@death_row);
	my $soul;
	while ($soul = <OLD>) {
		print NEW $soul unless ($soul =~ /^$good_as_dead/o);
	}

	close OLD;
	close NEW;
	&unlockFile(NEW);
	rename("$DATA_FILE.tmp","$DATA_FILE") || 
		die "Can't rename $DATA_FILE.tmp to $DATA_FILE. $!";
	&unlockFile(OLD);
}

sub lockFile {
	local($FH) = @_;
	local($try) = 0;
	local($status) = 0;

	while ($status != 0) {
		$status = flock($FH, 2);
		($try == 4) && last;
		$status && sleep(1);
		$try++;
	}
}

sub unlockFile {
	local($FH) = @_;
	flock($FH, 8);
}