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), optionally checks for spam with a user-defined
  18 spam-checking function, and optionally filters mail into separate mh
  19 folders.
  20
  21 The filtering is quite sophisticated, as it is done using real Perl
  22 matching (m//) commands.
  23
  24 =cut
  25
  26 use strict;
  27 use warnings;
  28
  29 require 'sysexits.ph';
  30
  31 use Data::Dumper;
  32 use Errno;
  33 use Fcntl qw(O_WRONLY O_EXCL O_CREAT);
  34 use File::Basename;
  35 use Getopt::Std;
  36 use Log::Dispatch;
  37 use Log::Dispatch::File;
  38 use POSIX qw(strftime WEXITSTATUS WIFEXITED);
  39
  40 # If a filter set's header is $MAGIC_TO_TOKEN, that set is compared
  41 # against headers matching this regex (taken from procmail).
  42 my $MAGIC_TO_REGEX = '^((Original-)?(Resent-)?(To|Cc|Bcc)|(X-Envelope |Apparently(-Resent)?)-To)';
  43 my $MAGIC_TO_TOKEN = ' TO';
  44
  45 =head1 OPTIONS
  46
  47 =over 4
  48
  49 =item B<-d>
  50
  51 Dump (using Data::Dumper) the FILTERS list and exit.  This is useful
  52 for testing the syntax of .mincfilter.
  53
  54 =item B<-f>
  55
  56 Filter only, then exit.  This is useful after running B<minc -s>.
  57
  58 =item B<-h>
  59
  60 Show help.
  61
  62 =item B<-n>
  63
  64 Dry run; do not actually incorporate the mail, but log and report to
  65 stdout/stderr as normal.
  66
  67 =item B<-s>
  68
  69 Process SPAM only, then exit, leaving all non-spam messages in the
  70 maildir.
  71
  72 =back
  73
  74 =cut
  75
  76 my $dumpfilters = 0;
  77 my $filteronly = 0;
  78 our $run = 1;
  79 my $spamonly = 0;
  80
  81 our $opt_d;
  82 our $opt_f;
  83 our $opt_h;
  84 our $opt_n;
  85 our $opt_s;                     # ;; # stupid cperl-mode
  86
  87 if (not getopts('dfhns')) {
  88     exit(&EX_USAGE);
  89 }
  90
  91 if ($opt_d) {
  92     $dumpfilters = 1;
  93 } elsif ($opt_h) {
  94     print("Sorry bub, no help.\n");
  95     exit(&EX_OK);
  96 } elsif ($opt_n) {
  97     $run = 0;
  98 }
  99
 100 if ($opt_f) {
 101     $filteronly = 1;
 102 } elsif ($opt_s) {              # ))){ # stupid cperl-mode
 103     $spamonly = 1;
 104 }
 105
 106 =head1 ENVIRONMENT
 107
 108 =over 4
 109
 110 =item HOME
 111
 112 Where configuration files (.mincfilter) are found.  Also,
 113 $HOME/Maildir is used for the maildir if MAILDIR is not set.
 114
 115 =item MAILDIR
 116
 117 Where mail is delivered.
 118
 119 =back
 120
 121 =cut
 122
 123 use Env qw(HOME MAILDIR);
 124
 125 if (not $HOME) {
 126     die("HOME environment variable must be set.\n");
 127 }
 128 if (not $MAILDIR) {
 129     $MAILDIR = "$HOME/Maildir";
 130 }
 131
 132 =head1 FILES
 133
 134 =over 4
 135
 136 =item $HOME/.mincfilter
 137
 138 This file is Perl code (included via the 'require' directive) which is
 139 expected to define the FILTERS list.
 140
 141 =item $HOME/.mincspam
 142
 143 If this file exists, B<minc> will include it with the expectation that it
 144 will define a B<is_spam> function.  This function takes a message
 145 filename as an argument and returns 1 if the message is spam, else 0.
 146 If this file does not exist, B<minc> will define a simple function that
 147 always returns 0.
 148
 149 One of B<minc>'s global variables is available to the user-defined
 150 is_spam function: $run.  This boolean should be honored; is_spam
 151 should only take real action (i.e. removing or creating files, running
 152 external programs, etc.) if $run is non-zero.
 153
 154 XXX: need more details about the spam-handling process; for now read
 155 the code.
 156
 157 =item `mhpath +`/logs/minc.log
 158
 159 Where B<minc> logs what it does, unless in -n mode.
 160
 161 =item `mhpath +`/logs/dryrun.log
 162
 163 Where B<minc> logs what it would do; used in -n mode.
 164
 165 =item `mhpath +`/.minc.context
 166
 167 B<minc> uses this file for context (i.e. current folder) instead of
 168 `mhpath +`/context.  This allows you some amount of freedom to use mh
 169 while B<minc> is running.  For example, you can changed folders without
 170 causing a message to be stored in the wrong folder.  Care must still
 171 be taken, however, about the unseen sequence; if you change it
 172 (whether via show, or mark, or anything else) while in the same folder
 173 as B<minc>, it is likely the new message B<minc> stores will not end up
 174 marked unseen.
 175
 176 =back
 177
 178 =cut
 179
 180 our @FILTERS;
 181 require "$HOME/.mincfilter2";
 182
 183 if (-f "$HOME/.mincspam") {
 184     require "$HOME/.mincspam";
 185 } else {
 186     sub is_spam {
 187         return 0;
 188     }
 189 }
 190
 191 my $mh;
 192 my $logfile;
 193
 194 $mh = `mhpath +`;
 195 chomp($mh);
 196
 197 if ($run) {
 198     $logfile = $mh . '/logs/minc.log';
 199 } else {
 200     $logfile = $mh . '/logs/dryrun.log';
 201 }
 202
 203 $ENV{"MHCONTEXT"} = $mh . '/.minc.context';
 204
 205 \f
 206 ###############################################################################
 207 # Logging
 208
 209 # debuglevels for the logger
 210 use constant LOG_DEBUGLEVEL     => 'info';
 211 use constant SCREEN_DEBUGLEVEL  => 'debug';
 212
 213 # characters used to wrap around the id field in the log so I can more
 214 # easily parse the msg flow
 215 use constant DEBUGCHAR          => '%';
 216 use constant INFOCHAR           => '=';
 217 use constant INCOMINGCHAR       => '<';
 218 use constant SAVECHAR           => '>';
 219 use constant WARNCHAR           => 'W';
 220 use constant ERRORCHAR          => 'E';
 221
 222 my $logger = new Log::Dispatch;
 223 $logger->add(new Log::Dispatch::File (name=>'logfile',
 224                                       filename=>$logfile,
 225                                       min_level=>'info',
 226                                       mode=>'append'));
 227
 228 # log alias, handles getting passed vars that are undef
 229 sub mylog {
 230     my $level = shift;
 231     my $act = shift;
 232     my $timestamp = strftime('%b %e %H:%M:%S', localtime);
 233     my $msg;
 234     foreach my $part (@_) {
 235         if (defined($part)) {
 236             $msg .= $part;
 237         }
 238     }
 239     # no newlines in the log message, thanks
 240     $msg =~ s/\n/ /gm;
 241     $msg = sprintf("%s %s%s %s\n", $timestamp, $act, $act, $msg);
 242     $logger->log(level=>$level, message=>$msg);
 243
 244     if ($act eq SAVECHAR) {
 245         $logger->log(level=>$level, message=>"\n");
 246     }
 247 }
 248
 249 sub logincoming { mylog('info', INCOMINGCHAR, @_); }
 250 sub logsave { mylog('notice', SAVECHAR, @_); }
 251 sub loginfo { mylog('info', INFOCHAR, @_); }
 252 sub logdebug { mylog('debug', DEBUGCHAR, @_); }
 253 sub logwarn { mylog('warning', WARNCHAR, @_); }
 254 sub logerr { mylog('error', ERRORCHAR, @_); }
 255
 256 sub log_headers {
 257     my %headers = @_;
 258
 259     # For an explanation of the %headers structure, see the
 260     # get_headers function below.
 261     logincoming('From:       ', @{$headers{'return-path'}}[-1]);
 262     logincoming('To:         ', @{$headers{'to'}}[-1]);
 263     logincoming('Subject:    ', @{$headers{'subject'}}[-1]);
 264     logincoming('Message-Id: ', @{$headers{'message-id'}}[-1]);
 265 }
 266
 267 \f
 268 ###############################################################################
 269 # Utility procedures
 270
 271 sub _errprint {
 272     printf(STDERR '%s:%s', __FILE__, __LINE__);
 273
 274     if (@_) {
 275         print(STDERR ': ');
 276         foreach (@_) {
 277             print(STDERR);
 278         }
 279     }
 280 }
 281
 282 sub err {
 283     my $ex = shift;
 284
 285     _errprint(@_);
 286     print(STDERR ": $!\n");
 287
 288     exit($ex);
 289 }
 290
 291 sub errx {
 292     my $ex = shift;
 293
 294     _errprint(@_);
 295     print(STDERR "\n");
 296
 297     exit($ex);
 298 }
 299
 300 sub mkfolder {
 301     my $mhfolder = shift;
 302     my $folder;
 303     my $target;
 304     my $component;
 305
 306     $folder = $mh . '/' . $mhfolder;
 307     $target = '';
 308
 309     if (not -d $folder) {
 310         foreach $component (split('/', $folder)) {
 311             if (defined($component) and length($component) >= 1) {
 312                 $target = $target . '/' . $component;
 313                 if (-d $target or mkdir($target)) {
 314                     next;
 315                 } else {
 316                     err(&EX_OSERR,
 317                         "Failed to create +$mhfolder ($component)");
 318                 }
 319             }
 320         }
 321     }
 322 }
 323
 324 sub getfiles {
 325     my $dir = shift;
 326     my @result;
 327
 328     if (not opendir(DIR, $dir)) {
 329         err(&EX_OSERR, "Failed opendir($dir)");
 330     }
 331
 332     # Initialize $! to 0 (success) because stupid stupid Perl provides
 333     # no way to distinguish an error from an empty directory; that
 334     # means setting $! to 0 and testing it afterwards is the only way
 335     # to detect an error.  Real Programmers don't handle errors,
 336     # right?  >sigh<
 337     $! = 0;
 338     @result = grep {
 339         ($_ ne '.' and $_ ne '..')
 340           and $_ = "$MAILDIR/new/$_"
 341       } readdir(DIR);
 342
 343     if ($! != 0) {
 344         err(&EX_OSERR, "Failed readdir($dir)");
 345     }
 346
 347     closedir(DIR);
 348
 349     return @result;
 350 }
 351
 352 sub get_highest_msgnum {
 353     my $mhfolder = shift;
 354     my $dir;
 355     my @list;
 356     my $highest;
 357     my $msgnum;
 358
 359     $dir = "$mh/$mhfolder";
 360     if (not opendir(DIR, $dir)) {
 361         err(&EX_OSERR, "Failed opendir($dir)");
 362     }
 363
 364     $! = 0;
 365     @list = readdir(DIR);
 366
 367     if ($! != 0) {
 368         err(&EX_OSERR, "Failed readdir($dir)");
 369     }
 370
 371     closedir(DIR);
 372
 373     $highest = 0;
 374     foreach $msgnum (@list) {
 375         # Look for integers.
 376         if ($msgnum =~ /^[0-9]+$/) {
 377             if ($msgnum > $highest) {
 378                 $highest = $msgnum;
 379             }
 380         }
 381     }
 382
 383     return $highest;
 384 }
 385
 386 # We want to print the name of each list that has new mail only once,
 387 # so use this hash to store the lists that have already been printed.
 388 # Start the list out with SPAM already in it, since we don't care when
 389 # new messages are added to it.
 390 my %FOLDERS = ('SPAM'=>1);
 391
 392 sub store_message {
 393     my $msg = shift;
 394     my $mhfolder = shift;
 395     my $msgnum;
 396     my $try;
 397     my $mhmsg;
 398     my $status;
 399
 400     # We must do this even in -n mode because later steps fail without
 401     # it.  This should be harmless.
 402     mkfolder($mhfolder);
 403
 404     # This loop is a modified version of the maildir delivery algorithm.
 405     $msgnum = get_highest_msgnum($mhfolder);
 406     for ($try = 0; ; $try++) {
 407         $msgnum++;
 408         $mhmsg = "$mh/$mhfolder/$msgnum";
 409
 410         if (not stat($mhmsg)) {
 411             if ($!{ENOENT}) {
 412                 # Now we have a non-existent file, let's try to create
 413                 # it.  We must create a zero-byte file first because a
 414                 # file my appear between our happy stat results and
 415                 # our later rename(2), which would clobber said file.
 416                 # So attempt to create a file with this name.  If it
 417                 # succeeds, in just a bit here we'll knowingly clobber
 418                 # this file with the rename(2) call.
 419                 if ($run) {
 420                     if (sysopen(MSG, "$mhmsg",
 421                                 O_WRONLY | O_EXCL | O_CREAT, 0600)) {
 422                         close(MSG);
 423                         last;
 424                     }
 425                 } else {
 426                     last;
 427                 }
 428             }
 429         }
 430
 431         # This algorithm is different from the maildir one; let's make
 432         # 10 tries instead of 3.
 433         if ($try == 9) {
 434             errx(&EX_TEMPFAIL, "Attempted filename $mhmsg exists.");
 435         }
 436
 437         # This algorithm is different; i don't think we need to sleep.
 438         #sleep(2);
 439     }
 440
 441     logsave("+$mhfolder");
 442
 443     if ($run) {
 444         if (not rename($msg, $mhmsg)) {
 445             err(&EX_OSERR, "Failed rename($msg, $mhmsg)");
 446         }
 447
 448         # Mark each message as soon as we store it and bomb if that
 449         # fails.  While it is slow, it is not safe to store multiple
 450         # messages and then have a failure before marking some (or
 451         # all).
 452         if ($mhfolder ne 'SPAM') {
 453             $status = system('mark', "+$mhfolder", "$msgnum", '-sequence',
 454                              'unseen', '-add');
 455             if (not WIFEXITED($status)) {
 456                 err(&EX_OSERR, "Failed to run mark");
 457             } elsif (WEXITSTATUS($status) != 0) {
 458                 errx(&EX_SOFTWARE, "Failed to mark message unseen.");
 459             }
 460         }
 461     }
 462
 463     if (not $FOLDERS{$mhfolder}) {
 464         print("+$mhfolder\n");
 465         $FOLDERS{$mhfolder} = 1;
 466     }
 467 }
 468
 469 # Parse a message file into a structure describing the headers.  The
 470 # structure is a hash of arrays.  The hash keys are the names of the
 471 # headers found in the message, made all lower-case.  Each item in
 472 # the hash is an array of header text.  The array has one element
 473 # per occurrence of the header.  Most headers will only have a single
 474 # element because they occur only once.  The Received header is the
 475 # most common header with multiple texts.
 476 sub get_headers {
 477     my $msg = shift;
 478     my %headers;
 479     my $current;                # current header, used for unfolding lines
 480     my $fieldname;              # unmolested header name
 481     my $contents;               # contents of header
 482
 483     open(MSG, $msg);
 484     while (<MSG>) {
 485         chomp;
 486         if (length == 0) {
 487             last;
 488         }
 489
 490         if (/^\s/) {
 491             # folded header continuation
 492
 493             if (not defined($current)) {
 494                 print(STDERR "Malformed message, cannot parse headers.\n");
 495                 return ();
 496             }
 497
 498             @{$headers{$current}}[-1] .= $_;
 499         } else {
 500             ($fieldname) = split(/:/);
 501             $current = lc($fieldname);
 502             (undef, $contents) = split(/^\Q$fieldname\E:\s*/);
 503
 504             if (defined($headers{$current})) {
 505                 # multiple occurence of same header
 506                 push(@{$headers{$current}}, $contents);
 507             } else {
 508                 # first occurence of a header
 509                 $headers{$current} = [$contents];
 510             }
 511         }
 512     }
 513     close(MSG);
 514
 515     return %headers;
 516 }
 517
 518 ###############################################################################
 519 # Spam handling
 520
 521 sub kill_spam {
 522     my @msglist = @_;
 523     my @result;
 524     my $msg;
 525     my $i;
 526
 527     @result = ();
 528
 529     $i = 0;
 530     foreach $msg (@msglist) {
 531         printf('%sChecking for spam... %6d/%d',
 532                "\r", ++$i, scalar(@msglist));
 533         if (is_spam($msg)) {
 534             print(" SPAM\n");
 535             store_message($msg, 'SPAM');
 536         } else {
 537             push(@result, $msg);
 538         }
 539     }
 540     print("\nDone: ", scalar(@result), " survivors\n");
 541
 542     return @result;
 543 }
 544
 545 \f
 546 ###############################################################################
 547 # Filtering
 548
 549 sub find_mh_folder {
 550     my $msg = shift;
 551     my %headers;
 552     my $filterref;
 553     my @filter;
 554     my $header;
 555     my $contents;
 556     my $pair;
 557     my $match;
 558     my $expression;
 559     my $result;
 560
 561     %headers = get_headers($msg);
 562     if (not %headers) {
 563         return 'malformed';
 564     }
 565
 566     log_headers(%headers);
 567
 568     # Walk the list of filters.  This structure is documented in
 569     # pod at the end of the program.
 570     foreach $filterref (@FILTERS) {
 571         @filter = @$filterref;
 572         $header = shift(@filter);
 573
 574         # Handle filters using the magic TO header specially.
 575         if ($header eq $MAGIC_TO_TOKEN) {
 576             foreach $header (keys(%headers)) {
 577                 if ($header =~ /$MAGIC_TO_REGEX/i) {
 578                     foreach $contents (@{$headers{lc($header)}}) {
 579                         foreach $pair (@filter) {
 580                             ($match, $expression) = @$pair;
 581                             if ($contents =~ /$match/) {
 582                                 return $expression;
 583                             }
 584                         }
 585                     }
 586                 }
 587             }
 588
 589             # Now that it's been processed specially, skip normal handling.
 590             next;
 591         }
 592
 593         # Walk the list of message headers matching the filter's
 594         # specified header.
 595         foreach $contents (@{$headers{lc($header)}}) {
 596             # Walk the filter's list of match/expression pairs.
 597             foreach $pair (@filter) {
 598                 ($match, $expression) = @$pair;
 599                 if ($contents =~ /$match/) {
 600                     if (eval "\$result = \"$expression\"") {
 601                         return $result;
 602                     }
 603                 }
 604             }
 605         }
 606     }
 607
 608     return 'inbox';
 609 }
 610
 611 sub filter_mail {
 612     my @msglist = @_;
 613     my $msg;
 614     my $mhfolder;
 615
 616     foreach $msg (@msglist) {
 617         $mhfolder = find_mh_folder($msg);
 618         store_message($msg, $mhfolder);
 619     }
 620 }
 621
 622 \f
 623 MAIN: {
 624     my @msglist;
 625
 626     if ($dumpfilters) {
 627         $Data::Dumper::Indent = 1;
 628         print(Dumper(\@FILTERS));
 629         exit(&EX_OK);
 630     }
 631
 632     @msglist = getfiles("$MAILDIR/new");
 633
 634     if (not $filteronly) {
 635         @msglist = kill_spam(@msglist);
 636     }
 637
 638     if (not $spamonly) {
 639         filter_mail(@msglist);
 640     }
 641 }
 642
 643 \f
 644 __END__
 645
 646 =head1 THE FILTERS STRUCTURE
 647
 648 The user's .mincfilter file must define the @FILTERS structure.  This
 649 structure is an array.  Each element of @FILTERS is a filter.  A
 650 filter is itself an array.  The first element of a filter is a string,
 651 the name of the header this filter acts upon.  The header name is not
 652 case-sensitive.  Each subsequent element of a filter is a pair (i.e. a
 653 two-element array): first, a regular expression B<minc> uses to
 654 determine whether this filter matches or not, and second, an
 655 expression which B<minc> evaluates to get the folder name.
 656
 657 B<minc> decides where to store a message by iterating over the
 658 @FILTERS array.  It tests each regexp of each filter against all
 659 headers matching that filter's specified header.  As soon as a match
 660 is found, B<minc> evaluates the second part of the pair.  This part
 661 may contain positional parameters from the matched regexp ($1, $2,
 662 etc.).  The result of this expression is used as the folder name.
 663
 664 Multiple occurrences of the same header are preserved and tested
 665 individually against the filters.  That means, for example, that
 666 filters can search all the Received headers for a certain string.
 667
 668 It is important to note that all the arrays of the @FILTERS structure
 669 are traversed I<in order>.  This means the filters can be arranged so
 670 that some have priority over others.  XXX: get Doug to write an
 671 example of having the same header matched more than once.
 672
 673 Lastly, B<minc> supports a magic ' TO' header.  Filters using this
 674 header are matched against a collection of headers related to (and
 675 including) the To.  Which headers to use is determined by a regular
 676 expression borrowed from procmail.
 677
 678 =head1 EXAMPLES
 679
 680 @FILTERS = (
 681
 682   ['List-Id',
 683    ['<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>', 'l/$1/$2'],
 684    ['<([[:graph:]]+?)(-list)?\.freedesktop\.org>', 'l/freedesktop/$1'],
 685    ['<swig\.cs\.uchicago\.edu>', 'l/swig'],
 686   ],
 687
 688   ['List-Post',
 689    ['<mailto:([[:graph:]]+)+@([[:graph:]]+)\.apache\.org>', 'l/apache/$2/$1'],
 690   ],
 691
 692   ['To',
 693    ['root', 'root'],
 694   ],
 695 );
 696
 697 The first List-Id filter is a surprisingly effective one which creates
 698 appropriate folder names (such as l/htdig/updates and l/rox/devel) for
 699 all Sourceforge lists to which i subscribe.  Certainly there are lists
 700 hosted at Sourceforge which do not work well with this, and this is
 701 where it is important to remember that the first match is the one
 702 uses.  Simply put the more specific rules before this one.
 703
 704 The next List-Id example is simple.  The swig example demonstrates
 705 that the folder name does not have to use a portion of the matched
 706 header; you can just hardcode the folder name.
 707
 708 The List-Post example is a nice one.  Most ASF projects have their own
 709 apache.org subdomain, with mailing lists hosted there.  So, given a
 710 list such as dev@httpd.apache.org, this filter will create the folder
 711 name l/apache/httpd/dev.
 712
 713 For an example is_spam function, see
 714 L<http:E<047>E<047>pretzelnet.orgE<047>cvsE<047>dotfilesE<047>.mincspam>
 715
 716 =head1 AUTHORS
 717
 718 Written by Eric Gillespie <epg@pretzelnet.org> with logging code
 719 stolen from Adam Lazur <adam@lazur.org>.
 720
 721 Design by Eric Gillespie and Doug Porter <dsp@waterspout.com>.
 722
 723 =cut
 724
 725 # Local variables:
 726 # cperl-indent-level: 4
 727 # perl-indent-level: 4
 728 # indent-tabs-mode: nil
 729 # End:
 730
 731 # vi: set tabstop=4 expandtab: