chiark - git - mdw - newsgate/blob - bin/mailpost.newsgate

   1 #! /usr/bin/perl
   2 require '/usr/lib/news/innshellvars.pl';
   3
   4 # mailpost - yet another mail-to-news filter
   5 # 21feb00 [added "lc" to duplicate header fixer stmt to make it case-insensitive]
   6 # doka 11may99 [fixed duplicate headers problem]
   7 # brister 19oct98 cleaned up somewhat for perl v. 5. and made a little more robust.
   8 # vixie 29jan95 RCS'd [$Id: mailpost.in,v 1.3.2.1 2000/08/13 02:03:59 rra Exp $]
   9 # vixie 15jun93 [added -m]
  10 # vixie 30jun92 [added -a and -d]
  11 # vixie 17jun92 [attempt simple-minded fixup to $path]
  12 # vixie 14jun92 [original]
  13
  14 use Getopt::Std ;
  15 use IPC::Open3;
  16 use IO::Select;
  17 use Sys::Syslog;
  18 use strict ;
  19
  20 my $debugging = 0 ;
  21 my $tmpfile ;
  22 my $msg ;
  23
  24 END {
  25     unlink ($tmpfile) if $tmpfile ;             # incase we die()
  26 }
  27
  28 my $LOCK_SH = 1;
  29 my $LOCK_EX = 2;
  30 my $LOCK_NB = 4;
  31 my $LOCK_UN = 8;
  32
  33 my $usage = $0 ;
  34 $usage =~ s!.*/!! ;
  35 my $prog = $usage ;
  36
  37 openlog $usage, "pid", $inn::syslog_facility ;
  38
  39 $usage .= "[ -r addr ][ -f addr ][ -a approved ][ -d distribution ]" .
  40     " [ -m mailing-list ][ -b database ][ -o output-path ] newsgroups" ;
  41
  42 use vars qw($opt_r $opt_f $opt_a $opt_d $opt_m $opt_b $opt_n $opt_o $opt_h) ;
  43 getopts("hr:f:a:d:m:b:no:") || die "usage: $usage\n" ;
  44 die "usage: $usage\n" if $opt_h ;
  45
  46 #
  47 # $Submit is a program which takes no arguments and whose stdin is supposed
  48 # to be a news article (without the #!rnews header but with the news hdr).
  49 #
  50
  51 my $Sendmail = $inn::mta ;
  52 my $Submit = $inn::inews . " -S -h";
  53 my $Database = ($opt_b || $inn::pathtmp) . "/mailpost-msgid" ;
  54 my $Maintainer = $inn::newsmaster || "usenet" ;
  55 my $WhereTo = $opt_o || $Submit ;
  56 my $Mailname = $inn::fromhost ;
  57
  58 # can't use $inn::tmpdir as we're usually not running as news
  59 my $Tmpdir = "/var/tmp" ;
  60
  61 if ($debugging || $opt_n) {
  62     $Sendmail = "cat" ;
  63     $WhereTo = "cat" ;
  64 }
  65
  66 chop ($Mailname = `/bin/hostname`) if ! $Mailname ;
  67
  68
  69 #
  70 # our command-line argument(s) are the list of newsgroups to post to.
  71 #
  72 # there may be a "-r sender" or "-f sender" which becomes the $path
  73 # (which is in turn overridden below by various optional headers.)
  74 #
  75 # -d (distribution) and -a (approved) are also supported to supply
  76 # or override the mail headers by those names.
  77 #
  78
  79 my $path = 'nobody';
  80 my $newsgroups = undef;
  81 my $approved = undef;
  82 my $distribution = undef;
  83 my $mailing_list = undef;
  84 my $references = undef;
  85 my @errorText = ();
  86
  87 if ($opt_r || $opt_f) {
  88     $path = $opt_r || $opt_f ;
  89     push @errorText, "((path: $path))\n" ;
  90 }
  91
  92 if ($opt_a) {
  93     $approved = &fix_sender_addr($opt_a);
  94     push @errorText, "((approved: $approved))\n";
  95 }
  96
  97 if ($opt_d) {
  98     $distribution = $opt_d ;
  99     push @errorText, "((distribution: $distribution))\n";
 100 }
 101
 102 if ($opt_m) {
 103     $mailing_list = "<" . $opt_m . "> /dev/null";
 104     push @errorText, "((mailing_list: $mailing_list))\n";
 105 }
 106
 107 $newsgroups = join ", ", @ARGV ;
 108
 109 die "usage:  $0 newsgroup [newsgroup]\n" unless $newsgroups;
 110
 111
 112 #
 113 # do the header.  our input is a mail message, with or without the From_
 114 #
 115
 116 #$message_id = sprintf("<mailpost.%d.%d@%s>", time, $$, $Hostname);
 117 my $real_news_hdrs = '';
 118 my $weird_mail_hdrs = '';
 119 my $fromHdr = "MAILPOST-UNKNOWN-FROM" ;
 120 my $dateHdr= "MAILPOST-UNKNOWN-DATE" ;
 121 my $msgIdHdr = "MAILPOST-UNKNOWN-MESSAGE-ID" ;
 122 my $from = undef;
 123 my $date = undef;
 124 my $hdr = undef;
 125 my $txt = undef;
 126 my $message_id ;
 127 my $subject = "(NONE)";
 128
 129 $_ = <STDIN>;
 130 if (!$_) {
 131     if ( $debugging || -t STDERR ) {
 132         die "empty input" ;
 133     } else {
 134         syslog "err", "empty input" ;
 135         exit (0) ;
 136     }
 137 }
 138
 139 chomp $_;
 140
 141 my $line = undef;
 142 if (/^From\s+([^\s]+)\s+/) {
 143     $path = $1;
 144     push @errorText, "((path: $path))\n";
 145     $_ = $';
 146     if (/ remote from /) {
 147         $path = $' . '!' . $path;
 148         $_ = $`;
 149     }
 150     $date = $_;
 151 } else {
 152     $line = $_;
 153 }
 154
 155 for (;;) {
 156     last if defined($line) && ($line =~ /^$/) ;
 157
 158     $_ = <STDIN> ;
 159     chomp ;
 160
 161     # gather up a single header with possible continuation lines into $line
 162     if (/^\s+/) {
 163         if (! $line) {
 164             $msg = "First line with leading whitespace!" ;
 165             syslog "err", $msg unless -t STDERR ;
 166             die "$msg\n" ;
 167         }
 168
 169         $line .= "\n" . $_ ;
 170         next ;
 171     }
 172
 173     # On the first header $line will be undefined.
 174     ($_, $line) = ($line, $_) ; # swap $line and $_ ;
 175
 176     last if defined($_) && /^$/ ;
 177     next if /^$/ ;              # only on first header will this happen
 178
 179     push @errorText, "($_)\n";
 180
 181     next if /^Approved:\s/sio && defined($approved);
 182     next if /^Distribution:\s/sio && defined($distribution);
 183
 184     if (/^(Organization|Distribution):\s*/sio) {
 185         $real_news_hdrs .= "$_\n";
 186         next;
 187     }
 188
 189     if (/^Subject:\s*/sio) {
 190         $subject = $';
 191         next;
 192     }
 193
 194     if (/^Message-ID:\s*/sio) {
 195         $message_id = $';
 196         next;
 197     }
 198
 199     if (/^Mailing-List:\s*/sio) {
 200         $mailing_list = $';
 201         next;
 202     }
 203
 204     if (/^(Sender|Approved):\s*/sio) {
 205         $real_news_hdrs .= "$&" . fix_sender_addr($') . "\n";
 206         next;
 207     }
 208
 209     if (/^Return-Path:\s*/sio) {
 210         $path = $';
 211         $path = $1 if ($path =~ /\<([^\>]*)\>/);
 212         push@errorText, "((path: $path))\n";
 213         next;
 214     }
 215
 216     if (/^Date:\s*/sio) {
 217         $date = $';
 218         next;
 219     }
 220
 221     if (/^From:\s*/sio) {
 222         $from = &fix_sender_addr($');
 223         next;
 224     }
 225
 226     if (/^References:\s*/sio) {
 227         $references = $';
 228         next;
 229     }
 230
 231     if (!defined($references) && /^In-Reply-To:[^\<]*\<([^\>]+)\>/sio) {
 232         $references = "<$1>";
 233         # FALLTHROUGH
 234     }
 235
 236     if (/^(MIME|Content)-[^:]+:\s*/sio) {
 237         $real_news_hdrs .= $_ . "\n" ;
 238         next ;
 239     }
 240
 241     # strip out news trace headers since otherwise posting may fail.  other
 242     # trace headers will be renamed to add 'X-' so we don't have to worry
 243     # about them.
 244     if (/^X-(Trace|Complaints-To):\s*/sio) {
 245         next ;
 246     }
 247
 248     # strip out Received headers since otherwise posting may fail
 249     # due to too large header size.
 250     if (/^(Received):\s*/sio) {
 251         next ;
 252     }
 253
 254     # random unknown header.  prepend 'X-' if it's not already there.
 255     $_ = "X-$_" unless /^X-/sio ;
 256     $weird_mail_hdrs .= "$_\n";
 257 }
 258
 259
 260 $msgIdHdr = $message_id if $message_id ;
 261 $fromHdr = $from if $from ;
 262 $dateHdr = $date if $date ;
 263
 264 if ($path !~ /\!/) {
 265     $path = "$'!$`" if ($path =~ /\@/);
 266 }
 267
 268 $real_news_hdrs .= "Subject: ${subject}\n";
 269 $real_news_hdrs .= "Message-ID: ${msgIdHdr}\n"     if defined($message_id);
 270 $real_news_hdrs .= "Mailing-List: ${mailing_list}\n" if defined($mailing_list);
 271 $real_news_hdrs .= "Distribution: ${distribution}\n" if defined($distribution);
 272 $real_news_hdrs .= "Approved: ${approved}\n"         if defined($approved);
 273 $real_news_hdrs .= "References: ${references}\n"     if defined($references);
 274
 275 # Remove duplicate headers.
 276 my %headers = ();
 277 $real_news_hdrs =~ s/(.*?:)[ \t].*?($|\n)([ \t]+.*?($|\n))*/$headers{lc$1}++?"":$&/ge;
 278
 279 # Inews writes error messages to stdout. We want to capture those and mail
 280 # them back to the newsmaster. Trying to write and read from a subprocess is
 281 # ugly and prone to deadlock, so we use a temp file.
 282 $tmpfile = sprintf "%s/mailpost.%d.%d", $Tmpdir, time, $$ ;
 283
 284 if (!open TMPFILE,">$tmpfile") {
 285     $msg = "cant open temp file ($tmpfile): $!" ;
 286     $tmpfile = undef ;
 287     syslog "err", "$msg\n" unless $debugging || -t STDERR ;
 288     open TMPFILE, "|" . sprintf ($Sendmail, $Maintainer) ||
 289         die "die(no tmpfile): sendmail: $!\n" ;
 290     print TMPFILE <<"EOF";
 291 To: $Maintainer
 292 Subject: mailpost failure ($newsgroups): $msg
 293
 294 -------- Article Contents
 295
 296 EOF
 297 }
 298
 299 print TMPFILE <<"EOF";
 300 Path: ${path}
 301 From: ${fromHdr}
 302 Newsgroups: ${newsgroups}
 303 ${real_news_hdrs}Date: ${dateHdr}
 304 ${weird_mail_hdrs}
 305 EOF
 306
 307 my $rest;
 308 $rest .= $_ while (<STDIN>);
 309 $rest =~ s/\n*$/\n/g;           # Remove trailing \n except very last
 310
 311 print TMPFILE $rest;
 312 close TMPFILE ;
 313
 314 if ( ! $tmpfile ) {
 315     # we had to bail and mail the article to the admin.
 316     exit (0) ;
 317 }
 318
 319
 320 ##
 321 ## We've got the article in a temp file and now we validate some of the
 322 ## data we found and update our message-id database.
 323 ##
 324
 325 mailArtAndDie ("no From: found") unless $from;
 326 mailArtAndDie ("no Date: found") unless $date;
 327 mailArtAndDie ("no Message-ID: found") unless $message_id;
 328 mailArtAndDie ("Malformed message ID ($message_id)")
 329     if ($message_id !~ /\<(\S+)\@(\S+)\>/);
 330
 331
 332 # update (with locking) our message-id database.  this is used to make sure we
 333 # don't loop our own gatewayed articles back through the mailing list.
 334
 335 my ($lhs, $rhs) = ($1, $2);     # of message_id match above.
 336 $rhs =~ tr/A-Z/a-z/;
 337
 338 $message_id = "${lhs}\@${rhs}";
 339
 340 push @errorText, "(TAS message-id database for $message_id)\n";
 341
 342 my $lockfile = sprintf("%s.lock", $Database);
 343
 344 open LOCKFILE, "<$lockfile" ||
 345     open LOCKFILE, ">$lockfile" ||
 346     mailArtAndDie ("can't open $lockfile: $!") ;
 347
 348 my $i ;
 349 for ($i = 0 ; $i < 5 ; $i++) {
 350     flock LOCKFILE, $LOCK_EX && last ;
 351     sleep 1 ;
 352 }
 353
 354 mailArtAndDie ("can't lock $lockfile: $!") if ($i == 5) ;
 355
 356 my %DATABASE ;
 357 dbmopen %DATABASE, $Database, 0666 || mailArtAndDie ("can't dbmopen $lockfile: $!");
 358
 359 exit 0  if defined $DATABASE{$message_id}; # already seen.
 360
 361 $DATABASE{$message_id} = sprintf "%d.%s", time, 'mailpost' ;
 362
 363 mailArtAndDie ("TAS didn't set $message_id") unless defined $DATABASE{$message_id};
 364
 365 dbmclose %DATABASE || mailArtAndDie ("can't dbmclose $lockfile: $!") ;
 366
 367 flock LOCKFILE, $LOCK_UN || mailArtAndDie ("can't unlock $lockfile: $!");
 368 close LOCKFILE ;
 369
 370 if (!open INEWS, "$WhereTo < $tmpfile 2>&1 |") {
 371     mailArtAndDie ("cant start: $WhereTo: $!") ;
 372 }
 373
 374 my @inews = <INEWS> ;
 375 close INEWS ;
 376 my $status = $? ;
 377
 378 if (@inews) {
 379     chomp @inews ;
 380     mailArtAndDie ("inews failed: @inews") ;
 381 }
 382
 383 unlink $tmpfile ;
 384
 385 exit $status;
 386
 387 sub mailArtAndDie {
 388     my ($msg) = @_ ;
 389
 390     print STDERR $msg,"\n" if -t STDERR ;
 391
 392     open SENDMAIL, "|" . sprintf ($Sendmail,$Maintainer) ||
 393         die "die($msg): sendmail: $!\n" ;
 394     print SENDMAIL <<"EOF" ;
 395 To: $Maintainer
 396 Subject: mailpost failure ($newsgroups): $msg
 397
 398 $msg
 399 EOF
 400
 401     if ($tmpfile && -f $tmpfile) {
 402         print SENDMAIL "\n-------- Article Contents\n\n" ;
 403         open FILE, "<$tmpfile" || die "open($tmpfile): $!\n" ;
 404         print SENDMAIL while <FILE> ;
 405         close FILE ;
 406     } else {
 407         print "No article left to send back.\n" ;
 408     }
 409     close SENDMAIL ;
 410
 411 #    unlink $tmpfile ;
 412
 413     exit (0) ;                  # using a non-zero exit may cause problems.
 414 }
 415
 416
 417 #
 418 # take 822-format name (either "comment <addr> comment" or "addr (comment)")
 419 # and return in always-qualified 974-format ("addr (comment)").
 420 #
 421 sub fix_sender_addr {
 422     my ($address) = @_;
 423     my ($lcomment, $addr, $rcomment, $comment);
 424     local ($',$`,$_) ;
 425
 426     if ($address =~ /\<([^\>]*)\>/) {
 427         ($lcomment, $addr, $rcomment) = (&dltb($`), &dltb($1), &dltb($'));
 428     } elsif ($address =~ /\(([^\)]*)\)/) {
 429         ($lcomment, $addr, $rcomment) = ('', &dltb($`.$'), &dltb($1));
 430     } else {
 431         ($lcomment, $addr, $rcomment) = ('', &dltb($address), '');
 432     }
 433
 434     #print STDERR "fix_sender_addr($address) == ($lcomment, $addr, $rcomment)\n";
 435
 436     $addr .= "\@$Mailname" unless ($addr =~ /\@/);
 437
 438     if ($lcomment && $rcomment) {
 439         $comment = $lcomment . ' ' . $rcomment;
 440     } else {
 441         $comment = $lcomment . $rcomment;
 442     }
 443
 444     $_ = $addr;
 445     $_ .= " ($comment)" if $comment;
 446
 447     #print STDERR "\t-> $_\n";
 448
 449     return $_;
 450 }
 451
 452 #
 453 # delete leading and trailing blanks
 454 #
 455
 456 sub dltb {
 457     my ($str) = @_;
 458
 459     $str =~ s/^\s+//o;
 460     $str =~ s/\s+$//o;
 461
 462     return $str;
 463 }
 464