#!/usr/bin/perl
#
# Handle RSVP submissions 
#
# web:
# 'name' 'email'
# 'reserve' 'line-N' -- revertable
# 'purchase' 'line-N' -- non-revertable
#
# collection:
# numline
# delete-line-#
# desc-line-#
# model-line-#
# cost-line-#
# link-line-#
# reserv-line-# (undef or $name)
# purch-line-#
#
# OOB_COMMAND=runjournal s funi -u apache -c /proj/sandbox/httpd /var/www/www.baka.org/Wedding/CustomReg.cgi

use CGI;
use Sys::Hostname;
use Time::Local;
use POSIX;
use strict;

my (%G,%AUX,%USERDATA,%collection,@reply,@header);

$G{'SKIPNORMAL'} = 0;		# Default deny
$G{'RETCODE'} = 200;		# Assume OK
$G{'MIMETYPE'} = "text/html";
$G{'MYPATH'} = "/Wedding/CustomReg.cgi";
$G{'FILEBASE'} = "/var/www/www.baka.org/Wedding/db";
$G{'START'} = "/Wedding/";
$G{'ABBR'} = "Wedding";
$G{'EMAIL'} = "wedding\@baka.org";
$G{'BGCOLOR'} = "#ffffff";
$G{'TEXT'} = "#000000";
$G{'LINK'} = "#0000ff";
$G{'VLINK'} = "#006666";

if ($ENV{'OOB_COMMAND'} ne "")
{
  oob_command($ENV{'OOB_COMMAND'});
  exitcleanup(0);
}

init();				# Open CUSFS databases and files
parse_user_data();
do_action();
make_reply();
send_reply();
exitcleanup(0);


######################################################################
#
# Out of band command
#
sub oob_command($)
{
  my($cmd) = @_;

  # XXX - new commands like printuser printcollection
  if ($cmd eq "runjournal")
  {
    init();
    seek(JOURNAL,0,0);
    while(<JOURNAL>)
    {
#	  print;
      chomp($_);
      runcmd($_);
    }
  }
  if ($cmd eq "print")
  {
    my($id);

    init();
    foreach $id (keys %collection)
    {
      print "COLLECTIONID=$id; 
$collection{$id}
\n";
    }
  }
  exitcleanup(0);
}



######################################################################
#
# Initialize databases and files
#
sub init()
{
  open(JOURNAL,"+>>$G{'FILEBASE'}/reg-journal.log") || die "Cannot append to journal\n";
  select((select(JOURNAL), $| = 1)[0]); # Piping hot
  dbmopen %collection, "$G{'FILEBASE'}/reg-collection", 0644 || die "Cannot open collection file";
}



######################################################################
#
# Clean everything and shut down
#
sub exitcleanup($)
{
  my ($retcode) = @_;

  close(JOURNAL);
  dbmclose %collection;

  exit($retcode);
}


