#! /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 <dhesi@rahul.net>

# 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 <<EOF;
usage: $myname -xvty -l limit

   -D dir    name of destination directory into which to move messages
   -S dir    name of source directory from where messages are scanned
   -e pat    don't touch messages whose destination matches 
	     case-insensitive perl pattern
   -x        enable debugging
   -v        be verbose
   -t        trace only -- no changes
   -l limit  threshold over which mail will be moved to auxilliary queue
   -y        required if no other option is used
   -p pat    move only if destination address matches this perl pattern

Searches in mail queue in $dir_mqueue for hosts for which a large
number of messages (default $LIMIT, but adjustable with the -l option)
is queued.  Moves each such queued message into an auxilliary queue
$dir_bigqueue.
EOF
exit(0);
}

$debug = $opt_x;
$trace = $opt_t;
$verbose = $opt_v || $debug;

if (defined($opt_l)) {
   $LIMIT = $opt_l;
}

if (!$opt_y && !$debug && !$verbose && !$trace && 
				    !$opt_l && !$opt_S && !$opt_D) {
   print STDERR "$myname: one of -xvtylSD is required  (or -h for help)\n";
   exit(1);
}

chdir($dir_mqueue) || die "$myname: can't chdir to $dir_mqueue: $!\n";

&getcounts();				# get counts of destination hosts
$count = &getbadhosts();		# find bad hosts

if ($count > 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 (<Q>) {
      # 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 = <Q>;			# error line (line 2)
	 if ($LIMIT > 0 && $errmsg !~ /^\s*\(/) {
	    # if no left paren is not error line)
	    next;
	 }
	 $debug && print ">> $errmsg";
	 $dest = <Q>;			# 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);
}