#!/usr/bin/perl 
##  RPH -- 991008 -- added -w
##  --- the -w causes all sorts of carping ...
#use strict;
## -- strict is very unhappy
## -- and don't even ask about Taint
#
# A computer support tracking system using web and email for a multi-level
# supporting structure, encouraging info sharing among all the independent
# local supporting groups.
#
# Author: Yunliang Yu <yu@math.duke.edu> 4/18/97
#
# Copyright (C) 1997,1998 Yunliang Yu.
# Distributed under the terms of the GNU General Public License, see 
# the 'Fine Print' section in the file 'req-null'.
#
############################################################################
####### RPH Custom #########################################################
############################################################################
##
##	changes to clean up and enhance the code by:
##		herrold@owlriver.com
##
##	RPH -- 990929 -- add the local directory to @INC
##
use lib './.';
##
##	RPH -- 991008 -- isolate versioning info
##
$version='2.7';
$version_date='Sept. 13, 1999';
##
##	RPH -- 991008 -- added more capable cookie expiration
##
$cookie_last = '+36h';
##
############################################################################
####### Data Structure #####################################################
############################################################################
# Special Characters:
# 	$fs		field separator within a record for all files & databases
# Directory Structure / File Formats:
# top/ (PWD)
#  req/
#	  1/
#		 active (gdbm):
#			 req#= 0req:# 1name 2uid 3email 4location 5date 6duedate 
#				   7priority:# 8owner:-uid 9status 10blink:uid/all 
#				   11lastactdate 12ostype 13area 14subject 
#				   15description 16mailheader 17actionlogs
#				   18allview(y|n|'') 19lastemail 20lastact 39rhost 40raddr 
#			 req#= ... 41'MERGED' 42loglength 43uids, 44emails, 45req# .....
#				with original req#s' field 41 set to 'merged', 42 to req#.
#				field 42 is the length of original 17actionlogs.
#				This req#'s 17actionlogs is the only one updated of all merged
#			 req#=   ... 41"merged" 42req:#
#		 nextid: (text, next available req id number, start from 1)
#			 #
#		 resolved/
#			 year/
#				 month (gdbm)
#		 deleted/
#			 year/
#				 month (gdbm)
#		 all (gdbm): short record of all undeleted req#s, for quickaccess
#			 req#=0gdbm_filename   or  req#=0group_number 1req# for moved req
#		 log (text): log file for some of the actions
#			 date active req# email raddr action byemail
#			 date resolved/year/month req# email raddr action byemail
#		 msig (gdbm): time stamp for all incoming email messages
#			 "email category req subject checksum" = time
#	  2/
#	     ......
#	  passwd (gdbm): passwords and netscape cookie database
#			 email=0cpass : 1auth : 2name : 3uid : 4location : 5rhost : 6raddr
#		   AUTHENTICATION RULES: Users are identified by the auth code
#		   and email address. We assume auth code(kept in user's
#		   cookies file) is as secure as identifying a user by email
#		   address or as secure as a poweruser's cookies file.
#		   auth/email pairs are unique in the database and poweruser
#		   must have a password (default to the dept's password if
#		   not). When a user logs in or submit a new request, his auth
#		   code is checked to see if the entered email address matches
#		   the one already in the database. If it matches, check any
#		   password and if he is a poweruser. If it doesn't match,
#		   check to see the same email address occurs in another auth
#		   code record. If it doesn't occur anywhere else, update the
#		   user's current auth code with any new info; otherwise, don't
#		   update the current auth code, and ask the user to login with
#		   password if the entered email address belongs to a
#		   poweruser.
#	  config (gdbm):
#			group#=0full 1faqhosts 2reqhosts 3emails 4reqhostsregex(|) 
#					5emails, 6priorities:# string 7cpass 8uid 9email 
#					10groupname 11group# 12emailreq 13faqhostsregex(|) 
#					14reqemail 15rooturl 16ostypes 17areas 18allview(*|'')
#					19emailreqs 20autoreply 21silent 22dsctempl 23reopen
#					24subscrible(*|'') 25subscribers 26groupinfo 27msg
#					28#active 29header 30restrictbyemail 31passmust
#					32statuses 39rhost 40raddr 
#			0=defaultgroup#
#  faq/ tech/ syslog/ sos/
#	  0/  root server global faqs/sos  yuyu
#	  1/
#		 current (gdbm): (use the same format as for req)
#			id#= 0id# 1name 2uid 3email 5date 8authors:uid,
#				 12ostype 13area 14subject 15description
#				 16mailheader 17req# 18rootid# 39rhost 40raddr
#		 nextid: (text, next available req id number, from 1)
#		 	#
#		 old (gdbm): deleted outdated entries
#		 log (text):
#			date current/old id# email rhost raddr action
#		 heads (gdbm): (not used, planned for a 'req-listfaq' GUI)
#			id#=0id# 1name 2headid 3headlink#s, 4faq#s,
#			    5uid 6email 7rhost 8raddr
#			where headid is its leading head's id#, headlink#s are the heads
#			follwoing it, faq#s are faqs following this head.
#			id 0 heads all headless faqs.
#		 net.html (collection of Internet search engines and databases)
#	  2/ ....
#
# Global Variables/Functions:
#	%cookies=auth:email   in base64
#		cookies are saved after login, zero all on logout in cookie file
#	$warn	warning message for browser not supporting cookies
# 	$auth	netscape cookie for current user auth
# 	$name $uid $email $location	   current user's name,uid,email,location
# 	$now @now $month $year $today $expire_now $expire	various time constants
#	@dept 	a dept's array
#	@ostypes	OS types array for this server
#	@areas	problem/request area for this server
#	@priorities	priority array for this server
#	$poweruser	if current user is on the req-dist list
#	$rhost $raddr	browser's hostname and IP number
# 	%DBM OUT IN LOCK	gdbm hash, output/input/lock filehandle
#	$top	top dir of the req data
#	$scriptdir	absolute dir name where all the req* scripts reside
# 	
# gmtime:
# 	0sec(0-61) 1min(0-59) 2hour(0-23) 3mday(1-31) 4mon(0-11) 5year(+1900)
# 	6wday(0-6) 7yday(0-365) 8isdst
####################################################################
# TODO: marked with yuyu
#	upload/list/search the root server
#
#	what to do with Cc: req w/o a req#? Cc: To: what action?
#
#	fix all log and usage info
#
#	a req might apply to more than one element of @ostypes or @areas
#	
#	For PhoneBook button, it should search the existing users in passwd too;
#	list related users after the phonebk results
#
#	large database? sort?
#
#	dynamic html outline for faq list?
#
#	reduce #trips to the server by rewriting some forms in javascript
#
#	alert and reminder for overdue requests
#
#	asset/user/skill/purchase tracking
#
#	profile requests and users
#
#	option to resync req/*/all file, if users delete some old DBM files
#
#	define API to forward requests to another wreq server or an email address
#
#	Rewrite all in OO way. 
#
#	Tie into SQL server using JDBC and maybe Corba.
#
#	Make all email address case insentive
#
####################################################################
# load in global config params
require "$0-config";
##
##	RPH  990929   
##
## use "$0-config-local";
####################################################################
$url="$ENV{'SCRIPT_NAME'}";
$server="$ENV{'SERVER_NAME'}";# set in server's conf file
$port=$ENV{'SERVER_PORT'}==80?'':":$ENV{'SERVER_PORT'}";
$http=$ENV{'HTTPS'} eq 'on'?'https':'http';# secure server
$fullurl="$http://$server$port$url";
$rhost="$ENV{'REMOTE_HOST'}";
$raddr="$ENV{'REMOTE_ADDR'}";
$ruser="$ENV{'REMOTE_USER'}" if $useHTTPauth; # set it only when .htaccess user auth is used
# other useful ENVs: HTTP_USER_AGENT, SERVER_SOFTWARE, HTTP_REFERER, LANG, TZ

