#! /usr/bin/perl require '/usr/lib/news/innshellvars.pl'; # mailpost - yet another mail-to-news filter # 21feb00 [added "lc" to duplicate header fixer stmt to make it case-insensitive] # doka 11may99 [fixed duplicate headers problem] # brister 19oct98 cleaned up somewhat for perl v. 5. and made a little more robust. # vixie 29jan95 RCS'd [$Id: mailpost.in,v 1.3.2.1 2000/08/13 02:03:59 rra Exp $] # vixie 15jun93 [added -m] # vixie 30jun92 [added -a and -d] # vixie 17jun92 [attempt simple-minded fixup to $path] # vixie 14jun92 [original] use Getopt::Std ; use IPC::Open3; use IO::Select; use Sys::Syslog; use strict ; my $debugging = 0 ; my $tmpfile ; my $msg ; END { unlink ($tmpfile) if $tmpfile ; # incase we die() } my $LOCK_SH = 1; my $LOCK_EX = 2; my $LOCK_NB = 4; my $LOCK_UN = 8; my $usage = $0 ; $usage =~ s!.*/!! ; my $prog = $usage ; openlog $usage, "pid", $inn::syslog_facility ; $usage .= "[ -r addr ][ -f addr ][ -a approved ][ -d distribution ]" . " [ -m mailing-list ][ -b database ][ -o output-path ] newsgroups" ; use vars qw($opt_r $opt_f $opt_a $opt_d $opt_m $opt_b $opt_n $opt_o $opt_h) ; getopts("hr:f:a:d:m:b:no:") || die "usage: $usage\n" ; die "usage: $usage\n" if $opt_h ; # # $Submit is a program which takes no arguments and whose stdin is supposed # to be a news article (without the #!rnews header but with the news hdr). # my $Sendmail = $inn::mta ; my $Submit = $inn::inews . " -S -h"; my $Database = ($opt_b || $inn::pathtmp) . "/mailpost-msgid" ; my $Maintainer = $inn::newsmaster || "usenet" ; my $WhereTo = $opt_o || $Submit ; my $Mailname = $inn::fromhost ; # can't use $inn::tmpdir as we're usually not running as news my $Tmpdir = "/var/tmp" ; if ($debugging || $opt_n) { $Sendmail = "cat" ; $WhereTo = "cat" ; } chop ($Mailname = `/bin/hostname`) if ! $Mailname ; # # our command-line argument(s) are the list of newsgroups to post to. # # there may be a "-r sender" or "-f sender" which becomes the $path # (which is in turn overridden below by various optional headers.) # # -d (distribution) and -a (approved) are also supported to supply # or override the mail headers by those names. # my $path = 'nobody'; my $newsgroups = undef; my $approved = undef; my $distribution = undef; my $mailing_list = undef; my $references = undef; my @errorText = (); if ($opt_r || $opt_f) { $path = $opt_r || $opt_f ; push @errorText, "((path: $path))\n" ; } if ($opt_a) { $approved = &fix_sender_addr($opt_a); push @errorText, "((approved: $approved))\n"; } if ($opt_d) { $distribution = $opt_d ; push @errorText, "((distribution: $distribution))\n"; } if ($opt_m) { $mailing_list = "<" . $opt_m . "> /dev/null"; push @errorText, "((mailing_list: $mailing_list))\n"; } $newsgroups = join ", ", @ARGV ; die "usage: $0 newsgroup [newsgroup]\n" unless $newsgroups; # # do the header. our input is a mail message, with or without the From_ # #$message_id = sprintf("", time, $$, $Hostname); my $real_news_hdrs = ''; my $weird_mail_hdrs = ''; my $fromHdr = "MAILPOST-UNKNOWN-FROM" ; my $dateHdr= "MAILPOST-UNKNOWN-DATE" ; my $msgIdHdr = "MAILPOST-UNKNOWN-MESSAGE-ID" ; my $from = undef; my $date = undef; my $hdr = undef; my $txt = undef; my $message_id ; my $subject = "(NONE)"; $_ = ; if (!$_) { if ( $debugging || -t STDERR ) { die "empty input" ; } else { syslog "err", "empty input" ; exit (0) ; } } chomp $_; my $line = undef; if (/^From\s+([^\s]+)\s+/) { $path = $1; push @errorText, "((path: $path))\n"; $_ = $'; if (/ remote from /) { $path = $' . '!' . $path; $_ = $`; } $date = $_; } else { $line = $_; } for (;;) { last if defined($line) && ($line =~ /^$/) ; $_ = ; chomp ; # gather up a single header with possible continuation lines into $line if (/^\s+/) { if (! $line) { $msg = "First line with leading whitespace!" ; syslog "err", $msg unless -t STDERR ; die "$msg\n" ; } $line .= "\n" . $_ ; next ; } # On the first header $line will be undefined. ($_, $line) = ($line, $_) ; # swap $line and $_ ; last if defined($_) && /^$/ ; next if /^$/ ; # only on first header will this happen push @errorText, "($_)\n"; next if /^Approved:\s/sio && defined($approved); next if /^Distribution:\s/sio && defined($distribution); if (/^(Organization|Distribution):\s*/sio) { $real_news_hdrs .= "$_\n"; next; } if (/^Subject:\s*/sio) { $subject = $'; next; } if (/^Message-ID:\s*/sio) { $message_id = $'; next; } if (/^Mailing-List:\s*/sio) { $mailing_list = $'; next; } if (/^(Sender|Approved):\s*/sio) { $real_news_hdrs .= "$&" . fix_sender_addr($') . "\n"; next; } if (/^Return-Path:\s*/sio) { $path = $'; $path = $1 if ($path =~ /\<([^\>]*)\>/); push@errorText, "((path: $path))\n"; next; } if (/^Date:\s*/sio) { $date = $'; next; } if (/^From:\s*/sio) { $from = &fix_sender_addr($'); next; } if (/^References:\s*/sio) { $references = $'; next; } if (!defined($references) && /^In-Reply-To:[^\<]*\<([^\>]+)\>/sio) { $references = "<$1>"; # FALLTHROUGH } if (/^(MIME|Content)-[^:]+:\s*/sio) { $real_news_hdrs .= $_ . "\n" ; next ; } # strip out news trace headers since otherwise posting may fail. other # trace headers will be renamed to add 'X-' so we don't have to worry # about them. if (/^X-(Trace|Complaints-To):\s*/sio) { next ; } # strip out Received headers since otherwise posting may fail # due to too large header size. if (/^(Received):\s*/sio) { next ; } # random unknown header. prepend 'X-' if it's not already there. $_ = "X-$_" unless /^X-/sio ; $weird_mail_hdrs .= "$_\n"; } $msgIdHdr = $message_id if $message_id ; $fromHdr = $from if $from ; $dateHdr = $date if $date ; if ($path !~ /\!/) { $path = "$'!$`" if ($path =~ /\@/); } $real_news_hdrs .= "Subject: ${subject}\n"; $real_news_hdrs .= "Message-ID: ${msgIdHdr}\n" if defined($message_id); $real_news_hdrs .= "Mailing-List: ${mailing_list}\n" if defined($mailing_list); $real_news_hdrs .= "Distribution: ${distribution}\n" if defined($distribution); $real_news_hdrs .= "Approved: ${approved}\n" if defined($approved); $real_news_hdrs .= "References: ${references}\n" if defined($references); # Remove duplicate headers. my %headers = (); $real_news_hdrs =~ s/(.*?:)[ \t].*?($|\n)([ \t]+.*?($|\n))*/$headers{lc$1}++?"":$&/ge; # Inews writes error messages to stdout. We want to capture those and mail # them back to the newsmaster. Trying to write and read from a subprocess is # ugly and prone to deadlock, so we use a temp file. $tmpfile = sprintf "%s/mailpost.%d.%d", $Tmpdir, time, $$ ; if (!open TMPFILE,">$tmpfile") { $msg = "cant open temp file ($tmpfile): $!" ; $tmpfile = undef ; syslog "err", "$msg\n" unless $debugging || -t STDERR ; open TMPFILE, "|" . sprintf ($Sendmail, $Maintainer) || die "die(no tmpfile): sendmail: $!\n" ; print TMPFILE <<"EOF"; To: $Maintainer Subject: mailpost failure ($newsgroups): $msg -------- Article Contents EOF } print TMPFILE <<"EOF"; Path: ${path} From: ${fromHdr} Newsgroups: ${newsgroups} ${real_news_hdrs}Date: ${dateHdr} ${weird_mail_hdrs} EOF my $rest; $rest .= $_ while (); $rest =~ s/\n*$/\n/g; # Remove trailing \n except very last print TMPFILE $rest; close TMPFILE ; if ( ! $tmpfile ) { # we had to bail and mail the article to the admin. exit (0) ; } ## ## We've got the article in a temp file and now we validate some of the ## data we found and update our message-id database. ## mailArtAndDie ("no From: found") unless $from; mailArtAndDie ("no Date: found") unless $date; mailArtAndDie ("no Message-ID: found") unless $message_id; mailArtAndDie ("Malformed message ID ($message_id)") if ($message_id !~ /\<(\S+)\@(\S+)\>/); # update (with locking) our message-id database. this is used to make sure we # don't loop our own gatewayed articles back through the mailing list. my ($lhs, $rhs) = ($1, $2); # of message_id match above. $rhs =~ tr/A-Z/a-z/; $message_id = "${lhs}\@${rhs}"; push @errorText, "(TAS message-id database for $message_id)\n"; my $lockfile = sprintf("%s.lock", $Database); open LOCKFILE, "<$lockfile" || open LOCKFILE, ">$lockfile" || mailArtAndDie ("can't open $lockfile: $!") ; my $i ; for ($i = 0 ; $i < 5 ; $i++) { flock LOCKFILE, $LOCK_EX && last ; sleep 1 ; } mailArtAndDie ("can't lock $lockfile: $!") if ($i == 5) ; my %DATABASE ; dbmopen %DATABASE, $Database, 0666 || mailArtAndDie ("can't dbmopen $lockfile: $!"); exit 0 if defined $DATABASE{$message_id}; # already seen. $DATABASE{$message_id} = sprintf "%d.%s", time, 'mailpost' ; mailArtAndDie ("TAS didn't set $message_id") unless defined $DATABASE{$message_id}; dbmclose %DATABASE || mailArtAndDie ("can't dbmclose $lockfile: $!") ; flock LOCKFILE, $LOCK_UN || mailArtAndDie ("can't unlock $lockfile: $!"); close LOCKFILE ; if (!open INEWS, "$WhereTo < $tmpfile 2>&1 |") { mailArtAndDie ("cant start: $WhereTo: $!") ; } my @inews = ; close INEWS ; my $status = $? ; if (@inews) { chomp @inews ; mailArtAndDie ("inews failed: @inews") ; } unlink $tmpfile ; exit $status; sub mailArtAndDie { my ($msg) = @_ ; print STDERR $msg,"\n" if -t STDERR ; open SENDMAIL, "|" . sprintf ($Sendmail,$Maintainer) || die "die($msg): sendmail: $!\n" ; print SENDMAIL <<"EOF" ; To: $Maintainer Subject: mailpost failure ($newsgroups): $msg $msg EOF if ($tmpfile && -f $tmpfile) { print SENDMAIL "\n-------- Article Contents\n\n" ; open FILE, "<$tmpfile" || die "open($tmpfile): $!\n" ; print SENDMAIL while ; close FILE ; } else { print "No article left to send back.\n" ; } close SENDMAIL ; # unlink $tmpfile ; exit (0) ; # using a non-zero exit may cause problems. } # # take 822-format name (either "comment comment" or "addr (comment)") # and return in always-qualified 974-format ("addr (comment)"). # sub fix_sender_addr { my ($address) = @_; my ($lcomment, $addr, $rcomment, $comment); local ($',$`,$_) ; if ($address =~ /\<([^\>]*)\>/) { ($lcomment, $addr, $rcomment) = (&dltb($`), &dltb($1), &dltb($')); } elsif ($address =~ /\(([^\)]*)\)/) { ($lcomment, $addr, $rcomment) = ('', &dltb($`.$'), &dltb($1)); } else { ($lcomment, $addr, $rcomment) = ('', &dltb($address), ''); } #print STDERR "fix_sender_addr($address) == ($lcomment, $addr, $rcomment)\n"; $addr .= "\@$Mailname" unless ($addr =~ /\@/); if ($lcomment && $rcomment) { $comment = $lcomment . ' ' . $rcomment; } else { $comment = $lcomment . $rcomment; } $_ = $addr; $_ .= " ($comment)" if $comment; #print STDERR "\t-> $_\n"; return $_; } # # delete leading and trailing blanks # sub dltb { my ($str) = @_; $str =~ s/^\s+//o; $str =~ s/\s+$//o; return $str; }