#!/usr/bin/perl -U

#
#   LOGIN SCRIPT
#
#
#   new_login.cgi    --   Rename this file new_login.cgi and place in base directory
#                         We place it in the top level directory so that cookies will
#                         work in all parts of the site, including the home page
#
#                         More information: http://www.downes.ca/midm.htm
#
#   by Stephen Downes
#   Version  0.8   -  November 29, 2005
#
#   This script handles user registration and user login functions for all other
#   scripts. It places new user data in the user database and, on login, places
#   login cookies on the user's browser.
#
#   Copyright 2005 Stephen Downes, National Research Council Canada
#   Prerelease - please do not distribute - I'll GPL it when it's ready
#


use CGI;
use CGI::Carp qw(fatalsToBrowser);
#use SQL::Abstract;
use Apache::DBI();
use XML::LibXML;
use LWP::Simple;
use strict;

# Set up site variables
our $Site = {}; bless $Site; &get_site($Site,"midm.conf");
die "Probable syntax error in midm.conf" unless ($Site);

#require "cgi-bin/edurss_harvest.pl";
#require "cgi-bin/edurss_options.pl";
#require "cgi-bin/edurss_database.pl";
#require "cgi-bin/edurss_output.pl";

our $Base_URL = "http://".$ENV{'SERVER_NAME'};
our $script = "http://".$ENV{'SERVER_NAME'}.$ENV{'SCRIPT_NAME'};


my $dbh = &db_open("DBI:mysql:$Site->{db_name}:$Site->{db_host}",$Site->{db_user},$Site->{db_pass}) or print "Database connect error: $!";
my $options = {};


my $query = new CGI; my $vars = $query->Vars;							# Get user input
my $refer = $vars->{refer};
$refer =~ s/AND/&/g;										# Replace ampersands in referring URL

if ($vars->{request} eq "confirm") { &return_key($vars->{site}); exit; }			# Handle mIDm confirm request, No login needed

our $person = &get_person($dbh,$query);								# Get User Information ( = Login Confirm)

if ($vars->{site}) { &record_key($vars,$person); exit; }					# Record mIDm site key


#   Do Actions
if ($vars->{foaf}) { &foaf($dbh,$options,$vars); exit; }

for ($vars->{action}) {

	/Login/ && do { &user_login($dbh,$options,$vars,$query,$person); last; 					};
	/Register/ && do { &registration_form_text($dbh,$options,$vars); last;	 				};
	/New/ && do { &new_user($dbh,$options,$vars,$query); last;	 					};
	/Email/ && do { &email_password($dbh,$options,$vars); last;	 					};
	/Send/ && do { &send_password($dbh,$options,$vars); last;	 					};
	/Register/ && do { &register_form($dbh,$options,$vars); last;	 					};
	/Logout/ && do { &user_logout($dbh,$options,$vars); last;						};
	/Subscribe/ && do { &subscribe($dbh,$options,$vars); last;						};
	/Unsubscribe/ && do { &unsubscribe($dbh,$options,$vars,$person); last;					};
	/Options/ && do { &options($dbh,$options,$vars,$person); last;						};
	/add/ && do { &add_subscription($dbh,$vars,$person);&options($dbh,$options,$vars,$person); last;	};
	/drop/ && do { &drop_subscription($dbh,$vars,$person);&options($dbh,$options,$vars,$person); last;	};
	&login_form_text($dbh,$options,$vars,$person); last;
}


#   End of main

exit;

#   -------------------------------------------------------------------------------------
#
#   get_site
#
#   Gets site configuration variables
#
#   -------------------------------------------------------------------------------------

sub get_site {

	my ($Site,$conf) = @_;

	# Get site information
	open SITE, "$conf"  || die "Cannot open site config: $!";;
	my $comment = '#';
	while (<SITE>) {
		chomp; next unless ($_); next if ($_ =~ /^$comment/);
		my @vararr = split ' ',$_;
		my $key = shift @vararr;
		next unless ($key);next if ($key =~ '#');
		my $val = join ' ',@vararr; my $junk;
		($val,$junk) = split $comment,$val;
		$Site->{$key} = $val;
	}
	close SITE;
}


#   -------------------------------------------------------------------------------------
#
#   index_of
#
#   Checks for membership of variable in an array
#
#   -------------------------------------------------------------------------------------

sub index_of {

	# Get item and array from input
	my ($item,$array) = @_;

	# Initialize counter
	my $index_count = 0;
	# For each item in the array
	foreach my $i (@$array) {

		# Return the counter value if it matches item
		if ($item eq $i) { return $index_count; }

		# Increment the counter
		$index_count++;
	}
	# Return -1 if no match is returned
	return "-1";
}

#   -------------------------------------------------------------------------------------
#
#   user_login
#
#   Logs in user. Requires:    $FORM{'userid'}
#                              $FORM{'password'}
#   Checks userid and password against information in user database. Returns an error
#   or writes userid cookies to the user's browser
#
#   -------------------------------------------------------------------------------------

sub user_login {
	my ($dbh,$options,$vars,$query,$person) = @_;

	unless (($vars->{person_title}) && ($vars->{person_password})) {					# Unless fields filled
		&error("Login info not provided"); }						# User Login Error

	$person = &db_get_record($dbh,'person',{person_title => $vars->{person_title}});
	unless ($person) { &error("Could not find $vars->{person_title} in my database."); }	# User exists?
	unless ($person->{person_password} eq $vars->{person_password}) { &error("Incorrect password."); }	# Correct Password?
	&user_are_go($dbh,$options,$vars,$query,$person);
}