$now=time; 
$expire_now='Wed, 09-Nov-1990 23:12:40 GMT'; # expire now, works
$expire='Mon, 09-Nov-2020 23:12:40 GMT'; # good until year 2020

##
##	RPH -- get cookies expiring reasonably -- 991008
##
$expire= expire_calc($cookie_last);

## The following code from Lincoln Stein's CGI.pm -- ver. CGI.pm,v 1.18
# This internal routine creates an expires time exactly some number of
# hours from the current time.  It incorporates modifications from 
# Mark Fisher.
##
sub expire_calc {
    my($time) = @_;
    my(%mult) = ('s'=>1,
                 'm'=>60,
                 'h'=>60*60,
                 'd'=>60*60*24,
                 'M'=>60*60*24*30,
                 'y'=>60*60*24*365);
    # format for time can be in any of the forms...
    # "now" -- expire immediately
    # "+180s" -- in 180 seconds
    # "+2m" -- in 2 minutes
    # "+12h" -- in 12 hours
    # "+1d"  -- in 1 day
    # "+3M"  -- in 3 months
    # "+2y"  -- in 2 years
    # "-3m"  -- 3 minutes ago(!)
    # If you don't supply one of these forms, we assume you are
    # specifying the date yourself
    my($offset);
    if (!$time || (lc($time) eq 'now')) {
        $offset = 0;
    } elsif ($time=~/^\d+/) {
        return $time;
    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
        $offset = ($mult{$2} || 1)*$1;
    } else {
        return $time;
    }
    return (time+$offset);
}
##

