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
  18 (http://razor.sourceforge.net/), and optionally filters mail into
  19 separate mh folders.
  20
  21 The filtering is quite sophisticated, as it is done using real Perl
  22 substitution (s//) 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 =head1 OPTIONS
  41
  42 =over 4
  43
  44 =item B<-d>
  45
  46 Dump (using Data::Dumper) the FILTERS hash and exit.  This is useful
  47 for testing the syntax of .mincfilter.
  48
  49 =item B<-h>
  50
  51 Show help.
  52
  53 =item B<-n>
  54
  55 Dry run; do not actually incorporate the mail, but log and report to
  56 stdout/stderr as normal.
  57
  58 =item B<-s>
  59
  60 Process SPAM only, then exit, leaving all non-spam messages in the
  61 maildir.
  62
  63 =back
  64
  65 =cut
  66
  67 my $dumpfilters = 0;
  68 my $run = 1;
  69 my $spamonly = 0;
  70
  71 our $opt_d;
  72 our $opt_h;
  73 our $opt_n;
  74 our $opt_s;                     # ;; # stupid cperl-mode
  75
  76 if (not getopts('dhns')) {
  77     exit(&EX_USAGE);
  78 }
  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 if ($opt_s) {                   # ))){ # stupid cperl-mode
  90     $spamonly = 1;
  91 }
  92
  93 =head1 ENVIRONMENT
  94
  95 =over 4
  96
  97 =item HOME
  98
  99 Where configuration files (.mincfilter) are found.  Also,
 100 $HOME/Maildir is used for the maildir if MAILDIR is not set.
 101
 102 =item MAILDIR
 103
 104 Where mail is delivered.
 105
 106 =back
 107
 108 =cut
 109
 110 use Env qw(HOME MAILDIR);
 111
 112 if (not $HOME) {
 113     die("HOME environment variable must be set.\n");
 114 }
 115 if (not $MAILDIR) {
 116     $MAILDIR = "$HOME/Maildir";
 117 }
 118
 119 =head1 FILES
 120
 121 =over 4
 122
 123 =item $HOME/.mincfilter
 124
 125 This file is Perl code (included via the 'require' directive) which is
 126 expected to define the FILTERS hash.
 127
 128 =item `mhpath +`/logs/minc.log
 129
 130 Where minc logs what it does, unless in -n mode.
 131
 132 =item `mhpath +`/logs/dryrun.log
 133
 134 Where minc logs what it would do; used in -n mode.
 135
 136 =cut
 137
 138 our %FILTERS;
 139 require "$HOME/.mincfilter";
 140
 141 my $mh;
 142 my $logfile;
 143
 144 $mh = `mhpath +`;
 145 chomp($mh);
 146
 147 if ($run) {
 148     $logfile = $mh . '/logs/minc.log';
 149 } else {
 150     $logfile = $mh . '/logs/dryrun.log';
 151 }
 152
 153 \f
 154 ###############################################################################
 155 # Logging
 156
 157 # debuglevels for the logger
 158 use constant LOG_DEBUGLEVEL     => 'info';
 159 use constant SCREEN_DEBUGLEVEL  => 'debug';
 160
 161 # characters used to wrap around the id field in the log so I can more
 162 # easily parse the msg flow
 163 use constant DEBUGCHAR          => '%';
 164 use constant INFOCHAR           => '=';
 165 use constant INCOMINGCHAR       => '<';
 166 use constant SAVECHAR           => '>';
 167 use constant WARNCHAR           => 'W';
 168 use constant ERRORCHAR          => 'E';
 169
 170 my $logger = new Log::Dispatch;
 171 $logger->add(new Log::Dispatch::File (name=>'logfile',
 172                                       filename=>$logfile,
 173                                       min_level=>'info',
 174                                       mode=>'append'));
 175
 176 # log alias, handles getting passed vars that are undef
 177 sub mylog {
 178     my $level = shift;
 179     my $act = shift;
 180     my $timestamp = strftime('%b %e %H:%M:%S', localtime);
 181     my $msg;
 182     foreach my $part (@_) {
 183         if (defined($part)) {
 184             $msg .= $part;
 185         }
 186     }
 187     # no newlines in the log message, thanks
 188     $msg =~ s/\n/ /gm;
 189     $msg = sprintf("%s %s%s %s\n", $timestamp, $act, $act, $msg);
 190     $logger->log(level=>$level, message=>$msg);
 191
 192     if ($act eq SAVECHAR) {
 193         $logger->log(level=>$level, message=>"\n");
 194     }
 195 }
 196
 197 sub logincoming { mylog('info', INCOMINGCHAR, @_); }
 198 sub logsave { mylog('notice', SAVECHAR, @_); }
 199 sub loginfo { mylog('info', INFOCHAR, @_); }
 200 sub logdebug { mylog('debug', DEBUGCHAR, @_); }
 201 sub logwarn { mylog('warning', WARNCHAR, @_); }
 202 sub logerr { mylog('error', ERRORCHAR, @_); }
 203
 204 sub log_headers {
 205     my %headers = @_;
 206
 207     logincoming('From:       ', $headers{'return-path'});
 208     logincoming('To:         ', $headers{'to'});
 209     logincoming('Subject:    ', $headers{'subject'});
 210     logincoming('Message-Id: ', $headers{'message-id'});
 211 }
 212
 213 \f
 214 ###############################################################################
 215 # Utility procedures
 216
 217 sub _errprint {
 218     printf('%s:%s', __FILE__, __LINE__);
 219
 220     if (@_) {
 221         print(': ');
 222         foreach (@_) {
 223             print;
 224         }
 225     }
 226 }
 227
 228 sub err {
 229     my $ex = shift;
 230
 231     _errprint(@_);
 232     print(": $!\n");
 233
 234     exit($ex);
 235 }
 236
 237 sub errx {
 238     my $ex = shift;
 239
 240     _errprint(@_);
 241     print("\n");
 242
 243     exit($ex);
 244 }
 245
 246 sub mkfolder {
 247     my $mhfolder = shift;
 248     my $folder;
 249     my $target;
 250     my $component;
 251
 252     $folder = $mh . '/' . $mhfolder;
 253     $target = '';
 254
 255     if (not -d $folder) {
 256         foreach $component (split('/', $folder)) {
 257             if (defined($component) and length($component) >= 1) {
 258                 $target = $target . '/' . $component;
 259                 if (-d $target or mkdir($target)) {
 260                     next;
 261                 } else {
 262                     err(&EX_TEMPFAIL,
 263                         "Failed to create +$mhfolder ($component)");
 264                 }
 265             }
 266         }
 267     }
 268 }
 269
 270 sub getfiles {
 271     my $dir = shift;
 272     my @result;
 273
 274     if (not opendir(DIR, $dir)) {
 275         err(&EX_TEMPFAIL, "Failed opendir($dir)");
 276     }
 277
 278     # Initialize $! to 0 (success) because stupid stupid Perl provides
 279     # no way to distinguish an error from an empty directory; that
 280     # means setting $! to 0 and testing it afterwards is the only way
 281     # to detect an error.  Real Programmers don't handle errors,
 282     # right?  >sigh<
 283     $! = 0;
 284     @result = grep {
 285         ($_ ne '.' and $_ ne '..')
 286           and $_ = "$MAILDIR/new/$_"
 287       } readdir(DIR);
 288
 289     if ($! != 0) {
 290         err(&EX_TEMPFAIL, "Failed readdir($dir)");
 291     }
 292
 293     closedir(DIR);
 294
 295     return @result;
 296 }
 297
 298 sub get_highest_msgnum {
 299     my $mhfolder = shift;
 300     my $dir;
 301     my @list;
 302     my $highest;
 303     my $msgnum;
 304
 305     $dir = "$mh/$mhfolder";
 306     if (not opendir(DIR, $dir)) {
 307         err(&EX_TEMPFAIL, "Failed opendir($dir)");
 308     }
 309
 310     $! = 0;
 311     @list = readdir(DIR);
 312
 313     if ($! != 0) {
 314         err(&EX_TEMPFAIL, "Failed readdir($dir)");
 315     }
 316
 317     closedir(DIR);
 318
 319     $highest = 0;
 320     foreach $msgnum (@list) {
 321         # Look for integers.
 322         if ($msgnum =~ /^[0-9]+$/) {
 323             if ($msgnum > $highest) {
 324                 $highest = $msgnum;
 325             }
 326         }
 327     }
 328
 329     return $highest;
 330 }
 331
 332 # We want to print the name of each list that has new mail only once,
 333 # so use this hash to store the lists that have already been printed.
 334 # Start the list out with SPAM already in it, since we don't care when
 335 # new messages are added to it.
 336 my %FOLDERS = ('SPAM'=>1);
 337
 338 sub store_message {
 339     my $msg = shift;
 340     my $mhfolder = shift;
 341     my $msgnum;
 342     my $try;
 343     my $mhmsg;
 344     my $status;
 345
 346     # We must do this even in -n mode because later steps fail without
 347     # it.  This should be harmless.
 348     mkfolder($mhfolder);
 349
 350     $msgnum = get_highest_msgnum($mhfolder);
 351     for ($try = 0; ; $try++) {
 352         $msgnum++;
 353         $mhmsg = "$mh/$mhfolder/$msgnum";
 354
 355         if (not stat($mhmsg)) {
 356             if ($!{ENOENT}) {
 357                 # Now we have a non-existent file, let's try to create
 358                 # it.  We must create a zero-byte file first because a
 359                 # file my appear between our happy stat results and
 360                 # our later rename(2), which would clobber said file.
 361                 # So attempt to create a file with this name.  If it
 362                 # succeeds, in just a bit here we'll knowingly clobber
 363                 # this file with the rename(2) call.
 364                 if ($run) {
 365                     if (sysopen(MSG, "$mhmsg",
 366                                 O_WRONLY | O_EXCL | O_CREAT, 0600)) {
 367                         close(MSG);
 368                         last;
 369                     }
 370                 } else {
 371                     last;
 372                 }
 373             }
 374         }
 375
 376         # This algorithm is different from the maildir one; let's make
 377         # 10 tries instead of 3.
 378         if ($try == 9) {
 379             errx(&EX_TEMPFAIL, "Attempted filename $mhmsg exists.");
 380         }
 381
 382         # This algorithm is different; i don't think we need to sleep.
 383         #sleep(2);
 384     }
 385
 386     logsave("+$mhfolder");
 387
 388     if ($run) {
 389         if (not rename($msg, $mhmsg)) {
 390             err(&EX_TEMPFAIL, "Failed rename($msg, $mhmsg)");
 391         }
 392
 393         # Mark each message as soon as we store it and bomb if that
 394         # fails.  While it is slow, it is not safe to store multiple
 395         # messages and then have a failure before marking some (or
 396         # all).
 397         if ($mhfolder ne 'SPAM') {
 398             $status = system("mark +$mhfolder $msgnum -sequence unseen -add");
 399             if (not (WIFEXITED($status) and WEXITSTATUS($status) == 0)) {
 400                 errx(&EX_TEMPFAIL, "Failed to mark message unseen");
 401             }
 402         }
 403     }
 404
 405     if (not $FOLDERS{$mhfolder}) {
 406         print("+$mhfolder\n");
 407         $FOLDERS{$mhfolder} = 1;
 408     }
 409 }
 410
 411 sub get_headers {
 412     my $msg = shift;
 413     my %headers;
 414     my $current;                # current header, used for unfolding lines
 415     my $fieldname;              # unmolested header name
 416
 417     open(MSG, $msg);
 418     while (<MSG>) {
 419         chomp;
 420         if (length == 0) {
 421             last;
 422         }
 423
 424         if (/^\s/) {
 425             # folded header continuation
 426
 427             if (not defined($current)) {
 428                 print("Malformed message, cannot parse headers.\n");
 429                 return ();
 430             }
 431
 432             $headers{$current} .= $_;
 433         } else {
 434             ($fieldname) = split(/:/);
 435             $current = lc($fieldname);
 436             (undef, $headers{$current}) = split(/^$fieldname:\s*/);
 437         }
 438     }
 439     close(MSG);
 440
 441     return %headers;
 442 }
 443
 444 \f
 445 ###############################################################################
 446 # Spam handling
 447
 448 sub is_spam {
 449     my $msg = shift;
 450     my $err;
 451     my $sig;
 452     my $line;
 453     my $message;
 454     my $status;
 455
 456     $err = $sig = $msg;
 457     $err =~ s|/new/|/err/|;
 458     $sig =~ s|/new/|/sig/|;
 459     if (-f $err) {
 460         open(ERR, $err);
 461         $line = <ERR>;
 462         close(ERR);
 463
 464         chomp($line);
 465         ($message, $!) = split(/:/, $line);
 466
 467         logerr("$err: $message: $!");
 468
 469         if ($run) {
 470             if (unlink($err) != 1) {
 471                 err(&EX_TEMPFAIL, "Failed unlink($err)");
 472             }
 473         }
 474     } elsif (-f $sig) {
 475         # This is supposed to be a signature created with razor-check
 476         # directly after delivery.  Currently this isn't supported
 477         # because it isn't clear to me how to get that signature back
 478         # into razor-check.  For now, just unlink any sig files we
 479         # find and proceed with full razor-check mode.
 480
 481         if ($run) {
 482             if (unlink($sig) != 1) {
 483                 err(&EX_TEMPFAIL, "Failed unlink($sig)");
 484             }
 485         }
 486     }
 487
 488     if ($run) {
 489         $status = system("razor-check < $msg");
 490         if (not WIFEXITED($status)) {
 491             err(&EX_TEMPFAIL, "Failed to run razor-check < $msg");
 492         } elsif (WEXITSTATUS($status) == 0) {
 493             return 1;
 494         } else {
 495             return 0;
 496         }
 497     } else {
 498         return 0;
 499     }
 500 }
 501
 502 sub kill_spam {
 503     my @msglist = @_;
 504     my @result;
 505     my $msg;
 506     my $i;
 507
 508     @result = ();
 509
 510     $i = 0;
 511     foreach $msg (@msglist) {
 512         printf('%sChecking for spam... %6d/%d',
 513                "\r", ++$i, scalar(@msglist));
 514         if (is_spam($msg)) {
 515             print(" SPAM\n");
 516             store_message($msg, 'SPAM');
 517         } else {
 518             push(@result, $msg);
 519         }
 520     }
 521     print("\nDone: ", scalar(@result), " survivors\n");
 522
 523     return @result;
 524 }
 525
 526 \f
 527 ###############################################################################
 528 # Filtering
 529
 530 sub find_mh_folder {
 531     my $msg = shift;
 532     my %headers;
 533     my $header;
 534     my $contents;
 535     my $regex;
 536     my $subst;
 537     my $try;
 538
 539     %headers = get_headers($msg);
 540     if (not %headers) {
 541         return 'inbox';
 542     }
 543
 544     log_headers(%headers);
 545
 546     foreach $header (keys(%FILTERS)) {
 547         $contents = $headers{lc($header)};
 548
 549         if (defined($contents)) {
 550             foreach $regex (keys(%{$FILTERS{$header}})) {
 551                 $subst = $FILTERS{$header}->{$regex};
 552
 553                 $try = '$contents =~';
 554                 $try .= " s|$regex|$subst|is";
 555                 if (eval $try) {
 556                     return $contents;
 557                 }
 558             }
 559         }
 560     }
 561
 562     return 'inbox';
 563 }
 564
 565 sub filter_mail {
 566     my @msglist = @_;
 567     my $msg;
 568     my $mhfolder;
 569
 570     foreach $msg (@msglist) {
 571         $mhfolder = find_mh_folder($msg);
 572         store_message($msg, $mhfolder);
 573     }
 574 }
 575
 576 \f
 577 MAIN: {
 578     my @msglist;
 579
 580     if ($dumpfilters) {
 581         $Data::Dumper::Indent = 1;
 582         print(Dumper(\%FILTERS));
 583         exit(&EX_OK);
 584     }
 585
 586     @msglist = kill_spam(getfiles("$MAILDIR/new"));
 587
 588     if (not $spamonly) {
 589         filter_mail(@msglist);
 590     }
 591 }
 592
 593 __END__
 594
 595 =head1 EXAMPLES
 596
 597 %FILTERS =
 598   ('List-Id:'=>
 599    {'.*<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>.*'=>'l/$1/$2',
 600     '.*<([[:graph:]]+?)(-list)?\.freedesktop\.org>.*'=>'l/freedesktop/$1',
 601     '.*<swig\.cs\.uchicago\.edu>.*'=>'l/swig'},
 602
 603    'List-Post:'=>
 604    {'<mailto:([[:graph:]]+)+@([[:graph:]]+)\.apache\.org>'=>'l/apache/$2/$1'},
 605
 606    'To:'=>
 607    {'root'=>'root'});
 608
 609 The first List-Id filter is a surprisingly effective one which creates
 610 appropriate folder names (such as l/htdig/updates and l/rox/devel) for
 611 all Sourceforge lists to which i subscribe.  Certainly there are lists
 612 hosted at Sourceforge which do not work well with this, and this is
 613 where it is important to remember that the first match is the one
 614 uses.  Simply put the more specific rules before this one.
 615
 616 The next List-Id example is simple.  The swig example demonstrates
 617 that the folder name does not have to use a portion of the matched
 618 header; you can just hardcode the folder name.
 619
 620 The List-Post example is a nice one.  Most ASF projects have their own
 621 apache.org subdomain, with mailing lists hosted there.  So, given a
 622 list such as dev@httpd.apache.org, this filter will create the folder
 623 name l/apache/httpd/dev.
 624
 625 =head1 AUTHORS
 626
 627 Written by Eric Gillespie <epg@pretzelnet.org> with logging code
 628 stolen from Adam Lazur <adam@lazur.org>.
 629
 630 Design by Eric Gillespie and Doug Porter <dsp@waterspout.com>.
 631
 632 =cut