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 mkfolder {
 201     my $mhfolder = shift;
 202     my $folder;
 203     my $target;
 204     my $component;
 205
 206     $folder = $mh . '/' . $mhfolder;
 207     $target = '';
 208
 209     if (! -d $folder) {
 210         foreach $component (split('/', $folder)) {
 211             if (defined($component) and length($component) >= 1) {
 212                 $target = $target . '/' . $component;
 213                 if (-d $target or mkdir($target)) {
 214                     next;
 215                 } else {
 216                     die("Failed to create +$mhfolder ($component): $!\n");
 217                 }
 218             }
 219         }
 220     }
 221 }
 222
 223 # We want to print the name of each list that has new mail only once,
 224 # so use this hash to store the lists that have already been printed.
 225 # Start the list out with SPAM already in it, since we don't care when
 226 # new messages are added to it.
 227 my %FOLDERS = ('SPAM'=>1);
 228
 229 sub store_message {
 230     my $msg = shift;
 231     my $mhfolder = shift;
 232     my $mhmsg;
 233     my $msgnum;
 234
 235     mkfolder($mhfolder);
 236
 237     $mhmsg = `mhpath +$mhfolder new`;
 238     chomp($mhmsg);
 239     $msgnum = basename($mhmsg);
 240
 241     logsave("+$mhfolder");
 242
 243     if ($run) {
 244         if (not rename($msg, $mhmsg)) {
 245             die("Rename failed: $!\n");
 246         }
 247
 248         if ($mhfolder ne 'SPAM') {
 249             system("mark +$mhfolder $msgnum -sequence unseen -add");
 250         }
 251     }
 252
 253     if (not $FOLDERS{$mhfolder}) {
 254         print("+$mhfolder\n");
 255         $FOLDERS{$mhfolder} = 1;
 256     }
 257 }
 258
 259 sub get_headers {
 260     my $msg = shift;
 261     my %headers;
 262     my $current;            # current header, used for unfolding lines
 263
 264     open(MSG, $msg);
 265     while (<MSG>) {
 266         chomp;
 267         if (length == 0) {
 268             last;
 269         }
 270
 271         if (/^\s/) {
 272             # folded header continuation
 273
 274             if (!defined($current)) {
 275                 # XXX: Malformed message; log to stderr
 276                 return undef;
 277             }
 278
 279             $headers{$current} .= $_;
 280         } else {
 281             ($current) = split(/:/);
 282
 283             # XXX: Is it correct simply to eat all whitespace between
 284             # the colon and the first text for the header?
 285             # Furthermore, is any space at all required?  Or is
 286             # '^Subject:hey$' a perfectly valid header?
 287             (undef, $headers{$current}) = split(/^$current:\s*/);
 288         }
 289     }
 290     close(MSG);
 291
 292     return %headers;
 293 }
 294
 295 \f
 296 ###############################################################################
 297 # Spam handling
 298
 299 sub is_spam {
 300     my $msg = shift;
 301     my $err;
 302     my $sig;
 303     my $status;
 304
 305     $err = $sig = $msg;
 306     $err =~ s|/new/|/err/|;
 307     $sig =~ s|/new/|/sig/|;
 308     if (-f $err) {
 309         my $line;
 310         my $message;
 311
 312         open(ERR, $err);
 313         $line = <ERR>;
 314         close(ERR);
 315
 316         chomp($line);
 317         ($message, $!) = split(/:/, $line);
 318
 319         logerr("$err: $message: $!");
 320
 321         if (unlink($err) != 1) {
 322             die("Failed unlink($err): $!\n");
 323         }
 324     } elsif (-f $sig) {
 325         # This is supposed to be a signature created with razor-check
 326         # directly after delivery.  Currently this isn't supported
 327         # because it isn't clear to me how to get that signature back
 328         # into razor-check.  For now, just unlink any sig files we
 329         # find and proceed with full razor-check mode.
 330
 331         if (unlink($sig) != 1) {
 332             die("Failed unlink($sig): $!\n");
 333         }
 334     }
 335
 336     #$status = system("razor-check < $msg");
 337     $status = system('false');
 338     if (WIFEXITED($status) and WEXITSTATUS($status) == 0) {
 339         return 1;
 340     } else {
 341         return 0;
 342     }
 343 }
 344
 345 sub kill_spam {
 346     my @msglist = @_;
 347     my @result;
 348     my $msg;
 349
 350     @result = ();
 351
 352     foreach $msg (@msglist) {
 353         if (is_spam($msg)) {
 354             store_message($msg, 'SPAM');
 355         } else {
 356             push(@result, $msg);
 357         }
 358     }
 359
 360     return @result;
 361 }
 362
 363 \f
 364 ###############################################################################
 365 # Filtering
 366
 367 sub find_mh_folder {
 368     my $msg = shift;
 369     my %headers;
 370     my $header;
 371     my $contents;
 372     my $regex;
 373     my $subst;
 374     my $try;
 375
 376     %headers = get_headers($msg);
 377
 378     log_headers(%headers);
 379
 380     foreach $header (keys(%FILTERS)) {
 381         $contents = $headers{$header};
 382
 383         if (defined($contents)) {
 384             foreach $regex (keys(%{$FILTERS{$header}})) {
 385                 $subst = $FILTERS{$header}->{$regex};
 386
 387                 $try = '$contents =~';
 388                 $try .= " s|$regex|$subst|is";
 389                 if (eval $try) {
 390                     return $contents;
 391                 }
 392             }
 393         }
 394     }
 395
 396     return 'inbox';
 397 }
 398
 399 sub filter_mail {
 400     my @msglist = @_;
 401     my $msg;
 402     my $mhfolder;
 403
 404     foreach $msg (@msglist) {
 405         $mhfolder = find_mh_folder($msg);
 406         store_message($msg, $mhfolder);
 407     }
 408 }
 409
 410 \f
 411 MAIN: {
 412     my @msglist;
 413
 414     if ($dumpfilters) {
 415         $Data::Dumper::Indent = 1;
 416         print(Dumper(\%FILTERS));
 417         exit(&EX_OK);
 418     }
 419
 420     @msglist = kill_spam(glob("$MAILDIR/new/*"));
 421     filter_mail(@msglist);
 422 }
 423
 424 __END__
 425
 426 =head1 EXAMPLES
 427
 428 %FILTERS =
 429   ('List-Id:'=>
 430    {'.*<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>.*'=>'l/$1/$2',
 431     '.*<([[:graph:]]+?)(-list)?\.freedesktop\.org>.*'=>'l/freedesktop/$1',
 432     '.*<swig\.cs\.uchicago\.edu>.*'=>'l/swig'},
 433
 434    'List-Post:'=>
 435    {'<mailto:([[:graph:]]+)+@([[:graph:]]+)\.apache\.org>'=>'l/apache/$2/$1'},
 436
 437    'To:'=>
 438    {'root'=>'root'});
 439
 440 The first List-Id filter is a surprisingly effective one which creates
 441 appropriate folder names (such as l/htdig/updates and l/rox/devel) for
 442 all Sourceforge lists to which i subscribe.  Certainly there are lists
 443 hosted at Sourceforge which do not work well with this, and this is
 444 where it is important to remember that the first match is the one
 445 uses.  Simply put the more specific rules before this one.
 446
 447 The next List-Id example is simple.  The swig example demonstrates
 448 that the folder name does not have to use a portion of the matched
 449 header; you can just hardcode the folder name.
 450
 451 The List-Post example is a nice one.  Most ASF projects have their own
 452 apache.org subdomain, with mailing lists hosted there.  So, given a
 453 list such as dev@httpd.apache.org, this filter will create the folder
 454 name l/apache/httpd/dev.
 455
 456 =head1 AUTHORS
 457
 458 Written by Eric Gillespie <epg@pretzelnet.org> with logging code
 459 stolen from Adam Lazur <adam@lazur.org>.
 460
 461 Design by Eric Gillespie and Doug Porter <dsp@waterspout.com>.
 462
 463 =cut