chiark / gitweb /
implement connfail
[innduct.git] / control / perl-nocem.in
1 #!/usr/bin/perl -w
2 # fixscript will replace this line with require innshellvars.pl
3
4 ##############################################################################
5 # perl-nocem - a NoCeM-on-spool implementation for INN 2.x.
6 # Copyright 2000 by Miquel van Smoorenburg <miquels@cistron.nl>
7 # Copyright 2001 by Marco d'Itri <md@linux.it>
8 # This program is licensed under the terms of the GNU General Public License.
9 #
10 # List of changes:
11 #
12 # 2002: Patch by Steven M. Christey for untrusted printf input.
13 # 2007: Patch by Christoph Biedl for checking a timeout.
14 # Documentation improved by Jeffrey M. Vinocur (2002), Russ Allbery (2006)
15 # and Julien Elie (2007).
16 #
17 ##############################################################################
18
19 require 5.00403;
20 use strict;
21
22 # XXX FIXME I haven't been able to load it only when installed.
23 # If nobody can't fix it just ship the program with this line commented.
24 #use Time::HiRes qw(time);
25
26 my $keyring = $inn::pathetc . '/pgp/ncmring.gpg';
27
28 # XXX To be moved to a config file.
29 #sub local_want_cancel_id {
30 #    my ($group, $hdrs) = @_;
31 #
32 ## Hippo has too many false positives to be useful outside of pr0n groups
33 #    if ($hdrs->{issuer} =~ /(?:Ultra|Spam)Hippo/) {
34 #        foreach (split(/,/, $group)) {
35 #            return 1 if /^alt\.(?:binar|sex)/;
36 #        }
37 #        return 0;
38 #    }
39 #    return 1;
40 #}
41
42 # no user serviceable parts below this line ###################################
43
44 # global variables
45 my ($working, $got_sighup, $got_sigterm, @ncmperm, $cancel);
46 my $use_syslog = 0;
47 my $log_open = 0;
48 my $nntp_open = 0;
49 my $last_cancel = 0;
50 my $socket_timeout = $inn::peertimeout - 100;
51
52 my $logfile = $inn::pathlog . '/perl-nocem.log';
53
54 # initialization and main loop ###############################################
55
56 eval { require Sys::Syslog; import Sys::Syslog; $use_syslog = 1; };
57
58 if ($use_syslog) {
59     eval "sub Sys::Syslog::_PATH_LOG { '/dev/log' }" if $^O eq 'dec_osf';
60     Sys::Syslog::setlogsock('unix') if $^O =~ /linux|dec_osf/;
61     openlog('nocem', '', $inn::syslog_facility);
62 }
63
64 if (not $inn::gpgv) {
65     logmsg('cannot find the gpgv binary', 'err');
66     sleep 5;
67     exit 1;
68 }
69
70 if ($inn::version and not $inn::version =~ /^INN 2\.[0123]\./) {
71     $cancel = \&cancel_nntp;
72 } else {
73     $cancel = \&cancel_ctlinnd;
74 }
75
76 $SIG{HUP}  = \&hup_handler;
77 $SIG{INT}  = \&term_handler;
78 $SIG{TERM} = \&term_handler;
79 $SIG{PIPE} = \&term_handler;
80
81 logmsg('starting up');
82
83 unless (read_ctlfile()) {
84     sleep 5;
85     exit 1;
86 }
87
88 while (<STDIN>) {
89     chop;
90     $working = 1;
91     do_nocem($_);
92     $working = 0;
93     term_handler() if $got_sigterm;
94     hup_handler() if $got_sighup;
95 }
96
97 logmsg('exiting because of EOF', 'debug');
98 exit 0;
99
100 ##############################################################################
101
102 # Process one NoCeM notice.
103 sub do_nocem {
104     my $token = shift;
105     my $start = time;
106
107     # open the article and verify the notice
108     my $artfh = open_article($token);
109     return if not defined $artfh;
110     my ($msgid, $nid, $issuer, $nocems) = read_nocem($artfh);
111     close $artfh;
112     return unless $nocems;
113
114     &$cancel($nocems);
115     logmsg("Articles cancelled: " . join(' ', @$nocems), 'debug');
116     my $diff = (time - $start) || 0.01;
117     my $nr = scalar @$nocems;
118     logmsg(sprintf("processed notice %s by %s (%d ids, %.5f s, %.1f/s)",
119         $nid, $issuer, $nr, $diff, $nr / $diff));
120 }
121
122 # - Check if it is a PGP signed NoCeM notice
123 # - See if we want it
124 # - Then check PGP signature
125 sub read_nocem {
126     my $artfh = shift;
127
128     # Examine the first 200 lines to see if it is a PGP signed NoCeM.
129     my $ispgp = 0;
130     my $isncm = 0;
131     my $inhdr = 1;
132     my $i = 0;
133     my $body = '';
134     my ($from, $msgid);
135     while (<$artfh>) {
136         last if $i++ > 200;
137         s/\r\n$/\n/;
138         if ($inhdr) {
139             if (/^$/) {
140                 $inhdr = 0;
141             } elsif (/^From:\s+(.*)\s*$/i) {
142                 $from =  $1;
143             } elsif (/^Message-ID:\s+(<.*>)/i) {
144                 $msgid = $1;
145             }
146         } else {
147             $body .= $_;
148             $ispgp = 1 if /^-----BEGIN PGP SIGNED MESSAGE-----/;
149             if (/^\@\@BEGIN NCM HEADERS/) {
150                 $isncm = 1;
151                 last;
152             }
153         }
154     }
155
156     # must be a PGP signed NoCeM.
157     if (not $ispgp) {
158         logmsg("Article $msgid: not PGP signed", 'debug');
159         return;
160     }
161     if (not $isncm) {
162         logmsg("Article $msgid: not a NoCeM", 'debug');
163         return;
164     }
165
166     # read the headers of this NoCeM, and check if it's supported.
167     my %hdrs;
168     while (<$artfh>) {
169         s/\r\n/\n/;
170         $body .= $_;
171         last if /^\@\@BEGIN NCM BODY/;
172         my ($key, $val) = /^([^:]+)\s*:\s*(.*)$/;
173         $hdrs{lc $key} = $val;
174     }
175     foreach (qw(action issuer notice-id type version)) {
176         next if $hdrs{$_};
177         logmsg("Article $msgid: missing $_ pseudo header", 'debug');
178         return;
179     }
180     return if not supported_nocem($msgid, \%hdrs);
181
182     # decide if we want it.
183     if (not want_nocem(\%hdrs)) {
184         logmsg("Article $msgid: unwanted ($hdrs{issuer}/$hdrs{type})", 'debug');
185         return;
186     }
187 # XXX want_hier() not implemented
188 #    if ($hdrs{hierarchies} and not want_hier($hdrs{hierarchies})) {
189 #        logmsg("Article $msgid: unwanted hierarchy ($hdrs{hierarchies})",
190 #            'debug');
191 #        return;
192 #    }
193
194     # We do want it, so read the entire article.  Also copy it to
195     # a temp file so that we can check the PGP signature when done.
196     my $tmpfile = "$inn::pathtmp/nocem.$$";
197     if (not open(OFD, ">$tmpfile")) {
198         logmsg("cannot open temp file $tmpfile: $!", 'err');
199         return;
200     }
201     print OFD $body;
202     undef $body;
203
204     # process NoCeM body.
205     my $inbody = 1;
206     my @nocems;
207     my ($lastid, $lastgrp);
208     while (<$artfh>) {
209         s/\r\n$/\n/;
210         print OFD;
211         $inbody = 0 if /^\@\@END NCM BODY/;
212         next if not $inbody or /^#/;
213
214         my ($id, $grp) = /^(\S*)\s+(\S+)/;
215         next if not $grp;
216         if ($id) {
217             push @nocems, $lastid
218                 if $lastid and want_cancel_id($lastgrp, \%hdrs);
219             $lastid = $id;
220             $lastgrp = $grp;
221         } else {
222             $lastgrp .= ',' . $grp;
223         }
224     }
225     push @nocems, $lastid if $lastid and want_cancel_id($lastgrp, \%hdrs);
226     close OFD;
227
228     # at this point we need to verify the PGP signature.
229     return if not @nocems;
230     my $e = pgp_check($hdrs{issuer}, $msgid, $tmpfile);
231     unlink $tmpfile;
232     return if not $e;
233
234     return ($msgid, $hdrs{'notice-id'}, $hdrs{issuer}, \@nocems);
235 }
236
237 # XXX not implemented: code to discard notices for groups we don't carry
238 sub want_cancel_id {
239     my ($group, $hdrs) = @_;
240
241     return local_want_cancel_id(@_) if defined &local_want_cancel_id;
242     1;
243 }
244
245 # Do we actually want this NoCeM?
246 sub want_nocem {
247     my $hdrs = shift;
248
249     foreach (@ncmperm) {
250         my ($issuer, $type) = split(/\001/);
251         if ($hdrs->{issuer} =~ /$issuer/i) {
252             return 1 if '*' eq $type or lc $hdrs->{type} eq $type;
253         }
254     }
255     return 0;
256 }
257
258 sub supported_nocem {
259     my ($msgid, $hdrs) = @_;
260
261     if ($hdrs->{version} !~ /^0\.9[0-9]?$/) {
262         logmsg("Article $msgid: version $hdrs->{version} not supported",
263             'debug');
264         return 0;
265     }
266     if ($hdrs->{action} ne 'hide') {
267         logmsg("Article $msgid: action $hdrs->{action} not supported",
268             'debug');
269         return 0;
270     }
271     return 1;
272 }
273
274 # Check the PGP signature on an article.
275 sub pgp_check {
276     my ($issuer, $msgid, $art) = @_;
277
278     # fork and spawn a child
279     my $pid = open(PFD, '-|');
280     if (not defined $pid) {
281         logmsg("pgp_check: cannot fork: $!", 'err');
282         return 0;
283     }
284     if ($pid == 0) {
285         open(STDERR, '>&STDOUT');
286         exec($inn::gpgv, '--status-fd=1',
287             $keyring ? '--keyring=' . $keyring : '', $art);
288         exit 126;
289     }
290
291     # Read the result and check status code.
292     local $_ = join('', <PFD>);
293     my $status = 0;
294     if (not close PFD) {
295         if ($? >> 8) {
296             $status = $? >> 8;
297         } else {
298             logmsg("Article $msgid: $inn::gpgv killed by signal " . ($? & 255));
299             return 0;
300         }
301     }
302 #    logmsg("Command line was: $inn::gpgv --status-fd=1"
303 #         . ($keyring ? ' --keyring=' . $keyring : '') . " $art", 'debug');
304 #    logmsg("Full PGP output: >>>$_<<<", 'debug');
305
306     if (/^\[GNUPG:\]\s+GOODSIG\s+\S+\s+(.*)/m) {
307         return 1 if $1 =~ /\Q$issuer\E/;
308         logmsg("Article $msgid: signed by $1 instead of $issuer");
309     } elsif (/^\[GNUPG:\]\s+NO_PUBKEY\s+(\S+)/m) {
310         logmsg("Article $msgid: $issuer (ID $1) not in keyring");
311     } elsif (/^\[GNUPG:\]\s+BADSIG\s+\S+\s+(.*)/m) {
312         logmsg("Article $msgid: bad signature from $1");
313     } elsif (/^\[GNUPG:\]\s+BADARMOR/m or /^\[GNUPG:\]\s+UNEXPECTED/m) {
314         logmsg("Article $msgid: malformed signature");
315     } elsif (/^\[GNUPG:\]\s+ERRSIG\s+(\S+)/m) {
316         # safety net: we get there if we don't know about some token
317         logmsg("Article $msgid: unknown error (ID $1)");
318     } else {
319         # some other error we don't know about happened.
320         # 126 is returned by the child if exec fails.
321         s/ at \S+ line \d+\.\n$//; s/\n/_/;
322         logmsg("Article $msgid: $inn::gpgv exited "
323             . (($status == 126) ? "($_)" : "with status $status"), 'err');
324     }
325     return 0;
326 }
327
328 # Read article.
329 sub open_article {
330     my $token = shift;
331     
332     if ($token =~ /^\@.+\@$/) {
333         my $pid = open(ART, '-|');
334         if ($pid < 0) {
335             logmsg('Cannot fork: ' . $!, 'err');
336             return undef;
337         }
338         if ($pid == 0) {
339             exec("$inn::newsbin/sm", '-q', $token) or
340                 logmsg("Cannot exec sm: $!", 'err');
341             return undef;
342         }
343         return *ART;
344     } else {
345         return *ART if open(ART, $token);
346         logmsg("Cannot open article $token: $!", 'err');
347     }
348     return undef;
349 }
350
351 # Cancel a number of Message-IDs.  We use ctlinnd to do this,
352 # and we run up to 15 of them at the same time (10 usually).
353 sub cancel_ctlinnd {
354     my @ids = @{$_[0]};
355
356     while (@ids > 0) {
357         my $max = @ids <= 15 ? @ids : 10;
358         for (my $i = 1; $i <= $max; $i++) {
359             my $msgid = shift @ids;
360             my $pid;
361             sleep 5 until (defined ($pid = fork));
362             if ($pid == 0) {
363                 exec "$inn::pathbin/ctlinnd", '-s', '-t', '180',
364                     'cancel', $msgid;
365                 exit 126;
366             }
367 #            logmsg("cancelled: $msgid [$i/$max]", 'debug');
368         }
369         #    Now wait for all children.
370         while ((my $pid = wait) > 0) {
371             next unless $?;
372             if ($? >> 8) {
373                 logmsg("Child $pid died with status " . ($? >> 8), 'err');
374             } else {
375                 logmsg("Child $pid killed by signal " . ($? & 255), 'err');
376             }
377         }
378     }
379 }
380
381 sub cancel_nntp {
382     my $ids = shift;
383     my $r;
384     
385     if ($nntp_open and time - $socket_timeout > $last_cancel) {
386         logmsg('Close socket for timeout');
387         close (NNTP);
388         $nntp_open = 0;
389     }
390     if (not $nntp_open) {
391         use Socket;
392         if (not socket(NNTP, PF_UNIX, SOCK_STREAM, 0)) {
393             logmsg("socket: $!", 'err');
394             goto ERR;
395         }
396         if (not connect(NNTP, sockaddr_un($inn::pathrun . '/nntpin'))) {
397             logmsg("connect: $!", 'err');
398             goto ERR;
399         }
400         if (($r = <NNTP>) !~ /^200 /) {
401             $r =~ s/\r\n$//;
402             logmsg("bad reply from server: $r", 'err');
403             goto ERR;
404         }
405         select NNTP; $| = 1; select STDOUT;
406         print NNTP "MODE CANCEL\r\n";
407         if (($r = <NNTP>) !~ /^284 /) {
408             $r =~ s/\r\n$//;
409             logmsg("MODE CANCEL not supported: $r", 'err');
410             goto ERR;
411         }
412         $nntp_open = 1;
413     }
414     foreach (@$ids) {
415         print NNTP "$_\r\n";
416         if (($r = <NNTP>) !~ /^289/) {
417             $r =~ s/\r\n$//;
418             logmsg("cannot cancel $_: $r", 'err');
419             goto ERR;
420         }
421     }
422     $last_cancel = time;
423     return;
424
425 ERR:
426     # discard unusable socket
427     close (NNTP);
428     logmsg('Switching to ctlinnd...', 'err');
429     cancel_ctlinnd($ids);
430     $cancel = \&cancel_ctlinnd;
431 }
432
433 sub read_ctlfile {
434     my $permfile = $inn::pathetc . '/nocem.ctl';
435
436     unless (open(CTLFILE, $permfile)) {
437         logmsg("Cannot open $permfile: $!", 'err');
438         return 0;
439     }
440     while (<CTLFILE>) {
441         chop;
442         s/^\s+//; s/\s+$//;
443         next if /^#/ or /^$/;
444         my ($issuer, $type) = split(/:/, lc $_);
445         logmsg("Cannot parse nocem.ctl line <<$_>>", 'err')
446             if not $issuer and $type;
447         $type =~ s/\s//g;
448         push @ncmperm, "$issuer\001$_" foreach split(/,/, $type);
449     }
450     close CTLFILE;
451     return 1;
452 }
453
454 sub logmsg {
455     my ($msg, $lvl) = @_;
456
457     if (not $use_syslog) {
458         if ($log_open == 0) {
459             open(LOG, ">>$logfile") or die "Cannot open log: $!";
460             $log_open = 1;
461             select LOG; $| = 1; select STDOUT;
462         }
463         $lvl ||= 'notice';
464         print LOG "$lvl: $msg\n";
465         return;
466     }
467     syslog($lvl || 'notice', '%s', $msg);
468 }
469
470 sub hup_handler {
471     $got_sighup = 1;
472     return if $working;
473     close LOG;
474     $log_open = 0;
475 }
476
477 sub term_handler {
478     $got_sigterm = 1;
479     return if $working;
480     logmsg('exiting because of signal');
481     exit 1;
482 }
483
484 # lint food
485 print $inn::pathrun.$inn::pathlog.$inn::pathetc.$inn::newsbin.$inn::pathbin
486     .$inn::pathtmp.$inn::peertimeout.$inn::syslog_facility;
487
488 __END__
489
490 =head1 NAME
491
492 perl-nocem - A NoCeM-on-spool implementation for S<INN 2.x>
493
494 =head1 SYNOPSIS
495
496 perl-nocem
497
498 =head1 DESCRIPTION
499
500 NoCeM, which is pronounced I<No See 'Em>, is a protocol enabling
501 authenticated third-parties to issue notices which can be used
502 to cancel unwanted articles (like spam and articles in moderated
503 newsgroups which were not approved by their moderators).  It can
504 also be used by readers as a I<third-party killfile>.  It is
505 intended to eventually replace the protocol for third-party cancel
506 messages.
507
508 B<perl-nocem> processes third-party, PGP-signed article cancellation
509 notices.  It is possible not to honour all NoCeM notices but only those
510 which are sent by people whom you trust (that is to say if you trust
511 the PGP key they use to sign their NoCeM notices).  Indeed, it is up
512 to you to decide whether you wish to honour their notices, depending
513 on the criteria they use.
514
515 Processing NoCeM notices is easy to set up:
516
517 =over 4
518
519 =item 1.
520
521 Import the keys of the NoCeM issuers you trust in order to check
522 the authenticity of their notices.  You can do:
523
524     gpg --no-default-keyring --primary-keyring <pathetc>/pgp/ncmring.gpg \
525         --no-options --allow-non-selfsigned-uid --no-permission-warning \
526         --batch --import <key-file>
527
528 where <pathetc> is the value of the I<pathetc> parameter set in F<inn.conf>
529 and <key-file> the file containing the key(s) to import.  The keyring
530 must be located in I<pathetc>/pgp/ncmring.gpg (create the directory
531 before using B<gpg>).  For old PGP-generated keys, you may have to use
532 B<--allow-non-selfsigned-uid> if they are not properly self-signed,
533 but anyone creating a key really should self-sign the key.  Current
534 PGP implementations do this automatically.
535
536 The keys of NoCeM issuers can be found in the web site of I<The NoCeM Registry>:
537 L<http://www.xs4all.nl/~rosalind/nocemreg/nocemreg.html>.  You can even
538 download there a unique file which contains all the keys.
539
540 =item 2.
541
542 Create a F<nocem.ctl> config file in I<pathetc> indicating the NoCeM issuers
543 and notices you want to follow.  This permission file contains lines like:
544
545     annihilator-1:*
546     clewis@ferret.ocunix:mmf
547     stephane@asynchrone:mmf,openproxy,spam
548
549 This will remove all articles for which the issuer (first part of the line,
550 before the colon C<:>) has issued NoCeM notices corresponding to the
551 criteria specified after the colon.
552
553 You will also find information about that on the web site of
554 I<The NoCeM Registry>.
555
556 =item 3.
557
558 Add to the F<newsfeeds> file an entry like this one in order to feed
559 B<perl-nocem> the NoCeM notices posted to alt.nocem.misc and
560 news.lists.filters:
561
562     nocem!\
563         :!*,alt.nocem.misc,news.lists.filters\
564         :Tc,Wf,Ap:<pathbin>/perl-nocem
565
566 with the correct path to B<perl-nocem>, located in <pathbin>.  Then, reload
567 the F<newsfeeds> file (C<ctlinnd reload newsfeeds 'NoCeM channel feed'>).
568
569 Note that you should at least carry news.lists.filters on your news
570 server (or other newsgroups where NoCeM notices are sent) if you wish
571 to process them.
572
573 =item 4.
574
575 Everything should now work.  However, do not hesitate to manually test
576 B<perl-nocem> with a NoCeM notice, using:
577
578     grephistory '<Message-ID>' | perl-nocem
579
580 Indeed, B<perl-nocem> expects tokens on its standard input, and
581 B<grephistory> can easily give it the token of a known article,
582 thanks to its Message-ID.
583
584 =back
585
586 When you have verified that everything works, you can eventually turn
587 off regular spam cancels, if you want, not processing any longer
588 cancels containing C<cyberspam> in the Path: header (see the
589 I<refusecybercancels> parameter in F<inn.conf>).
590
591 =head1 FILES
592
593 =over 4
594
595 =item I<pathbin>/perl-nocem
596
597 The Perl script itself used to process NoCeM notices.
598
599 =item I<pathetc>/nocem.ctl
600
601 The configuration file which specifies the NoCeM notices to be processed.
602
603 =item I<pathetc>/pgp/ncmring.gpg
604
605 The keyring which contains the public keys of trusted NoCeM issuers.
606
607 =back
608
609 =head1 BUGS
610
611 The Subject: header is not checked for the @@NCM string and there is no
612 check for the presence of the References: header.
613
614 The Newsgroups: pseudo header is not checked, but this can be done in
615 local_want_cancel_id().
616
617 The Hierarchies: header is ignored.
618
619 =head1 HISTORY
620
621 Copyright 2000 by Miquel van Smoorenburg <miquels@cistron.nl>.
622
623 Copyright 2001 by Marco d'Itri <md@linux.it>.
624
625 $Id: perl-nocem.in 7733 2008-04-06 09:16:20Z iulius $
626
627 =head1 SEE ALSO
628
629 gpgv(1), grephistory(1), inn.conf(5), newsfeeds(5), pgp(1).
630
631 =cut