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