sub user_are_go {
	my ($dbh,$options,$vars,$query,$person) = @_;
	print "Content-type: text/html\n";				  # Print HTTP header
	my $exp; if ($vars->{remember}) { $exp = '+1y'; } else { $exp = '+1h'; }
	my $cookie1 = $query->cookie(-name=>'person_id',-value=>$person->{person_id},-expires=>$exp,-path=>'/',-domain=>$Site->{co_host},-secure=>0);
        my $cookie2 = $query->cookie(-name=>'person_title',-value=>$person->{person_title},-expires=>$exp,-path=>'/',-domain=>$Site->{co_host},-secure=>0);
        print $query->header(-cookie=>[$cookie1,$cookie2]);
	print "\n\n";							  # Complete HTTP header



	my $header = &template($dbh,"top");
	my $left = &template($dbh,"left");

	$header =~ s/Welcome/Login Successful/;
	print $header;
	print "<div id=\"centercontent\">";
	if ($options->{new} eq "yes") { &show_subscriptions($dbh,$vars,$person); }
	print "<h1>Login Successful</h1><p><ul>";
	&print_nav_options($dbh,$options,$vars,$person);
	print $left."</div></body></html>";
}



sub unsubscribe {	# Retained for backward compatibility

	my ($dbh,$options,$vars,$person) = @_;
	&options($dbh,$options,$vars,$person);

}

#   -------------------------------------------------------------------------------------
#
#   login_form_text
#
#   Returns a string containing the login form
#
#   -------------------------------------------------------------------------------------

