Mercurial > notdcc

comparison cgi-bin/common.in @ 0:c7f6b056b673

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
First import of vendor version
author Peter Gervai <grin@grin.hu>
date Tue, 10 Mar 2009 13:49:58 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:c7f6b056b673
1 #! @PERL@ -wT
2
3 # get local DCC parameters for DCC whitelist CGI scripts.
4
5 # Copyright (c) 2008 by Rhyolite Software, LLC
6 #
7 # This agreement is not applicable to any entity which sells anti-spam
8 # solutions to others or provides an anti-spam solution as part of a
9 # security solution sold to other entities, or to a private network
10 # which employs the DCC or uses data provided by operation of the DCC
11 # but does not provide corresponding data to other users.
12 #
13 # Permission to use, copy, modify, and distribute this software without
14 # changes for any purpose with or without fee is hereby granted, provided
15 # that the above copyright notice and this permission notice appear in all
16 # copies and any distributed versions or copies are either unchanged
17 # or not called anything similar to "DCC" or "Distributed Checksum
18 # Clearinghouse".
19 #
20 # Parties not eligible to receive a license under this agreement can
21 # obtain a commercial license to use DCC by contacting Rhyolite Software
22 # at sales@rhyolite.com.
23 #
24 # A commercial license would be for Distributed Checksum and Reputation
25 # Clearinghouse software. That software includes additional features. This
26 # free license for Distributed ChecksumClearinghouse Software does not in any
27 # way grant permision to use Distributed Checksum and Reputation Clearinghouse
28 # software
29 #
30 # THE SOFTWARE IS PROVIDED "AS IS" AND RHYOLITE SOFTWARE, LLC DISCLAIMS ALL
31 # WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
32 # OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL RHYOLITE SOFTWARE, LLC
33 # BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES
34 # OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
35 # WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
36 # ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
37 # SOFTWARE.
38 # Rhyolite Software DCC 1.3.103-1.89 $Revision$
39 # @configure_input@
40
41 # check this file by running it separately
42 use strict 'subs';
43
44 use integer;
45
46 use 5.004;
47 use Fcntl qw(:DEFAULT :flock);
48 use POSIX qw(strftime);
49
50 # quiet Perl taint checks with a path that should work everywhere for
51 # the few commands these scripts use.
52 $ENV{PATH}="/sbin:/bin:/usr/sbin:/usr/bin";
53
54 # global variables
55 # $DCCM_USERDIRS, # from dcc_conf
56 # $whiteclnt, # path to the per-user whitelist file
57 # %query,
58 # $thold_cks, # checksums that can have thresholds
59 # $user,
60 # $hostname,
61 # $user_dir,
62 # $edit_url,
63 # $list_log_url,
64 # $list_log_link,
65 # $list_msg_link,
66 # $edit_url, $edit_link,
67 # $passwd_url, $passwd_link,
68 # $logoutID,
69 # $url_ques, $url_suffix,
70 # $sub_white, # 'subsitute' headers from dcc_conf
71 # $form_hidden # state for main form
72
73
74
75 # so this file can be used with do('@cgibin@/common')
76 # besides, check_user() must be called before html_head()
77 return check_user();
78
79
80
81 sub debug_time {
82 my($label) = @_;
83
84 return if (!$query{debug});
85
86 my(@ts, $ts);
87 require 'sys/syscall.ph';
88
89 $ts = pack("LL", ());
90 syscall(&SYS_gettimeofday, $ts, 0);
91 @ts = unpack("LL", $ts);
92
93 chomp($label);
94 printf STDERR "%38s", $label;
95 print STDERR strftime(" %X", localtime($ts[0]));
96 printf STDERR ".%03d", $ts[1]/1000;
97 printf STDERR " %.3f", $_ foreach times;
98 print STDERR "\n";
99 }
100
101
102
103 sub debug_printf {
104 my($label, $str) = @_;
105
106 return if (!$query{debug});
107 $str =~ s/\n/\\n/g;
108 print STDERR "$label='$str'\n";
109 }
110
111
112 # emit HTTP/HTML header
113 sub html_head {
114 my($title, # title of the web page
115 $refresh_url) = @_; # next step in re-login sequence if not null
116 my($header, $style);
117
118 print <<EOF;
119 Content-type: text/html; charset=iso-8859-1
120 Expires: Thu, 01 Dec 1994 16:00:00 GMT
121 pragma: no-cache
122
123 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
124 <HTML>
125 <HEAD>
126 <TITLE>$title</TITLE>
127 <META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
128 <META HTTP-EQUIV="Content-Style-Type" CONTENT="text/css">
129 EOF
130
131 print "<META HTTP-EQUIV=refresh content=\"1;url=$refresh_url\">\n"
132 if ($refresh_url);
133
134 # Use header if supplied
135 # it is mostly text for the start of the <BODY>,
136 # but it can also contain either <LINK rel="stylesheet"...
137 # or <STYLE>...</STYLE>
138 $header = "\n";
139 if (open(HEADER, "$user_dir/header")
140 || open(HEADER, "@cgibin@/header")) {
141 my $line;
142
143 $header .= $line while ($line = <HEADER>);
144 close(HEADER);
145 }
146
147 # Use our style style if the supplied header has none
148 if ($header =~ s/([ \t]*<STYLE[^>]*>.*<\/STYLE>\s*)//si) {
149 $style = $1;
150 } elsif ($header =~ s/([ \t]*<link[^>]*rel=['"]?stylesheet[^>]*>)//si) {
151 $style = $1;
152 } else {
153 $style = <<EOF;
154 <STYLE type="text/css">
155 <!--
156 BODY {background-color:white; color:black}
157 .warn {color:red}
158 .mono {font-family:monospace}
159 .small {font-size:smaller}
160 .strong {font-weight:bolder}
161 .nopad {margin:0; padding:0}
162 INPUT.selected {font-size:smaller; font-weight:bolder; color:blue}
163 TABLE {white-space:nowrap}
164 TD.first {text-align:right; vertical-align:baseline}
165 IMG.logo {width:6em; vertical-align:middle}
166 ADDRESS {font-size:smaller}
167 -->
168 </STYLE>
169 EOF
170 }
171
172 print <<EOF;
173 $style
174 </HEAD>
175 <BODY>
176 <H2>$title</H2>
177 $header
178 EOF
179 }
180
181
182
183 sub html_footer {
184 if (open(FOOTER, "$user_dir/footer")
185 || open(FOOTER, "@cgibin@/footer")) {
186 my $line;
187
188 print $line while ($line = <FOOTER>);
189 close(FOOTER);
190 }
191 }
192
193
194
195 sub common_buttons {
196 my($msg, $cur, $list_log, $edit, $passwd, $id);
197
198
199 $msg = $query{msg} ? "${url_ques}msg=$query{msg}" : "";
200
201 $cur = "$ENV{SCRIPT_NAME}$url_suffix";
202 $list_log = ($cur ne $list_log_url
203 ? "$list_log_link$msg\">Log</A>"
204 : "List Log");
205 $edit = ($cur ne $edit_url
206 ? "$edit_link\">Settings</A>"
207 : "Settings");
208 $passwd = ($cur ne $passwd_url
209 ? "$passwd_link\">Password</A>"
210 : "Password");
211
212 print <<EOF;
213 <TABLE>
214 <TR><TD>$list_log
215 <TD>$edit
216 <TD>$passwd
217 <TD><A HREF="$cur${url_ques}logoutID=$logoutID">LogOut/In</A>
218 EOF
219 }
220
221
222
223 # give up, but not entirely, with an HTML whine
224 sub html_whine {
225 my($msg) = @_;
226
227 html_head("Internal Error");
228 common_buttons();
229 print <<EOF;
230 </TABLE>
231 <H1>Internal Error</H1>
232 <P class=warn>$msg
233 <P><HR>
234 $ENV{SERVER_SIGNATURE}
235 </BODY>
236 </HTML>
237 EOF
238 exit;
239 }
240
241
242
243 # die with an HTML whine
244 sub html_die {
245 my($msg) = @_;
246
247 # put the message into the httpd error log
248 print STDERR "DCC CGI script internal error: $msg\n";
249
250 html_head("Internal Error");
251 print <<EOF;
252 <P class=warn>$msg
253 <P><HR>
254 $ENV{SERVER_SIGNATURE}
255 </BODY>
256 </HTML>
257 EOF
258 exit;
259 }
260
261
262 # punt to some other web page, perhaps after the logout/in kludge
263 # this cannot be used after html_head()
264 sub punt2 {
265 my($msg, # message saying why
266 $url) = @_; # the other web page
267
268 # don't punt a punt
269 html_die($msg) if ($query{result});
270
271 $url = ((($ENV{HTTPS} && $ENV{HTTPS} eq "on") ? "https://" : "http://")
272 . $ENV{SERVER_NAME}
273 . $url);
274 $url .= $url_ques."result=".url_encode($msg) if ($msg);
275
276 print "Status: 302 Moved Temporarily\nLocation: $url\n";
277 html_head("redirect to $url");
278 print "redirecting to $url\n</BODY>\n</HTML>\n";
279 exit;
280 }
281
282
283
284 # Check authentication and gather system parameters.
285 # Require a user name as well as one that can't be used as a sneaky path.
286 sub check_user {
287 my($sub_args, $cks, $thold, $line, $var);
288
289 if ($ENV{HTTP_NAME}) {
290 $hostname = $ENV{HTTP_NAME};
291 } elsif ($ENV{SERVER_NAME}){
292 $hostname = $ENV{SERVER_NAME};
293 } else {
294 $hostname=`hostname`;
295 chop($hostname);
296 }
297
298 $user = $ENV{REMOTE_USER};
299 if (!$user){
300 $user = '';
301 html_die("no user name")
302 }
303 # allow the user name to be a subdirectory
304 html_die("user name $user is invalid")
305 if ($user =~ /\.\./ || $user !~ /^([-\/.,#_%a-z0-9]+)$/i);
306 $user = $1; # stop Perl taint warnings
307
308 # convert the user name to lower case because sendmail likes to
309 $user =~ tr/A-Z/a-z/;
310
311 # rely on the /var/dcc/dcc_conf configuration file for almost everything
312 $DCC_HOMEDIR = "@prefix@"; # unneeded except for compatibility
313 $DCCM_USERDIRS = "userdirs";
314 $DCCM_ENABLE = "on";
315 $DCCIFD_ENABLE = "off";
316 open(CONF, '2>/dev/null sh -c \'. @prefix@/dcc_conf;
317 echo DCCM_ENABLE="$DCCM_ENABLE";
318 echo DCCM_USERDIRS="$DCCM_USERDIRS";
319 echo DCCM_ARGS="$DCCM_ARGS";
320 echo DCCM_REJECT_AT="$DCCM_REJECT_AT";
321 echo DCCM_CKSUMS="$DCCM_CKSUMS";
322 echo DCCIFD_USERDIRS="$DCCIFD_USERDIRS";
323 echo DCCIFD_ENABLE="$DCCIFD_ENABLE";
324 echo DCCIFD_ARGS="$DCCIFD_ARGS";
325 echo DCCIFD_REJECT_AT="$DCCIFD_REJECT_AT";
326 echo DCCIFD_CKSUMS="$DCCIFD_CKSUMS";
327 echo GREY_CLIENT_ARGS="$GREY_CLIENT_ARGS";
328 echo DNSBL_ARGS="$DNSBL_ARGS";
329 \'|')
330 || html_die("cannot get DCC configuration");
331 while ($line = <CONF>) {
332 chomp($line);
333 if ($line !~ s/(^[A-Z_]+)=//) {
334 print STDERR "unrecognized dcc_conf line $line";
335 next;
336 }
337 $var = $1;
338 if ($line =~ /^([-0-9,.\/a-z_]*)$/i) {
339 ${$var} = $1; # suppress taint warnings on good paths
340 } else {
341 ${$1} = $line;
342 }
343 }
344 close(CONF);
345
346 $main_whiteclnt = "@prefix@/whiteclnt";
347 if ($DCCM_ENABLE eq "off" && $DCCIFD_ENABLE eq "on") {
348 $sub_args = $DCCIFD_ARGS;
349 $cks = $DCCIFD_CKSUMS;
350 $thold = $DCCIFD_REJECT_AT;
351 $logout_tmpdir = "@prefix@/$DCCIFD_USERDIRS/tmp";
352 # Assume "name" per-user directory for simple dccifd user names.
353 $user_dir = "@prefix@/$DCCIFD_USERDIRS/$user";
354 } else {
355 $sub_args = $DCCM_ARGS;
356 $cks = $DCCM_CKSUMS;
357 $thold = $DCCM_REJECT_AT;
358 $logout_tmpdir = "@prefix@/$DCCM_USERDIRS/tmp";
359 # Assume "local/name" per-user directory for simple dccm user names.
360 $user_dir = ($user =~ /\//) ? $user : "local/$user";
361 $user_dir = "@prefix@/$DCCM_USERDIRS/$user_dir";
362 }
363 html_die("no user directory $user_dir")
364 if (! -d $user_dir) ;
365 $logdir = "$user_dir/log";
366 $whiteclnt = "$user_dir/whiteclnt";
367
368 # Figure out which substitute headers are turned on
369 # This does not detect all possible SMTP "field names," but it also
370 # won't get Perl confused with field names such as 'foo[bar]'.
371 $sub_hdrs = "";
372 $sub_hdrs .= "|$1"
373 while ($sub_args && $sub_args =~ s/(?:-[VdbxANQW]*S\s*)
374 ((?i:[-a-z_0-9]+))
375 ($|\s+)
376 /$2/x);
377 $sub_white = $sub_hdrs;
378 # pattern matching optional or substitute SMTP headers
379 $sub_hdrs =~ s/^\|+//;
380 # pattern matching optional or substitute checksum types
381 $sub_white =~ s/\|/)|(substitute\\s+/g;
382 $sub_white =~ s/^[|)(]*/(/;
383 $sub_white .= ')';
384
385 # names of checksums whose thresholds can be set
386 $thold_cks_cmn = 'Body,Fuz1,Fuz2';
387 $thold_cks = $thold_cks_cmn;
388 # all checksums including those not kept by (almost all) DCC servers
389 #$thold_cks_all = 'IP,env_From,From,env_To,Message-ID,' . $thold_cks;
390
391 # compute default checksum thresholds
392 if ($thold) {
393 $cks = $thold_cks_cmn if (!$cks);
394 foreach my $ck (split(/,/,$cks)) {
395 my ($t,$v) = ($ck, $thold);
396 $conf_cks_tholds{$t} = "<STRONG>$v</STRONG> <SMALL>by default in @prefix@/dcc_conf</SMALL>"
397 if (parse_thold_value($t, $v));
398 }
399 }
400
401 $cgibin = $ENV{SCRIPT_NAME};
402 # trim the name of our script from the path
403 $cgibin =~ s!/+[^/]+$!!;
404 # trim extra leading /s that can mess up our generated links
405 $cgibin =~ s!^/{2,}!/!;
406
407 get_query();
408
409 return 1;
410 }
411
412
413
414 # Get user's parameters
415 sub get_query {
416 my($buffer, $name, $value);
417
418 if ($ENV{REQUEST_METHOD} && $ENV{REQUEST_METHOD} =~ /GET|HEAD/) {
419 $buffer = $ENV{'QUERY_STRING'};
420 } elsif (!$ENV{CONTENT_LENGTH}) {
421 $buffer = '';
422 } else {
423 read(STDIN, $buffer, $ENV{CONTENT_LENGTH});
424 }
425 $buffer =~ tr/+/ /;
426 foreach my $pair (split(/&/, $buffer)) {
427 ($name, $value) = split(/=/, $pair);
428 $name =~ s/%([a-fA-F0-9]{2})/pack("C", hex($1))/eg;
429 if ($value) {
430 $value =~ s/%([a-fA-F0-9]{2})/pack("C", hex($1))/eg;
431 } else {
432 $value = "";
433 }
434 $query{$name} = $value;
435 }
436
437 if (!$query{debug} || $query{debug} !~ /^\d+$/) {
438 $url_ques = "?";
439 $url_suffix = "";
440 $form_hidden = "";
441 } else {
442 if ($query{debug} > 1) {
443 debug_time("start $ENV{SCRIPT_NAME}");
444 print STDERR " $_=\"$query{$_}\"\n" foreach (keys %query);
445 print STDERR " AuthName=\"$ENV{AuthName}\"\n"
446 if ($ENV{AuthName});
447 print STDERR " SCRIPT_NAME=\"$ENV{SCRIPT_NAME}\"\n"
448 if ($ENV{SCRIPT_NAME});
449 }
450 $url_suffix = "?debug=$query{debug}";
451 $url_ques = '&amp;';
452 $form_hidden = "\n <INPUT type=hidden name=debug value=$query{debug}>";
453 }
454
455 $list_log_url = "$cgibin/list-log$url_suffix";
456 $list_log_link = "<A HREF=\"$list_log_url";
457 $list_msg_link = "<A HREF=\"$cgibin/list-msg$url_suffix";
458 $edit_url = "$cgibin/edit-whiteclnt$url_suffix";
459 $edit_link = "<A HREF=\"$edit_url";
460 $passwd_url = "$cgibin/chgpasswd$url_suffix";
461 $passwd_link = "<A HREF=\"$passwd_url${url_ques}goback=$ENV{SCRIPT_NAME}";
462
463 $logoutID = $ENV{UNIQUE_ID};
464 # do the best we can if Apache mod_unique_id is not present
465 $logoutID = "$ENV{REMOTE_ADDR}-$ENV{REMOTE_PORT}-$$-" . time()
466 if (!$logoutID);
467 $logoutID = url_encode($logoutID);
468
469 # kludge to handle "logout" button including recognizing that we have
470 # already handled it. The usual tactic of requiring the user to
471 # specifying a new username and then using a cookie seems ugly.
472 $tfile = $query{logoutID};
473 if ($tfile && $tfile =~ /^([-.A-Za-z0-9@]+)$/) {
474 $tfile = "$logout_tmpdir/logout.$1";
475
476 # delete any old logout marker files
477 my($old_tfiles) = `find $logout_tmpdir -name 'logout.*' -mtime +1`;
478 if ($old_tfiles && $old_tfiles =~ /^(.+)\s*$/) {
479 $old_tfiles = $1; # untaint
480 my @old_tfiles = split /\s/,$old_tfiles;
481 print "unlink($old_tfiles): $!\n"
482 if ($#old_tfiles >= unlink @old_tfiles);
483 }
484
485 # Look for our logout marker file.
486 if (-f $tfile) {
487 # If it exists, then we have been here before, so just delete it.
488 # and refresh
489 unlink $tfile;
490 punt2("", "$ENV{SCRIPT_NAME}$url_suffix");
491
492 } else {
493 # If it does not exist, create it & force a cycle of authentication.
494 if (!open(TFILE, "> $tfile")) {
495 print STDERR "open($tfile): $!\n";
496 html_whine("open($tfile): $!", $edit_url);
497 }
498 while (($name,$value) = each %ENV) {
499 print TFILE "$name=$value\n";
500 }
501
502 # Demand a new user name and password
503 my($AuthName) = $ENV{AuthName} ? $ENV{AuthName} : "DCC user";
504 print <<EOF;
505 WWW-authenticate: Basic realm="$AuthName"
506 Status: 401 Unauthorized
507 EOF
508 html_head("Access Failure");
509 print "<P class=warn>\n";
510 print $msg ? $msg : "Access Failure";
511 print "\n</BODY></HTML>\n";
512 exit;
513 }
514 }
515 }
516
517
518
519
520 ##########################################################################
521
522 # %-encode text for a URL
523 sub url_encode {
524 my($out) = @_;
525
526 $out =~ s/([^-_.+!*(),0-9a-zA-Z])/sprintf("%%%02X",ord($1))/eg;
527 return $out;
528 }
529
530
531
532 # encode text for ordinary HTML to avoid special HTML flags such as '<'
533 # retain newlines
534 sub html_str_encode {
535 my($out) = @_;
536
537 $out =~ s/&/&amp;/g;
538 $out =~ s/</&lt;/g;
539 $out =~ s/>/&gt;/g;
540 $out =~ s/([\00-\10\13-\17\42\47\177-\377])/sprintf("&#%d;",ord($1))/eg;
541 return $out;
542 }
543
544
545
546 # encode text for HTML, and replace newlines with <BR>
547 sub html_text_encode {
548 my($out) = html_str_encode(@_);
549 $out =~ s/\n/<BR>\n/g;
550 return $out;
551 }
552
553
554
555 # encode text for HTML, trimmed to at most 32 characters with the end replaced
556 # by an ellipsis if too long
557 sub hdr_trim_encode {
558 my($out) = @_;
559
560 return "&nbsp;" if (!$out);
561
562 return html_str_encode($out) if (length($out) <= 32);
563
564 $out = substr($out, 0, 28)
565 if ($out !~ s/(^.{20,28}[^<>.@\t ])[<>.@\t ].*/$1/);
566 $out = html_str_encode($out);
567 $out .= "&nbsp;...";
568 return $out;
569 }
570
571
572
573 ##########################################################################
574 # Open and parse a log message
575 # sets these globals
576 # $msg_date # envelope
577 # $msg_helo # envelope
578 # $msg_ip # envelope
579 # $msg_client_name # envelope
580 # $msg_env_from # envelope
581 # @msg_env_to # envelope
582 # $msg_mail_host # envelope
583 # $msg_from # header
584 # $msg_subject
585 # $msg_hdrs
586 # $msg_body
587 # $msg_cksums
588 # $msg_result
589
590
591 # globals
592 # %msgs_cache, # key=compressed name, [0]=mtime [1]=i-number
593 # $cache_line_len,
594 # $cache_pack,
595 # $cache_version,
596 # $msg_encode_str,
597 # %msgs_cache_state, # key=day, value=1 if good
598 # %msgs_date, %msgs_result,
599 # %msgs_from, %msgs_subject,
600 # $msg_day_first, $msg_day_last,
601 # $msg_first, $msg_last,
602 # $msg_newer, $msg_part_num,
603 # @msgs_num # compressed names sorted by mtime
604
605
606 sub parse_log_msg {
607 my($msg, $no_body) = @_;
608 my(@error, $path, $line, $num_hdrs, $cur_hdr, $hdr_type,
609 $misc_hdr, $seen_message_id, $ise_msg, $cksum_marker, $cksum_marker_p);
610
611 undef $msg_date;
612 undef $msg_helo;
613 undef $msg_ip;
614 undef $msg_client_name;
615 undef $msg_env_from;
616 undef @msg_env_to;
617 undef $msg_mail_host;
618 undef $msg_from;
619 undef $msg_subject;
620 $msg_hdrs = '';
621 $msg_body = '';
622 $msg_cksums = '';
623 $msg_result = ': ';
624
625 $num_hdrs = 0;
626
627 $ise_msg = "Internal Server Error";
628 $cksum_marker = "### end of message body ########################\n";
629 $cksum_marker_p = qr/^### end of message body ########################\s*$/;
630
631 $no_body = "" if ($no_body && $no_body ne "no body");
632 $path = msg2path($msg);
633
634 sysopen(MSG, $path, O_RDONLY, 0)
635 || return ($ise_msg, "open($path): $!");
636
637 return ($ise_msg, "empty $path") if (!($msg_date = <MSG>));
638
639 if ($msg_date !~ /^VERSION/) {
640 close(MSG);
641 return ($ise_msg, "format of $path unrecognized");
642 }
643 if (!($msg_date = <MSG>)) {
644 close(MSG);
645 return ($ise_msg, "$path truncated after VERSION line");
646 }
647 if (!($msg_date =~ s/^DATE: +(.*) +[^ ]+/$1/)) {
648 close(MSG);
649 return ($ise_msg, "unrecognized DATE line $msg_date in message $msg");
650 }
651
652 if (!($msg_ip = <MSG>)) {
653 close(MSG);
654 return ($ise_msg, "message $msg truncated in envelope");
655 }
656 if ($msg_ip =~ /^IP: ([^ :]*) *([:.0-9a-fA-F]*) *$/) {
657 $msg_ip = $2;
658 $msg_client_name = $1;
659 $msg_ip =~ s/^::ffff://i;
660 $msg_client_name =~ s/^\[.*]$//;
661 $msg_client_name = ' ' if ($msg_client_name eq '');
662 if (!($msg_helo = <MSG>)) {
663 close(MSG);
664 return ($ise_msg, "message $msg truncated in envelope");
665 }
666 chop($msg_helo);
667 } else {
668 # no IP line
669 $msg_helo = $msg_ip;
670 undef $msg_ip;
671 }
672 if (!($msg_helo =~ s/^HELO: //)) {
673 # no HELO line
674 $msg_env_from = $msg_helo;
675 undef($msg_helo);
676 } else {
677 if (!($msg_env_from = <MSG>)) {
678 close(MSG);
679 return ($ise_msg, "message $msg truncated after HELO line");
680 }
681 chop($msg_env_from);
682 }
683 if (!($msg_env_from =~ s/^env_From: //)) {
684 # no env_from line
685 $line = $msg_env_from;
686 undef($msg_env_from);
687 } else {
688 $msg_mail_host = $msg_env_from;
689 $msg_mail_host =~ s/.*mail_host=(.*)/$1/;
690 $msg_env_from =~ s/<?([^\t> ]*).*/$1/;
691 $line = <MSG>;
692 }
693
694 # Save the envelope env_To lines.
695 for (;;) {
696 if (!$line) {
697 close(MSG);
698 return ($ise_msg, "message $msg truncated in envelope");
699 }
700 last if ($line =~ /^[\r\n]*$/);
701 if ($line eq "abort\n") {
702 close(MSG);
703 return ("aborted transaction", "");
704 }
705 push(@msg_env_to, $1) if ($line =~ /env_To:[\t ]*<?([^\t> ]+).*/);
706 $line = <MSG>;
707 }
708
709
710 # Look for header lines that get checksums as we collect the whole message.
711 $new_hdr = "";
712 undef($hdr_type);
713 for (;;) {
714 if (!($line = <MSG>)) {
715 close(MSG);
716 return ($ise_msg, "message $msg truncated in headers");
717 }
718
719 # dccifd logs header lines with <CR><LF> but dccm uses <LF>
720 $line =~ s/\r\n$/\n/;
721
722 # deal with header continuation
723 if ($line =~ /^[\t ]+/) {
724 $new_hdr .= $line;
725 $$cur_hdr .= $line if ($cur_hdr);
726 next;
727 }
728
729 if ($cur_hdr) {
730 # end a preceding interesting header
731 $$cur_hdr =~ s/[\t ]*\n[\r\s]*/ /g;
732 $$cur_hdr =~ s/^\s+//;
733 $$cur_hdr =~ s/\s+$//;
734 # emit a link
735 if (!$no_body) {
736 if ($hdr_type) {
737 $msg_hdrs .= "$edit_link${url_ques}type=$hdr_type&amp;val=";
738 $msg_hdrs .= url_encode($$cur_hdr);
739 $msg_hdrs .= "&amp;msg=$msg&amp;auto=1#cur_key\">";
740 chop($new_hdr);
741 $msg_hdrs .= html_str_encode($new_hdr);
742 $msg_hdrs .= "</A>\n";
743 undef($hdr_type);
744 } else {
745 $msg_hdrs .= html_str_encode($new_hdr);
746 }
747 }
748 undef $cur_hdr;
749 } else {
750 # end preceding boring header
751 $msg_hdrs .= html_str_encode($new_hdr);
752 }
753
754 # stop after the headers
755 last if ($line eq "\n");
756
757 ++$num_hdrs;
758
759 $new_hdr = $line;
760
761 # Start an interesting header
762
763 if ($line =~ s/^from:\s*//i) {
764 $hdr_type = "from";
765 $msg_from = $line;
766 $cur_hdr = \$msg_from;
767 next;
768 }
769 if ($line =~ s/^(Message-ID):\s*//i) {
770 $hdr_type = "Message-ID";
771 $misc_hdr = $line;
772 $cur_hdr = \$misc_hdr;
773 $seen_message_id = 1;
774 next;
775 }
776 if ($line =~ s/^subject:\s*//i && 'subject:' =~ /^($sub_hdrs):/i) {
777 $hdr_type = url_encode("substitute subject");
778 $msg_subject = $line;
779 $cur_hdr = \$msg_subject;
780 next;
781 }
782
783 if (!$no_body && $line =~ s/^($sub_hdrs):\s*//i) {
784 $hdr_type = $1;
785 $hdr_type =~ tr/A-Z/a-z/;
786 $hdr_type = url_encode("substitute $hdr_type");
787 $misc_hdr = $line;
788 $cur_hdr = \$misc_hdr;
789 next;
790 }
791 }
792
793 # fake empty Message-ID if required
794 if (!$seen_message_id && $num_hdrs) {
795 $msg_hdrs .= "$edit_link${url_ques}type=";
796 $msg_hdrs .= "Message-ID";
797 $msg_hdrs .= "&amp;val=%3c%3e&amp;msg=$msg&amp;auto=1#cur_key\">missing Message-ID</A>\n";
798 }
799
800 # copy the body of the message
801 for (;;) {
802 if (!($line = <MSG>)) {
803 close(MSG);
804 return ($ise_msg, "message $msg truncated in body");
805 }
806 last if ($line =~ $cksum_marker_p);
807 $line =~ s/[ \t\r]+$//mg;
808 $msg_body .= html_text_encode($line) if (!$no_body);
809 }
810
811
812 # copy the checksums
813 while ($line = <MSG>) {
814 # notice quoted checksums that are part of the body
815 if ($line =~ $cksum_marker_p) {
816 if (!$no_body) {
817 $msg_body .= "<PRE class=mono>\n";
818 $msg_body .= $cksum_marker;
819 $msg_body .= $msg_cksums;
820 $msg_body .= "</PRE>\n";
821 }
822 $msg_cksums = '';
823 $msg_result = ': ';
824 next;
825 }
826
827 $msg_cksums .= $line;
828
829 # Build a string of all of the reasons why the message should
830 # have been accepted or rejected as we build the list of checksums.
831 # Use italics for disabled checks.
832 $msg_result .= "MTA " if ($line =~ /\bMTA-->spam(|\(first\))\b/);
833 $msg_result .= "MTA-OK " if ($line =~ /\bMTA-->OK(|\(first\))\b/);
834 $msg_result .= "BL " if ($line =~ /\bwlist-->spam\b/);
835 $msg_result .= "WL " if ($line =~ /\bwlist-->OK\b/);
836 $msg_result .= "DCC " if ($line =~ /\bDCC-->spam\b/);
837 $msg_result .= "<I>DCC</I> " if ($line =~ /\bDCC-->spam\(off\)\b/);
838 $msg_result .= "OK-DCC " if ($line =~ /\bDCC-->OK\b/);
839 $msg_result .= "<I>OK-DCC</I> " if ($line =~ /\bDCC-->OK\(off\)\b/);
840 $msg_result .= "Rep " if ($line =~ /\bRep-->spam\b/);
841 $msg_result .= "<I>Rep</I> " if ($line =~ /\bRep-->spam\(off\)\b/);
842 $msg_result .= "$1 " while ($line =~ s/\b(DNSBL\d?)-->spam\b//);
843 $msg_result .= "<I>$1</I> "
844 if ($line =~ s/\b(DNSBL\d?)-->spam\(off\)\b// );
845
846 # Prefix the string of reasons with what was done.
847 if ($line =~ /^result: temporary greylist embargo/) {
848 $msg_result = "Grey" . $msg_result;
849 } elsif ($line =~ /^result: accept after greylist embargo/) {
850 $msg_result = "OK-Grey" . $msg_result;
851 } elsif ($line =~ /^result: accept/) {
852 $msg_result = "OK" . $msg_result;
853 } elsif ($line =~ /^result: reject temporarily/) {
854 $msg_result = "Delay" . $msg_result;
855 } elsif ($line =~ /^result: reject/) {
856 $msg_result = "Reject" . $msg_result;
857 } elsif ($line =~ /^result: discard/) {
858 $msg_result = "Discard" . $msg_result;
859 } elsif ($line =~ /^result: .*abort/) {
860 $msg_result = "abort";
861 }
862 }
863 $msg_result =~ s/^: //;
864 $msg_cksums = html_str_encode($msg_cksums) if (!$no_body);
865
866
867 close(MSG);
868 return undef;
869 }
870
871
872
873 sub decode_msg_name {
874 my($str) = @_;
875 my($val, $i, $c);
876
877 use integer;
878
879 $val = 0;
880 for ($i = 0; $i < length($str); ++$i) {
881 $c = ord(substr($str, $i, 1));
882 if ($c >= ord('a')) {
883 $c = $c - ord('a') + 10;
884 } elsif ($c >= ord('A')) {
885 $c = $c - ord('A') + 10+26;
886 } else {
887 $c -= ord('0');
888 }
889 $val = ($val * (10+26+26)) + $c;
890 }
891 return $val;
892 }
893
894
895
896 sub msg2path {
897 my($msg, $path) = @_;
898
899 $path = $logdir . '/' if (!defined $path);
900
901 if (length($msg) >= 8) {
902 $path .= sprintf("%03d/", decode_msg_name(substr($msg, 6, 2)));
903 if (length($msg) >= 9) {
904 $path .= sprintf("%02d/", decode_msg_name(substr($msg, 8, 1)));
905 if (length($msg) >= 10) {
906 $path .= sprintf("%02d/", decode_msg_name(substr($msg, 9, 1)));
907 }
908 }
909 }
910
911 return $path . 'msg.' . substr($msg, 0, 6);
912 }
913
914
915
916 # flush one cache file
917 sub cache_write_file {
918 my($buf, $cnum) = @_;
919 my($tmp, $cfname, $date);
920
921 $tmp = "msg.cache." . "new." . $$;
922 if (!sysopen(CFILE, $tmp, O_WRONLY | O_CREAT, 0660)){
923 print STDERR "open($tmp): $!\n";
924 return undef;
925 }
926 if (syswrite(CFILE, $cache_version) != length($cache_version)
927 || syswrite(CFILE, $buf) != length($buf)) {
928 print STDERR "syswrite $tmp: $!\n";
929 close(CFILE);
930 unlink($tmp);
931 return undef;
932 }
933
934 close(CFILE);
935 $cnum =~ /(\d+)/; $cnum = $1; # suppress Perl taint warning
936 $date = $cnum * (24*3600);
937 if ($date <= time) {
938 utime($date, $date, $tmp)
939 || print STDERR "utime($date, $date, $tmp): $!\n";
940 }
941 $cfname = "msg.cache." . $cnum;
942 if (!rename($tmp, $cfname)) {
943 print STDERR "rename($tmp, $cfname): $!\n";
944 unlink($tmp);
945 return undef;
946 }
947
948 $msgs_cache_state{$cnum} = 1;
949 return 1;
950 }
951
952
953
954 # flush the cache files
955 sub cache_flush {
956 my($cache_files, $log_files,
957 $cnum, $cfname, $state, $new_cnum, $msg, $buf, $buf_start);
958
959 if (! -w ".") {
960 my $marker = "$logout_tmpdir/msg.$user-nocache";
961 if (! -f $marker
962 || (stat(_))[9] < time()-(4*3600)) {
963 if (!open(CFILE,">>",$marker)){
964 print STDERR "open($marker): $!\n";
965 } else {
966 print CFILE "$logdir not writable for cache files\n";
967 close CFILE;
968 }
969 print STDERR "$logdir not writable for cache files\n";
970 }
971 return;
972 }
973
974 $cache_files = 0;
975 $log_files = 0;
976 $buf_start = 0;
977
978 $cnum = 0;
979 foreach $msg (@msgs_num) {
980 # one cache file per day, so pick the cache for this log file
981 # note that the files are sorted by mtime
982 $new_cnum = $msgs_cache{$msg}[0] / (24*3600);
983
984 # skip this log file if its cache file is good
985 next if ($msgs_cache_state{$new_cnum});
986
987 # close the current cache file if we are dealing with a new day
988 # and so a new cache file
989 if ($cnum != $new_cnum) {
990 if ($log_files - $buf_start > 10) {
991 ++$cache_files;
992 return if (!cache_write_file($buf, $cnum));
993 $buf_start = $log_files;
994 } else {
995 # forget the cache file if it would be tiny
996 $log_files= $buf_start;
997 }
998 undef $buf;
999 $cnum = $new_cnum;
1000 }
1001
1002 $buf .= pack($cache_pack,
1003 $msgs_cache{$msg}[0],
1004 $msgs_cache{$msg}[1],
1005 $msg);
1006 ++$log_files;
1007 }
1008 if ($log_files - $buf_start > 10) {
1009 ++$cache_files;
1010 cache_write_file($buf, $cnum);
1011 } else {
1012 $log_files= $buf_start;
1013 }
1014
1015 # delete junk cache files
1016 while (($cnum, $state) = each %msgs_cache_state) {
1017 next if ($state);
1018 $cfname = "msg.cache." . $cnum;
1019 if (-f $cfname && !unlink($cfname)) {
1020 print STDERR "unlink($cfname): $!\n";
1021 return;
1022 }
1023 }
1024
1025 debug_time("flushed $cache_files cache files with $log_files files");
1026 }
1027
1028
1029
1030 # get the list of messages
1031 # The first arg is the current file
1032 # Try to limit the size of the table to the second arg
1033 # divide days worth of files to fit the page size if it is <0
1034 #
1035 # sets globals %msgs_date, %msgs_result, %msgs_from, %msgs_subject,
1036 # $msg_day_first, $msg_day_last, $msg_first, $msg_last,
1037 # $msg_newer, $msg_part_num, @msgs_num
1038 sub get_log_msgs {
1039 my($page_msg, # target log message
1040 $page_size, # log files / web page
1041 $mode # 0=old, 1=reverse sort & divide days
1042 ) = @_;
1043 my($cache_len, $need_flush, $cache_parse_limit, $dir_len,
1044 $line, $msg, $entry, $days, $sort_order,
1045 $msg_tgt, $date_tgt, $date_cur, $date1, $msg_num, $msg_num_prev, $start);
1046
1047 $cache_parse_limit = 100;
1048
1049 $cache_version = "DCC msg.cache version 3\n";
1050 $cache_pack = "LLA10";
1051 $cache_line_len = length(pack($cache_pack, 0));
1052 $msg_encode_str = ("0123456789"
1053 . "abcdefghijklmnopqrstuvwxyz"
1054 . "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
1055
1056 # reverse the sort for old callers
1057 $sort_order = !$mode ? -1 : 1;
1058
1059
1060 # Build a list of log file names and dates
1061 # Use cache files of names and dates. Validate the cache
1062 # files by checking i-numbers. Use the `ls` command because the
1063 # the Perl readdir() function does not provide d_ino/d_fileno.
1064
1065 chdir($logdir) || html_whine("chdir($logdir): $!");
1066
1067 # ls -ifC1 would be faster, but it does not work on files on Solaris
1068 html_whine("ls -iC1 $logdir: $!")
1069 if (!open(DIR, "find . -name 'msg.*' | @DCC_XARGS@ /bin/ls -iC1 |"));
1070 $dir_len = 0;
1071 while ($line = <DIR>) {
1072 # find simple log files as well as log files in DDD, DDD/HH, and
1073 # DDD/HH/MM subdirectories
1074 if ($line =~ /^\s*(\d+)\s+\.\/((\d\d\d)(\/(\d\d))?(\/(\d\d))?\/)?msg\.([A-Za-z\d]{6})\s*$/) {
1075 my ($filename, $subdir);
1076 $filename = $8;
1077 if (defined $3) {
1078 # encode the subdirectory
1079 next if ($3 > 366);
1080 use integer;
1081 $filename .= (substr($msg_encode_str,
1082 $3 / length($msg_encode_str), 1)
1083 . substr($msg_encode_str,
1084 $3 % length($msg_encode_str), 1));
1085 if (defined $5) {
1086 next if ($5 >= 24);
1087 $filename .= substr($msg_encode_str, $5, 1);
1088 if (defined $7) {
1089 next if ($7 >= 60);
1090 $filename .= substr($msg_encode_str, $7, 1);
1091 }
1092 }
1093 }
1094 $msgs_cache{$filename}[1] = $1;
1095 ++$dir_len;
1096 next;
1097 }
1098 # notice cache files
1099 if ($line =~ /^\s*\d+\s+\.\/(msg\.cache\.(\d{5}))\s*$/
1100 && -f $1
1101 && (((stat(_))[7] - length($cache_version))
1102 % $cache_line_len) == 0) {
1103 $msgs_cache_state{$2} = 0;
1104 next;
1105 }
1106 }
1107 close(DIR);
1108 debug_time("$dir_len files found");
1109
1110 # load the cache files
1111 # Because cache files are named with dates, are read in sorted
1112 # order, and have sorted contents, we do not need to sort
1113 # what we read from them.
1114 $cache_len = 0;
1115 $need_flush = 0;
1116 foreach my $cnum (sort keys(%msgs_cache_state)) {
1117 my($total, $good, $date_lo, $date_hi);
1118
1119 next if (!open(CFILE, "msg.cache." . $cnum));
1120
1121 if (!read(CFILE, $buf, length($cache_version))
1122 || $buf ne $cache_version) {
1123 close CFILE;
1124 next;
1125 }
1126
1127 # the names in a cache file are for a single day
1128 $date_lo = $cnum * 24*3600;
1129 $date_hi = $date_lo + 24*3600 - 1;
1130 $good = $total = 0;
1131 while (read(CFILE, $buf, $cache_line_len)) {
1132 my($date, $ino, $msg) = unpack($cache_pack, $buf);
1133 ++$total;
1134
1135 # a cache file is bogus if it contains bad dates
1136 last if ($date < $date_lo || $date > $date_hi);
1137
1138 # skip deleted log files
1139 next if (!exists($msgs_cache{$msg}));
1140
1141 # skip cached file names that have been recycled
1142 next if ($msgs_cache{$msg}[1] != $ino);
1143
1144 $msgs_cache{$msg}[0] = $date;
1145 push @msgs_num, $msg;
1146
1147 ++$good;
1148 }
1149 close(CFILE);
1150 if ($good == 0 || $good+20 < $total) {
1151 $need_flush = 1;
1152 } elsif ($good == $total) {
1153 $msgs_cache_state{$cnum} = 1;
1154 }
1155 $cache_len += $good;
1156 }
1157 debug_time("$cache_len files cached");
1158
1159 # If there are any new log files,
1160 # then we must get their dates and then sort all of the names
1161 if ($cache_len != $dir_len) {
1162 $need_flush = 1 if ($dir_len > $cache_len+100);
1163 $msg_num = 0;
1164 while (($msg, $entry) = each %msgs_cache) {
1165 next if (@$entry[0]); # we know about this file from cache
1166
1167 my $date = (stat msg2path($msg))[9];
1168 if (!$date) {
1169 # forget this file if we cannot stat() it
1170 delete $msgs_cache{$msg};
1171 next;
1172 }
1173 @$entry[0] = $date;
1174 $msgs_cache_state{$date / (24*3600)} = 0;
1175 ++$msg_num;
1176 }
1177 debug_time("$msg_num files dated");
1178
1179 # this is obscure but much faster than using comparison functions that
1180 # do hash lookups for each comparison of the sort
1181 @msgs_num = map {my @a = unpack("NA10",$_); $a[1]}
1182 (sort map pack("NA10",
1183 $msgs_cache{$_}[0]*$sort_order,
1184 $_),
1185 keys %msgs_cache);
1186 debug_time("sorted " . ($#msgs_num+1) . " files");
1187 }
1188
1189 # find the target message that must be listed
1190 $msg_tgt = ($sort_order > 0 && $#msgs_num >= 0) ? $#msgs_num : 0;
1191 if ($page_msg) {
1192 for ($msg_num = 0; $msg_num <= $#msgs_num; ++$msg_num) {
1193 if ($msgs_num[$msg_num] eq $page_msg) {
1194 $msg_tgt = $msg_num;
1195 last;
1196 }
1197 }
1198 debug_time("found #" . $msg_tgt);
1199 }
1200
1201 # we are finished if the caller only wanted the list of files
1202 # perhaps for URLs pointing to previous and next files
1203 if (!$page_size || $page_size < 1 || $#msgs_num < 0) {
1204 cache_flush() if ($need_flush);
1205 $msg_first = $msg_tgt;
1206 $msg_last = $#msgs_num;
1207 $msg_newer = $#msgs_num;
1208 $msg_part_num = 0;
1209 $msgs_mtime{$page_msg} = 1 if (!$mode && $page_msg);
1210 return;
1211 }
1212
1213 # Get summary information from all of the files on the target day, the
1214 # last file on the previous day, and on the first file on the next day.
1215 #
1216 # walk backward from the target to the first log file of the target day
1217 $date_tgt = $date_cur = (localtime $msgs_cache{$msgs_num[$msg_tgt]}[0])[7];
1218 for ($msg_day_first = $msg_tgt;
1219 $msg_day_first > 0;
1220 $msg_day_first = $msg_num) {
1221 $msg_num = $msg_day_first-1;
1222 $date_cur = (localtime $msgs_cache{$msgs_num[$msg_num]}[0])[7];
1223 last if ($date_cur != $date_tgt);
1224 }
1225 if (!$mode) {
1226 $msg_part_num = 0;
1227 $msg_first = $msg_day_first;
1228 } else {
1229 $msg_part_num = ($msg_tgt - $msg_day_first) / $page_size;
1230 $msg_first = $msg_day_first + ($msg_part_num * $page_size);
1231 }
1232
1233 # walk forward to the end of the day or $page_size files
1234 $days = 0; # count space used by date headings
1235 $msg_last = $msg_first + $page_size-1;
1236 $msg_last = $#msgs_num if ($msg_last > $#msgs_num);
1237 $msg_newer = $msg_first + $page_size;
1238 $msg_newer = $#msgs_num if ($msg_newer > $#msgs_num);
1239 $msg_day_last = $#msgs_num;
1240 $date1 = $date_tgt;
1241 for ($msg_num = $msg_tgt+1; $msg_num <= $#msgs_num; ++$msg_num) {
1242 $date_cur = (localtime $msgs_cache{$msgs_num[$msg_num]}[0])[7];
1243 next if ($date_cur == $date1);
1244
1245 ++$days;
1246
1247 if ($date1 == $date_tgt) {
1248 $msg_day_last = $msg_num-1;
1249
1250 # the "newer" link goes to the first file of the next day if
1251 # the current day fits on the web page
1252 $msg_newer = $msg_num if (!$msg_newer || $msg_num < $msg_newer);
1253 }
1254
1255 if ($msg_num > $msg_first + $page_size - $days) {
1256 $msg_last = $msg_num-1 if (!$mode);
1257 last;
1258 }
1259
1260 $msg_last = $msg_num-1 if ($#msgs_num > $msg_first+$page_size-$days);
1261 $date1 = $date_cur;
1262 }
1263
1264 if ($mode) {
1265 ++$msg_part_num if ($msg_part_num != 0
1266 || $msg_first + $page_size <= $msg_day_last);
1267 # overlap the parts of a day by a line
1268 ++$msg_last if ($msg_part_num != 0 && $msg_last < $msg_day_last);
1269 }
1270
1271 # parse the log files to get the data
1272 for ($msg_num = $msg_first; $msg_num <= $msg_last; ++$msg_num) {
1273 $msg = $msgs_num[$msg_num];
1274 my(@error) = parse_log_msg($msg, "no body");
1275 if (defined $error[0]) {
1276 $msgs_date{$msg} = strftime("%x %X",
1277 localtime($msgs_cache{$msg}[0]))
1278 if (!$msgs_date{$msg} && $msgs_cache{$msg}[0]);
1279 $msgs_from{$msg} = "<STRONG class=warn>$error[0]</STRONG>";
1280 $msgs_result{$msg} = '';
1281 $msgs_subject{$msg} = "<STRONG class=warn>$error[1]</STRONG>";
1282 } else {
1283 $msgs_date{$msg} = $msg_date;
1284 $msgs_from{$msg} = hdr_trim_encode($msg_from
1285 ? $msg_from
1286 : $msg_env_from);
1287 $msgs_result{$msg} = $msg_result ? $msg_result : "&nbsp;";
1288 $msgs_subject{$msg} = hdr_trim_encode($msg_subject);
1289 }
1290 }
1291 debug_time(($msg_last - $msg_first + 1) . " log files parsed");
1292
1293 cache_flush() if ($need_flush);
1294 }
1295
1296
1297
1298 ##########################################################################
1299 # whiteclnt file functions
1300
1301 # The file is represented as an array or list of references to 3-tuples.
1302 # The first of the three is the whitelist entry in a canonical form
1303 # as a key uniquely identifying the entry.
1304 # The second is a comment string of zero or more comment lines.
1305 # The third is the DCC whiteclnt entry.
1306 #
1307 # The canonical form and the whiteclnt line of the first 3-tuple for a file
1308 # are null, because it contains the comments, if any, before the file's
1309 # preamble of dans when the file has been changed and flags.
1310 # The file[1] is an empty slot for adding option settings.
1311 # The last triple in a file may also lack a whitelist entry.
1312
1313 # There is a hash or dictionary of references to entries in the list
1314
1315
1316 # lock, read, and parse the file
1317 sub read_whiteclnt {
1318 my($file_ref, $dict_ref) = @_;
1319 my($entry, $prev_entry, $comment);
1320
1321 @$file_ref = ();
1322 %$dict_ref = ();
1323
1324 # Creating the file here is usually a waste of effort, because
1325 # it must be writable by both the HTTP server and dccm or dccifd.
1326 # They are probably not in any common group.
1327 # Let the @libexecdir@/newwebuser script create the per-user
1328 # directories and files.
1329 # Because whitelists might be a little sensitive, they should not be
1330 # readable by "other"
1331 html_whine("open($whiteclnt): $!")
1332 if (!sysopen(WHITECLNT, $whiteclnt, O_RDWR | O_CREAT, 0660));
1333 chmod(0660, $whiteclnt);
1334
1335 html_whine("flock($whiteclnt): $!")
1336 if (!flock(WHITECLNT, LOCK_EX | LOCK_NB));
1337
1338 $comment = "";
1339 while ($entry = <WHITECLNT>) {
1340 # end the last line properly even if the file doesn't
1341 $entry .= "\n" if (substr($entry,-1) ne "\n");
1342
1343 # collect lines until we get a non-comment
1344 if ($entry =~ /^\s*(#|$)/) {
1345 $comment .= $entry;
1346 next;
1347 }
1348
1349 # use the previous count if the current value is missing,
1350 # because that is what dcclib/parse_whitefile.c does.
1351 $entry = "$1$entry"
1352 if ($entry =~ /^[ \t]/
1353 && $#$file_ref > 0
1354 && ($prev_entry = ${${$file_ref}[$#$file_ref]}[2])
1355 && $prev_entry =~ /^(\S+)/);
1356
1357 add_white_entry($file_ref, $dict_ref, $comment, $entry);
1358 $comment = "";
1359 }
1360
1361 # save a non-trivial trailing comment
1362 add_white_entry($file_ref, $dict_ref, $comment, "")
1363 if ($comment && $comment !~ /^\s*$/);
1364 }
1365
1366
1367
1368 # read the main whiteclnt file to determine the default option settings
1369 sub read_whitedefs {
1370 my($def_ref) = @_;
1371 my(@sb1, @sb2, $line, @parsed, $bydef);
1372
1373
1374 # these defaults for the defaults must match dcclib/parse_whitefile.c
1375 # or elsewhere in the DCC client source (e.g. for discardok)
1376 %$def_ref = ();
1377 $bydef = " <SMALL>by default</SMALL>";
1378 ${$def_ref}{dccenable} = "<STRONG>on</STRONG>$bydef";
1379 ${$def_ref}{greyfilter} = "<STRONG>on</STRONG>$bydef";
1380 ${$def_ref}{greylog} = "<STRONG>on</STRONG>$bydef";
1381 ${$def_ref}{mtafirst} = "<STRONG>last</STRONG>$bydef";
1382 ${$def_ref}{rep} = "<STRONG>off</STRONG>$bydef";
1383 ${$def_ref}{dnsbl1} = "<STRONG>off</STRONG>$bydef";
1384 ${$def_ref}{dnsbl2} = "<STRONG>off</STRONG>$bydef";
1385 ${$def_ref}{dnsbl3} = "<STRONG>off</STRONG>$bydef";
1386 ${$def_ref}{logall} = "<STRONG>off</STRONG>$bydef";
1387 ${$def_ref}{discardok} = "<STRONG>delay mail</STRONG>$bydef";
1388
1389 foreach my $ck (split(/,/,$thold_cks)) {
1390 my $nm = "thold-$ck";
1391 if (!$conf_cks_tholds{$ck}) {
1392 ${$def_ref}{$nm} = "<STRONG>Never</STRONG>$bydef";
1393 } else {
1394 ${$def_ref}{$nm} = $conf_cks_tholds{$ck};
1395 }
1396 }
1397
1398 if (!sysopen(MAINWHITE, $main_whiteclnt, O_RDONLY, 0)) {
1399 print STDERR "open(${main_whiteclnt}: $!\n";
1400 return;
1401 }
1402
1403 if (!(@sb1 = stat(MAINWHITE))) {
1404 print STDERR "stat(${main_whiteclnt}: $!\n";
1405 } elsif (!(@sb2 = stat(WHITECLNT))) {
1406 print STDERR "stat(${$whiteclnt}: $!\n";
1407 } elsif ($sb1[0] == $sb2[0] && $sb1[1] == $sb2[1]) {
1408 # ignore it if we are somehow working on the main file
1409 } else {
1410 while ($line = <MAINWHITE>) {
1411 # skip everything except option settings
1412 next if ($line !~ /^\s*option\s+/i);
1413
1414 @parsed = parse_white_entry($line, "option");
1415 next if (!$parsed[1]);
1416 ${$def_ref}{$parsed[0]} = "<STRONG>$parsed[2]</STRONG> <SMALL>by default in $main_whiteclnt</SMALL>";
1417 }
1418 }
1419 close(MAINWHITE);
1420 }
1421
1422
1423
1424 # add an entry to our image of the file
1425 # sets the globals:
1426 # $whiteclnt_version, #webuser version ...
1427 # $whiteclnt_notify, #webuser mail-notify=X mailbox=Y
1428 # $whiteclnt_notify_pat, #regex for #webuser mail-notify=X mailbox=Y
1429 # $whiteclnt_lock, #webuser (un)locked
1430 # $whiteclnt_cur_key #editing position in the file
1431 # $whiteclnt_change_log, #list of dates when file was changed
1432
1433 sub add_white_entry {
1434 my($file_ref, $dict_ref, $comment, $line) = @_;
1435 my(@parsed);
1436
1437 # trim unneeded white space
1438 $line =~ s/\s+$//;
1439 $comment =~ s/[ \t]+$//mg;
1440
1441 # deal with the preamble.
1442 # The preamble consists of the comments that start the file.
1443 if (! @$file_ref) {
1444 my($preamble, @buf);
1445
1446 # remove the change-history, version, and parameters from the preamble
1447 $whiteclnt_version = "#webuser version 1.0\n";
1448 while ($comment =~ s/^#webuser version ([0-9.]+)\n/ \n/m) {
1449 # for now, insist on version 1.0
1450 html_whine("unrecognized version $1 in $whiteclnt")
1451 if ($1 ne "1.0");
1452 }
1453
1454 $whiteclnt_notify_pat = '(#webuser mail-notify=)(on|off)( mailbox=)([-_a-z0-9]*)';
1455 $whiteclnt_notify = "#webuser mail-notify=off mailbox=\n";
1456 while ($comment =~ s/^$whiteclnt_notify_pat\n/ \n/im) {
1457 $whiteclnt_notify = "$1$2$3$4\n";
1458 }
1459
1460 $whiteclnt_lock = "#webuser unlocked\n";
1461 while ($comment =~ s/^#\s*webuser\s+unlocked\n/ \n/im) {
1462 }
1463 while ($comment =~ s/^#\s*webuser\s+locked\n/ \n/im) {
1464 $whiteclnt_lock = "#webuser locked\n";
1465 }
1466
1467 $whiteclnt_cur_key = "";
1468 while ($comment =~ s/^#\s*webuser\s+cur_key\s+(.*)\n/ \n/im) {
1469 $whiteclnt_cur_key = $1;
1470 }
1471
1472 $whiteclnt_change_log = "";
1473 while ($comment =~ s/^#\s*webuser created\s+(.+\n)/ \n/im) {
1474 $whiteclnt_change_log = "#webuser created $1";
1475 }
1476 undef(@buf);
1477 while ($comment =~ s/^#webuser\s+changed\s+(.+\n)/ \n/im) {
1478 push(@buf, "#webuser changed $1");
1479 }
1480 # keep only the last 20 dates of change
1481 if (@buf) {
1482 my($start);
1483 $start = $#buf-20;
1484 $start = 0
1485 if ($start < 0);
1486 $whiteclnt_change_log .= join('', @buf[$start .. $#buf]);
1487 }
1488
1489 # We have removed the parameter lines from the first comment of the
1490 # file and replaced them with " \n"
1491 # Before starting we remove blanks from the ends of lines.
1492 # The first block of comments must now be divided between (1) comments
1493 # about the file and (2) comments about the first real line of the file.
1494 if ($comment =~ s/^(.* \n)//s) {
1495 # Take the comment lines through the last marker if there were any.
1496 # Add the first blank line after the markers if present.
1497 $preamble = $1;
1498 $preamble .= "\n" if ($comment =~ s/^\n//);
1499 # remove the markers for detected parameter lines
1500 $preamble =~ s/ \n//g;
1501 } else {
1502 # without parameters, take lines through the first blank line as (1)
1503 $preamble = ($comment =~ s/(.*?\n\n)//s
1504 || $comment =~ s/(.*?\n[# \t]+\n)//s) ? $1 : "";
1505 }
1506
1507 # start the memory copy of the file with the preamble
1508 # and the spare slot for option changes
1509 @$file_ref = ([undef, $preamble, ""], ["", undef, undef]);
1510
1511 # finished if the file has no entries,
1512 return if (!$line && !$comment);
1513
1514 # or deal with the first entry
1515 }
1516
1517 # If the line makes sense, remember where it will be.
1518 # Treat the line as a comment if it makes no sense
1519 @parsed = parse_white_entry($line, "");
1520 if (!$parsed[1]) {
1521 $comment .= $line;
1522 $comment .= "\n" if ($comment !~ /\n$/);
1523 push @$file_ref, [undef, $comment, ""];
1524 } else {
1525 my($cur_key, $entry, $i, $k);
1526
1527 $cur_key = $parsed[0];
1528 $entry = [$cur_key, $comment, $parsed[1]];
1529 push @$file_ref, $entry;
1530
1531 if (${$dict_ref}{$cur_key}) {
1532 $i = 0;
1533 # mark duplicate values for eventual deletion
1534 # keep the last setting in the file
1535 while (${$dict_ref}{$k = "DUP-$i-$cur_key"}) {
1536 ++$i;
1537 }
1538 ${$dict_ref}{$k} = ${$dict_ref}{$cur_key};
1539 }
1540 ${$dict_ref}{$cur_key} = $entry;
1541 }
1542 }
1543
1544
1545 # check the syntax of IP addresses and CIDR blocks
1546 # return undef if ok but an error string if not
1547 sub check_ip {
1548 my($value) = @_;
1549
1550 return "blank or missing IP address" if (!$value);
1551
1552 my $addr = $value;
1553 if ($addr =~ s/(.*)\/(\d+)/$1/) {
1554 my $cidr = $2;
1555 $cidr += 96 if ($addr =~ /:/);
1556 return "\"$value\" is not a valid CIDR block"
1557 if ($cidr > 128 || $cidr <= 0);
1558 }
1559
1560 # it would be better to use some library to parse the IP address,
1561 # but in 2005, there was no Perl module that could handle IPv6
1562 # addresses and is almost always available
1563 return "\"$value\" is not a valid IP address"
1564 if ($addr !~ /^[.:0-9a-f]+$/);
1565
1566 if ($addr =~ /:/) {
1567 # IPv6
1568 my $colons = $addr;
1569 $colons =~ s/[^:]+//g;
1570 $colons = length($colons);
1571 if ($addr =~ /^::/ && $colons <= 7) {
1572 ++$colons while ($colons < 7 && $addr =~ s/^::/::0:/);
1573 $addr =~ s/^::/0:/ if ($colons == 7);
1574 } elsif ($addr =~ /::$/ && $colons <= 7) {
1575 ++$colons while ($colons < 7 && $addr =~ s/::$/:0::/);
1576 $addr =~ s/::$/:0/ if ($colons == 7);
1577 } else {
1578 ++$colons while ($colons < 7 && $addr =~ s/::/::0:/);
1579 $addr =~ s/::/:0:/ if ($colons == 7);
1580 }
1581 return "$value is not a valid IP address" if ($colons > 7);
1582
1583 $addr =~ s/^([0-9a-f]{1,4}:)+//;
1584 $addr =~ s/^[0-9a-f]{1,4}$/127.0.0.1/;
1585 return "\"$value\" is not a valid IP address" if ($addr =~ /:/);
1586
1587 # stop looking at IPv6 address with either the IPv4 trailing part
1588 #or a fake 127.0.0.1
1589 }
1590
1591 my $quads = 0;
1592 while ($addr =~ s/^(\d{1,3})\.//) {
1593 return "\"$value\" is not a valid IP address" if ($1 > 255);
1594 ++$quads;
1595 }
1596 return "$value is not a valid IP address" if ($addr > 255 || $quads > 3);
1597
1598 # we should now check for collisions among addresses
1599
1600 return undef;
1601 }
1602
1603
1604
1605 sub check_present {
1606 my($type, $value) = @_;
1607
1608 # dcc_str2ck() via dcc_parse_ck() ignores outside quotes and <>,
1609 # whitespace, and upper/lower case, and trailing periods. So our key must
1610 # also.
1611 # The value for the line in the file need not be as clean.
1612 $value =~ s/^\s+//;
1613 $value =~ s/\s+$//;
1614 $value =~ s/^<\s*(.+)\s*>$/$1/
1615 if ($value !~ s/^"\s*(.+)\s*"$/$1/);
1616 $value =~ s/\.+$//;
1617
1618 return ($type, $value) if ($value);
1619 return ($type, "<>", "blank or missing $type value");
1620 }
1621
1622
1623
1624 sub check_hex {
1625 my($type, $value) = @_;
1626
1627 return ($type, $value, "blank or missing $type value")
1628 if (!$value);
1629
1630 return ($type, $value) if ($value =~ s/([0-9a-f]{8})\s+([0-9a-f]{8})
1631 \s+([0-9a-f]{8})\s+([0-9a-f]{8})$
1632 /$1 $2 $3 $4/ix);
1633
1634 return ($type, $value, "\"$value\" is an invalid $type checksum");
1635 }
1636
1637
1638
1639 # canonicalize a whitelist checksum "type value" string
1640 # return a (type, value) pair or (x, x, "error string") triple
1641 sub parse_type_value {
1642 my $value = $_[0];
1643
1644 # Check for type
1645 # Don't support received checksums.
1646 # Body checksums must be hex.
1647 $value =~ s/\s+$//;
1648
1649 return ("IP", $value, check_ip($value))
1650 if ($value =~ s/^IP:?(\s*|$)//i);
1651
1652 return check_present("env_From", $value)
1653 if ($value =~ s/^env[-_]from:?(\s+|$)//i);
1654
1655 return check_present("env_To", $value)
1656 if ($value =~ s/^env[-_]To:?(\s+|$)//i);
1657
1658 return check_present("From", $value)
1659 if ($value =~ s/^from:?(\s+|$)//i);
1660
1661 return check_present("Message-ID", $value)
1662 if ($value =~ s/^message[-_]id:?(\s+|$)//i);
1663
1664 # don't worry much about substitute types.
1665 return check_present("substitute $1", $value)
1666 if ($value =~ s/^substitute\s+([-a-z_0-9]+)+:?(\s+|$)//i);
1667
1668 return check_hex("hex Body", $value)
1669 if ($value =~ s/^hex\s+body:?(\s+|$)//i);
1670
1671 return check_hex("hex Fuz$1", $value)
1672 if ($value =~ s/^hex\s+fuz([12]):?(\s+|$)//i);
1673
1674 return (undef, undef, "unrecognized whiteclnt value \"$value\"");
1675 }
1676
1677
1678
1679 # canonicalize a threshold setting
1680 sub parse_thold_value {
1681 my($pat, $type, $val);
1682
1683 # check the name of the checksum by converting it into a pattern
1684 # and matching it against the list of checksum types that can have
1685 # per-user thresholds
1686 $pat = ",($_[0]),";
1687 $pat =~ s/[-_]/[-_]/g;
1688 $type = ',' . $thold_cks . ',';
1689 return 0 if ($type !~ /$pat/i);
1690 $type = $1;
1691
1692 # check the threshold value
1693 if ($_[1] =~ /^Never$/i) {
1694 $val = 'Never';
1695 } elsif ($_[1] =~ /^many/i) {
1696 # reputation threshold is a % and reputation total is finite
1697 return 0 if ($type =~ /^rep/);
1698 $val = "many";
1699 } elsif ($_[1] =~ /^\d+$/) {
1700 $val = $_[1];
1701 if ($type =~ /^rep$/i) {
1702 return 0 if ($val > 100);
1703 $val .= '%';
1704 }
1705 } elsif ($_[1] =~ /^(\d+)%$/) {
1706 # reputation threshold is a %
1707 return 0 if ($1 > 100 || $type !~ /^rep$/i);
1708 $val = $_[1];
1709 } else {
1710 return 0;
1711 }
1712
1713
1714 $_[0] = $type;
1715 $_[1] = $val;
1716 return 1;
1717 }
1718
1719
1720
1721 # See if a whiteclnt line makes sense
1722 # If so, return a list of key and canonicalized line.
1723 # If it is an option setting, return a third string that is the value
1724 # for the edit form.
1725 # If not, return only an error message.
1726 sub parse_white_entry {
1727 my($line, # line to parse
1728 $mode # ''=accept from file,
1729 # 'option'=new option setting
1730 # 'strict'=new whitelist entry
1731 ) = @_;
1732
1733 my($count, $key, $type, $value, $emsg);
1734
1735 # recognize options
1736 if (!$mode || $mode eq "option") {
1737 return ("dccenable", "option dcc-$1\n", "$1")
1738 if ($line =~ /^\s*option\s+DCC-(on|off)\s*$/i);
1739
1740 return ("greyfilter", "option greylist-$1\n", "$1")
1741 if ($line =~ /^\s*option\s+greylist-(on|off)\s*$/i);
1742
1743 return ("greylog", "option greylist-log-$1\n", "$1")
1744 if ($line =~ /^\s*option\s+greylist-log-(on|off)\s*$/i);
1745
1746 return ("mtafirst", "option MTA-$1\n", "$1")
1747 if ($line =~ /^\s*option\s+MTA-(first|last)\s*$/i);
1748
1749 return ("rep", "option DCC-rep-$1\n", "$1")
1750 if ($line =~ /^\s*option\s+DCC-reps?-(on|off)\s*$/i);
1751
1752 return ("dnsbl1", "option dnsbl1-$1\n", "$1")
1753 if ($line =~ /^\s*option\s+dnsbl-(on|off)\s*$/i);
1754 return ("dnsbl$1", "option dnsbl$1-$2\n", "$2")
1755 if ($line =~ /^\s*option\s+dnsbl([123])-(on|off)\s*$/i);
1756
1757 return ("logall", "option log-all\n", "on")
1758 if ($line =~ /^\s*option\s+log-all\s*$/i);
1759 return ("logall", "option log-normal\n", "off")
1760 if ($line =~ /^\s*option\s+log-normal\s*$/i);
1761
1762 return ("logsubdir", "option log-subdirectory-$1\n", "$1")
1763 if ($line =~ /^\s*option\s+log-subdirectory-(day|hour|minute)\s*$/i);
1764
1765 return ("discardok", "option forced-discard-ok\n", "discard spam")
1766 if ($line =~ /^\s*option\s+forced-discard-ok\s*$/i);
1767 return ("discardok", "option no-forced-discard\n", "delay mail")
1768 if ($line =~ /^\s*option\s+no-forced-discard\s*$/i
1769 || $line =~ /^\s*option\s+forced-discard-nok\s*$/i); # obsolete
1770
1771 if ($line =~ /^\s*option\s+threshold\s+(\S+),(\S+)\s*$/i) {
1772 $type = $1;
1773 $value = $2;
1774 return ("thold-$type", "option threshold $type,$value\n", "$value")
1775 if (parse_thold_value($type, $value));
1776 }
1777
1778 # recognize old logging options
1779 return ("greylog", "option greylist-log-on\n", "on")
1780 if ($line =~ /^\s*log\s+all-grey\s*$/i);
1781 return ("greylog", "option greylist-log-off\n", "off")
1782 if ($line =~ /^\s*log\s+no-grey\s*$/i);
1783
1784 # we are finished if only parsing a new option line we know is ok
1785 return "unrecognized option line" if ($mode && $mode eq "option");
1786 }
1787
1788 # must be "" with a bad option or "strict" when we should see an option
1789 return "unrecognized option line"
1790 if ($line =~/^log/i || $line =~ /^option/i);
1791
1792 return "unrecognized line" if ($line !~ /^(\S+)\s+(.*)/);
1793 $count = $1;
1794 $value = $2;
1795
1796 return "unrecognized count \"$count\"" if ($count !~ /many|ok|ok2/i);
1797
1798 ($type, $value, $emsg) = parse_type_value($value);
1799 return $emsg if ($emsg);
1800
1801 # build the whiteclnt line
1802 $line = "$count\t$type";
1803 $line .= (length($type) < 8) ? "\t" : ' ';
1804 $line .= "$value\n";
1805
1806 $value =~ s/\s//g;
1807 $value =~ tr/A-Z/a-z/;
1808 $key = "$type $value";
1809
1810 return ($key, $line);
1811 }
1812
1813
1814
1815 # check a proposed entry
1816 # return an array of the error message if the proposed entry is bogus
1817 # or an array of (key, comment, line) if it make sense
1818 sub ck_new_white_entry {
1819 my($comment, $count, $type, $value) = @_;
1820 my(@parsed, @entry);
1821
1822 return "missing comment" if (!defined($comment));
1823 return "missing count" if (!$count);
1824 return "missing type" if (!$type);
1825 return "missing value" if (!$value);
1826
1827 # trim trailing whitespace from the comment lines
1828 $comment =~ s/\s+\n/\n/g;
1829 # ensure comment lines start with '#'
1830 $comment =~ s/^([ \t]*[^# \t\n])/#$1/gm;
1831 # trim trailing blank lines from the comment
1832 $comment =~ s/\s+$//s;
1833 $comment .= "\n" if (length($comment) != 0);
1834
1835 @parsed = parse_white_entry("$count $type $value", "strict");
1836 return ($parsed[0]) if (!defined($parsed[1]));
1837
1838 $entry[0] = $parsed[0];
1839 $entry[2] = $parsed[1];
1840 $entry[1] = $comment;
1841 return @entry;
1842 }
1843
1844
1845
1846 # add, change, or delete a whitelist entry
1847 # write our image of the file to disk, changing it as we go
1848 # then read the file
1849 sub chg_white_entry {
1850 my($file_ref, # the file in memory
1851 $dict_ref, # dictionary for the file
1852 $cur_key, # change or delete this entry
1853 $entry_ref, # change this if not null
1854 $add_pos # add before this if defined
1855 ) = @_;
1856 my($msg, $i, $k, @file);
1857
1858 return "$whiteclnt locked" if ($whiteclnt_lock =~ /\blocked/);
1859
1860 @file = @$file_ref;
1861
1862 if (!${$dict_ref}{$cur_key}) {
1863 # it is a new entry if it exists
1864 if ($entry_ref) {
1865 # add it to the list that will go to the disk
1866 ${$dict_ref}{$cur_key} = @$entry_ref;
1867 if (!$add_pos || $add_pos > $#file) {
1868 # append to the file without a good position
1869 push @file, $entry_ref;
1870 } else {
1871 # insert at the right position
1872 @file = (@file[0 .. $add_pos-1],
1873 $entry_ref,
1874 @file[$add_pos .. $#file]);
1875 }
1876 }
1877
1878 } else {
1879 # changing or deleting existing entry, so delete duplicates
1880 $i = 0;
1881 while (${$dict_ref}{$k = "DUP-$i-$cur_key"}) {
1882 ${$dict_ref}{$k}[1] = undef;
1883 ++$i;
1884 }
1885
1886 if (!$entry_ref) {
1887 # delete an entry
1888 ${$dict_ref}{$cur_key}[1] = undef;
1889
1890 } else {
1891 # change an entry
1892 @{${$dict_ref}{$cur_key}} = @$entry_ref;
1893 }
1894 }
1895
1896 # put the changes on the disk
1897 $msg = write_whiteclnt(@file);
1898 return $msg if ($msg);
1899
1900 # set the web form that includes the response
1901 read_whiteclnt($file_ref, $dict_ref);
1902 return undef;
1903 }
1904
1905
1906
1907 # write a new version of the file
1908 sub write_whiteclnt { # return undef or error message
1909 my(@file) = @_;
1910 local(*DIR, *BAK);
1911 my(@baks, $bak, $buf, $entry, $preamble);
1912
1913 # delete old backup files and find the name of the next one
1914 # keep only the last few and fairly recent revisions
1915 opendir(DIR, "$user_dir") or html_whine("opendir($user_dir): $!");
1916 @baks = map("$user_dir/$_",
1917 sort grep {/^(whiteclnt\.bak\d+$)/ && -f "$user_dir/$1"}
1918 readdir(DIR));
1919 closedir(DIR);
1920 while ($#baks > 1 && ($baks[0] =~ /(.*\/whiteclnt\.bak\d+$)/)
1921 && ((-M $1) >= 1 || $#baks >= 19)) {
1922 unlink $1; # suppress taint warning
1923 shift(@baks);
1924 }
1925 if ($#baks >= 0) {
1926 $baks[$#baks] =~ /\/whiteclnt\.bak(\d+)$/;
1927 $bak = sprintf("%s/whiteclnt.bak%06d", $user_dir, $1+1);
1928 } else {
1929 $bak = "$whiteclnt.bak000000";
1930 }
1931
1932 # create the undo file and copy the real file to it
1933 # It could be smoother to rename the current file, but we might
1934 # not have permission to create the new file with the correct owner.
1935 # There are also dangers with symbolic links and rename().
1936 return "cannot create $bak: $!"
1937 if (!sysopen(BAK, $bak, O_WRONLY | O_CREAT | O_EXCL, 0660));
1938 return "seek($whiteclnt): $!"
1939 if (!seek(WHITECLNT, 0, 0));
1940 while (read(WHITECLNT, $buf, 8*1024)) {
1941 return "write($bak): $!"
1942 if (!syswrite(BAK, $buf));
1943 }
1944 close(BAK);
1945
1946 # rewrite the real file
1947 return "seek($whiteclnt): $!"
1948 if (!seek(WHITECLNT, 0, 0));
1949 return "truncate($whiteclnt): $!"
1950 if (!truncate(WHITECLNT, 0));
1951
1952 $preamble = 0;
1953 foreach $entry (@file) {
1954 # skip deleted entries,
1955 next if (!defined($$entry[1]));
1956
1957 # put the parameters in the preamble
1958 if (!$preamble) {
1959 $preamble = $$entry[1];
1960 $whiteclnt_change_log .= strftime("#webuser changed %x %X%n",
1961 localtime);
1962 $preamble =~ s/\n(\n?)$/\n/;
1963 $whiteclnt_change_log .= $1;
1964 print WHITECLNT $preamble;
1965 print WHITECLNT $whiteclnt_version;
1966 print WHITECLNT $whiteclnt_notify;
1967 print WHITECLNT $whiteclnt_lock;
1968 print WHITECLNT "#webuser cur_key $whiteclnt_cur_key\n"
1969 if ($whiteclnt_cur_key);
1970 print WHITECLNT $whiteclnt_change_log;
1971 } else {
1972 print WHITECLNT $$entry[1];
1973 print WHITECLNT $$entry[2];
1974 }
1975 }
1976
1977 return undef;
1978 }
1979
1980
1981
1982 # undo the most recent operation by copying from the newest backup
1983 sub undo_whiteclnt {
1984 my($bak, $buf);
1985 local(*BAK);
1986
1987 return "$whiteclnt locked" if ($whiteclnt_lock =~ /\blocked/);
1988
1989 $bak = newest_whiteclnt_bak();
1990 return "nothing undone"
1991 if (!$bak);
1992
1993 return "open($bak): $!"
1994 if (!open(BAK, "< $bak"));
1995
1996 return "seek($whiteclnt): $!"
1997 if (!seek(WHITECLNT, 0, 0));
1998 return "truncate($whiteclnt): $!"
1999 if (!truncate(WHITECLNT, 0));
2000 while (read(BAK, $buf, 8*1024)) {
2001 return "write($whiteclnt): $!"
2002 if (!print(WHITECLNT $buf));
2003 }
2004
2005 return "unlink($bak): $!"
2006 if (!unlink($bak));
2007
2008 return undef;
2009 }
2010
2011
2012
2013 # find the newest backup file
2014 sub newest_whiteclnt_bak {
2015 local(*DIR);
2016 my(@baks, $bak);
2017
2018 opendir(DIR, "$user_dir") || return undef;
2019 @baks = sort grep {/^whiteclnt\.bak\d+/ && -f "$user_dir/$_"}
2020 readdir(DIR);
2021 closedir(DIR);
2022
2023 return undef
2024 if ($#baks < 0);
2025 $bak = "$user_dir/$baks[$#baks]";
2026 return undef
2027 if (-M $bak >= 1);
2028 return undef # suppress taint warning
2029 if ($bak !~ /(.*\/whiteclnt\.bak\d+$)/);
2030 return $1;
2031 }