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
 279     mkfolder($mhfolder);
 280
 281     $mhmsg = `mhpath +$mhfolder new`;
 282     chomp($mhmsg);
 283     $msgnum = basename($mhmsg);
 284
 285     logsave("+$mhfolder");
 286
 287     if ($run) {
 288         if (not rename($msg, $mhmsg)) {
 289             err(&EX_TEMPFAIL, "Failed rename($msg, $mhmsg)");
 290         }
 291
 292         if ($mhfolder ne 'SPAM') {
 293             system("mark +$mhfolder $msgnum -sequence unseen -add");
 294         }
 295     }
 296
 297     if (not $FOLDERS{$mhfolder}) {
 298         print("+$mhfolder\n");
 299         $FOLDERS{$mhfolder} = 1;
 300     }
 301 }
 302
 303 sub get_headers {
 304     my $msg = shift;
 305     my %headers;
 306     my $current;                # current header, used for unfolding lines
 307     my $fieldname;              # unmolested header name
 308
 309     open(MSG, $msg);
 310     while (<MSG>) {
 311         chomp;
 312         if (length == 0) {
 313             last;
 314         }
 315
 316         if (/^\s/) {
 317             # folded header continuation
 318
 319             if (!defined($current)) {
 320                 # XXX: Malformed message; log to stderr
 321                 return undef;
 322             }
 323
 324             $headers{$current} .= $_;
 325         } else {
 326             ($fieldname) = split(/:/);
 327             $current = lc($fieldname);
 328             (undef, $headers{$current}) = split(/^$fieldname:\s*/);
 329         }
 330     }
 331     close(MSG);
 332
 333     return %headers;
 334 }
 335
 336 \f
 337 ###############################################################################
 338 # Spam handling
 339
 340 sub is_spam {
 341     my $msg = shift;
 342     my $err;
 343     my $sig;
 344     my $status;
 345
 346     $err = $sig = $msg;
 347     $err =~ s|/new/|/err/|;
 348     $sig =~ s|/new/|/sig/|;
 349     if (-f $err) {
 350         my $line;
 351         my $message;
 352
 353         open(ERR, $err);
 354         $line = <ERR>;
 355         close(ERR);
 356
 357         chomp($line);
 358         ($message, $!) = split(/:/, $line);
 359
 360         logerr("$err: $message: $!");
 361
 362         if (unlink($err) != 1) {
 363             err(&EX_TEMPFAIL, "Failed unlink($err)");
 364         }
 365     } elsif (-f $sig) {
 366         # This is supposed to be a signature created with razor-check
 367         # directly after delivery.  Currently this isn't supported
 368         # because it isn't clear to me how to get that signature back
 369         # into razor-check.  For now, just unlink any sig files we
 370         # find and proceed with full razor-check mode.
 371
 372         if (unlink($sig) != 1) {
 373             err(&EX_TEMPFAIL, "Failed unlink($sig)");
 374         }
 375     }
 376
 377     $status = system("razor-check < $msg");
 378     if (WIFEXITED($status) and WEXITSTATUS($status) == 0) {
 379         return 1;
 380     } else {
 381         return 0;
 382     }
 383 }
 384
 385 sub kill_spam {
 386     my @msglist = @_;
 387     my @result;
 388     my $msg;
 389     my $i;
 390
 391     @result = ();
 392
 393     $i = 0;
 394     foreach $msg (@msglist) {
 395         printf('%sChecking for spam... %6d/%d',
 396                "\r", ++$i, scalar(@msglist));
 397         if (is_spam($msg)) {
 398             print(" SPAM\n");
 399             store_message($msg, 'SPAM');
 400         } else {
 401             push(@result, $msg);
 402         }
 403     }
 404     print("\nDone: ", scalar(@result), "\n");
 405
 406     return @result;
 407 }
 408
 409 \f
 410 ###############################################################################
 411 # Filtering
 412
 413 sub find_mh_folder {
 414     my $msg = shift;
 415     my %headers;
 416     my $header;
 417     my $contents;
 418     my $regex;
 419     my $subst;
 420     my $try;
 421
 422     %headers = get_headers($msg);
 423
 424     log_headers(%headers);
 425
 426     foreach $header (keys(%FILTERS)) {
 427         $contents = $headers{$header};
 428
 429         if (defined($contents)) {
 430             foreach $regex (keys(%{$FILTERS{$header}})) {
 431                 $subst = $FILTERS{$header}->{$regex};
 432
 433                 $try = '$contents =~';
 434                 $try .= " s|$regex|$subst|is";
 435                 if (eval $try) {
 436                     return $contents;
 437                 }
 438             }
 439         }
 440     }
 441
 442     return 'inbox';
 443 }
 444
 445 sub filter_mail {
 446     my @msglist = @_;
 447     my $msg;
 448     my $mhfolder;
 449
 450     foreach $msg (@msglist) {
 451         $mhfolder = find_mh_folder($msg);
 452         store_message($msg, $mhfolder);
 453     }
 454 }
 455
 456 \f
 457 MAIN: {
 458     my @msglist;
 459
 460     if ($dumpfilters) {
 461         $Data::Dumper::Indent = 1;
 462         print(Dumper(\%FILTERS));
 463         exit(&EX_OK);
 464     }
 465
 466     @msglist = kill_spam(glob("$MAILDIR/new/*"));
 467
 468     if (not $spamonly) {
 469         filter_mail(@msglist);
 470     }
 471 }
 472
 473 __END__
 474
 475 =head1 EXAMPLES
 476
 477 %FILTERS =
 478   ('List-Id:'=>
 479    {'.*<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>.*'=>'l/$1/$2',
 480     '.*<([[:graph:]]+?)(-list)?\.freedesktop\.org>.*'=>'l/freedesktop/$1',
 481     '.*<swig\.cs\.uchicago\.edu>.*'=>'l/swig'},
 482
 483    'List-Post:'=>
 484    {'<mailto:([[:graph:]]+)+@([[:graph:]]+)\.apache\.org>'=>'l/apache/$2/$1'},
 485
 486    'To:'=>
 487    {'root'=>'root'});
 488
 489 The first List-Id filter is a surprisingly effective one which creates
 490 appropriate folder names (such as l/htdig/updates and l/rox/devel) for
 491 all Sourceforge lists to which i subscribe.  Certainly there are lists
 492 hosted at Sourceforge which do not work well with this, and this is
 493 where it is important to remember that the first match is the one
 494 uses.  Simply put the more specific rules before this one.
 495
 496 The next List-Id example is simple.  The swig example demonstrates
 497 that the folder name does not have to use a portion of the matched
 498 header; you can just hardcode the folder name.
 499
 500 The List-Post example is a nice one.  Most ASF projects have their own
 501 apache.org subdomain, with mailing lists hosted there.  So, given a
 502 list such as dev@httpd.apache.org, this filter will create the folder
 503 name l/apache/httpd/dev.
 504
 505 =head1 AUTHORS
 506
 507 Written by Eric Gillespie <epg@pretzelnet.org> with logging code
 508 stolen from Adam Lazur <adam@lazur.org>.
 509
 510 Design by Eric Gillespie and Doug Porter <dsp@waterspout.com>.
 511
 512 =cut