chiark / gitweb /
implement connfail
[innduct.git] / control / controlchan.in
1 #! /usr/bin/perl -w
2 require "/usr/local/news/lib/innshellvars.pl";
3
4 ##  $Id: controlchan.in 7591 2006-11-22 07:20:46Z eagle $
5 ##
6 ##  Channel feed program to route control messages to an appropriate handler.
7 ##
8 ##  Copyright 2001 by Marco d'Itri <md@linux.it>
9 ##
10 ##  Redistribution and use in source and binary forms, with or without
11 ##  modification, are permitted provided that the following conditions
12 ##  are met:
13 ##
14 ##   1. Redistributions of source code must retain the above copyright
15 ##      notice, this list of conditions and the following disclaimer.
16 ##
17 ##   2. Redistributions in binary form must reproduce the above copyright
18 ##      notice, this list of conditions and the following disclaimer in the
19 ##      documentation and/or other materials provided with the distribution.
20 ##
21 ##  Give this program its own newsfeed.  Make sure that you've created
22 ##  the newsgroup control.cancel so that you don't have to scan through
23 ##  cancels, which this program won't process anyway.
24 ##
25 ##  Make a newsfeeds entry like this:
26 ##
27 ##  controlchan!\
28 ##     :!*,control,control.*,!control.cancel\
29 ##     :Tc,Wnsm\
30 ##     :@prefix@/bin/controlchan
31
32 require 5.004_03;
33 use strict;
34
35 delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
36
37 # globals
38 my ($cachedctl, $curmsgid);
39 my $lastctl = 0;
40 my $use_syslog = 0;
41 my $debug = 0;
42
43 # setup logging ###########################################################
44 # do not log to syslog if stderr is connected to a console
45 if (not -t 2) {
46     eval { require INN::Syslog; import INN::Syslog; $use_syslog = 1; };
47     eval { require Sys::Syslog; import Sys::Syslog; $use_syslog = 1; }
48         unless $use_syslog;
49 }
50
51 if ($use_syslog) {
52     eval "sub Sys::Syslog::_PATH_LOG { '/dev/log' }" if $^O eq 'dec_osf';
53     Sys::Syslog::setlogsock('unix') if $^O =~ /linux|dec_osf|freebsd|darwin/;
54     openlog('controlchan', 'pid', $inn::syslog_facility);
55 }
56 logmsg('starting');
57
58 # load modules from the control directory #################################
59 opendir(CTL, $inn::controlprogs)
60     or logdie("Cannot open $inn::controlprogs: $!", 'crit');
61 foreach (readdir CTL) {
62     next if not /^([a-z\.]+\.pl)$/ or not -f "$inn::controlprogs/$_";
63     eval { require "$inn::controlprogs/$1" };
64     if ($@) {
65         $@ =~ s/\n/  /g;
66         logdie($@, 'crit');
67     }
68     logmsg("loaded $inn::controlprogs/$1", 'debug');
69 }
70 closedir CTL;
71
72 # main loop ###############################################################
73 while (<STDIN>) {
74     chop;
75     my ($token, $sitepath, $msgid) = split(/\s+/, $_);
76     next if not defined $token;
77     $sitepath ||= '';
78     $curmsgid = $msgid || '';
79
80     my $artfh = open_article($token);
81     next if not defined $artfh;
82
83     # suck in headers and body, normalize the strange ones
84     my (@headers, @body, %hdr);
85     if (not parse_article($artfh, \@headers, \@body, \%hdr)) {
86         close $artfh;
87         next;
88     }
89     close $artfh or logdie('sm died with status ' . ($? >> 8));
90
91     next if not exists $hdr{control};
92
93     $curmsgid = $hdr{'message-id'};
94     my $sender = cleanaddr($hdr{sender} || $hdr{from});
95     my $replyto = cleanaddr($hdr{'reply-to'} || $hdr{from});
96
97     my (@progparams, $progname);
98     if ($hdr{control} =~ /\s/) {
99         $hdr{control} =~ /^(\S+)\s+(.+)?/;
100         $progname = lc $1;
101         @progparams = split(/\s+/, lc $2) if $2;
102     } else {
103         $progname = lc $hdr{control};
104     }
105
106     next if $progname eq 'cancel';
107
108     if ($progname !~ /^([a-z]+)$/) {
109         logmsg("Naughty control in article $curmsgid ($progname)");
110         next;
111     }
112     $progname = $1;
113
114     # Do we want to process the message?  Let's check the permissions.
115     my ($action, $logname, $newsgrouppats) =
116         ctlperm($progname, $sender, $progparams[0],
117                 $token, \@headers, \@body);
118
119     next if $action eq 'drop';
120
121     if ($action eq '_pgpfail') {
122         my $type = '';
123         if ($progname and $progname eq 'newgroup') {
124             if ($progparams[1] and $progparams[1] eq 'moderated') {
125                 $type = 'm ';
126             } else {
127                 $type = 'y ';
128             }
129         }
130         logmsg("skipping $progname $type$sender"
131             . "(pgpverify failed) in $curmsgid");
132         next;
133     }
134
135     # used by checkgroups. Convert from perl regexp to grep regexp.
136     if (local $_ = $newsgrouppats) {
137         s/\$\|/|/g;
138         s/[^\\]\.[^*]/?/g;
139         s/\$//;
140         s/\.\*/*/g;
141         s/\\([\$\+\.])/$1/g;
142         $progparams[0] = $_;
143     }
144
145     # find the appropriate module and call it
146     my $subname = "control_$progname";
147     my $subfind = \&$subname;
148     if (not defined &$subfind) {
149         if ($logname) {
150             logger($logname, "Unknown control message by $sender",
151                 \@headers, \@body);
152         } else {
153             logmsg("Unknown \"$progname\" control by $sender");
154         }
155         next;
156     }
157
158     my $approved = $hdr{approved} ? 1 : 0;
159     logmsg("$subname, " . join(' ', @progparams)
160         . " $sender $replyto $token, $sitepath, $action"
161         . ($logname ? "=$logname" : '') .", $approved");
162
163     &$subfind(\@progparams, $sender, $replyto, $sitepath,
164         $action, $logname, $approved, \@headers, \@body);
165 }
166
167 closelog() if $use_syslog;
168 exit 0;
169
170 print $inn::most_logs.$inn::syslog_facility.$inn::mta.
171     $inn::newsmaster.$inn::locks; # lint food
172
173 # misc functions ##########################################################
174 sub parse_article {
175     my ($artfh, $headers, $body, $hdr) = @_;
176     my $h;
177     my %uniquehdr = map { $_ => 1 }    qw(date followup-to from message-id
178         newsgroups path reply-to subject sender);
179
180     while (<$artfh>) {
181         s/\r?\n$//;
182         last if /^$/;
183         push @$headers, $_;
184         if (/^(\S+):\s+(.+)/) {
185             $h = lc $1;
186             if (exists $hdr->{$h}) {
187                 if (exists $uniquehdr{$h}) {
188                     logmsg("Multiple $1 headers in article $curmsgid");
189                     return 0;
190                 }
191                 $hdr->{$h} .= ' ' . $2;
192             } else {
193                 $hdr->{$h} = $2;
194             }
195             next;
196         } elsif (/^\s+(.+)/) {
197             if (defined $h) {
198                 $hdr->{$h} .= ' ' . $1;
199                 next;
200             }
201         }
202         logmsg("Broken headers in article $curmsgid");
203         return 0;
204     }
205
206     # article is empty or does not exist
207     return 0 if not @$headers;
208
209     chop (@$body = <$artfh>);
210     return 1;
211 }
212
213 # Strip a mail address, innd-style.
214 sub cleanaddr {
215     local $_ = shift;
216     s/(\s+)?\(.*\)(\s+)?//g;
217     s/.*<(.*)>.*/$1/;
218     s/[^-a-zA-Z0-9+_.@%]/_/g;    # protect MTA
219     s/^-/_/;                    # protect MTA
220     return $_;
221 }
222
223 # Read and cache control.ctl.
224 sub readctlfile {
225     my $mtime = (stat($inn::ctlfile))[9];
226     return $cachedctl if $lastctl == $mtime;    # mtime has not changed.
227     $lastctl = $mtime;
228
229     my @ctllist;
230     open(CTLFILE, $inn::ctlfile)
231         or logdie("Cannot open $inn::ctlfile: $!", 'crit');
232     while (<CTLFILE>) {
233         chop;
234         # Not a comment or blank? Convert wildmat to regex
235         next if not /^(\s+)?[^\#]/ or /^$/;
236         if (not /:(?:doit|doifarg|drop|log|mail|verify-.*)(?:=.*)?$/) {
237             s/.*://;
238             logmsg("$_ is not a valid action for control.ctl", 'err');
239             next;
240         }
241         # Convert to a : separated list of regexps
242         s/^all:/*:/i;
243         s/([\$\+\.])/\\$1/g;
244         s/\*/.*/g;
245         s/\?/./g;
246         s/(.*)/^$1\$/;
247         s/:/\$:^/g;
248         s/\|/\$|^/g;
249         push @ctllist, $_;
250     }
251     close CTLFILE;
252
253     logmsg('warning: control.ctl is empty!', 'err') if not @ctllist;
254     return $cachedctl = [ reverse @ctllist ];
255 }
256
257 # Parse a control message's permissions.
258 sub ctlperm {
259     my ($type, $sender, $newsgroup, $token, $headers, $body) = @_;
260
261     my $action = 'drop';    # default
262     my ($logname, $hier);
263
264     # newgroup and rmgroup require newsgroup names; check explicitly for that
265     # here and return drop if the newsgroup is missing (to avoid a bunch of
266     # warnings from undefined values later on in permission checking).
267     if ($type eq 'newgroup' or $type eq 'rmgroup') {
268         unless ($newsgroup) {
269             return ('drop', undef, undef);
270         }
271     }
272
273     my $ctllist = readctlfile();
274     foreach (@$ctllist) {
275         my @ctlline = split /:/;
276         # 0: type  1: from@addr  2: group.*  3: action
277         if ($type =~ /$ctlline[0]/ and $sender =~ /$ctlline[1]/i and
278             ($type !~ /(?:new|rm)group/ or $newsgroup =~ /$ctlline[2]/)) {
279             $action = $ctlline[3];
280             $action =~ s/\^(.+)\$/$1/;
281             $action =~ s/\\//g;
282             $hier = $ctlline[2] if $type eq 'checkgroups';
283             last;
284         }
285     }
286
287     ($action, $logname) = split(/=/, $action);
288
289     if ($action =~ /^verify-(.+)/) {
290         my $keyowner = $1;
291         if ($inn::pgpverify and $inn::pgpverify =~ /^(?:true|on|yes)$/i) {
292             my $pgpresult = defined &local_pgpverify ?
293                 local_pgpverify($token, $headers, $body) : pgpverify($token);
294             if ($keyowner eq $pgpresult) {
295                 $action = 'doit';
296             } else {
297                 $action = '_pgpfail';
298             }
299         } else {
300             $action = 'mail';
301         }
302     }
303
304     return ($action, $logname, $hier);
305 }
306
307 # Write stuff to a log or send mail to the news admin.
308 sub logger {
309     my ($logfile, $message, $headers, $body) = @_;
310
311     if ($logfile eq 'mail') {
312         my $mail = sendmail($message);
313         print $mail map { s/^~/~~/; "$_\n" } @$headers;
314         print $mail "\n" . join ('', map { s/^~/~~/; "$_\n" } @$body)
315             if $body;
316         close $mail or logdie("Cannot send mail: $!");
317         return;
318     }
319
320     if ($logfile =~ /^([^.\/].*)/) {
321         $logfile = $1;
322     } else {
323         logmsg("Invalid log file: $logfile", 'err');
324         $logfile = 'control';
325     }
326
327     $logfile = "$inn::most_logs/$logfile.log" unless $logfile =~ /^\//;
328     my $lockfile = $logfile;
329     $lockfile =~ s#.*/##;
330     $lockfile = "$inn::locks/LOCK.$lockfile";
331     shlock($lockfile);
332
333     open(LOGFILE, ">>$logfile") or logdie("Cannot open $logfile: $!");
334     print LOGFILE "$message\n";
335     foreach (@$headers, '', @$body, '') {
336         print LOGFILE "    $_\n";
337     }
338     close LOGFILE;
339     unlink $lockfile;
340 }
341
342 # write to syslog or errlog
343 sub logmsg {
344     my ($msg, $lvl) = @_;
345
346     return if $lvl and $lvl eq 'debug' and not $debug;
347     if ($use_syslog) {
348         syslog($lvl || 'notice', '%s', $msg);
349     } else {
350         print STDERR (scalar localtime) . ": $msg\n";
351     }
352 }
353
354 # log a message and then die
355 sub logdie {
356     my ($msg, $lvl) = @_;
357
358     $msg .= " ($curmsgid)" if $curmsgid;
359     logmsg($msg, $lvl || 'err');
360     exit 1;
361 }
362
363 # wrappers executing external programs ####################################
364
365 # Open an article appropriately to our storage method (or lack thereof).
366 sub open_article {
367     my $token = shift;
368
369     if ($token =~ /^\@.+\@$/) {
370         my $pid = open(ART, '-|');
371         logdie('Cannot fork: ' . $!) if $pid < 0;
372         if ($pid == 0) {
373             exec("$inn::newsbin/sm", '-q', $token) or
374                 logdie("Cannot exec sm: $!");
375         }
376         return *ART;
377     } else {
378         return *ART if open(ART, $token);
379         logmsg("Cannot open article $token: $!");
380     }
381     return undef;
382 }
383
384 sub pgpverify {
385     my $token = shift;
386
387     if ($token =~ /^\@.+\@$/) {
388         open(PGPCHECK, "$inn::newsbin/sm -q $token "
389             . "| $inn::newsbin/pgpverify |") or goto ERROR;
390     } else {
391         open(PGPCHECK, "$inn::newsbin/pgpverify < $token |") or goto ERROR;
392     }
393     my $pgpresult = <PGPCHECK>;
394     close PGPCHECK or goto ERROR;
395     $pgpresult ||= '';
396     chop $pgpresult;
397     return $pgpresult;
398 ERROR:
399     logmsg("pgpverify failed: $!", 'debug');
400     return '';
401 }
402
403 sub ctlinnd {
404     my ($cmd, @args) = @_;
405
406     my $st = system("$inn::newsbin/ctlinnd", '-s', $cmd, @args);
407     logdie('Cannot run ctlinnd: ' . $!) if $st == -1;
408     logdie('ctlinnd returned status ' . ($st & 255)) if $st > 0;
409 }
410
411 sub shlock {
412     my $lockfile = shift;
413
414     my $locktry = 0;
415     while ($locktry < 60) {
416         if (system("$inn::newsbin/shlock", '-p', $$, '-f', $lockfile) == 0) {
417             return 1;
418         }
419         $locktry++;
420         sleep 2;
421     }
422
423     my $lockreason;
424     if (open(LOCKFILE, $lockfile)) {
425         $lockreason = 'held by ' . (<LOCKFILE> || '?');
426         close LOCKFILE;
427     } else {
428         $lockreason = $!;
429     }
430     logdie("Cannot get lock $lockfile: $lockreason");
431     return undef;
432 }
433
434 # If $body is not defined, returns a file handle which must be closed.
435 # Don't forget checking the return value of close().
436 # $addresses may be a scalar or a reference to a list of addresses.
437 # If not defined, $inn::newsmaster is the default.
438 # parts of this code stolen from innmail.pl
439 sub sendmail {
440     my ($subject, $addresses, $body) = @_;
441     $addresses = [ $addresses || $inn::newsmaster ] if not ref $addresses;
442     $subject ||= '(no subject)';
443
444     # fix up all addresses
445     my @addrs = map { s#[^-a-zA-Z0-9+_.@%]##g; $_ } @$addresses;
446
447     my $sm = $inn::mta;
448     if ($sm =~ /%s/) {
449         $sm = sprintf($sm, join(' ', @addrs));
450     } else {
451         $sm .= ' ' . join(' ', @addrs);
452     }
453
454     # fork and spawn the MTA whitout using the shell
455     my $pid = open(MTA, '|-');
456     logdie('Cannot fork: ' . $!) if $pid < 0;
457     if ($pid == 0) {
458         exec(split(/\s+/, $sm)) or logdie("Cannot exec $sm: $!");
459     }
460
461     print MTA 'To: ' . join(",\n\t", @addrs) . "\nSubject: $subject\n\n";
462     return *MTA if not defined $body;
463     $body = join("\n", @$body) if ref $body eq 'ARRAY';
464     print MTA $body . "\n";
465     close MTA or logdie("Execution of $sm failed: $!");
466     return 1;
467 }