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