#! @PERL@ -w

# get local DCC parameters for DCC whitelist CGI scripts.

# Copyright (c) 2005 by Rhyolite Software
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND RHYOLITE SOFTWARE DISCLAIMS ALL
# WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL RHYOLITE SOFTWARE
# BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES
# OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
# WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
# SOFTWARE.
#	Rhyolite Software DCC 1.2.74-1.22 $Revision$
#	@configure_input@

# check this file by running it separately
use strict 'subs';


# so this file can be used with do('@cgibin@/common')
return check_user();



# emit HTTP/HTML header
sub html_head {
    my($title) = @_;

    print <<EOF;
Content-type: text/html; charset=iso-8859-1
Expires: Thu, 01 Dec 1994 16:00:00 GMT
pragma: no-cache

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<HTML>
<HEAD>
    <TITLE>$title</TITLE>
    <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
    <META HTTP-EQUIV="Content-Style-Type" CONTENT="text/css">
    <STYLE type="text/css">
	<!--
	BODY {background-color:white; color:black}
	P.warn {color:red}
	B.warn {color:red}
	TD.mono {font-family:monospace}
	-->
    </STYLE>
</HEAD>
<BODY>
<H2>Control DCC Log and Whitelist for <EM>$user</EM> at $hostname</H2>

EOF
}


sub common_buttons {
    my($msg, $list_log, $edit, $passwd, $id);


    $msg = $query{msg} ? "?msg=$query{msg}" : "";
    $list_log = ($ENV{SCRIPT_NAME} ne $list_log_url
		 ? "$list_log_link$msg\">Log</A>"
		 : "List Log");
    $edit = ($ENV{SCRIPT_NAME} ne $edit_url
	     ? "$edit_link\">Settings</A>"
	     : "Settings");
    $passwd = ($ENV{SCRIPT_NAME} ne "$cgibin/chgpasswd"
	       ? "<A HREF=\"$cgibin/chgpasswd\">Password</A>"
	       : "Password");

    $id = $ENV{UNIQUE_ID};
    # if mod_unique_id is not present, do the best we can
    $id = "$ENV{REMOTE_HOST}-$ENV{REMOTE_PORT}-$$"
	if (! $id);
    $id = url_encode($id);

    print <<EOF;
<TABLE>
<TR><TD>$list_log
    <TD>$edit
    <TD>$passwd
    <TD>$list_log_link?logoutID=$id">Change User</A>
EOF
}



# Demand a new user name and password
sub force_re_auth {
    my($msg) = @_;

    print("WWW-authenticate: Basic realm=\"DCC user\"\n");
    print("Status: 401 Unauthorized\n");
    html_head("Access Failure");
    print("<H1>Access Failure</H1>\n$msg\n</BODY></HTML>\n");
    exit;
}



# this cannot be used after html_head()
sub punt {
    my($msg) = @_;;
    my($url);

    $msg = url_encode($msg ? $msg : "");
    $url = "https://$ENV{SERVER_NAME}$list_log_url?result=$msg";

    print "Status: 302 Moved Temporarily\n";
    print "Location: $url\n";
    html_head("redirect to $url");
    print "redirecting to $url\n";
    print "</body></html>\n";
    exit;
}



# die with an HTML whine
#   Because there is nothing the user can do except log in as some other
#   user, force re-authentication.
sub html_die {
    my($msg) = @_;

    force_re_auth($msg);

    # put the message into the httpd error_log
    print STDERR "$msg";
    exit 1;
}


# give up but not entirely with an HTML whine
#   This can and must be used after html_head();
sub html_whine {
    my($msg) = @_;

    html_head("Internal Error");
    print <<EOF;
<H1>Internal Error</H1>
<P class=warn>$msg
<P><HR>
<ADDRESS>$ENV{SERVER_SIGNATURE}</ADDRESS>
</BODY></HTML>
EOF
    exit;
}



# kludge to handle "logout" button including recognizing that we've already
#   handled it.  The usual tactic of requiring the user to specify a new
#   username seems ugly.
sub logout {
    my($tfile, $old_tfiles);

    # This only works through the front door.
    $tfile = $query{logoutID};
    if (! $tfile) {
	return if (!defined($tfile));
	$tfile = $id;
    }
    $tfile = "$logout_tmpdir/logout.$tfile";

    # Look for our logout marker file.
    # If it exists, then we've been here before, so delete it.
    if (-f $tfile) {
	unlink $tfile;
	punt("");
    }

    # If it does not exist, create it and force a cycle of authentication.
    # But first delete any old logout marker files
    $old_tfiles = `find $logout_tmpdir -name 'logout.*' -mtime +0`;
    `/bin/rm $old_tfiles` if ($old_tfiles);
    if (!open(TFILE, "> $tfile")) {
	print STDERR "open($tfile): $!\n";
	punt("open($tfile): $!");
    }
    print TFILE %ENV;
    force_re_auth("logout");
}