sub login_form_text {

	my ($dbh,$options,$vars) = @_;

	#Check for mIDm auto-login
	my @useragentstuff = split /;/,$ENV{'HTTP_USER_AGENT'};
	my $redirect = pop @useragentstuff;
	#my $redirect = "http://www.downes.ca/new_login.cgi?user=Downes";
	&midm($dbh,$vars,$redirect) if ($redirect =~ /http:\/\//i);

	print "Content-type: text/html\n\n";
	my $header = &template($dbh,"top");
	$header =~ s/Welcome/Login/m;
	my $left = &template($dbh,"left");
	print $header . "<div id=\"centercontent\"><h1>Login</h1><p>$vars->{msg}</p>".
		"<form method='post' action='$script'>\n" .			  # Form
	      	"<p>Please enter your user name:<br>\n<input name='person_title' type='text' size=20></p>\n" .	  # Userid
		"<p>Please enter your password:<br>\n<input name='person_password' type='password' size=20></p>\n" .  # Password
		"<p><input type='checkbox' name='remember' value='yes'> Remember me next time</p>\n" .		  # Remember
      		"<p><input type='hidden' name='refer' value='$vars->{refer}'>\n" .				  # Referring URL
		"<input type='hidden' name='action' value='Login'>\n" .					  # Action
      		"<input type='submit' value='Click here to continue'></p>\n" .					  # Submit
      		"</form>\n" .												  # End of form
		"<p>Not a registered user?\n" .
		"<a href='$script?refer=$vars->{refer}&action=Register'>\n" .				  # Register
      		"Click Here</a></p>" .
		"<p>Forget your password?\n" .
		"<a href='$script?refer=$vars->{refer}&action=Email'>\n" .					  # Email password
      		"Click Here</a></p></div>\n".
		$left."</body></html>";
}


#   -------------------------------------------------------------------------------------
#
#   midm
#
#   mIDm autologin function
#
#   -------------------------------------------------------------------------------------

sub midm {

	my ($dbh,$vars,$redirect) = @_;

	unless ($vars->{confirm}) {
		my $key = time;
		open KEYS,">>confirmkeys.dat";
		print KEYS time."\t$redirect\t$key\n";
		close KEYS;
		$redirect .= "&site=".$script."&key=$key";
		print "Content-type:text/html\nLocation:$redirect\n\n";
		exit;
	}

	my $verify = $redirect . "&site=".$script."&request=confirm";

	my $content = get $verify;
	die "Couldn't get $verify" unless defined $content;

	my ($key,$foaf) = split /\n/,$content;

	if(&verified($redirect,$key)) {

		my $uid = &db_locate($dbh,"person",{person_midm => $redirect});
		if ($uid) {
			$person = &db_get_record($dbh,'person',{person_id => $uid});
			&user_are_go($dbh,$options,$vars,$query,$person);
			exit;

		} else {
			$vars->{person_password} = crypt("password",time);
			$vars->{person_midm} = $redirect;
			if ($foaf) {
				$vars->{person_foaf} = $foaf;
				&parse_url($vars,$vars->{person_foaf});
				unless ($vars->{person_title}) { $vars->{person_title} = $vars->{person_name}; }
			} else {
				$vars->{person_title} = time;
				$vars->{person_email} = $vars->{person_title} . '@newstrolls.com';
			}
			&new_user($dbh,$options,$vars,$query);
		}


		# Get more information, write them a cookie, do whatever you want with your signed-on user here


	} else {
		print "Not verified<p>";
		# Send them to a login screen, whatever
	}
	exit;
}


#   -------------------------------------------------------------------------------------
#
#   record_key
#
#   used by mIDm autologin function
#
#   -------------------------------------------------------------------------------------

sub record_key {
	my ($vars,$person) = @_;

	# Make sure we are recording for the right person
	die "mIDm identity error in record_key()" unless ($vars->{user} eq $person->{user_title});

	die "Key not defined in record_key()" unless ($vars->{key});
	my $keyfile = &sitefile($vars->{site});

	open KEYOUT,">$keyfile" || die "Cannot open keyfile: $!";
	print KEYOUT $vars->{key} || die "Cannot print to keyfile: $!";;
	close KEYOUT;

	print "Content-type: text/html\n";
	print "Location: $vars->{site}?confirm=yes\n\n";
	exit;

}

#   -------------------------------------------------------------------------------------
#
#   return_key
#
#   used by mIDm autologin function
#
#   -------------------------------------------------------------------------------------

sub return_key {
	my $site = shift;
	die "Must specify a site to request from" unless ($site);
	my $keyfile = &sitefile($site); my $key;
	open KEYOUT,"$keyfile" || die "Cannot open keyfile: $!";
	while (<KEYOUT>) { $key = $_; last; }
	close KEYOUT;
	unlink $keyfile;
	print "Content-type: text/html\n\n";
	print "$key\nhttp://www.downes.ca/new_login.cgi?foaf=Downes";
	exit;
}

#   -------------------------------------------------------------------------------------
#
#   sitefile
#
#   used by mIDm autologin function
#
#   -------------------------------------------------------------------------------------

sub sitefile {
	my $sitefile = shift;
	$sitefile =~ s/\?/_/ig;
	$sitefile =~ s/=/_/ig;
	$sitefile =~ s/\&/_/ig;
	$sitefile =~ s/http:\/\///ig;
	$sitefile =~ s/\//_/ig;
	$sitefile =~ s/\./_/g;
	$sitefile .= ".dat";
	#print "Content-type: text/html\n\n";
	#print "$sitefile<p>";
	return $sitefile;
}

#   -------------------------------------------------------------------------------------
#
#   verified
#
#   used by mIDm autologin function
#
#   -------------------------------------------------------------------------------------

sub verified {
	my ($redirect,$content) = @_;
	my $confirmed = 0; my $eek;
	my $datafile = "confirmkeys.dat";
	my $tempfile = "confirmkeys.temp";
	my $backfile = "confirmkeys.bak";
	open KEYS,"$datafile";
	open TEMP,">$tempfile";
	while (<KEYS>) {
		chomp;my ($time,$user,$key) = split /\t/,$_;
		if (($user eq $redirect) && ($key eq $content)) { $confirmed = 1; }
		if ((time-$time)<30) { print TEMP "$time\t$redirect\t$key\n"; }
	}
	unless ($eek) { 	# Rename OLD to BAK, NEW to OLD
		if (-e $datafile) { rename($datafile, $backfile) || die "Cant Rename: $!"; }
		if (-e $tempfile) { rename($tempfile, $datafile) || die "Can't rename: $!"; }
	}
	close KEYS;
	close TEMP;
	return $confirmed;
}


#   -------------------------------------------------------------------------------------
#
#   registration_form_text
#
#   Returns a string containing the registration form
#
#   -------------------------------------------------------------------------------------


sub registration_form_text {
	my ($dbh,$options,$vars) = @_;
	print "Content-type: text/html\n\n";
	my $header = &template($dbh,"top");
	$header =~ s/Welcome/Register - Newsletter Subscription/;
	my $left = &template($dbh,"left");
	print	$header . "<div id=\"centercontent\"><h1>Register - Newsletter Subscription</h1>".
		"<p>$Site->{st_name} collects user information " .							  # Privacy Notice
		"in order to confirm passwords and to properly attribute " .
		"comments and other submissions. " .
   		"User information will remain private and will not be sold to " .
 		"any external agency. For more information, please see our " .
      		"<a href='" . $Base_URL . "/privacy.htm'>Privacy Policy</a>.</p>\n" .
		"<form method='post' action='$script'>\n" .				  # Form
	      	"<p>Select a  user name:<br>\n<input name='person_title' type='text' size=20></p>\n" .	  	  # Userid
		"<p>Enter your email address:<br>\n<input name='person_email' type='text' size='40'></p>\n" .		  # Email Address
		"<p>Select a password:<br>\n<input name='person_password' type='password' size=20></p>\n" .  		  # Password
      		"<p><input type='hidden' name='refer' value='$vars->{refer}'>\n" .				  # Referring URL
		"<input type='hidden' name='action' value='New'>\n" .						  # Action
		"(Optional) Where did you hear about this website?<br/>".
		"<textarea name=\"source\" cols=60 rows=7></textarea></p><p>".
      		"<input type='submit' value='Click here to register'></p>\n" .					  # Submit
      		"</form>\n".												  # End of form
		$left."</div></body></html>";
}

#   -------------------------------------------------------------------------------------
#
#   presents and handles user options
#
#   -------------------------------------------------------------------------------------

sub options {


	my ($dbh,$options,$vars) = @_;

	# Check User Login, Redirect to Login Form
	unless ($person && $person->{person_id} ne 2) {
		$vars->{msg} = "<p>You must be logged in to access options.</p>";
		&login_form_text($dbh,$options,$vars,$person); exit;
	}

	if ($vars->{person_foaf}) { &parse_url($vars,$vars->{person_foaf}); }

	if (($vars->{person_name}) || ($vars->{person_eformat})) {	# Triggers data update
		my $where = { person_id => $person->{person_id}};
		$vars->{person_id} = &db_updater($dbh,"person", $vars, $person->{person_id});
		$options->{msg} .= " Your data has been successfully updated<br/>";
		$person = &get_person($dbh,$query);								# Get User Information
	}

	print "Content-type: text/html\n\n";
	my $header = &template($dbh,"top");
	$header =~ s/<PAGE_TITLE>/Personal Information and Options/;
	print $header;


	print qq|<div id="centercontent"><br/><br/><p>|;
	if ($options->{msg}) { print qq|&nbsp;$options->{msg}<br/>|; }
	print qq|<b>&nbsp;Editing data for UserID: $person->{person_title}</b>
	[<a href="$script?action=Logout">Logout</a>]</p>|;

	&show_subscriptions($person);

	print qq|

		<h1>Personal Information and Options</h1>
		<form method="post" action="$script">
		<input type="hidden" name="action" value="Options">

		<table cellpadding=3>
		<tr><td colspan=2><br/>

		<b>Use FOAF</b>: If you have a FOAF file, enter the URL here and your personal information will be updated
		directly from that file. Please note that a currently <a href="http://xmlns.com/foaf/0.1/">valid FOAF document</a> must be used;
		older FOAF files may not work properly (but it can&apos;t hurt to try, and you can always use the form later).
		<tr><td align="right">FOAF:</td><td><input type='text' size=60 name='person_foaf' value='$person->{person_foaf}'></td></tr>
		</table>
		<p><input type="submit" value="Update Personal Information from FOAF"></p>
		</form>

		<form method="post" action="$script">
		<input type="hidden" name="action" value="Options">
		<table cellpadding=3>
		<tr><td colspan=3><br/><br/><b>- OR -</b><br/><br/><b>Use Form</b>: You may enter personal
		information directly using this form. If you do not have
		a FOAF file and would like one, update your information, then <a href="?foaf=$person->{person_title}">view your FOAF here</a>.
		<br/><b>Please Note:</b> information entered here may be publicly displayed. If you do not wish to display certain
		information, select 'Hide' from the options to the right.<br/></td></tr>
		<tr><td align="right">Title:</td><td><input type='text' size=20 name='person_pref' value='$person->{person_pref}'>
		(Mr., Ms., Professor, Sir, Lord, etc.)</td>|.&show_hide($person,"show_pref").qq|</tr>
		<tr><td align="right">Name:</td><td><input type='text' size=60 name='person_name' value='$person->{person_name}'></td>
		|.&show_hide($person,"show_name").qq|</tr>
		<tr><td align="right">Password:</td><td><input type='password' size=20 name='person_password' value='$person->{person_password}'>
			(Type new password to change password)</td></tr>
		<tr><td align="right">HomePage:</td><td><input type='text' size=60 name='person_html' value='$person->{person_html}'></td>
		|.&show_hide($person,"show_html").qq|</tr>
		<tr><td align="right">Weblog:</td><td><input type='text' size=60 name='person_weblog' value='$person->{person_weblog}'></td>
		|.&show_hide($person,"show_weblog").qq|</tr>
		<tr><td valign="top" align="right">Photo:</td><td><input type='text' size=60
		name='person_photo' value='$person->{person_photo}'><br/>(Enter URL of photo. You should use a small (100x100 or so) photo.)</td>
		|.&show_hide($person,"show_photo").qq|</tr>
		<tr><td valign="top" align="right">Email:</td><td><input type='text' size=60 name='person_email' value='$person->{person_email}'>
		</td>|.&show_hide($person,"show_email").qq|</tr>
		</table>
		<p><input type="submit" value="Update Personal Information from Form"></p>
		</form>
		<h1>mIDm Address</h1>
		<p>Your mIDm address is: $script?user=$person->{person_title} <br/>
		(For more information on mIDm please <a href="http://www.downes.ca/midm.htm">click here</a>).</p>|;



	my $left = &template($dbh,"left");												  # End of form
	print $left."</div></body></html>";
}

sub show_hide {
	my ($person,$item) = @_;
	my $show="";my $hide="";
	if ($person->{$item} eq "show") { $show = " selected"; } else { $hide = " selected"; }
	return qq|<td valign="top"><select name="$item">\n<option value="show"$show>Show</option>\n<option value="hide"$hide>Hide</option>\n</select></td>|;
}

sub show_subscriptions {
	my ($person) = @_;

	# Email Format Options
	my $eformatopts;
	if ($person->{person_eformat} eq "txt") {
		$eformatopts = qq|<option value="txt" selected>Text Only</option><option value="htm">HTML Format</option>|; }
	else { $eformatopts = qq|<option value="txt">Text Only</option><option value="htm" selected>HTML Format</option>|; }

	# Get Array of Subscriptions
	my $stmt = "SELECT subscription_box FROM subscription WHERE subscription_person = '$person->{person_id}'";
	my $ary_ref = $dbh->selectcol_arrayref($stmt);
	print qq|<h1>Email Subscriptions</h1><table cellpadding=3><tr><td colspan=3>
		This table lists all possible subscriptions. Your current subscriptions are in bold. The email you receive,
		in $person->{person_eformat} format, will be a combination of your subscription selections. Click on the
		'subscribe' or 'unsubscribe' links to modify your subscriptions.</td></tr>|;

	print qq|<tr><td colspan=3><form method="post" action="$script">
		<input type="hidden" name="action" value="Options"> Send email in: <select name="person_eformat">$eformatopts</select>
		<input type="submit" value="Update Email Format"><br/>
		Note: HTML Format is strongly recommended unless you have a text-only email client.</td></tr>|;

	# Get Possible Subscriptions
	my $stmt = qq|SELECT * FROM box|;
	my $sth = $dbh -> prepare($stmt);
	$sth -> execute();
	while (my $box = $sth -> fetchrow_hashref()) {
		print "<tr>";
		unless ($box->{box_txt_version}) { $box->{box_txt_version} = "-1"; }
		next unless ($box->{box_sub} && $box->{box_format} eq "htm");
		my $day = " (Publishes " . ($box->{box_day} || "every weekday").")";
		if (&index_of($box->{box_id},$ary_ref) ne "-1") {
			print qq|<td valign='top'><b>[<a href="$script?action=drop&sub=$box->{box_id}">Unubscribe</a>]</b></td>
			<td><b>$box->{box_title} $day</b><br/>$box->{box_description}</td>|;
		} elsif (&index_of($box->{box_txt_version},$ary_ref) ne "-1") {
			print qq|<td valign='top'><b>[<a href="$script?action=drop&sub=$box->{box_id}">Unubscribe</a>]</b></td>
			<td><b>$box->{box_title} $day</b><br/>$box->{box_description}</td>|;
		} else {
			print qq|<td valign='top'>[<a href="$script?action=add&sub=$box->{box_id}">Subscribe</a>]</td>
				<td>$box->{box_title} $day</b><br/>$box->{box_description}</td>|;
		}
		print "<tr>";
	}
	print "</table>";
}

sub add_subscription {

	my ($dbh,$vars,$person) = @_;
	return unless ($vars->{sub});

	my $pid = $person->{person_id};my $sb = $vars->{sub};
	my $curtime = time;

	$dbh->do(qq{INSERT INTO subscription SET subscription_box=?, subscription_person=?, subscription_crdate=?},
		undef,$sb,$pid,$curtime);

	my $subid = $dbh->{'mysql_insertid'};
	unless ($subid) { &error("For some unknown reason your subscription failed. Please try again later once the database is fixed."); }
	&notify_subscribe($person,"Subscribe",$sb);
	return;
}


sub drop_subscription {

	my ($dbh,$vars,$person) = @_;
	return unless ($vars->{sub});

	my $pid = $person->{person_id};my $sb = $vars->{sub};
	my $curtime = time;

	# Remove Previous Subscriptions
	my $stmt = "DELETE FROM subscription WHERE subscription_person=? AND subscription_box=?";
	my $sth = $dbh->prepare($stmt);
	$sth->execute($pid,$sb);
	&notify_subscribe($person,"Unsubscribe",$sb);
	return;
}

sub notify_subscribe {

	my ($person,$action,$boxid) = @_;

	my $boxtitle; my $msg;
	if ($boxid) {
		my $stmt = qq|SELECT box_title FROM box WHERE box_id = ?|;
		my $sth = $dbh -> prepare($stmt);
		$sth -> execute($boxid);
		my $box = $sth -> fetchrow_hashref();
		$boxtitle = $box->{box_title};
	}

	if ($action eq "Subscribe") { $msg = "\n	You have successfully subscribed to $boxtitle. Congratulations.\n"; }
	elsif ($action eq "Unsubscribe") { $msg = "\n	You have successfully unsubscribed from $boxtitle. Sorry it did not work out for you.\n"; }

	$msg = $msg . qq|
	You can always change your personal information, email address
	and subscriptions. Simply click on the following link:\n
	|.$script.qq|?action=Options\n
	-- Stephen
	|;

	my $from = q|Stephen Downes <stephen@downes.ca>|;
	my $subj = "Stephen's Web: $action";
	my $to = $person->{person_email};
	&send_email($to,$from,$subj,$msg);

	# Send Email to Admin
	my $pagetext = qq|

	$action:

	Userid: $person->{person_title}
	Email: $person->{person_email}
	Subscription: $boxtitle

	|;
	&send_email($from,$from,$subj,$pagetext);
	return;
}
#   -------------------------------------------------------------------------------------
#
#   foaf
#
#   Display foaf for UserID
#
#   -------------------------------------------------------------------------------------

sub foaf {
	my ($dbh,$options,$vars) = @_;
	my $stmt = qq|SELECT * FROM person WHERE person_title=?|;
	my $sth = $dbh -> prepare($stmt);
	$sth -> execute($vars->{foaf});
	my $foafperson = $sth -> fetchrow_hashref();

	my $data = "";

	if ($foafperson->{person_name} && $foafperson->{show_name} eq "show") {
		$data .= qq|  <foaf:name>$foafperson->{person_name}</foaf:name>\n|; }

	if ($foafperson->{person_pref} && $foafperson->{show_pref} eq "show") {
		$data .= qq|  <foaf:title>$foafperson->{person_pref}</foaf:title>\n|; }

	if ($foafperson->{person_title} && $foafperson->{show_title} eq "show") {
		$data .= qq|  <foaf:nick>$foafperson->{person_title}</foaf:nick>\n|; }

	if ($foafperson->{person_html} && $foafperson->{show_html} eq "show") {
		$data .= qq|  <foaf:homepage rdf:resource="$foafperson->{person_html}"/>\n|; }

	if ($foafperson->{person_email} && $foafperson->{show_email} eq "show") {
		$data .= qq|  <foaf:mbox rdf:resource="mailto:$foafperson->{person_email}"/>\n|; }

	if ($foafperson->{person_weblog} && $foafperson->{show_weblog} eq "show") {
		$data .= qq|  <foaf:weblog rdf:resource="$foafperson->{person_weblog}"/>\n|; }

	if ($foafperson->{person_photo} && $foafperson->{show_photo} eq "show") {
		$data .= qq|  <foaf:depiction rdf:resource="$foafperson->{person_photo}"/>\n|; }

	print qq|Content-type: text/xml\n\n|;
	print qq|<rdf:RDF
      xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
      xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" 
      xmlns:foaf="http://xmlns.com/foaf/0.1/"> 

<foaf:Person>
$data
</foaf:Person>
 
</rdf:RDF>
	|;
}


#   -------------------------------------------------------------------------------------
#
#   new_user
#
#   Accepts forms input and registers new user.
#
#   -------------------------------------------------------------------------------------

sub new_user {


	my ($dbh,$options,$vars,$query) = @_; my $table = 'person';

	unless ( ($vars->{person_title}) &&									# Unless Userid completed
		  ($vars->{person_email}) &&									# and Email completed
		  ($vars->{person_password})) {									# and Password completed
		&error("You must provide your name, email address and a password."); }				# Generate Error

	my ($to) = $vars->{person_email};									# Check email address
	if ($to =~ m/[^0-9a-zA-Z.\-_@]/) { &error("Bad Email"); }

	if (&db_locate($dbh,"person",{person_email => $vars->{person_email}}) ) {				# Unique Email
		&error("Someone else is using this email address."); };

	if (&db_locate($dbh,"person",{person_email => $vars->{person_title}}) ) {				# Unique Name
		&error("Someone else named $vars->{person_title} has already registered."); };

	my $idname = $table."_id";my $idval = 'new';								# Crteate the User Record
	$vars->{key} = &db_insert($dbh,$table,$vars,$idval);

	$options->{new} = "yes";

	# Send email to user
	my $pagetext = qq|


	Welcome to $Site->{st_name}. It's nice to have you aboard.

	This email confirms your new user registration. Please save it in a safe place.
	In order to post comments on the website, you will need to login with your
	userid and password.

	Your userid is: $vars->{person_title}
	Your password is: $vars->{person_password}

	Should you forget your userid and password, you can always have them sent to
	you at this email address.

	Your mIDm server location is: $script?user=$vars->{person_title}
	(Information on mIDm is here: http://www.downes.ca/midm.htm )

	-- $Site->{st_crea}
	|;

	my $from = q|Stephen Downes <stephen@downes.ca>|;
	my $subj = "Welcome to Stephen's Web";
	&send_email($vars->{person_email},$from,$subj,$pagetext);

	# Send Email to Admin
	my $pagetext = qq|

	New User Registration:

	Userid: $vars->{person_title}
	Email: $vars->{person_email}

	Source:

	$vars->{source}

	|;
	&send_email($from,$from,$subj,$pagetext);
	&user_login($dbh,$options,$vars,$query,$person);									# Log in the new user
}

#   -------------------------------------------------------------------------------------
#
#   user_logout
#
#   Form to request password sent to the user's email address
#
#   -------------------------------------------------------------------------------------

sub user_logout {
	my ($dbh,$options,$vars) = @_;
	print "Content-type: text/html\n";				  # Print HTTP header
	#,-expires=>'-1y',-path=>'/',-domain=>'.downes.ca',-secure=>0
	my $cookie1 = $query->cookie(-name=>'person_id',-value=>'2',-expires=>'-1y',-path=>'/',-domain=>$Site->{co_host},-secure=>0);
        my $cookie2 = $query->cookie(-name=>'person_title',-value=>'Anymouse',-expires=>'-1y',-path=>'/',-domain=>$Site->{co_host},-secure=>0);
        print $query->header(-cookie=>[$cookie1,$cookie2]);
	print "\n\n";							  # Complete HTTP header

	my $header = &template($dbh,"top");
	$header =~ s/Welcome/Logout Successful/m;
	my $left = &template($dbh,"left");
	print $header;
	print "<div id=\"centercontent\"><h1>Logout successful</h1>";
	&print_nav_options($dbh,$options,$vars);
	print $left."</div></body></html>";
}

#   -------------------------------------------------------------------------------------
#
#   print_nav_options
#
#   Print Navigation Options
#
#   -------------------------------------------------------------------------------------

sub print_nav_options {
	my ($dbh,$options,$vars) = @_;

	print "<p><ul>";
	print qq|<li><a href="$script?action=Options&refer=$vars->{refer}">Edit Your Personal Information and Options</a></li>|;
	if ($vars->{refer}) {
		my $rf = $vars->{refer}; $rf =~ s/AND/&/g;
		print qq|<li><a href="$rf">Go back to where you were</a></li>|;
	}
	print qq|<li><a href="$Base_URL">Go to the site home page</a></li>|;
	print qq|<li><a href="$script?refer=$vars->{refer}">Log on as another user</a></li>|;
	print qq|</ul></p>|;

}

#   -------------------------------------------------------------------------------------
#
#   email_password
#
#   Form to request password sent to the user's email address
#
#   -------------------------------------------------------------------------------------

sub email_password {
	my ($dbh,$options,$vars) = @_;
	print "Content-type: text/html\n\n";
	my $header = &template($dbh,"top");
	$header =~ s/Welcome/Retrieve Password/m;
	my $left = &template($dbh,"left");
	print $header;
	print "<div id=\"centercontent\"><h1>Retrieve Password</h1>";

	print "<form method=\"post\" action=\"$script\">\n" .	# Form
		"<p>Enter your Email Address:\n" .
		"<input type=\"hidden\" name=\"refer\" value=\"$vars->{refer}\">" .
		"<input type='text' size='20' name='person_email'>\n" .
		"<input type='hidden' name='action' value='Send'></p>\n" .	# Send
		"<p><input type=\"submit\" value=\"Click Here\"></p>\n" .	# Submit
		"</form>\n";							# End form
	&print_nav_options($dbh,$options,$vars);
	print $left."</div></body></html>";
}


#   -------------------------------------------------------------------------------------
#
#   send_password
#
#   Sends password to the user's email address
#
#   -------------------------------------------------------------------------------------

sub send_password {
	my ($dbh,$options,$vars) = @_;
   	print "Content-type: text/html\n\n";		     		# Print HTML header

	unless ($vars->{person_email}) { &error("Please enter your email address."); }

	my $header = &template($dbh,"top");
	$header =~ s/Welcome/Send Password/m;
	my $left = &template($dbh,"left");
	print $header;
	print "<div id=\"centercontent\"><h1>Send Password</h1>";
	print "<p>Searching for $vars->{person_email} </p>";
	my $person = &db_get_record($dbh,'person',{person_email => $vars->{person_email}});
	unless ($person) { &error("Could not find $vars->{person_email} in my database."); }	# User exists?
	unless ($person->{person_email}) { &error("Could not find your email address."); }		# With email addy?
	&send_email($person->{person_email},$person->{person_email},
		"Your Password from Stephen's Web",
		"Your UserID: $person->{person_title}\n" .
		"Password: $person->{person_password}\n\n");			# Send the Password
	print "<p>Your password has been sent to $person->{person_email} </p>";
	&print_nav_options($dbh,$options,$vars);
	print $left."</div></body></html>";
}

#   -------------------------------------------------------------------------------------
#
#   error
#
#   Prints an error and exits
#
#   -------------------------------------------------------------------------------------


sub error {

	my @err = @_;
	print "Content-type:text/html\n\n";

	print "<h1>Error</h1>";
	foreach my $e (@err) { print "<p>$e </p>"; }
	print qq{<p><a href="">Return to Main Menu</a></p>};
	print "</body></html>";
	exit;
}







#   -------------------------------------------------------------------------------------
#
#   send_email
#
#   Sends email, given the usual email variables
#
#   -------------------------------------------------------------------------------------


sub send_email {
	my $Mailprog = "/usr/sbin/sendmail";
	my ($to,$from,$subj,$pagetext) = @_;
	open (MAIL,"|$Mailprog -t") or print "Can't find email program $Mailprog";
	print MAIL "To: $to\nFrom: $from\nSubject: $subj\n\n$pagetext";
	close MAIL;

}




sub template {
	my ($dbh,$title,$options,$person) = @_;
	my $templ;
	if ($options->{template}->{$title}) {						 		# cached
		$templ = $options->{template}->{$title};
	} else {											# not cached
		my $stmt = qq|SELECT * FROM template WHERE template_title = ?|;
		my $sth = $dbh -> prepare($stmt);
		$sth -> execute($title); $options->{execute}++;
		my $ref = $sth -> fetchrow_hashref();
		$options->{template}->{$title} = $ref->{template_description}; # Cache
		$templ = $ref->{template_description};
	}

	while ($templ =~ /LOGIN_OPTIONS/sg) {								# login options
		my $replace = &login_options($dbh,$vars,$options,$person);
		$templ =~ s/LOGIN_OPTIONS/$replace/sig;
	}

	return $templ;
}

#   -------------------------------------------------------------------------------------
#
#   get_person
#
#   Gets login information based on cookie data
#
#   -------------------------------------------------------------------------------------

sub get_person {

	# Get Person Info from Cookies
	my ($dbh,$query) = @_;
	my $person_title = $query->cookie('person_title');
	my $person_id = $query->cookie('person_id');
	unless (($person_title) && ($person_id)) {
		$person_title = "Anymouse"; $person_id = 2;
	}

	# Get Person Data
	my $stmt = qq|SELECT * FROM person WHERE person_title = ? AND person_id = ?|;
	my $sth = $dbh -> prepare($stmt);
	$sth -> execute($person_title,$person_id);
	$person = $sth -> fetchrow_hashref();
	unless ($person) { &login_form_text($dbh,$options,$vars) ; exit; } # Login Failure

	$person->{posts} = {};
	return $person if ($person_title eq "Anymouse");

	# Get Person Posts-to-read Info
	$person->{posts} = {};
	$stmt = qq|SELECT * FROM posttoread WHERE pr_person = ?|;
	$sth = $dbh -> prepare($stmt);
	$sth -> execute($person->{person_id});
	while (my $ref = $sth -> fetchrow_hashref()) {
		my $thr = $ref->{pr_thread};
		unless ($person->{posts}->{$thr}) { $person->{posts}->{$thr} = []; }
		push @{$person->{posts}->{$thr}},$ref->{pr_post};
	}
	return $person;
}

#----------------------------------------------------------------------------
#
#   Database Functions
#
#----------------------------------------------------------------------------

sub db_columns {

	my ($dbh,$table) = @_;
	my @columns = ();								# Get a list of columns safeguard data input
	my $showstmt = "SHOW COLUMNS FROM $table";
	my $sth = $dbh -> prepare($showstmt);
	$sth -> execute();
	while (my $showref = $sth -> fetchrow_hashref()) { push @columns,$showref->{Field}; }
	return @columns;
}

sub db_open {

	my ($dsn,$user,$password) = @_;
	my $dbh = DBI->connect($dsn, $user, $password)
		or die "Database connect error: $! \n";
	  if ($dbh) { $dbh->trace(2,"dberror.txt"); }
	return $dbh;
}

sub db_get_record {

	my ($dbh,$table,$value_arr) = @_;
	my @value_list; my @value_vals;
	while (my($kx,$ky) = each %$value_arr) { push @value_list,"$kx=?"; push @value_vals,$ky; }
	my $value_str = join " AND ",@value_list;
	return unless ($value_str);
	my $stmt = "SELECT * FROM $table WHERE $value_str";
	my $sth = $dbh -> prepare($stmt);
	$sth -> execute(@value_vals);
	my $ref = $sth -> fetchrow_hashref();
	return $ref;
}

sub db_updater {		# Updates record $where (must be ID) in table from hash

	my $dbh = shift || die "Database handler not initiated";
	my $table = shift || die "Table not specified on update";
	my $input = shift || die "No data provided on update";
	my $id = shift || die "Record ID not specified on update";
	die "Unsupported data type specified to update" unless ref $input eq 'HASH';

	my $data = &db_prepare_input($dbh,$table,$input);
	my $sql = "UPDATE $table SET ";
	my(@sqlf, @sqlv) = ();

	for my $k (sort keys %$data) {
		push @sqlf, "$k = ?";
		push @sqlv, $data->{$k};
        }

	$sql .= join ', ', @sqlf;
	$sql .= " WHERE ".$table."_id = '".$id."'";

	my $sth = $dbh->prepare($sql);
    	$sth->execute(@sqlv);

	return $id;

	# Adapted from SQL::Abstract by Nathan Wiger
}

sub db_insert {		# Inserts record into table from hash

	my $dbh = shift || die "Database handler not initiated";
	my $table = shift || die "Table not specified on insert";
	my $input = shift || die "No data provided on insert";
	die "Unsupported data type specified to insert" unless ref $input eq 'HASH';
	my $data= &db_prepare_input($dbh,$table,$input);

	my $sql   = "INSERT INTO $table ";

	my(@sqlf, @sqlv, @sqlq) = ();

	for my $k (sort keys %$data) {
		push @sqlf, $k;
		push @sqlq, '?';
		push @sqlv, $data->{$k};
	}
	$sql .= '(' . join(', ', @sqlf) .') VALUES ('. join(', ', @sqlq) .')';

	my $sth = $dbh->prepare($sql);
    	$sth->execute(@sqlv);

	return $dbh->{'mysql_insertid'};

	# Adapted from SQL::Abstract by Nathan Wiger
}

sub db_update {
#print "DB Update<br>";
	my ($dbh,$table,$id,$record) = @_; my $fieldvals = {};
	my $idkey = $table."_id"; my $where = { $idkey => $id };		# Define item to update
	my @columns = &db_columns($dbh,$table);					# Get a list of columns safeguard data input
	my $idfield = $table."_id";
	foreach my $ikeys (keys %$record) {					# Clean input for save
		next unless ($record->{$ikeys});				#   - no blank fields
		next if ($ikeys eq /$idfield/);				#   - do not change ID
		next unless (&index_of($ikeys,\@columns) >= 0);			#   - input column must exist
		$fieldvals->{$ikeys} = $record->{$ikeys};
	}

	my $sql = SQL::Abstract->new;
	my($stmt, @bind);
	if ($id eq "new") {							# Create
		my $crdkey = $table."_crdate";
		$fieldvals->{$crdkey} = time;
		($stmt, @bind) = $sql->insert($table, $fieldvals);
	} else {								# Update
		($stmt, @bind) = $sql->update($table, $fieldvals, $where);
	}

#print "$stmt <br>";
#print join ", ",@bind;print "<p>";
	my $sth = $dbh->prepare($stmt);
    	$sth->execute(@bind);
	return $dbh->{'mysql_insertid'} || $id;
}

sub db_prepare_input {	# Filters input hash to contain only columns in given table

	my ($dbh,$table,$input) = @_;
	my $data = ();

	my @columns = &db_columns($dbh,$table);				# Get a list of columns safeguard data input
	foreach my $ikeys (keys %$input) {				# Clean input for save
		next unless ($input->{$ikeys});					#   - no blank fields
		next if ($ikeys =~ /_id/i);					#   - do not change ID
		next unless (&index_of($ikeys,\@columns) >= 0);			#   - input column must exist
		$data->{$ikeys} = $input->{$ikeys};			# Transfer to input hash
	}

	return $data;

}

sub db_locate {

	my ($dbh,$table,$vals) = @_;

	die "db_locate(): Cannot locate with no values" unless ($vals);
	my $stmt = "SELECT ".$table."_id from $table WHERE ";
	my $wherestr = ""; my @whvals;
	while (my($vx,$vy) = each %$vals) {
		if ($wherestr) { $wherestr .= ", "; }
		$wherestr .= "$vx = ?";
		push @whvals,$vy;
	}
	$stmt .= $wherestr . " LIMIT 1";
	my $sth = $dbh->prepare($stmt);
	$sth->execute(@whvals);
  	my $hash_ref = $sth->fetchrow_hashref;
	return $hash_ref->{$table."_id"};

}

#----------------------------------------------------------------------------
#
#   FOAF Functions
#
#----------------------------------------------------------------------------

sub parse_url {


	my ($vars,$url) = @_;
	scalar $url or die "usage: shownodes xmlfile\n";

	use LWP::Simple;
	my $content = get $url;
	die "Could not get $url" unless defined $content;

	my $parser = XML::LibXML->new();
	my $tree = $parser->parse_string($content);
	my $root = $tree->getDocumentElement;
	&show($vars,$root->childNodes);

#exit;


}

sub show {
    my ($vars,@nodes) = @_;

    my $personctr = 0;
    foreach my $node (@nodes) {
	next if ($node->nodeName eq "text");
	next if ($node->nodeName eq "comment");
	next if ($node->nodeName eq "knows");
	next if ($personctr > 0);
	if ($node->nodeName =~ /person/i) { $personctr++; }	# One person only

	my $nodetext = $node->findvalue("./text()");
	if ($nodetext) { $nodetext =~ s/(\n|\r)/ /g; $nodetext =~ s/\s+/ /g; if ($nodetext eq " ") { $nodetext = ""; } }
	$nodetext =~ s/'/\\'/g;
	my $aname = 'resource';
	my $avalue = $node->getAttribute( $aname );

	#print $node->nodeName." = ".$nodetext." or ".$avalue."<br>";
	unless ($vars->{person_name}) { if ($node->nodeName =~ /foaf:name/i) { $vars->{person_name} = $nodetext; } }
	unless ($vars->{person_pref}) { if ($node->nodeName =~ /foaf:title/i) { $vars->{person_pref} = $nodetext; } }
	#unless ($vars->{person_title}) { if ($node->nodeName =~ /foaf:nick/i) { $vars->{person_title} = $nodetext; } }
	unless ($vars->{person_email}) { if ($node->nodeName =~ /foaf:mbox/i) { $vars->{person_email} = $avalue; $vars->{person_email} =~ s/mailto://g;} }
	unless ($vars->{person_html}) { if ($node->nodeName =~ /foaf:homepage/i) { $vars->{person_html} = $avalue;  } }
	unless ($vars->{person_weblog}) { if ($node->nodeName =~ /foaf:weblog/i) { $vars->{person_weblog} = $avalue;  } }
	unless ($vars->{person_photo}) { if ($node->nodeName =~ /foaf:depiction/i) { $vars->{person_photo} = $avalue;  } }
	unless ($vars->{person_description}) { if ($node->nodeName =~ /foaf:plan/i) { $vars->{person_description} = $nodetext;  } }
	unless ($vars->{person_organization}) { if ($node->nodeName =~ /foaf:Organization/i) { $vars->{person_organization} = $nodetext; } }


	show($vars,$node->childNodes);
    }

}