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