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