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