#! /usr/bin/perl # (C) Copyright 1993 Rahul Dhesi, All Rights Reserved # (C) Copyright 1994 Rahul Dhesi, All Rights Reserved # ... except that permission is granted for copying and creation # of derivative works under the same conditions as perl. # # This script is offered "as is", though it appears to work under SunOS 4.1 # and SunOS 4.1.1, with sendmail-5.65c+IDA-1.4.4.1. # $Header: /local/undoc/RCS/qmail,v 1.34 1995/01/07 11:26:37 dhesi Exp $ # Scan sendmail queue, looking for any clogging. We define clogging as # the situation such that more than $LIMIT messages are queued for the # same destination host. For each destination host that is clogged, we # move its queue files into an auxiliary queue that will be processed at # longer intervals. Thus, if a remote host is down, messages queued for # it will get moved out of the default queue, thus avoiding slowing down # of mail processing. The auxilliary queue can be processed at larger # intervals by a separate sendmail process. This has been very useful # at the a2i network, allowing a high volume of mail destined for # unreliable hosts (including hosts belonging to our competitors :-) # to be effectively handled. # # Since you now have a second mail queue in a nonstandard location, you # will need to provide your users with an alternative to 'mailq' to list # the contents of the auxiliary queue. Else they might believe that # their outgoing messages have been sent, even though they were simply # moved to the auxiliary queue. Providing such a command is left as # an exercise for the reader. # # Rahul Dhesi # Don't forget to process the auxilliary queue at intervals from root's # crontab, e.g.: # # 20 4,10,16,22 * * * test -d /usr/spool/bigqueue && \ # /usr/lib/sendmail -oT3d -oQ/usr/spool/bigqueue -q >/dev/null 2>&1 # The mail queue is scanned by invoking "mailq" as a subprocess. Its output, # after skipping header lines, will be in the following format. If your # version of sendmail (mailq) prints queue entries in a different format, # you will need to modify this script. # AA10549 247 Wed Feb 24 00:58 plugh!jim # (Deferred: Connection timed out during user open with bad.hos) # kim@bad.host.in.edu $myname = "qmail"; # CONFIGURATION SECTION # program to invoke to print the sendmail queue $mailq = "mailq"; # or 'sendmail -bp' # Normal sendmail queue location. Default, may be changed with -S. $dir_mqueue = "/etc/mqueue.5.67a"; # alternative queue -- this is the queue to which we move messages # Default, may be changed with -D. $dir_bigqueue = "/i/bigqueue"; # if there are more than $LIMIT messages queued for a host, all # messages queued for that host will be moved from $dir_mqueue to # $dir_bigqueue. $LIMIT = 4; # END OF CONFIGURATION SECTION $LOCK_EX = 2; # exclusive flock $LOCK_NB = 4; # nonblocking flock require "getopts.pl"; &Getopts("xvtyl:hD:S:p:e:"); if ($opt_S) { $dir_mqueue = $opt_S; $mailq = "/usr/lib/sendmail -bp -oQ$opt_S"; } if ($opt_D) { $dir_bigqueue = $opt_D; } $EXCLUDE = $opt_e; if ($opt_h) { print < 0) { if (! -d $dir_bigqueue && ! $trace) { mkdir($dir_bigqueue, 0666); chmod(0755, $dir_bigqueue); } $verbose && print "MOVING $count messages\n"; $verbose = 0; # don't show all the renames and unlinks &moveq(); # move into slow queue } else { ## if (! $trace) { ## rmdir($dir_bigqueue); # delete dir -- maybe empty ## } } sub getcounts { open(Q, "$mailq|") || die "$myname: can't read mail queue: $!\n"; while () { # if not already in a list of destinations, look for a new queue id if (! (/^\s/ && $indestlist)) { /^(\w\w\d\d\d\d\d)(.)/ || next; # look for queue id (line 1) ($2 eq '*') && next; # message being processed -- skip it /\(no control file\)/ && next; # message being processed -- skip it $id = $1; # get queue id, e.g. "AA10549" $debug && print ">> $_"; $errmsg = ; # error line (line 2) if ($LIMIT > 0 && $errmsg !~ /^\s*\(/) { # if no left paren is not error line) next; } $debug && print ">> $errmsg"; $dest = ; # destination address } else { $dest = $_; # destination address } $debug && print ">> $dest"; # destination address is user@host or host!user # ... or any pipe if ( ( ($dest =~ /^\s+\S+\@(\S+)/) || ($dest =~ /^\s+(\S+)\!\S+/) || ($dest =~ /<\S+\@(\S+)>/) || ($dest =~ /\|/) ) && (! $opt_p || ($dest =~ /$opt_p/i)) ) { $dest = $1; $count{$dest}++; # increment host count $id{$dest} .= " $id"; # save queue id $debug && print "$dest => $count{$dest}\n"; $indestlist = 1; # remember we are processing dest list } } close(Q); } # locate hosts with high counts; push names into @badhosts sub getbadhosts { local($count) = 0; for $dest (keys(%count)) { # for each dest host $EXCLUDE && ($dest =~ /$EXCLUDE/o) && next; $debug && printf "%-25s %5d\n", $dest, $count{$dest}; if ($count{$dest} > $LIMIT) { ## (! $debug && $verbose) && printf "%-25s %5d MOVE\n", ## $dest, $count{$dest}; push(@badhosts, $dest); $count++; } } return $count; } # Move messages from normal queue to big queue, with locking. # Locking is done by (a) creating tf$id and df$id symlinks in current and new # queue directories and also (b) doing flock() on qf$id in current dir. # Thus if either tf$id or df$id already exists, or if qf$id is already # flock'd by some other process, the message won't be moved. The locking # strategy used here is probably too conservative, but it doesn't hurt. # I did not read the sendmail source code to figure out the perfect # locking strategy. Race conditions might be lurking. Handle with care. sub moveq { for $h (@badhosts) { # for each clogged host for $id (split(' ', $id{$h})) { # for each queue id (! -f "qf$id") && next; # .. skip if no queue file (! -f "df$id") && next; # .. skip if no data file $lock = "tf$id"; # (lock in src dir) $newlock = "$dir_bigqueue/$lock"; # (lock in dest dir) if (&symlink("LOCK.$id", $lock)) { # if we can lock it if (&symlink("LOCK.$id", $newlock)) { if (! -e "$dir_bigqueue/qf$id") { if (open(L, ">>qf$id") && flock(L, $LOCK_EX|$LOCK_NB)) { &rename("qf$id", "$dir_bigqueue/qf$id"); &rename("df$id", "$dir_bigqueue/df$id"); &unlink("tf$id"); &unlink("xf$id"); } else { $debug && print "failed to lock qf$id\n"; } close(L); } &unlink($newlock); } else { $debug && print "failed to lock $newlock\n"; } &unlink($lock); } else { $debug && print "failed to lock $lock\n"; } } } } # Selected system call wrappers. for debugging. # $verbose, $trace and $debug are honored sub rename { local($from, $to) = @_; $verbose && print "rename $from $to\n"; $trace && return 1; rename($from, $to); } sub symlink { local($old, $new) = @_; $debug && print "symlink $old $new\n"; $trace && return 1; symlink($old, $new); } sub unlink { local($name) = @_; $debug && print "unlink $name\n"; $trace && return 1; unlink($name); }