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