# This internal routine creates date strings suitable for use in
# cookies and HTTP headers.  (They differ, unfortunately.)
# Thanks to Mark Fisher for this.
##
sub expires {
    my($time,$format) = @_;
    $format ||= 'http';

    my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

    # pass through preformatted dates for the sake of expire_calc()
    $time = expire_calc($time);
    return $time unless $time =~ /^\d+$/;

    # make HTTP/cookie date string from GMT'ed time
    # (cookies use '-' as date separator, HTTP uses ' ')
    my($sc) = ' ';
    $sc = '-' if $format eq "cookie";
    my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time);
    $year += 1900;
    return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT",
                   $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec);
}
##

##  ends expiration of cookies logic

$fs="\035"; # don't change

if(! -d $top){
	&html_error("Error, the req directory \"$top\" doesn't exist.");
}
chdir $top || &html_error("Error, can't cd to top.");
push @INC,$scriptdir; # `pwd` doesn't work here, since perl is interpreted
umask 022;

$oldauth=$auth=$warn='';
if($ruser){$email=$ruser;}else{
if(defined($ENV{'HTTP_COOKIE'})){# it still could be empty
	#&html_error($ENV{'HTTP_COOKIE'});
	if($ENV{'HTTP_COOKIE'} =~ /(^|; )cookies=([^; ]+)/){
		($auth,$email)=split ':',&decode_base64($2),2;
		$oldauth=$auth; #&html_error("$auth,$email");
    }
}else{
	$warn="<p><em>Your browser doesn't support cookies, or the support was disabled; " .
		  "Please use a capable browser or enable cookie support, and try again.</em><p>\n";
}}

$OK_CHARS='a-zA-Z0-9_\-\.@&\+=%\*\/';# AES 11-11-97, CERT Advisory CA-97.25
if ($ENV{'REQUEST_METHOD'} eq 'POST') { # handle FORM inputs
	read(STDIN,$buffer, $ENV{'CONTENT_LENGTH'});
	#&html_error("$buffer"); # get all urlencoded ascii chars for $OK_CHARS
	$buffer =~ s/[^$OK_CHARS]/_/g;
	my @pairs=split(/&/,$buffer);
	foreach $pair (@pairs) {
		my($name,$value) = split(/=/,$pair,2);
		$value=~ tr/+/ /; # urldecode $name too?
		$value=~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
		# limit the size of name/value, to prevent possible misuse:
		if(length($name) > 100){ $name=substr($name,0,100) . '...';}
		if(length($value) > 50000){ $value=substr($value,0,50000) . '...';}
		$FORM{$name}.=$fs if (defined($FORM{$name})); # multiple selections
		$FORM{$name}.=$value;
	}
	if (!$FORM{'action'}) {
		&html_error("Error, no action supplied in FORM!");
	}
	if ($FORM{'action'} eq 'create'){
		require 'req-create';
		if($FORM{'send'} ne 'Delete'){
			&createSupport;
		} else {
			&deleteSupport;
		}
	} elsif ($FORM{'action'} eq 'newreq'){
		if($FORM{'send'} eq 'PhoneBook'){
			require 'req-socket';
			&phoneBook;
		}else{
			require 'req-newreq';
			&newReq;
		} 
	} elsif ($FORM{'action'} eq 'newfaq'){
		require 'req-showfaq';
		&newFaq;
	} elsif ($FORM{'action'} eq 'update'){
		if($FORM{'send'} eq 'PhoneBook'){
			require 'req-socket';
			&phoneBook;
		}else{
			require 'req-update';
			&updateReq;
		}
	} elsif ($FORM{'action'} eq 'updatefaq'){
		require 'req-showfaq';
		&updatefaq;
	} elsif ($FORM{'action'} eq 'emailfaq'){
		require 'req-showfaq';
		&emailfaq;
	} elsif ($FORM{'action'} eq 'givegive'){
		require 'req-update';
		&givegiveReq;
	} elsif ($FORM{'action'} eq 'movereq'){
		require 'req-update';
		&moveReq;
	} elsif ($FORM{'action'} eq 'mergereq'){
		require 'req-update';
		&mergeReq;
	} elsif ($FORM{'action'} eq 'receivemail'){
		require 'req-newreq';
		&receivemail;
	} elsif ($FORM{'action'} eq 'login'){
		if($FORM{'send'} eq 'PhoneBook'){
			require 'req-socket';
			&phoneBook;
		}else{
			require 'req-login';
			&login;
		}
	} elsif ($FORM{'action'} eq 'status'){
		require 'req-status';
		&status;
	} elsif ($FORM{'action'} eq 'search'){
		require 'req-list';
		&search;
	} elsif ($FORM{'action'} eq 'newheader'){
		require 'req-listfaq';
		&newHeader;
	} elsif ($FORM{'action'} eq 'deluser'){
		require 'req-create';
		&deluser;
	} elsif ($FORM{'action'} eq 'listshow'){
		require 'req-show';
		&listshow;
    } elsif ($FORM{'action'} eq 'group'){
        require 'req-list';
        &setGroup;
	} elsif ($FORM{'action'} eq 'ttysent'){
		require 'req-tty';
		&doTty;
	}else{
		&html_error("action not programmed yet.");
	}
} elsif ($ENV{'REQUEST_METHOD'} eq 'GET') { # ISINDEX input or no input
	$buffer=$ENV{'QUERY_STRING'};
	$buffer =~ s/[^$OK_CHARS]/_/g; # change $OK_CHARS if too restrictive
	$buffer=~ tr/+/ /;
	$buffer=~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
	if (!$buffer) {
		require 'req-newreq';
		&reqForm(@buffer);
		exit 0;
	}
	@buffer=split(/-/,$buffer);
	my $action=shift @buffer;
	if($action eq 'create'){
		require 'req-create';
		&createSupportForm;
	} elsif ($action eq 'list'){
		if(@buffer <= 2){# lay the frames, list type instead of default
			require 'req-null';
		}else{
			require 'req-list';
		}
		&listReqs(@buffer);
	} elsif ($action eq 'show'){
		require 'req-show';
		&showReq(@buffer);
	} elsif ($action eq 'showfaq'){
		require 'req-showfaq';
		&showFaq(@buffer);
	} elsif ($action eq 'listfaq'){
		require 'req-listfaq';
		&listFaq(@buffer);
	} elsif ($action eq 'updatefaq'){
		require 'req-showfaq';
		&updatefaqForm(@buffer);
	} elsif ($action eq 'deletefaq'){
		require 'req-showfaq';
		&deletefaq(@buffer);
	} elsif ($action eq 'condensefaq'){
		require 'req-showfaq';
		&condensefaq(@buffer);
	} elsif ($action eq 'login'){
		require 'req-login';
		&loginForm(@buffer);
	} elsif ($action eq 'logout'){
		require 'req-login';
		&logout(@buffer);
	} elsif ($action eq 'add' || $action eq 'top'){
		if($buffer[0] eq 'active'){
			require 'req-newreq';
			my $fb=$action eq 'top'?'topfoobar':'foobar';
			&reqForm('','','',$fb,$buffer[1]);
		}else{
			require 'req-showfaq';
			&faqForm(@buffer);
		}
	} elsif ($action eq 'search'){
		require 'req-search';
		&searchForm(@buffer);
	} elsif ($action eq 'update'){ 
		require 'req-update';
		&update(@buffer);
	} elsif ($action eq 'config'){
		require 'req-create';
		&configInfo(@buffer);
	} elsif ($action eq 'status'){
		require 'req-status';
		&statusForm(@buffer);
	} elsif ($action eq 'credits'){
		require 'req-null';
		&credits;
	} elsif ($action eq 'newheader'){
		require 'req-listfaq';
		&newHeaderForm(@buffer);
	} elsif ($action eq 'deluser'){
		require 'req-create';
		&deluserForm;
	} elsif ($action eq 'showmore'){
		require 'req-show';
		&showmore(@buffer);
	} elsif ($action eq 'listshow'){
		require 'req-show';
		&listshowForm(@buffer);
	} elsif ($action eq 'showMIME'){
		require 'req-show';
		&showMIME(@buffer);
	} elsif ($action eq 'getlog'){
		require 'req-show';
		&showReq(@buffer);
	} elsif ($action eq 'PhoneBook'){
		require 'req-socket';
		&phoneBook(@buffer);
	} elsif ($action eq 'local'){
		require 'req-newreq';
		$DOLOCALFORM=1; &reqForm(@buffer);
	} elsif ($action eq 'mergereq'){
		require 'req-update';
		&mergeReqForm(@buffer);
	} elsif ($action eq 'version'){
		&html_header(); &html_trailer();
	} else {
		&html_error("action \"$action\" not programmed yet.");
	}
} else {
	&html_error("Processing error. Please contact the author.");
}
exit 0;
####################################################################
sub html_header { # . title P* W* b* X R#?path JS* F/f C BC R string string ....
	my $a1;my $a2; my $frame=0; my $title=shift;
	my $wintarget=''; my $bodyonload='';

	if(!$ruser && $oldauth ne $auth){# && $email
		my $secur=$ENV{'HTTPS'} eq 'on'?'; secure':'';
		print "Set-Cookie: cookies=". &encode_base64("$auth:$email") ."; ";
		#print "expires=$expire; path=$url; domain=$server\n";
		#print "expires=$expire; path=$url\n"; # set domain trouble for some
		print "expires=$expire$secur\n"; #no need to set path, path not work in IE4.0
	}
	# can have multiple Set-Cookie lines here, each must end with \n\r
	if($_[0] =~ /^P(\S*)$/){
		print "Pragma: no-cache\n";
		print "Pragma: $1\n" if $1;
		print "Expires: Tue Jan 26 09:38:24 EST 1999\n";
		shift;
	}
	if($_[0] =~ /^W(\S+)$/){
		print "Window-target: $1\n";
		#$wintarget=$1;
		shift;
	}
	if($_[0] =~ /^bT(\S+)$/){#onload
		$bodyonload=" onLoad=\"location=\'$url?$1\'\" ";
		shift;
	}
	if($_[0] =~ /^b(\S+)$/){#onload
		#$bodyonload=" onLoad=\"parent.M1.location=\'$url?$1\'\" ";
		$bodyonload=" onLoad=\"if(parent.M1){parent.M1.location=\'$url?$1\'}\" ";
		shift;
	}
	print "Content-type: text/html\n\r";
	print "\n"; # all header stuff must send before this line

	print "<HTML>\n";
	print "<HEAD>\n";
	if($_[0] eq 'X'){ # try to force IE4.0 to refresh, not work
		#print "Expires: $expire_now\n";
		#print "<META HTTP-EQUIV=\"expires\" CONTENT=\"Tue, 20 Aug 1996 14:25:27 GMT\">\n"; 
		print "<META HTTP-EQUIV=\"expires\" CONTENT=\"0\">\n";
		# or put "Cache-Control: no-cache" in HTTP 1.1 headers or
		# "Expires: 0" or "Pragma: no-cache" in HTTP 1.0 headers or
		# "Expires: Tue, 08 Apr 1997 17:20:00 GMT"
		shift;
	}
	if($_[0] =~ /^R(\d+)(.*)$/){# $2=?.*
		print "<META http-equiv=\"Refresh\" content=\"$1; URL=$fullurl";
		if($2){print "$2";} 
		print "\">\n";
		shift;
	}
	if($wintarget){
		print "<BASE TARGET=\"$wintarget\">\n";
		#print "<META HTTP-EQUIV="Window-target" CONTENT=\"$wintarget\">\n";
	}
	if($title){print "<TITLE>$title</TITLE>\n";}
	if($_[0] =~ /^JS(.*)/s){ # javscript
		print "$1\n";shift @_;
	}
	print "</HEAD>\n";

	if($_[0] eq 'F' || $_[0] eq 'Frame'){# if the doc is a frameset
		shift; $frame=1;
	} else {
		print "<BODY link=blue vlink=blue$bodyonload>\n";
		if($_[0] eq 'f'){# not in frame, but don't want the title in the page
			shift; $frame=1;
		}
	} 

	if($title && !$frame){
		if($_[0] eq 'C'){
			print "<H2 ALIGN=CENTER>$title</H2>\n";
			$a1='<CENTER>'; $a2='</CENTER>'; shift;
		} elsif($_[0] eq 'BC'){
			print "<H2 ALIGN=CENTER><B>$title</B></H2>\n";
			$a1='<CENTER><B>'; $a2='</B></CENTER>'; shift;
		} elsif($_[0] eq 'R'){
			print "<H2 ALIGN=RIGHT>$title</H2>\n";
			$a1='<DIV ALIGN=right>';$a2='</DIV>';shift;
		} else {
			print "<H2>$title</H2>\n";
		}
	}
	if(@_ > 0){
		foreach (@_){
			printf "$a1$_$a2\n";
		}
	}
}
sub html_error {# as for html_header
	&html_header(@_);
	&html_trailer;
	exit 0;
}
sub html_trailer { # no argv
	print "\n<hr>\n";
## RPH -- 991008 -- isolate versioning at top of file
	print "Wreq version $version, $version_date.\n";
	print '&nbsp;&nbsp;('.(time-$now).'sec)'; # also times();
	if($_[0] ne 'F' && $_[0] ne 'Frame'){print "</BODY>\n";}
	print "</HTML>\n";
}
sub encode_base64 {#. string   adapted from MIME-Base64-2.09
    my($s,$res)=($_[0],'');
    while ($s =~ /(.{1,45})/gs) {
    	$res .= substr(pack('u', $1), 1); chop($res);
    }
    $res =~ tr|` -_|AA-Za-z0-9+/|;
    my $padding = (3 - length($s) % 3) % 3;
    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
    $res;
}
sub decode_base64 {#. string   adapted from MIME-Base64-2.09
    my($s,$res)=($_[0],'');
    $s =~ tr|A-Za-z0-9+=/||cd;
    #if (length($s) % 4) {return;}
    $s =~ s/=+$//;
    $s =~ tr|A-Za-z0-9+/| -_|;
    while ($s =~ /(.{1,60})/gs) {
    	$res .= unpack("u", chr(32 + length($1)*3/4) . $1 );
    }
    $res;
}
#print &decode_base64(&encode_base64("this is a \ngood! test: hi ih" x 45));
sub decode_qp { #. string   adapted from MIME-Base64-2.11
    my $res = shift;
    $res =~ s/[ \t]+?(\r?\n)/$1/g;  # rule #3 (trailing space must be deleted)
    $res =~ s/=\r?\n//g;            # rule #5 (soft line breaks)
    $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
    $res;
}
#print &decode_qp("ABC\n=6Ctest\n\nboo\n");