# Check authentication as well as gather system parameters.
#   Require a user name as well as one that can't be used as a sneaky path.
sub check_user {
    my($args, $line, @setting);

    $hostname=`hostname`;
    chop($hostname);

    $user = $ENV{REMOTE_USER};
    if (!$user || $user =~ /\.\./) {
	html_die("user name $user is invalid");
    }

    #   convert the user name to lower case because sendmail likes to
    $user =~ tr/A-Z/a-z/;

    # rely on the /var/dcc/dcc_conf configuration file for almost everything
    $DCC_HOMEDIR = "@prefix@";
    $DCCM_USERDIRS = "userdirs";
    $DCCM_ENABLE = "on";
    $DCCIFD_ENABLE = "off";
    open(ENV, '2>/dev/null sh -c \'. /var/dcc/dcc_conf;
		echo DCCM_ENABLE="$DCCM_ENABLE";
		echo DCCM_USERDIRS="$DCCM_USERDIRS";
		echo DCCM_ARGS="$DCCM_ARGS"
		echo DCCIFD_USERDIRS="$DCCIFD_USERDIRS";
		echo DCCIFD_ENABLE="$DCCIFD_ENABLE";
		echo DCCIFD_ARGS="$DCCIFD_ARGS"
		\'|')
	|| html_die("cannot get configuration");
    while ($line = <ENV>) {
	chop($line);
	@setting = split(/=/, $line);
	${$setting[0]} = $setting[1];
    }
    close(ENV);

    $main_whiteclnt = "$DCC_HOMEDIR/whiteclnt";
    if ($DCCM_ENABLE eq "off" && $DCCIFD_ENABLE eq "on") {
	$args = $DCCIFD_ARGS;
	$logout_tmpdir = "$DCC_HOMEDIR/$DCCM_USERDIRS/tmp";
	# Assume "local/name" per-user directory for simple dccifd user names.
	$user_dir = "$DCC_HOMEDIR/$DCCM_USERDIRS/$user";
    } else {
	$args = $DCCM_ARGS;
	$logout_tmpdir = "$DCC_HOMEDIR/$DCCM_USERDIRS/tmp";
	# Assume "local/name" per-user directory for simple dccm user names.
	$user_dir = ($user =~ /\//) ? $user : "local/$user";
	$user_dir = "$DCC_HOMEDIR/$DCCM_USERDIRS/$user_dir";
    }
    html_whine("no user directory $user_dir")
	if (! -d $user_dir) ;
    $logdir = "$user_dir/log";
    $whiteclnt = "$user_dir/whiteclnt";

    # Figure out which substitute headers are turned on
    #	This does not detect all possible SMTP "field names," but it also
    #	won't get Perl confused with field names such as 'foo[bar]'.
    $sub_hdrs = "";
    $sub_hdrs .= "|$1"
	while ($args =~ s/(?:-[VdbxANQW]*S\s*)
	       ((?i:[-a-z_0-9]+))
	       ($|\s+)
	       /$2/x);
    $sub_white = $sub_hdrs;
    # pattern matching optional or substitute SMTP headers
    $sub_hdrs =~ s/^\|+//;
    # pattern matching optional or substitute checksum types
    $sub_white =~ s/\|/)|(substitute\\s+/g;
    $sub_white =~ s/^[|)(]*/(/;
    $sub_white .= ')';

    $cgibin = $ENV{SCRIPT_NAME};
    # trim the name of our script from the path
    $cgibin =~ s!/+[^/]+$!!;
    # trim extra leading /s that can mess up our generated links
    $cgibin =~ s!^/{2,}!/!;

    $list_log_url = "$cgibin/list-log";
    $list_log_link = "<A HREF=\"$list_log_url";
    $list_msg_link = "<A HREF=\"$cgibin/list-msg";
    $edit_url = "$cgibin/edit-whiteclnt";
    $edit_link = "<A HREF=\"$edit_url";

    return 1;
}



# Get user's parameters
sub get_query {
    my($buffer, @pairs, $pair, $name, $value);

    if (($ENV{REQUEST_METHOD} eq "GET")) {
	$buffer = $ENV{QUERY_STRING};
    } else {
	read(STDIN, $buffer, $ENV{CONTENT_LENGTH});
    }
    $buffer =~ tr/+/ /;
    @pairs = split(/&/, $buffer);
    foreach $pair (@pairs) {
	($name, $value) = split(/=/, $pair);
	$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	if ($value) {
	    $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	} else {
	    $value = "";
	}
	$query{$name} = $value;
    }

    if ($query{debug}) {
	print STDERR "\n\n\n..........\n";
	foreach my $parm (keys %query) {
	    print STDERR "$parm=\"$query{$parm}\"\n";
	}
    }

    logout() if (defined($query{logoutID}));
}




##########################################################################
# %-encode text
sub url_encode {
    my($out) = @_;

    $out =~ s/([^-_.+!*(),0-9a-zA-Z])/sprintf("%%%02X",ord($1))/eg;
    return $out;
}



sub html_str_encode {
    my($out) = @_;

    $out =~ s/&/&amp;/g;
    $out =~ s/</&lt;/g;
    $out =~ s/>/&gt;/g;
    $out =~ s/([\00-\10\13-\17\42\47\177-\377])/sprintf("&#%d;",ord($1))/eg;
    return $out;
}



sub html_text_encode {
    my($out) = html_str_encode(@_);

    $out =~ s/\n/<BR>\n/g;
    return $out;
}



sub hdr_trim_encode {
    my($out) = @_;

    return "&nbsp;" if (!$out);
    return html_str_encode($out) if (length($out) <= 32);

    $out = substr($out, 0, 28)
	if ($out !~ s/(^.{20,28}[^<>.@\t ])[<>.@\t ].*/$1/);
    $out = html_str_encode($out);
    $out .=  "&nbsp;...";
    return $out;
}



##########################################################################
# Open and parse a log message
# sets these globals
#	$msg_mtime		# inode
#	$msg_date		# envelope
#	$msg_helo		# envelope
#	$msg_ip			# envelope
#	$msg_env_from		# envelope
#	$msg_mail_host		# envelope
#	$msg_from		# header
#	$msg_subject
#	$msg_hdrs
#	$msg_body
#	$msg_cksums
sub parse_log_msg {
    my($msg, $path, $no_body) = @_;
    my($ise_msg, @sb, $line, $cur_hdr, $hdr_type, $misc_hdr, $seen_message_id);
    $ise_msg = "Internal Server Error";

    undef $msg_date;
    undef $msg_helo;
    undef $msg_ip;
    undef $msg_env_from;
    undef $msg_mail_host;
    undef $msg_from;
    undef $msg_subject;
    undef $msg_hdrs;
    undef $msg_body;
    undef $msg_cksums;

    if (!(@sb = stat($path))) {
	$msg_mtime = 0x7fffffff;
	return ($ise_msg, "stat($path) failed: $!");
    }
    $msg_mtime = $sb[9];

    open(MSG, $path) || return ($ise_msg, "open($path): $!");

    if (!($msg_date = <MSG>)) {
	close(MSG);
	return ($ise_msg, "empty msg.$msg");
    }
    chop($msg_date);
    if ($msg_date =~ /^VERSION/) {
	if (!($msg_date = <MSG>)) {
	    close(MSG);
	    return ($ise_msg, "message $msg truncated after VERSION line");
    }
    }
    if (!($msg_date =~ s/^DATE: +(.*) +[^ ]+/$1/)) {
	close(MSG);
	return ($ise_msg, "unrecognized DATE line $msg_date in message $msg");
    }

    if (!($msg_ip = <MSG>)) {
	close(MSG);
	return ($ise_msg, "message $msg truncated in envelope");
    }
    if ($msg_ip !~ /^IP: +([^ ]*) +(?:::ffff:)?(.+)\s*$/) {
	# no IP line
	$msg_helo = $msg_ip;
	undef($msg_ip);
	undef($msg_client_name);
    } else {
	$msg_client_name = $1;
	$msg_ip = $2;
	$msg_client_name .= ' ' if ($msg_client_name !~ s/^\[.*]$//);
	if (!($msg_helo = <MSG>)) {
	    close(MSG);
	    return ($ise_msg, "message $msg truncated in envelope");
	}
	chop($msg_helo);
    }
    if (!($msg_helo =~ s/^HELO: //)) {
	# no HELO line
	$msg_env_from = $msg_helo;
	undef($msg_helo);
    } else {
	if (!($msg_env_from = <MSG>)) {
	    close(MSG);
	    return ($ise_msg, "message $msg truncated after HELO line");
	}
	chop($msg_env_from);
    }
    if (!($msg_env_from =~ s/^env_From: //)) {
	# no env_from line
	$line = $msg_env_from;
	undef($msg_env_from);
    } else {
	$msg_mail_host = $msg_env_from;
	$msg_mail_host =~ s/.*mail_host=(.*)/$1/;
	$msg_env_from =~ s/<?([^\t> ]*).*/$1/;
	$line = <MSG>;
    }

    # skip the envelope env_To lines.
    for (;;) {
	if (! $line) {
	    close(MSG);
	    return ($ise_msg, "message $msg truncated in envelope");
	}
	last if ($line =~ /^[\r\n]*$/);
	if ($line eq "abort\n") {
	    close(MSG);
	    return ("abort", "");
	}
	$line = <MSG>;
    }


    # Look for header lines that get checksums as we collect the whole message.
    $msg_hdrs = "";
    $new_hdr = "";
    undef($hdr_type);
    for (;;) {
	if (!($line = <MSG>)) {
	    close(MSG);
	    return ($ise_msg, "message $msg truncated in headers");
	}

	# deal with header continuation
	if ($line =~ /^[\t ]+/) {
	    $new_hdr .= $line;
	    $$cur_hdr .= $line if ($cur_hdr);
	    next;
	}

	if ($cur_hdr) {
	    # end a preceding interesting header
	    $$cur_hdr =~ s/[\t ]*\n[\r\s]*/ /g;
	    $$cur_hdr =~ s/^\s+//;
	    $$cur_hdr =~ s/\s+$//;
	    # emit a link
	    if ($hdr_type) {
		$msg_hdrs .= "$edit_link?type=$hdr_type&amp;val=";
		$msg_hdrs .= url_encode($$cur_hdr);
		$msg_hdrs .= "&amp;msg=$msg&amp;auto=1\">";
		chop($new_hdr);
		$msg_hdrs .= html_str_encode($new_hdr);
		$msg_hdrs .= "</A>\n";
		undef($hdr_type);
	    } else {
		$msg_hdrs .= html_str_encode($new_hdr);
	    }
	    undef $cur_hdr;
	} else {
	    # end preceding boring header
	    $msg_hdrs .= html_str_encode($new_hdr);
	}


	# stop after the headers
	last if ($line eq "\n");

	$new_hdr = $line;

	# Start an interesting header
	if ($line =~ s/^from:\s*//i) {
	    $hdr_type = "from";
	    $msg_from = $line;
	    $cur_hdr = \$msg_from;
	    next;
	}
	if ($line =~ s/^(message-id):\s*//i) {
	    $hdr_type = $1;
	    $hdr_type =~ tr/-A-Z/_a-z/;
	    $misc_hdr = $line;
	    $cur_hdr = \$misc_hdr;
	    $seen_message_id = 1
		if ($hdr_type eq "message_id");
	    next;
	}
	if ($line =~ s/^subject:\s*//i) {
	    $hdr_type = url_encode("substitute subject")
		if ('subject:' =~ /^($sub_hdrs):/i);
	    $msg_subject = $line;
	    $cur_hdr = \$msg_subject;
	    next;
	}
	if ($line =~ s/^($sub_hdrs):\s*//i) {
	    $hdr_type = $1;
	    $hdr_type =~ tr/A-Z/a-z/;
	    $hdr_type = url_encode("substitute $hdr_type");
	    $misc_hdr = $line;
	    $cur_hdr = \$misc_hdr;
	    next;
	}
    }

    # fake empty Message-ID if required
    if (! $seen_message_id) {
	$msg_hdrs .= "$edit_link?type=";
	$msg_hdrs .= url_encode("message_id");
	$msg_hdrs .= "&amp;val=%3c%3e&amp;msg=$msg&amp;auto=1\">missing&nbsp;Message-ID</A>\n";
    }

    # quit if no one cares about the message itself
    if ($no_body) {
	close(MSG);
	return undef;
    }


    # copy the body of the message
    $msg_body = '';
    for (;;) {
	if (!($line = <MSG>)) {
	    close(MSG);
	    return ($ise_msg, "message $msg truncated in body");
	}
	last if ($line eq "### end of message body ########################\n");
	$line =~ s/[ \t\r]*\n/\n/g;
	$line = html_text_encode($line);
	$msg_body .= $line;
    }


    # copy the checksums
    for (;;) {
	last if (!($line = <MSG>));
	$msg_cksums .= html_str_encode($line);
    }


    close(MSG);
    return undef;
}



sub set_msgs_error {
    my($msg, $error0, $error1) = @_;

    $msgs_date{$msg} = "&nbsp;" if (!$msgs_date{$msg});
    $msgs_from{$msg} = "<B class=warn>$error0</B>";
    $msgs_subject{$msg} = "<B class=warn>$error1</B>";
}



sub get_log_msg {
    my($msg_num) = @_;
    my($msg, @error);

    $msg = $msgs_num[$msg_num];

    # skip parsing it if already known (bad)
    return 1 if ($msgs_date{$msg});

    local($msg_date, $msg_from, $msg_env_from, $msg_subject);
    @error = parse_log_msg($msg, "$logdir/msg.$msg", "stop short");
    if (defined $error[0]) {
	# ignore aborted SMTP transactions
	if ($error[0] eq "abort") {
	    delete $msgs_mtime{$msg};
	    $msgs_num[$msg_num] = undef;
	    return 0;
		++$msg_last if ($msg_last < @msgs_num);
		next;
	    }
	    set_msgs_error($msg, $error[0], $error[1]);

	} else {
	    $msgs_date{$msg} = $msg_date;
	    $msgs_from{$msg} = hdr_trim_encode($msg_from
					       ? $msg_from : $msg_env_from);
	    $msgs_subject{$msg} = hdr_trim_encode($msg_subject);
	}
}



# get the list of messages
#   sets globals %msgs_mtime, %msgs_date, %msgs_from, %msgs_subject,
#	$msg_first, $msg_last, @msgs_num
sub get_log_msgs {
    my($page_msg, $page_len) = @_;
    local(*DIR);
    my(@error, $msg, $msg_path, $msg_num, $date1, $date2);

    html_whine("cannot open $logdir") if (! -d $logdir
					  || !opendir(DIR, $logdir));
    while ($msg = readdir(DIR)) {
	# open and read the interesting bits of each log file
	next if ($msg !~ s/^msg\.([0-9a-z]{6})$/$1/i);
	$msg_path = "$logdir/msg.$msg";
	next if (! -f $msg_path);

	if (!(@sb = stat($msg_path))) {
	    $msgs_mtime{$msg} = 0x7fffffff;
	    set_msgs_error($msg, $ise_msg, "stat($msg_path) failed: $!");
	} else {
	    $msgs_mtime{$msg} = $sb[9];
	}
    }
    closedir(DIR);

    $msg_first = 0;
    $msg_num = 0;
    foreach $msg (sort {$msgs_mtime{$b} <=> $msgs_mtime{$a}}
		  keys %msgs_mtime) {
	$msg_first = $msg_num if ($page_msg && $msg eq $page_msg);
	$msgs_num[$msg_num] = $msg;
	++$msg_num;
    }
    $msg_last = $msg_num-1;

    if (defined($page_len)) {
	return if ($page_len <= 0);
	$msg_last = $msg_first+$page_len-1
	    if ($msg_first+$page_len-1 < $msg_last);
    }

    for ($msg_num = $msg_first; $msg_num <= $msg_last; ++$msg_num) {
	++$msg_last if (!get_log_msg($msg_num)
			&& $msg_last < @msgs_num);
    }

    # get all of the first and last days
    while ($msg_first > 0) {
	$msg_num = $msg_first-1;
	last if (!get_log_msg($msg_num));
	$date1 = $msgs_date{$msgs_num[$msg_num]};
	last if ($date1 !~ s/(.*) .*/$1/);
	$date2 = $msgs_date{$msgs_num[$msg_first]};
	last if ($date2 !~ s/(.*) .*/$1/);
	last if ($date1 ne $date2);
    } continue {
	--$msg_first;
    }
    while (($msg_num = $msg_last+1) < @msgs_num) {
	next if (!get_log_msg($msg_num));
	$date1 = $msgs_date{$msgs_num[$msg_num]};
	next if ($date1 !~ s/(.*) .*/$1/);
	$date2 = $msgs_date{$msgs_num[$msg_last]};
	last if ($date2 !~ s/(.*) .*/$1/);
	last if ($date1 ne $date2);
    } continue {
	++$msg_last;
    }
}



##########################################################################
# whiteclnt file functions

# The file is represented as a list of references to 3-tuples.
#   The first of the three is the whitelist entry in a canonical form
#	as a key uniquely identifying the entry.
#   The second is a comment string of zero or more comment lines.
#   The third is the DCC whiteclnt entry.
#
#   The canonical form and the whiteclnt line of the first 3-tuple for a file
#   are null, because it is a preamble for the file.  It contains some of the
#   dates when the file has been changed as well as flags for the webuser
#   machinery.
#   The last triple in a file may also lack a whitelist entry.

# There is a hash or dictionary of references to entries in the list

use 5.004;
use Fcntl qw(:DEFAULT :flock);
use POSIX qw(strftime);


# lock, read, and parse the file
sub read_whiteclnt {
    my($file_ref, $dict_ref) = @_;
    my($line, $prev_line, $comment);

    @$file_ref = ();
    %$dict_ref = ();

    # Creating the file here is usually a waste of effort, because
    # it must be writable by both the HTTP server and dccm or dccifd.
    # They are probably not in any common group.
    # Let the /var/dcc/libexec/webuser-notify script create the per-user
    #	directories and files.
    punt("open($whiteclnt):$!")
	if (!sysopen(WHITECLNT, $whiteclnt, O_RDWR | O_CREAT, 0664));
    chmod(0664, $whiteclnt);

    punt("flock($whiteclnt): $!")
	if (!flock(WHITECLNT, LOCK_EX | LOCK_NB));

    $comment = "";
    while ($line = <WHITECLNT>) {
	$line .= "\n" if (substr($line,-1) ne "\n");

	# collect the comment lines preceding the next entry
	$line =~ s/[ \t]+$//;
	if ($line =~ /(^#.*)|(^\S*$)/) {
	    $comment .= $line;
	    next;
	}

	# use the previous count if the current value is missing,
	#	because that is what dcclib/parse_whitefile.c does.
	$line = "$1$line"
	    if ($line =~ /^[ \t]+/
		&& $#$file_ref > 0
		&& ($prev_line = ${${$file_ref}[$#$file_ref]}[2])
		&& $prev_line =~ /^(\S+)/);

	add_white_entry($file_ref, $dict_ref, $comment, $line);
	$comment = "";
    }

    # get trailing comment
    add_white_entry($file_ref, $dict_ref, $comment, "");
}



# read the main whiteclnt file to determine the default option settings
sub read_whitedefs {
    my($def_ref) = @_;
    my($line, @parsed, $val);

    %$def_ref = ();

    # these defaults for the defaults must match dcclib/parse_whitefile.c
    ${$def_ref}{dccenable} = "<B>on</B> by default in $main_whiteclnt";
    ${$def_ref}{greyfilter} = "<B>on</B> by default in $main_whiteclnt";
    ${$def_ref}{greylog} = "<B>on</B> by default in $main_whiteclnt";
    ${$def_ref}{dnsbl} = "<B>off</B> by default in $main_whiteclnt";
    ${$def_ref}{logall} = "<B>off</B> by default in $main_whiteclnt";

    if (!sysopen(MAINWHITE, $main_whiteclnt, O_RDONLY, 0)) {
	print STDERR "open(${main_whiteclnt}: $!\n";
	return;
    }

    while ($line = <MAINWHITE>) {
	# skip everything except option settings
	next if ($line !~ /^[ \t]*option[ \t]+/i);

	@parsed = parse_white_entry($line, 'option');
	if ($parsed[1] =~ /log-all\n$/) {
	    $val = "on";
	} elsif ($parsed[1] =~ /log-normal\n$/) {
	    $val = "off";
	} else {
	    $val = ($parsed[1] =~ /.*-on\n$/) ? "on" : "off";
	}
	${$def_ref}{$parsed[0]} = "<B>$val</B> by default in $main_whiteclnt";
    }
    close(MAINWHITE);
}



# add an entry to our image of the file
#   sets the globals:
#	$whiteclnt_version	    #webuser version ...
#	$whiteclnt_notify	    #webuser mail-notify=X mailbox=Y
#	$whiteclnt_notify_pat	    regex for #webuser mail-notify=X mailbox=Y
#	$whiteclnt_lock		    #webuser (un)locked
#	$whiteclnt_change_log	    list of dates when file was changed
sub add_white_entry {
    my($file_ref, $dict_ref, $comment, $line) = @_;
    my(@parsed);

    # trim white space that is invisible on the web form
    $line =~ s/[ \t]+\n/\n/;
    $comment =~ s/[ \t]+\n/\n/g;

    # Notice and deal with the preamble.
    #	The preamble consists of the comments that start the file.
    if (! @$file_ref) {
	my($preamble, @buf, $got_parm);

	# remove the change-history, version, and parameters from the preamble
	$whiteclnt_version = "#webuser version 1.0\n";
	while ($comment =~ s/^#webuser version ([0-9.]+)[ \t]*\n//m) {
	    # for now, insist on version 1.0
	    punt("unrecognized version $1 in $whiteclnt")
	       if ($1 ne "1.0");
	    $got_parm = "yes";
	}

	$whiteclnt_notify_pat = '(#webuser mail-notify=)(on|off)( mailbox=)([-_a-zA-Z0-9]*)';
	$whiteclnt_notify = "#webuser mail-notify=off mailbox=\n";
	while ($comment =~ s/^$whiteclnt_notify_pat[ \t]*\n//im) {
	    $whiteclnt_notify = "$1$2$3$4\n";
	    $got_parm = "yes";
	}

	$whiteclnt_lock = "#webuser unlocked\n";
	while ($comment =~ s/^#\s*webuser unlocked[ \t]*\n//im) {
	    $got_parm = "yes";
	}
	while ($comment =~ s/^#\s*webuser locked[ \t]*\n//im) {
	    $whiteclnt_lock = "#webuser locked\n";
	    $got_parm = "yes";
	}

	$whiteclnt_change_log = "";
	while ($comment =~ s/^#\s*webuser created (.*)[ \t]*\n//im) {
	    $whiteclnt_change_log = "#webuser created $1\n";
	    $got_parm = "yes";
	}
	undef(@buf);
	while ($comment =~ s/^#webuser changed (.+)[ \t]*\n//im) {
	    push(@buf, "#webuser changed $1\n");
	    $got_parm = "yes";
	}
	# keep only the last 20 dates of change
	if (@buf) {
	    my($start);
	    $start = $#buf-20;
	    $start = 0
		if ($start < 0);
	    $whiteclnt_change_log .= join('', @buf[$start .. $#buf]);
	}

	# Collect the non-parameter comments of the preamble, or everything
	#   through the last blank line before the first non-comment line.
	$preamble = "";
	$preamble .= $1 while ($comment =~ s/^(.*\n\n)//s);
	# everything is the preamble if there is no non-comment line
	#   or if the preamble seems to be empty
	if (($preamble eq "" && ! $got_parm)
	    || $line eq "" || $comment eq "\n") {
	    $preamble .= $comment;
	    $comment = "";
	}
	$preamble =~ s/\n+\n$/\n/;
	$preamble =~ s/^\n+//;
	push @$file_ref, [undef, $preamble, "\n"];

	# make a slot for option changes
	push @$file_ref, ["", undef, undef];

	return
	    if ($line eq "" &&  $comment eq "");
    }

    # If the line makes sense to use, remember where it will be.
    # Add it to the memory image of the file in either case.
    @parsed = parse_white_entry($line, '');
    if (! $parsed[1]) {
	# if it makes no sense, treat it like a comment
	$comment .= $line;
	push @$file_ref, [undef, $comment, ""];
    } else {
	my($cur_key, $entry, $i, $k);

	$cur_key = $parsed[0];
	$entry = [$cur_key, $comment, $parsed[1]];
	push @$file_ref, $entry;

	if (${$dict_ref}{$cur_key}) {
	    $i = 0;
	    # mark duplicate values for eventual deletion
	    #	keep the last setting in the file
	    while (${$dict_ref}{$k = "DUP-$i-$cur_key"}) {
		++$i;
	    }
	    ${$dict_ref}{$k} = ${$dict_ref}{$cur_key};
	}
	${$dict_ref}{$cur_key} = $entry;
    }
}



# See if a whiteclnt line makes sense
#   If so, return a list of the key and the line with extra blanks removed
#	and generally cleaned up.
#   If not, return an error message.
sub parse_white_entry {
    my($line, $mode) = @_;
    my($count, $type, $value, $key);

    # recognize options
    return ("dccenable", "option dcc-on\n")
	if ($line =~ /^\s*option\s+DCC-ON\s*$/i);
    return ("dccenable", "option dcc-off\n")
	if ($line =~ /^\s*option\s+DCC-OFF\s*$/i);

    return ("greyfilter", "option greylist-on\n")
	if ($line =~ /^\s*option\s+GREYLIST-ON\s*$/i);
    return ("greyfilter", "option greylist-off\n")
	if ($line =~ /^\s*option\s+GREYLIST-OFF\s*$/i);

    return ("greylog", "option greylist-log-on\n")
	if ($line =~ /^\s*option\s+GREYLIST-LOG-ON\s*$/i);
    return ("greylog", "option greylist-log-off\n")
	if ($line =~ /^\s*option\s+GREYLIST-LOG-OFF\s*$/i);

    return ("dnsbl", "option DNSBL-on\n")
	if ($line =~ /^\s*option\s+DNSBL-ON\s*$/i);
    return ("dnsbl", "option DNSBL-off\n")
	if ($line =~ /^\s*option\s+DNSBL-OFF\s*$/i);

    return ("logall", "option log-all\n")
	if ($line =~ /^\s*option\s+LOG-ALL\s*$/i);
    return ("logall", "option log-normal\n")
	if ($line =~ /^\s*option\s+LOG-NORMAL\s*$/i);

    # recognize old logging options
    return ("greylog", "option greylist-log-on\n")
	if ($line =~ /^\s*log\s+ALL-GREY\s*$/i);
    return ("greylog", "option greylist-log-off\n")
	if ($line =~ /^\s*log\s+NO-GREY\s*$/i);

    return if ($mode eq 'option');

    return 'unrecognized option line'
	if ($line =~/^log/i || $line =~ /^option/i);

    return 'unrecognized DCC whitelist line'
	if ($line !~ /^(\S+)\s+(.*)/);
    $count = $1;
    $value = $2;

    return "unrecognized DCC whitelist count \"$count\""
	if ($count !~ /many|ok|ok2/i);

    # check for type, but don't worry much about substitute types
    if ($value =~ s/^(IP
		      |env-from|env_from
		      |from
		      |message-id|message_id
		      )\s+//ix) {
	$type = $1;
	$type =~ tr/-a-z/_A-Z/;
    } elsif ($value =~ s/^substitute\s+([-a-z_0-9]+)+\s+//i) {
	$type = "substitute $1";
    } elsif ($value =~ s/^(hex\s+
			   (?:Body
			    |Fuz[12])):?
			\s+([0-9a-f]{8})\s+([0-9a-f]{8})
			\s+([0-9a-f]{8})\s+([0-9a-f]{8})\s*$
			/$2 $3 $4 $5/ix) {
	$type = $1;
	$type =~ tr/-a-z/_A-Z/;
    } else {
	return "unrecognized DCC whitelist value \"$value\"";
    }

    if ($mode eq 'strict') {
	if ($value eq '') {
	    return "use a value of '<>' for missing or null Message-IDs"
		if ($type =~ /message_id/i);
	    return "missing $type value";
	}
	return "$value is not a valid IP address"
	    if ($type =~ /IP/i
		&& ($value !~ /^([0-9]+\.){1,3}[0-9]+(\/([0-9]+))?$/
		    || ($3 && ($3 < 8 || $3 > 31))));
    }

    # trim quotes, <>, whitespace, upper/lower case, and trailing periods
    #	from the value of the line to match dcc_parse_ck()
    $value =~ s/\s+//g;
    $value =~ tr/A-Z/a-z/;
    $value =~ s/<(.*)>/$1/
	if ($value !~ s/"(\.*)\"/$1/);
    $value =~ s/\.+$//;
    $key = "$type $value";


    return ($key, $line);
}



# check a proposed entry
#   quit if it is bogus
sub ck_new_white_entry {
    my($comment, $count, $type, $value) = @_;
    my($line, @parsed);

    foreach my $nm ('count', 'type', 'val', 'comment') {
	return "broken POST values without $nm\n"
	    if (!defined($query{$nm}));
    }

    $comment =~ s/[ \t\r]+\n/\n/g;
    $comment =~ s/[\s\r]+$//;
    $comment =~ s/^([^#\n])/#$1/gm;
    $comment .= "\n" if (length($comment) != 0);
    $value =~ s/[\s\r]+$//;

    $line = "$count\t$type";
    $line .= (length($type) < 8) ? "\t" : ' ';
    $line .= "$value\n";

    @parsed = parse_white_entry($line, 'strict');
    return ($parsed[0])	if (!defined($parsed[1]));

    $parsed[2] = $parsed[1];
    $parsed[1] = $comment;
    return @parsed;
}



# add, change, or delete a whitelist entry
sub chg_white_entry {
    my($file_ref, $dict_ref, $cur_key, $entry_ref) = @_;
    my($msg, $i, $k);

    return "$whiteclnt locked" if ($whiteclnt_lock =~ / locked/);

    if (!${$dict_ref}{$cur_key}) {
	if ($entry_ref) {
	    # if new, add it to the list that will go to the disk
	    ${$dict_ref}{$cur_key} = @$entry_ref;
	    push @$file_ref, $entry_ref;
	}

    } else {
	# changing or deleting existing entry, so delete duplicates
	$i = 0;
	while (${$dict_ref}{$k = "DUP-$i-$cur_key"}) {
	    ${$dict_ref}{$k}[1] = undef;
	    ++$i;
	}

	if (!$entry_ref) {
	    # delete an entry
	    ${$dict_ref}{$cur_key}[1] = undef;

	} else {
	    # change an entry
	    @{${$dict_ref}{$cur_key}} = @$entry_ref;
	}
    }

    # put the changes on the disk
    $msg = write_whiteclnt(@$file_ref);
    return $msg if ($msg);

    # set the web form that includes the response
    read_whiteclnt($file_ref, $dict_ref);
    return undef;
}



# write a new version of the file
sub write_whiteclnt {		# return undef or error message
    my(@file) = @_;
    local(*DIR, *BAK);
    my($unlinked, @baks, $bak, $buf, $entry,  $preamble);

    # delete old backup files and find the name of the next one
    # keep only the last few and fairly recent revisions
    opendir(DIR, "$user_dir") || html_whine("opendir($user_dir): $!");
    @baks = map("$user_dir/$_",
		sort(grep {/^(whiteclnt\.bak[0-9]+$)/ && -f "$user_dir/$1"}
		     readdir(DIR)));
    closedir(DIR);
    while ($#baks > 1 && ((-M $baks[0]) >= 1 || $#baks >= 19)) {
	$unlinked = 1;
	unlink shift(@baks);
    }
    if ($#baks >= 0) {
	$bak = $baks[$#baks];
	$bak =~ s/([0-9]+)$/sprintf("%06d",$1+1)/e;
    } else {
	$bak = "$whiteclnt.bak000000";
    }

    # create undo file and copy real file to it
    #	It might be smoother to rename the current file, but we might
    #	not have permission to create the new file with the correct owner.
    return "cannot create $bak: $!"
	if (!sysopen(BAK, $bak, O_WRONLY | O_CREAT | O_EXCL, 0644));
    return "seek($whiteclnt): $!"
	if (!seek(WHITECLNT, 0, 0));
    while (read(WHITECLNT, $buf, 8*1024)) {
	return "write($bak): $!"
	    if (!syswrite(BAK, $buf));
    }
    close(BAK);

    # rewrite the real file
    return "seek($whiteclnt): $!"
	if (!seek(WHITECLNT, 0, 0));
    return "truncate($whiteclnt): $!"
	if (!truncate(WHITECLNT, 0));

    $preamble = 0;
    foreach $entry (@file) {
	next if (!defined($$entry[1]));		# skip deleted entries

	print WHITECLNT $$entry[1];
	# output the parameters in the end of the preamble
	if (! $preamble) {
	    $preamble = 1;
	    print WHITECLNT $whiteclnt_version;
	    print WHITECLNT $whiteclnt_notify;
	    print WHITECLNT $whiteclnt_lock;
	    print WHITECLNT $whiteclnt_change_log;
	    print WHITECLNT strftime("#webuser changed %x %X%n", localtime);
	}
	print WHITECLNT $$entry[2];
    }
}



# undo the most recent operation by copying from the newest backup
sub undo_whiteclnt {
    my($bak, $buf);
    local(*BAK);

    return "$whiteclnt locked" if ($whiteclnt_lock =~ / locked/);

    $bak = newest_whiteclnt_bak();
    return "nothing undone"
	if (! $bak);

    return "open($bak): $!"
	if (!open(BAK, "< $bak"));

    return "seek($whiteclnt): $!"
	if (!seek(WHITECLNT, 0, 0));
    return "truncate($whiteclnt): $!"
	if (!truncate(WHITECLNT, 0));
    while (read(BAK, $buf, 8*1024)) {
	return "write($whiteclnt): $!"
	    if (!print(WHITECLNT $buf));
    }

    return "unlink($bak): $!"
	if (!unlink($bak));

    return undef;
}



# find the newest backup file
sub newest_whiteclnt_bak {
    local(*DIR);
    my(@baks, $bak);

    opendir(DIR, "$user_dir") || html_whine("opendir($user_dir): $!");
    @baks = sort(grep {/^whiteclnt\.bak/ && -f "$user_dir/$_"}
		 readdir(DIR));
    closedir(DIR);

    return undef
	if ($#baks < 0);
    $bak = "$user_dir/$baks[$#baks]";
    return undef
	if (-M $bak >= 1);
    return $bak;
}
