diplodocus.org Git - minc/blob - minc

   1 #! /usr/local/bin/perl
   2
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 B<minc> - Incorporate mail from a maildir into mh folders.
   8
   9 =head1 SYNOPSIS
  10
  11 B<minc> [-B<dhns>]
  12
  13 =head1 DESCRIPTION
  14
  15 B<minc> is a program for incorporating mail from a maildir to a mh
  16 folder hierarchy.  It takes mail from a maildir folder (not a maildir
  17 folder hierarchy), checks for spam with razor
  18 (http://razor.sourceforge.net/), and optionally filters mail into
  19 separate mh folders.
  20
  21 The filtering is quite sophisticated, as it is done using real Perl
  22 substitution (s//) commands.
  23
  24 =cut
  25
  26 use strict;
  27 use warnings;
  28
  29 require 'sysexits.ph';
  30
  31 use Data::Dumper;
  32 use Errno;
  33 use Fcntl qw(O_WRONLY O_EXCL O_CREAT);
  34 use File::Basename;
  35 use Getopt::Std;
  36 use Log::Dispatch;
  37 use Log::Dispatch::File;
  38 use POSIX qw(strftime WEXITSTATUS WIFEXITED);
  39
  40 =head1 OPTIONS
  41
  42 =over 4
  43
  44 =item B<-d>
  45
  46 Dump (using Data::Dumper) the FILTERS hash and exit.  This is useful
  47 for testing the syntax of .mincfilter.
  48
  49 =item B<-f>
  50
  51 Filter only, then exit.  This is useful after running B<minc -s>.
  52
  53 =item B<-h>
  54
  55 Show help.
  56
  57 =item B<-n>
  58
  59 Dry run; do not actually incorporate the mail, but log and report to
  60 stdout/stderr as normal.
  61
  62 =item B<-s>
  63
  64 Process SPAM only, then exit, leaving all non-spam messages in the
  65 maildir.
  66
  67 =back
  68
  69 =cut
  70
  71 my $dumpfilters = 0;
  72 my $filteronly = 0;
  73 my $run = 1;
  74 my $spamonly = 0;
  75
  76 our $opt_d;
  77 our $opt_f;
  78 our $opt_h;
  79 our $opt_n;
  80 our $opt_s;                     # ;; # stupid cperl-mode
  81
  82 if (not getopts('dhns')) {
  83     exit(&EX_USAGE);
  84 }
  85
  86 if ($opt_d) {
  87     $dumpfilters = 1;
  88 } elsif ($opt_h) {
  89     print("Sorry bub, no help.\n");
  90     exit(&EX_OK);
  91 } elsif ($opt_n) {
  92     $run = 0;
  93 }
  94
  95 if ($opt_f) {
  96     $filteronly = 1;
  97 } elsif ($opt_s) {              # ))){ # stupid cperl-mode
  98     $spamonly = 1;
  99 }
 100
 101 =head1 ENVIRONMENT
 102
 103 =over 4
 104
 105 =item HOME
 106
 107 Where configuration files (.mincfilter) are found.  Also,
 108 $HOME/Maildir is used for the maildir if MAILDIR is not set.
 109
 110 =item MAILDIR
 111
 112 Where mail is delivered.
 113
 114 =back
 115
 116 =cut
 117
 118 use Env qw(HOME MAILDIR);
 119
 120 if (not $HOME) {
 121     die("HOME environment variable must be set.\n");
 122 }
 123 if (not $MAILDIR) {
 124     $MAILDIR = "$HOME/Maildir";
 125 }
 126
 127 =head1 FILES
 128
 129 =over 4
 130
 131 =item $HOME/.mincfilter
 132
 133 This file is Perl code (included via the 'require' directive) which is
 134 expected to define the FILTERS hash.
 135
 136 =item `mhpath +`/logs/minc.log
 137
 138 Where minc logs what it does, unless in -n mode.
 139
 140 =item `mhpath +`/logs/dryrun.log
 141
 142 Where minc logs what it would do; used in -n mode.
 143
 144 =cut
 145
 146 our %FILTERS;
 147 require "$HOME/.mincfilter";
 148
 149 my $mh;
 150 my $logfile;
 151
 152 $mh = `mhpath +`;
 153 chomp($mh);
 154
 155 if ($run) {
 156     $logfile = $mh . '/logs/minc.log';
 157 } else {
 158     $logfile = $mh . '/logs/dryrun.log';
 159 }
 160
 161 \f
 162 ###############################################################################
 163 # Logging
 164
 165 # debuglevels for the logger
 166 use constant LOG_DEBUGLEVEL     => 'info';
 167 use constant SCREEN_DEBUGLEVEL  => 'debug';
 168
 169 # characters used to wrap around the id field in the log so I can more
 170 # easily parse the msg flow
 171 use constant DEBUGCHAR          => '%';
 172 use constant INFOCHAR           => '=';
 173 use constant INCOMINGCHAR       => '<';
 174 use constant SAVECHAR           => '>';
 175 use constant WARNCHAR           => 'W';
 176 use constant ERRORCHAR          => 'E';
 177
 178 my $logger = new Log::Dispatch;
 179 $logger->add(new Log::Dispatch::File (name=>'logfile',
 180                                       filename=>$logfile,
 181                                       min_level=>'info',
 182                                       mode=>'append'));
 183
 184 # log alias, handles getting passed vars that are undef
 185 sub mylog {
 186     my $level = shift;
 187     my $act = shift;
 188     my $timestamp = strftime('%b %e %H:%M:%S', localtime);
 189     my $msg;
 190     foreach my $part (@_) {
 191         if (defined($part)) {
 192             $msg .= $part;
 193         }
 194     }
 195     # no newlines in the log message, thanks
 196     $msg =~ s/\n/ /gm;
 197     $msg = sprintf("%s %s%s %s\n", $timestamp, $act, $act, $msg);
 198     $logger->log(level=>$level, message=>$msg);
 199
 200     if ($act eq SAVECHAR) {
 201         $logger->log(level=>$level, message=>"\n");
 202     }
 203 }
 204
 205 sub logincoming { mylog('info', INCOMINGCHAR, @_); }
 206 sub logsave { mylog('notice', SAVECHAR, @_); }
 207 sub loginfo { mylog('info', INFOCHAR, @_); }
 208 sub logdebug { mylog('debug', DEBUGCHAR, @_); }
 209 sub logwarn { mylog('warning', WARNCHAR, @_); }
 210 sub logerr { mylog('error', ERRORCHAR, @_); }
 211
 212 sub log_headers {
 213     my %headers = @_;
 214
 215     logincoming('From:       ', $headers{'return-path'});
 216     logincoming('To:         ', $headers{'to'});
 217     logincoming('Subject:    ', $headers{'subject'});
 218     logincoming('Message-Id: ', $headers{'message-id'});
 219 }
 220
 221 \f
 222 ###############################################################################
 223 # Utility procedures
 224
 225 sub _errprint {
 226     printf('%s:%s', __FILE__, __LINE__);
 227
 228     if (@_) {
 229         print(': ');
 230         foreach (@_) {
 231             print;
 232         }
 233     }
 234 }
 235
 236 sub err {
 237     my $ex = shift;
 238
 239     _errprint(@_);
 240     print(": $!\n");
 241
 242     exit($ex);
 243 }
 244
 245 sub errx {
 246     my $ex = shift;
 247
 248     _errprint(@_);
 249     print("\n");
 250
 251     exit($ex);
 252 }
 253
 254 sub mkfolder {
 255     my $mhfolder = shift;
 256     my $folder;
 257     my $target;
 258     my $component;
 259
 260     $folder = $mh . '/' . $mhfolder;
 261     $target = '';
 262
 263     if (not -d $folder) {
 264         foreach $component (split('/', $folder)) {
 265             if (defined($component) and length($component) >= 1) {
 266                 $target = $target . '/' . $component;
 267                 if (-d $target or mkdir($target)) {
 268                     next;
 269                 } else {
 270                     err(&EX_TEMPFAIL,
 271                         "Failed to create +$mhfolder ($component)");
 272                 }
 273             }
 274         }
 275     }
 276 }
 277
 278 sub getfiles {
 279     my $dir = shift;
 280     my @result;
 281
 282     if (not opendir(DIR, $dir)) {
 283         err(&EX_TEMPFAIL, "Failed opendir($dir)");
 284     }
 285
 286     # Initialize $! to 0 (success) because stupid stupid Perl provides
 287     # no way to distinguish an error from an empty directory; that
 288     # means setting $! to 0 and testing it afterwards is the only way
 289     # to detect an error.  Real Programmers don't handle errors,
 290     # right?  >sigh<
 291     $! = 0;
 292     @result = grep {
 293         ($_ ne '.' and $_ ne '..')
 294           and $_ = "$MAILDIR/new/$_"
 295       } readdir(DIR);
 296
 297     if ($! != 0) {
 298         err(&EX_TEMPFAIL, "Failed readdir($dir)");
 299     }
 300
 301     closedir(DIR);
 302
 303     return @result;
 304 }
 305
 306 sub get_highest_msgnum {
 307     my $mhfolder = shift;
 308     my $dir;
 309     my @list;
 310     my $highest;
 311     my $msgnum;
 312
 313     $dir = "$mh/$mhfolder";
 314     if (not opendir(DIR, $dir)) {
 315         err(&EX_TEMPFAIL, "Failed opendir($dir)");
 316     }
 317
 318     $! = 0;
 319     @list = readdir(DIR);
 320
 321     if ($! != 0) {
 322         err(&EX_TEMPFAIL, "Failed readdir($dir)");
 323     }
 324
 325     closedir(DIR);
 326
 327     $highest = 0;
 328     foreach $msgnum (@list) {
 329         # Look for integers.
 330         if ($msgnum =~ /^[0-9]+$/) {
 331             if ($msgnum > $highest) {
 332                 $highest = $msgnum;
 333             }
 334         }
 335     }
 336
 337     return $highest;
 338 }
 339
 340 # We want to print the name of each list that has new mail only once,
 341 # so use this hash to store the lists that have already been printed.
 342 # Start the list out with SPAM already in it, since we don't care when
 343 # new messages are added to it.
 344 my %FOLDERS = ('SPAM'=>1);
 345
 346 sub store_message {
 347     my $msg = shift;
 348     my $mhfolder = shift;
 349     my $msgnum;
 350     my $try;
 351     my $mhmsg;
 352     my $status;
 353
 354     # We must do this even in -n mode because later steps fail without
 355     # it.  This should be harmless.
 356     mkfolder($mhfolder);
 357
 358     $msgnum = get_highest_msgnum($mhfolder);
 359     for ($try = 0; ; $try++) {
 360         $msgnum++;
 361         $mhmsg = "$mh/$mhfolder/$msgnum";
 362
 363         if (not stat($mhmsg)) {
 364             if ($!{ENOENT}) {
 365                 # Now we have a non-existent file, let's try to create
 366                 # it.  We must create a zero-byte file first because a
 367                 # file my appear between our happy stat results and
 368                 # our later rename(2), which would clobber said file.
 369                 # So attempt to create a file with this name.  If it
 370                 # succeeds, in just a bit here we'll knowingly clobber
 371                 # this file with the rename(2) call.
 372                 if ($run) {
 373                     if (sysopen(MSG, "$mhmsg",
 374                                 O_WRONLY | O_EXCL | O_CREAT, 0600)) {
 375                         close(MSG);
 376                         last;
 377                     }
 378                 } else {
 379                     last;
 380                 }
 381             }
 382         }
 383
 384         # This algorithm is different from the maildir one; let's make
 385         # 10 tries instead of 3.
 386         if ($try == 9) {
 387             errx(&EX_TEMPFAIL, "Attempted filename $mhmsg exists.");
 388         }
 389
 390         # This algorithm is different; i don't think we need to sleep.
 391         #sleep(2);
 392     }
 393
 394     logsave("+$mhfolder");
 395
 396     if ($run) {
 397         if (not rename($msg, $mhmsg)) {
 398             err(&EX_TEMPFAIL, "Failed rename($msg, $mhmsg)");
 399         }
 400
 401         # Mark each message as soon as we store it and bomb if that
 402         # fails.  While it is slow, it is not safe to store multiple
 403         # messages and then have a failure before marking some (or
 404         # all).
 405         if ($mhfolder ne 'SPAM') {
 406             $status = system("mark +$mhfolder $msgnum -sequence unseen -add");
 407             if (not (WIFEXITED($status) and WEXITSTATUS($status) == 0)) {
 408                 errx(&EX_TEMPFAIL, "Failed to mark message unseen");
 409             }
 410         }
 411     }
 412
 413     if (not $FOLDERS{$mhfolder}) {
 414         print("+$mhfolder\n");
 415         $FOLDERS{$mhfolder} = 1;
 416     }
 417 }
 418
 419 sub get_headers {
 420     my $msg = shift;
 421     my %headers;
 422     my $current;                # current header, used for unfolding lines
 423     my $fieldname;              # unmolested header name
 424
 425     open(MSG, $msg);
 426     while (<MSG>) {
 427         chomp;
 428         if (length == 0) {
 429             last;
 430         }
 431
 432         if (/^\s/) {
 433             # folded header continuation
 434
 435             if (not defined($current)) {
 436                 print("Malformed message, cannot parse headers.\n");
 437                 return ();
 438             }
 439
 440             $headers{$current} .= $_;
 441         } else {
 442             ($fieldname) = split(/:/);
 443             $current = lc($fieldname);
 444             (undef, $headers{$current}) = split(/^$fieldname:\s*/);
 445         }
 446     }
 447     close(MSG);
 448
 449     return %headers;
 450 }
 451
 452 \f
 453 ###############################################################################
 454 # Spam handling
 455
 456 sub is_spam {
 457     my $msg = shift;
 458     my $err;
 459     my $sig;
 460     my $line;
 461     my $message;
 462     my $status;
 463
 464     $err = $sig = $msg;
 465     $err =~ s|/new/|/err/|;
 466     $sig =~ s|/new/|/sig/|;
 467     if (-f $err) {
 468         open(ERR, $err);
 469         $line = <ERR>;
 470         close(ERR);
 471
 472         chomp($line);
 473         ($message, $!) = split(/:/, $line);
 474
 475         logerr("$err: $message: $!");
 476
 477         if ($run) {
 478             if (unlink($err) != 1) {
 479                 err(&EX_TEMPFAIL, "Failed unlink($err)");
 480             }
 481         }
 482     } elsif (-f $sig) {
 483         # This is supposed to be a signature created with razor-check
 484         # directly after delivery.  Currently this isn't supported
 485         # because it isn't clear to me how to get that signature back
 486         # into razor-check.  For now, just unlink any sig files we
 487         # find and proceed with full razor-check mode.
 488
 489         if ($run) {
 490             if (unlink($sig) != 1) {
 491                 err(&EX_TEMPFAIL, "Failed unlink($sig)");
 492             }
 493         }
 494     }
 495
 496     if ($run) {
 497         $status = system("razor-check < $msg");
 498         if (not WIFEXITED($status)) {
 499             err(&EX_TEMPFAIL, "Failed to run razor-check < $msg");
 500         } elsif (WEXITSTATUS($status) == 0) {
 501             return 1;
 502         } else {
 503             return 0;
 504         }
 505     } else {
 506         return 0;
 507     }
 508 }
 509
 510 sub kill_spam {
 511     my @msglist = @_;
 512     my @result;
 513     my $msg;
 514     my $i;
 515
 516     @result = ();
 517
 518     $i = 0;
 519     foreach $msg (@msglist) {
 520         printf('%sChecking for spam... %6d/%d',
 521                "\r", ++$i, scalar(@msglist));
 522         if (is_spam($msg)) {
 523             print(" SPAM\n");
 524             store_message($msg, 'SPAM');
 525         } else {
 526             push(@result, $msg);
 527         }
 528     }
 529     print("\nDone: ", scalar(@result), " survivors\n");
 530
 531     return @result;
 532 }
 533
 534 \f
 535 ###############################################################################
 536 # Filtering
 537
 538 sub find_mh_folder {
 539     my $msg = shift;
 540     my %headers;
 541     my $header;
 542     my $contents;
 543     my $regex;
 544     my $subst;
 545     my $try;
 546
 547     %headers = get_headers($msg);
 548     if (not %headers) {
 549         return 'inbox';
 550     }
 551
 552     log_headers(%headers);
 553
 554     foreach $header (keys(%FILTERS)) {
 555         $contents = $headers{lc($header)};
 556
 557         if (defined($contents)) {
 558             foreach $regex (keys(%{$FILTERS{$header}})) {
 559                 $subst = $FILTERS{$header}->{$regex};
 560
 561                 $try = '$contents =~';
 562                 $try .= " s|$regex|$subst|is";
 563                 if (eval $try) {
 564                     return $contents;
 565                 }
 566             }
 567         }
 568     }
 569
 570     return 'inbox';
 571 }
 572
 573 sub filter_mail {
 574     my @msglist = @_;
 575     my $msg;
 576     my $mhfolder;
 577
 578     foreach $msg (@msglist) {
 579         $mhfolder = find_mh_folder($msg);
 580         store_message($msg, $mhfolder);
 581     }
 582 }
 583
 584 \f
 585 MAIN: {
 586     my @msglist;
 587
 588     if ($dumpfilters) {
 589         $Data::Dumper::Indent = 1;
 590         print(Dumper(\%FILTERS));
 591         exit(&EX_OK);
 592     }
 593
 594     @msglist = getfiles("$MAILDIR/new");
 595
 596     if (not $filteronly) {
 597         @msglist = kill_spam(@msglist);
 598     }
 599
 600     if (not $spamonly) {
 601         filter_mail(@msglist);
 602     }
 603 }
 604
 605 __END__
 606
 607 =head1 EXAMPLES
 608
 609 %FILTERS =
 610   ('List-Id:'=>
 611    {'.*<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>.*'=>'l/$1/$2',
 612     '.*<([[:graph:]]+?)(-list)?\.freedesktop\.org>.*'=>'l/freedesktop/$1',
 613     '.*<swig\.cs\.uchicago\.edu>.*'=>'l/swig'},
 614
 615    'List-Post:'=>
 616    {'<mailto:([[:graph:]]+)+@([[:graph:]]+)\.apache\.org>'=>'l/apache/$2/$1'},
 617
 618    'To:'=>
 619    {'root'=>'root'});
 620
 621 The first List-Id filter is a surprisingly effective one which creates
 622 appropriate folder names (such as l/htdig/updates and l/rox/devel) for
 623 all Sourceforge lists to which i subscribe.  Certainly there are lists
 624 hosted at Sourceforge which do not work well with this, and this is
 625 where it is important to remember that the first match is the one
 626 uses.  Simply put the more specific rules before this one.
 627
 628 The next List-Id example is simple.  The swig example demonstrates
 629 that the folder name does not have to use a portion of the matched
 630 header; you can just hardcode the folder name.
 631
 632 The List-Post example is a nice one.  Most ASF projects have their own
 633 apache.org subdomain, with mailing lists hosted there.  So, given a
 634 list such as dev@httpd.apache.org, this filter will create the folder
 635 name l/apache/httpd/dev.
 636
 637 =head1 AUTHORS
 638
 639 Written by Eric Gillespie <epg@pretzelnet.org> with logging code
 640 stolen from Adam Lazur <adam@lazur.org>.
 641
 642 Design by Eric Gillespie and Doug Porter <dsp@waterspout.com>.
 643
 644 =cut