|
0
|
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 = '&'; |
|
|
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/&/&/g; |
|
|
538 $out =~ s/</</g; |
|
|
539 $out =~ s/>/>/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 " " 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 .= " ..."; |
|
|
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&val="; |
|
|
738 $msg_hdrs .= url_encode($$cur_hdr); |
|
|
739 $msg_hdrs .= "&msg=$msg&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 .= "&val=%3c%3e&msg=$msg&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 : " "; |
|
|
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 } |