######################################################################
#
# Parse the user data
#
sub parse_user_data()
{
  my ($key, $value, @values);
  my ($query)=new CGI;

  return if (!defined($query->param));

  foreach $key ($query->param)
  {
    @values = $query->param($key);
    $value = $values[0];

    # strip quoting characters
    @values = grep(s/[\"\n]+//g||1,@values);
      
    push(@{$USERDATA{$key}},@values);

#    print STDERR "KEY: '$key' '$USERDATA{$key}' '$USERDATA{$key}->[0]', >".join(",",@values)."< - >".join(",",$query->param($key))."<\n";

  }
}



######################################################################
#
# Do action
#
sub do_action()
{
  my($ret, $x, @cmds);

  return undef if ($G{'SKIPNORMAL'});

  mktitle("Custom Wedding Registry");

  return unless ($USERDATA{'active'} && $USERDATA{'action'}->[0] ne "Retry");

  if (length($USERDATA{'name'}->[0]) < 5 || !($USERDATA{'email'}->[0] =~ /\@/))
  {
    mk_error_page(500,qq^Must fill out name and email address to make changes^);
    return undef;
  }

  for ($x=0;$x<$collection{'numline'};$x++)
  {
    my ($reserve,$purchase);

    next if ($collection{"delete-line-$x"});
    next if ($collection{"purch-line-$x"} ne "");

    $reserve = grep(/line-$x/,@{$USERDATA{'reserve'}});
    $purchase = grep(/line-$x/,@{$USERDATA{'purchase'}});

    # Detect change
    if (($reserve > 0) != ($collection{"reserv-line-$x"} ne ""))
    {				# This reservation has changed
      if (!$reserve && $USERDATA{'name'}->[0] ne $collection{"reserv-line-$x"})
      {
	mk_error_page(500,qq^Your name is '$USERDATA{"name"}->[0]', yet this item was reserved by '$collection{"reserv-line-$x"}'.  You may not change someone else\'s reservation.^);
	return undef;
      }

      push(@cmds,$reserve?"ADDRESV":"DELRESV", qq*LINE="$x", NAME="$USERDATA{'name'}->[0]", EMAIL="$USERDATA{'email'}->[0]"*);
      if ($reserve)
      {
        push(@reply, qq^<center><b><p>Thank you for your reservation of $collection{"desc-line-$x"} -- $reserve -- $collection{"reserv-line-$x"}</p></b></center>\n^);
      }
      else
      {
        push(@reply, qq^<center><b><p>You are no longer reserving $collection{"desc-line-$x"}</p></b></center>\n^);
      }
    }
	
    # Detect change
    if (($purchase > 0) != ($collection{"purch-line-$x"} ne ""))
    {				# This purchase has changed
      if (!$purchase)
      {
	mk_error_page(500,qq^Items, once purchased, cannot be undone.  Ask webmaster for assistance if you really made a mistake.^);
	return undef;
      }

      if ($purchase && $collection{"reserv-line-$x"} ne "" && $USERDATA{'name'}->[0] ne $collection{"reserv-line-$x"})
      {
	mk_error_page(500,qq^Your name is "$USERDATA{'name'}->[0]", yet this item was reserved by "$collection{"reserv-line-$x"}".  You may not purchase someone else\'s reservation.^);
	return undef;
      }

      push(@cmds, "PURCHASE", qq*LINE="$x", NAME="$USERDATA{'name'}->[0]", EMAIL="$USERDATA{'email'}->[0]"*);
      push(@reply, qq^<center><b><p>Thank you for your purchase of $collection{"desc-line-$x"}</p></b></center>\n^);
    }
  }
  while ($#cmds >= 0)
  {
    my($cmd) = shift(@cmds);
    my($str) = shift(@cmds);

    &runcmd(logcmd($cmd, $str));
  }
}



######################################################################
#
# Make reply (next page)
#
sub make_reply()
{
  if (!$G{'SKIPNORMAL'} && abs($G{'RETCODE'} - 200) < 100 )
  {
    my($x);

    &mkform($G{'MYPATH'},"active=yes");

    push(@reply,"<p><a href='db/regbook.html'>Forum to read and leave notes to find gift buddies!</a> (band together to buy that sub!)</p>\n");

    push(@reply,"<p>Shipping instructions:  Please ship small items (e.g. not dishwasher, A/C or sub) to the address shown below.</p><p><i>&nbsp;&nbsp;&nbsp;&nbsp;Seth Robertson<br />&nbsp;&nbsp;&nbsp;&nbsp;c/o System Detection<br />&nbsp;&nbsp;&nbsp;&nbsp;5 W. 19th Suite 2K<br />&nbsp;&nbsp;&nbsp;&nbsp;New York, NY 10011</i>.</p><p>Please make delivery arrangements via <a href='mailto:wedding\@baka.org'>email</a> on larger items.</p>\n");

    push(@reply,"<p><center><b>How to use this page.</b></center><li>First, enter your
    name and email address into the boxes.</li><li>Next, scan through the
    list until you have found something that has neither been
    purchased or reserved by someone else.</li><li>Click on the reserved
    button for that item.  After making all selections, hit the submit
    button at the bottom of the page.</li><li>Assuming everything went well,
    you should get a fresh copy of the page with some messages
    appearing above this paragraph.  These messages should confirm
    that you have reserved the items you requested--indeed when you
    scan down through the list, those buttons should be checked.<br .>Now
    go out and purchase the items you have reserved.</li><li>Once the
    purchase has been confirmed, go through the list again and click
    the purchased button--alternatively, if you did not make the
    purchase (e.g. the sub costs \$80 million instead of \$78 million,
    and \$80 million is just too much to spend on a gift for us),
    unclick the reserved button.</li><li>Again hit the submit button at the
    bottom.  Again you should receive confirmation messages above this
    paragraph describing what has happened.  If you clicked on
    purchase and submit but it turned out the \$78 million check
    bounced and you cannot purchase the sub after all, you must
    contact the <a href='mailto:webmaster\@baka.org'>webmaster</a> to
    reverse the purchase indication.</li></p><p>Note: the 'available from' represents the first place we stumbled across, not the best or cheapest, so please feel free to buy from some other location.  We are not officially registered at any store for these items.</p>\n");

    mktable();
    push(@reply, qq^<tr><td><label for="name">Name (First Last): </label></td><td><input type="text" name="name" value="$USERDATA{'name'}->[0]" /></td></tr>^);
    push(@reply, qq^<tr><td><label for="email">Email: </label></td><td><input type="text" name="email" value="$USERDATA{'email'}->[0]" /></td></tr>^);
    push @reply, qq*</table></center><br /><br />\n*;

    mktable("Registry");
    push(@reply,qq^<tr><th>Description</th><th>Model</th><th>Available From</th><th>List Price</th><th>Reserve</th><th>Purchase</th></tr>\n^);

    for ($x=0;$x<$collection{'numline'};$x++)
    {
      my ($line);
      next if ($collection{"delete-line-$x"});
      $line = qq^<tr><td>$collection{"desc-line-$x"}</td><td>$collection{"model-line-$x"}</td><td>$collection{"link-line-$x"}</td><td>$collection{"cost-line-$x"}</td>^;
      if ($collection{"purch-line-$x"})
      {
	$line .= qq^<td colspan="2">Purchased</td></tr>\n^;
      }
      else
      {
	my ($checked);
	if ($collection{"reserv-line-$x"} ne "")
	{
	  $checked = "checked";
	}
	$line .= qq^<td><input type="checkbox" name="reserve" value="line-$x" $checked></input></td>^;
	$line .= qq^<td><input type="checkbox" name="purchase" value="line-$x"></input></td></tr>\n^;
      }
      push(@reply,$line);
    }
    push @reply, qq*</table></center><br /><br />\n*;
    &mkstdbuttons("Submit");
  }

  if ($G{'MIMETYPE'} eq 'text/html')
  {
    unshift @reply, qq*<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n*;
    unshift @reply, "<html>";
  }
  unshift @header, "Status: $G{'RETCODE'}\n";
  unshift @header, "Expires: " . CGI::Util::expire_calc("+5",'http') . "\n";
#  unshift @header, "Expires: " . CGI::Util::expire_calc("0",'http') . "\n";
  unshift @header, "Cache-Control: no-cache\n";
  unshift @header, "Last-modified: " . CGI::Util::expire_calc(0,'http') . "\n";
  unshift @header, "Content-type: $G{'MIMETYPE'}\n";

  if ($G{'MIMETYPE'} eq 'text/html')
  {
    push(@reply, qq^<p /><hr /><p><font size=-4><address>Comments and bugs should be directed to: <a href="mailto:$G{'EMAIL'}">$G{'EMAIL'}</a></p><br />^);
    push(@reply, q^Version: $Id: CustomReg.cgi,v 1.7 2004/01/23 17:57:31 seth Exp $\n</address></html>^);
  }

  return;
}



######################################################################
#
#  Send reply
#
sub send_reply()
{
  print join '', @header;
  print "\n";
  print join '', @reply; 
  return;
}



############################################################################
#
#                               ERROR PAGE
#
sub mk_error_page($$)
{
  my ($lretcode, $errmsg) = @_;
  
  # Erase previous pushed data.
  undef @reply;
  $G{'RETCODE'}=$lretcode;

  push @reply, qq^
<head>
<title>
$G{'ABBR'} ERROR
</title>
</head>
<body>
<h1><center>
Error in submission
</center></h1>

<br /><hr /><br />

<center><b>$errmsg</b></center>

  ^;

  my(@A,$key,$value);

  foreach $key (keys %USERDATA)
  {
    next if ($key eq "action");
    foreach $value (dequote($USERDATA{$key}->[0],','))
    {
      push(@A,qq*$key="$value"*);
    }
  }

  &mkform($G{'MYPATH'},@A);
  &mkstdbuttons("Retry");

  return;
}



######################################################################
#
# Generate a checkbox input selection
#
sub gencheck($$$@)
{
  my($type,$default,$name,@vals) = @_;
  my($check,$value,$string);

  if (defined($default))
  {
    $default = quotemeta($default);
    $default =~ s/\\,/|/g;
  }

  foreach $value (@vals)
  {
    undef $check;
    $value =~ s/^(\*|)//;
    if (defined($default))
    {
      $check = " checked" if ($value =~ /^($default)$/);
    }
    else
    {
      $check = " checked" if ($1 eq '*');
    }
    $string .= qq^<INPUT TYPE=$type name=$name value="$value"$check>&nbsp;$value &nbsp; ^;
  }

  $string;
}



######################################################################
#
# Generate a selection list with defaults
#
sub genselect($$@)
{
  my($name,$default,@list) = @_;
  my($string) = qq*<select name="$name">*;
  foreach (@list)
  {
    $string .= qq*<option value="$_"*;
    $string .= " selected" if ($_ eq $default);
    $string .= ">$_";
  }
  $string .= "</select>";
}



######################################################################
#
# Generate standard form
#
sub mktable($)
{
  my($caption) = @_;

  push @reply, qq^
<br />
<center>
<table align="center" border>
<caption><font size=+2>$caption</font></caption>
  ^;
}



######################################################################
#
# Put the form headers on
#
sub mkstdbuttons(@)
{
  my(@buttons) = @_;

  push @reply, "<br /><hr /><br />\n";
  push @reply, qq*<center><table width="100%"><tr align="center">\n*;
  foreach (@buttons)
    {
      push @reply, qq*<td><input type=submit name=action value=$_></td>\n*;
    }
  push @reply, qq*<td><a href="$G{'START'}">Home</a>\n*;
  push @reply, qq*</tr></table></center>\n*;
}



######################################################################
#
# Put the form headers on
#
sub mkform($@)
{
  my ($path,@hidden) = @_;

  push @reply, qq^<form method=post action="$path">\n^;
  foreach (@hidden)
  {
    my($n,$v) = split(/=/,$_,2);
    push @reply, qq^<input type=hidden name=$n value=$v>\n^;
  }
}



######################################################################
#
# Make a generic header for the page
#
sub mktitle($)
{
  my($title) = @_;

  push @reply, qq^
<?xml version="1.0" encoding="us-ascii"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US"
lang="en-US">
<head>
<meta http-equiv="Content-Type"
content="text/html; charset=us-ascii" />
<meta http-equiv="PICS-Label"
content='(PICS-1.1 "http://www.classify.org/safesurf/" l gen true for "http://www.baka.org" by "seth\@baka.org" r (SS~~000 1 SS~~100 1))' />
<meta http-equiv="PICS-Label"
content='(PICS-1.1 "http://www.icra.org/ratingsv02.html" l gen true for "http://www.baka.org" r (cz 1 lz 1 nz 1 oz 1 vz 1) "http://www.rsac.org/ratingsv01.html" l gen true for "http://www.baka.org" r (n 0 s 0 v 0 l 0))' />
<body $G{'BODYAUX'} bgcolor="$G{'BGCOLOR'}" text=$G{'TEXT'} link=$G{'LINK'} vlink=$G{'VLINK'}>
<center><h1><font size=+2>$title</font></h1></center>
<p /><hr /><p />
^;
}



######################################################################
#
# Dequote a quoted element or list
#
sub dequote($;$)
{
  my($str,$sep) = @_;
  my(@r);
  my($rest,$last);

  return $str if ($str !~ /\"/);

  if (!defined($sep))
  {
    $str =~ s/\"([^\"]*)\"/$1/;
    return $str;
  }

  $rest = $str;
  $last = length($rest);
  while ($last > 0)
  {
    $rest =~ s/^\"([^\"]*)\"($sep\s*)?//;
    push(@r,$1);
    $rest =~ s/^[ \t\n]+//;
    if (length($rest) >= $last)
    {
      my ($package, $filename, $line, $subroutine, $hasargs, $wantargs) = caller(1);
      die "ASSERT: decode_obj length did not shrink: :$subroutine: :$str: :$rest:\n";
    }
    $last = length($rest);
  }

  @r;
}



######################################################################
#
# mkcmdstr
#
sub mkcmdstr
{
  my($hashref, @names) = @_;
  my($string);

  foreach (@names)
  {
    $string .= qq*$_="*.dequote($hashref->{$_}).qq*", *;
  }
  $string =~ s/, $//;
  $string;
}



######################################################################
#
# logcmd - log a transaction to the journal
#
sub logcmd
{
  my($cmd, $args) = @_;
  my($string) = qq*$cmd LOGDATE="*.time.qq*", $args*;

  # Get rid of newlines
  $string =~ s/\015\012/\015/g;
  $string =~ s/\012/\015/g;

  print JOURNAL "$string\n";
  $string;
}



######################################################################
#
# runcmd -- run a low level maintenance command
#
sub runcmd
{
  my($cmdstr) = @_;
  my($cmd,$args,$rest,%args,@args,$id);

  # TODO begin WRITE locking

  ($cmd,$args) = split(/ /,$cmdstr,2);
  $rest = $args;
  while (length($rest) > 0)
  {
    if ($rest =~ /^([^=]+)=\"([^\"]*)\"(,\s*)?/)
    {
      $rest =~ s/^([^=]+)=\"([^\"]*)\"(,\s*)?//;
      $args{$1} = $2;
    }
    else
    {
      $rest =~ s/^([^,]+)(,\s*)?//;
      push @args, $1;
    }
    $rest =~ s/^[ \t\n,]+//;
  }

  if ($cmd =~ /^ADDRESV$/)
  {
    # Add a reservation
    $collection{"reserv-line-$args{'LINE'}"} = $args{'NAME'};
    return;
  }

  if ($cmd =~ /^DELRESV$/)
  {
    # Add a reservation
    $collection{"reserv-line-$args{'LINE'}"} = undef;
    return;
  }

  if ($cmd =~ /^PURCHASE$/)
  {
    $collection{"purch-line-$args{'LINE'}"} = $args{'NAME'};
    return;
  }

  if ($cmd =~ /^INIT$/)
  {
    undef(%collection);
    $collection{"numline"} = 0;
    return;
  }

  if ($cmd =~ /^ADD$/)
  {
    my ($line) = $collection{"numline"}++;
    
    $collection{"delete-line-$line"} = 0;
    $collection{"desc-line-$line"} = $args{'DESC'};
    $collection{"model-line-$line"} = $args{'MODEL'};
    $collection{"cost-line-$line"} = $args{'COST'};
    $collection{"link-line-$line"} = $args{'LINK'};
    $collection{"reserv-line-$line"} = undef;
    $collection{"purch-line-$line"} = undef;
    return;
  }

  if ($cmd =~ /^DEL$/)
  {
    $collection{"delete-line-$args{'LINE'}"} = 1;
    return;
  }

  die "Unknown command $cmd\n";
}