stump/bin/submission.pl

   1 #
   2 # this script accepts submissions that come to the robomoderator by
   3 # email. It make s a decision whether the submission deserves
   4 # rejection, automatic approval, or is suspicious and should be
   5 # forwarded to human moderators for review.
   6 #
   7 # A decision is essentially a choice of the program that will be
   8 # fed with preprocessed article.
   9 #
  10 # Also note that this script fixes common problems and mistakes in
  11 # newsreaders, newsservers, and users. Even though we have no
  12 # obligation to fix these problems, people get really disappointed
  13 # if we outright reject their bogus messages, because these
  14 # people often have no control over how the posts get delivered to us.
  15 #
  16 # This script supports notion of blacklisting and list of
  17 # preapproved persons. As the names imply, we reject all submissions
  18 # from blacklisted posters and automatically approve all messages submitted
  19 # by preapproved posters (provided that their posts meet other criteria
  20 # imposed by the robomoderator.
  21 #
  22 # For an automatic rejection, it gives a main "reason" for rejection
  23 #
  24 #Currently supported list of reasons:
  25 #
  26 #       - crosspost
  27 #       - abuse
  28 #       - harassing
  29 #       - offtopic
  30
  31 # get the directory where robomod is residing
  32 $MNG_ROOT = $ENV{'MNG_ROOT'} || die "Root dir for moderation not specified";
  33
  34 # common library
  35 require "$MNG_ROOT/bin/robomod.pl";
  36
  37 # max allowed number of newsgroups in crossposts
  38 # change it if you want, but 5 is really good.
  39 $maxNewsgroups = $ENV{'MAX_CROSSPOSTS'} || 5;
  40
  41 # should we ALWAYS require preapproved posters to sign their submissions
  42 # with PGP? Turn it on in the `etc/modenv' if you suffer from numerous
  43 # forgeries in the names of preapproved posters.
  44 $PGPCheckPreapproved = $ENV{ "WHITELIST_MUST_SIGN" } eq "YES";
  45
  46 # So, what newsgroup I am moderating?
  47 $Newsgroup = $ENV{'NEWSGROUP'};
  48
  49 # as the name implies. ATTENTION: $TMP must be mode 700!!!
  50 $TmpFile = "$ENV{'TMP'}/submission.$$";
  51
  52 # how do we treat suspicious articles?
  53 $Command_Suspicious = "formail -a \"Newsgroups: $Newsgroup\" " .
  54                       "| stump.pl suspicious.pl";
  55
  56 # approved
  57 $Command_Approve = "processApproved robomod";
  58 # rejected
  59 $Command_Reject  = "processRejected robomod";
  60
  61 # location of blacklist
  62 $badGuys = "bad.guys.list";
  63
  64 # location of preapproved list
  65 $goodGuys = "good.guys.list";
  66
  67 # words that trigger robomod to mark messages suspicious, even
  68 # when the message comes from a preapproved person.
  69 $badWords = "bad.words.list";
  70
  71 # list of people who want all their submissions to be signed
  72 $PGPMustList = "pgp.must.list";
  73
  74 # set PMUSER and ROBOMOD to Internal. Will be used by `suspicious' script.
  75 $ENV{'PMUSER'} = $ENV{'PMUSER_INTERNAL'};
  76 $ENV{'ROBOMOD'} = $ENV{'ROBOMOD_INTERNAL'};
  77
  78
  79 ######################################################################
  80 # Filter rules
  81 # checks if all is OK with newsgroups.
  82 # what's not OK:
  83 #   1. Megacrossposts
  84 #   2. Crossposts to other moderated groups
  85 #   3. Control messages (currently)
  86 #
  87 sub checkNewsgroups {
  88
  89   # We have not implemented Control: yet...
  90   if( $Control ) {
  91 print STDERR "CONTROL message - rejected\n";
  92     return "$Command_Reject crosspost You posted a Control message which " .
  93            "is not allowed.";
  94   }
  95
  96   if( $#newsgroups >= $maxNewsgroups ) {
  97 print STDERR "Too many newsgroups\n";
  98     return "$Command_Reject crosspost Too many newsgroups, " .
  99            "$maxNewsgroups is maximum.";
 100   }
 101
 102   local( $good ) = 0;
 103
 104   for( $i = 0; $i <= $#newsgroups; $i++ ) {
 105
 106     if( $newsgroups[$i] eq $Newsgroup ) {
 107       $good = 1;
 108       next;
 109     }
 110
 111     if( $NewsgroupsDB{$newsgroups[$i]} eq 'm' &&
 112         $newsgroups[$i] ne $Newsgroup) {
 113 print STDERR "posting to ANOTHER moderated newsgroups\n";
 114       return "$Command_Reject crosspost You crossposted to another " .
 115              "moderated newsgroup.";
 116     }
 117
 118   }
 119
 120   if( !$good ) { # Some fool forgot to list the moderated newsgroup
 121                  # in the Newsgroups
 122     $Newsgroups .= ",$Newsgroup";
 123     if( $#newsgroups + 1 >= $maxNewsgroups ) {
 124 print STDERR "Too many newsgroups\n";
 125       return "$Command_Reject crosspost Too many newsgroups, FIVE is maximum.";
 126     }
 127   }
 128
 129   return 0;
 130 }
 131
 132 ###################################################################### checkAck
 133 # checks if poster needs acknowledgment of receipt
 134 #
 135 sub checkAck {
 136   my $fromaddr = $From;
 137   $fromaddr =~ s/^[-A-Za-z]+\s*\:\s*//;
 138   print STDERR "checking noack.list for \"$From|$fromaddr\"\n";
 139   if( &nameIsInListExactly( $fromaddr, "noack.list" ) ) {
 140     $needAck = "no";
 141   } else {
 142     $needAck = "yes";
 143   }
 144 }
 145
 146 ################################################################### checkPGP
 147 # checks PGP sig IF REQUIRED
 148 #
 149 # we can reject a post if
 150 #
 151 #   1. A post must be signed accordinng to rules OR
 152 #   2. A post is signed but verification fails.
 153 #
 154 # Note that we set From: to the user ID in the PGP signature
 155 # if a signature is present. It allows for identification of trolls
 156 # and for preventing subtle forgeries.
 157 #
 158 sub checkPGP {
 159
 160   local( $FromSig ) = `verifySignature < $TmpFile`; chop( $FromSig );
 161   local( $good ) = $? == 0;
 162
 163 print STDERR "FromSig = $FromSig, good = $good\n" if $FromSig;
 164
 165   if( !$good ) {
 166     return "$Command_Reject signature Your PGP signature does NOT match, or is not in our keyring";
 167   }
 168
 169   if( &nameIsInListRegexp( $From, $PGPMustList ) ||
 170       ($PGPCheckPreapproved && &nameIsInListExactly($From, $goodGuys) ) ) {
 171     if( $FromSig eq "" ) {
 172       return "$Command_Reject signature You are REQUIRED to sign your posts.";
 173     }
 174   }
 175
 176   if( $FromSig ) {
 177     $X_Origin = $From;
 178     $From = "From: $FromSig";
 179     $ReplyTo = $From;
 180   }
 181
 182   # else nothing to do
 183   return 0;
 184 }
 185
 186 ################################################################ checkCharter
 187 # checks charter calling conforms_charter
 188 #
 189 sub checkCharter {
 190   open( VERIFY, "|conforms_charter" ) or die $!;
 191   print VERIFY $Body or die $!;
 192   close( VERIFY );
 193
 194   return $? == 0;
 195 }
 196
 197 ################################################################### Filter
 198 # contains all filtering rules. calls subroutines above.
 199 sub Filter {
 200
 201
 202   local( $response );
 203
 204   @newsgroups = split( /,/, $Newsgroups );
 205
 206   return "Command_Reject charter We do not allow any control and " .
 207          "cancel messages. contact newsgroup administrator"
 208     if( $Control );
 209
 210   if( $response = &checkNewsgroups() ) {
 211       return $response;
 212   }
 213
 214   if( $paranoid_pgp ) {
 215     if( $response = &checkPGP() ) {
 216         return $response;
 217     }
 218   }
 219
 220   if( &nameIsInListRegexp( $From, $badGuys ) ) {
 221     return "$Command_Reject blocklist";
 222   }
 223
 224   # note that if even a preapproved person uses "BAD words" (that is
 225   # words from a special list), his/her message will be marked
 226   # "suspicious" and will be forwarded to a humen mod for review.
 227   # As an example of a bad word may be "MAKE MONEY FAST - IT REALLY WORKS!!!"
 228   #
 229   if( $badWord = &nameIsInListRegexp( $Body, $badWords ) ) {
 230 print STDERR "BAD WORD $badWord FOUND!!!\n";
 231     return $Command_Suspicious; # messages from approved guys MAY be
 232                          # suspicious if they write about
 233                          # homosexual forgers
 234   }
 235
 236   # checking for charter-specific restrictions
 237   if( !&checkCharter || ($Encoding =~ "base64") ) {
 238     return "$Command_Reject charter you sent a " .
 239            "binary encoded file which is not allowed.";
 240   }
 241
 242   # Checking preapproved list
 243   if( &nameIsInListExactly( $From, $goodGuys ) ) {
 244   local( $from ) = $From; $from =~ s/^From: //i;
 245 print STDERR "$from is a PREAPPROVED person\n";
 246     return $Command_Approve;
 247   }
 248
 249   # Here I may put some more rules...
 250
 251   return $Command_Suspicious;
 252 }
 253
 254 ######################################################################
 255 # set defaults
 256 sub setDefaults {
 257   if( !$Newsgroups ) {
 258     $Newsgroups = $ENV{ "NEWSGROUP" } || die "No default newsgroup";
 259   }
 260 }
 261
 262 ################################################################# ignoreHeader
 263 # some of the header fields present in emails must be ignored.
 264 #
 265 sub ignoreHeader {
 266   local( $header ) = pop( @_ );
 267
 268 #  return 1 if( $header =~ /^Control:/i );
 269   return 1 if( $header =~ /^Expires:/i );
 270   return 1 if( $header =~ /^Supersedes:/i );
 271   return 1 if( $header =~ /^Precedence:/i );
 272   return 1 if( $header =~ /^Apparently-To:/i );
 273   return 1 if( $header =~ /^Expires:/i );
 274   return 1 if( $header =~ /^Distribution:/i );
 275   return 1 if( $header =~ /^Path:/i );
 276   return 1 if( $header =~ /^NNTP-Posting-Host:/i );
 277   return 1 if( $header =~ /^Xref:/i );
 278   return 1 if( $header =~ /^Status:/i );
 279   return 1 if( $header =~ /^Lines:/i );
 280   return 1 if( $header =~ /^Apparently-To:/i );
 281   return 1 if( $header =~ /^Cc:/i );
 282   return 1 if( $header =~ /^Sender:/i );
 283   return 1 if( $header =~ /^In-Reply-To:/i );
 284   return 1 if( $header =~ /^Originator:/i );
 285   return 1 if( $header =~ /^X-Trace:/i );
 286   return 1 if( $header =~ /^X-Complaints-To:/i );
 287   return 1 if( $header =~ /^NNTP-Posting-Date:/i );
 288
 289   return 0;
 290 }
 291
 292
 293 ######################################################################
 294 # Getting data
 295 #
 296 # reads message, sets variables describing header fields
 297 #
 298 # it also tries to "fix" the problem with old newsservers (B-News I think)
 299 # when they try to "wrap" a submission in one more layer of meaningless
 300 # headers. It is recognized by STUPID presense of TWO identical To:
 301 # fields.
 302 #
 303
 304 sub readMessage {
 305
 306 #open IWJL, ">>/home/webstump/t.log";
 307 #print IWJL "=========== SUBMISSION READMESSAGE\n";
 308
 309   open( TMPFILE, "> $TmpFile" ) or die $!;
 310
 311   $IsBody = 0;
 312
 313   my @unfolded;
 314   my $readahead = '';
 315
 316   our $warnings=0;
 317   my $warning = sub {
 318     sprintf "X-STUMP-Warning-%d: %s\n", $warnings++, $_[0];
 319   };
 320
 321 #open TTY, ">/home/webstump/t";
 322   for (;;) {
 323 #print TTY "=| $IsBody | $readahead ...\n";
 324     if (!defined $readahead) {
 325       # we got EOF earlier;
 326       last;
 327     }
 328     if (length $readahead) {
 329       $_ = $readahead;
 330       $readahead = '';
 331     } else {
 332       $_ = <>;
 333       last unless defined;
 334     }
 335     if (!$IsBody) {
 336       # right now there is no readahead, since we just consumed it into $_
 337       if ($_ !~ m/^\r?\n$/) { # blank line ? no...
 338         $readahead = <>;
 339         if (defined $readahead && $readahead =~ m/^[ \t]/) {
 340           # this is a continuation, keep stashing
 341           $readahead = $_.$readahead;
 342           next;
 343         }
 344         # OK, $readahead is perhaps:
 345         #   - undef: we got eof
 346         #   - empty line: signalling end of (these) headers
 347         #   - start of next header
 348         # In these cases, keep that in $readahead for now,
 349         # and process the previous header, which is in $_.
 350         # But, first, a wrinkle ...
 351         if (!m/^(?:References):/i) {
 352           push @unfolded, (m/^[^:]+:/ ? $& : '????')
 353             if s/\n(?=.)//g;
 354           my $maxlen = 510;
 355           if (length $_ > $maxlen+1) { # $maxlen plus one \n
 356             chomp;
 357             $_ = substr($_, 0, $maxlen);
 358             $_ .= "\n";
 359             $readahead = $_;
 360             m/^[0-9a-z-]+/i;
 361             $_ = $warning->("Next header ($&) truncated!");
 362           }
 363         }
 364       } else {
 365         # $_ is empty line at end of headers
 366         # (and, there is no $readahead)
 367         if (@unfolded) {
 368           # insert this warning into the right set of headers
 369           $readahead = $_;
 370           $_ = $warning->("Unfolded headers @unfolded");
 371           @unfolded = ();
 372         }
 373       }
 374       # Now we have in $_ either a complete header, unfolded,
 375       # or the empty line at the end of headers
 376     }
 377 #print TTY "=> $IsBody | $readahead | $_ ...\n";
 378
 379     $Body .= $_;
 380
 381     if( !$IsBody && &ignoreHeader( $_ ) ) {
 382       next;
 383     }
 384
 385     print TMPFILE or die $!;
 386
 387     chop;
 388
 389     if( /^$/ ) {
 390       if( !$Subject && $From =~ /news\@/) {
 391         $BadNewsserver = 1;
 392       }
 393
 394       if( $BadNewsserver ) { # just ignore the outer layer of headers
 395         $To = 0;
 396       } else {
 397         $IsBody = 1;
 398       }
 399     }
 400
 401     if( !$IsBody ) {
 402
 403       if( /^Newsgroups: / ) { # set Newsgroups, remove spaces
 404         $Newsgroups = $_;
 405         $Newsgroups =~ s/^Newsgroups: //i;
 406         $Newsgroups =~ s/ //g; # some fools put spaces in list of newsgroups
 407       } elsif( /^Subject: / ) {
 408         $Subject = $_;
 409       } elsif( /^From: / ) {
 410         $From = $_;
 411       } elsif( /^To: / ) {
 412         if( $To && ($To eq $_)) {
 413           # Old & crappy news servers that wrap submissions with one more
 414           # layer of headers. For them, I simply ignore the outer
 415           # headers. These (at least I think) submissions may be
 416           # recognized by TWO idiotic To: header fields.
 417 print STDERR "BAD NEWSSERVER\n";
 418           $BadNewsserver = 1;
 419         }
 420         $To = $_;
 421       } elsif( /^Path: / ) {
 422         $Path = $_;
 423       } elsif( /^Keywords: / ) {
 424         $Keywords = $_;
 425       } elsif( /^Summary: / ) {
 426         $Summary = $_;
 427       } elsif( /^Control: / ) {
 428         $Control = $_;
 429       } elsif( /^Message-ID: / ) {
 430         $Message_ID = $_;
 431       } elsif ( /^Content-Transfer-Encoding: / ) {
 432         $Encoding = $_;
 433         $Encoding =~ s/^Content-Transfer-Encoding: //;
 434       }
 435
 436     }
 437   }
 438 use IO::Handle;
 439 #  print IWJL "SbRmE $!\n";
 440   die "read message $! !" if STDIN->error;
 441
 442   close( TMPFILE );
 443 }
 444
 445 ###################################################################### work
 446 # all main work is done here
 447
 448 ######################################################################
 449 # read the thing
 450 &readMessage();
 451
 452 if( !$Newsgroups ) {
 453   $Newsgroups = $Newsgroup;
 454 }
 455
 456 ######################################################################
 457 # process acks
 458 &checkAck;
 459 $Command_Suspicious .= " $needAck";
 460
 461 ######################################################################
 462 # set defaults
 463 &setDefaults();
 464
 465 ######################################################################
 466 # Check
 467
 468 $command = &Filter;
 469
 470 ######################################################################
 471 # process
 472 print STDERR "command = $command\n";
 473
 474 #open IWJL, ">>/home/webstump/t.log";
 475 #print IWJL "=========== SUBMISSION MAIN\n";
 476
 477 open( COMMAND, "| $command" ) or die $!;
 478 open( TMPFILE, "$TmpFile" ) || die "cant open tmpfile";
 479
 480   $IsBody = 0;
 481
 482   while( <TMPFILE> ) {
 483
 484     if( $BadNewsserver && !(/^$/) ) {
 485       next;
 486     }
 487
 488     if( $BadNewsserver && /^$/ ) {
 489       $BadNewsserver = 0;
 490       next;
 491     }
 492
 493     if( /^$/ ) {
 494       $IsBody = 1;
 495     }
 496
 497     if( /^From / ) {
 498       print COMMAND or die $!;
 499       print COMMAND "X-Origin: $X_Origin, $_" or die $! if $X_Origin;
 500       print STDERR "Subject =`$Subject'\n";
 501       print COMMAND "Subject: No subject given\n" or die $! if !$Subject;
 502       # nothing
 503     } elsif( /^From: / && !$IsBody) {
 504       next if $FromWasUsed;
 505
 506       $FromWasUsed = 1; # note that some crappy remailers have several
 507                         # "From: " fields. We really do NOT want two
 508                         # "From: " to go to headers!
 509
 510       if( $From ) {
 511         print COMMAND "$From\n" or die $!;
 512         $From = "";
 513       } else {
 514         print COMMAND or die $!;
 515       }
 516     } elsif( /^Newsgroups: / && !$IsBody ) {
 517       print COMMAND "Newsgroups: $Newsgroups\n" or die $!;
 518     } else {
 519       print COMMAND or die $!;
 520     }
 521   }
 522
 523 close( TMPFILE ) or die $!;
 524 close( COMMAND ) or die "$? $!";
 525
 526 ################################################################## Archiving
 527 # archive
 528
 529 #open( COMMAND, "| procmail -f- $MNG_ROOT/etc/procmail/save-incoming" );
 530 #print COMMAND $Body;
 531 #close( COMMAND );
 532
 533 unlink( $TmpFile );