quinncomendant/qmail-queue-wrapper.pl

## qmail-queue-wrapper.pl
#!/usr/bin/perl -w
#
# $Id: qmail-queue-wrapper.pl,v 1.3 2007/03/06 14:55:09 psamuel Exp $
#
# qmail-queue wrapper program.
#
# This program should be used when you wish to manipulate a mail
# message BEFORE it is placed in the queue. Possible uses include:
#
#    - header rewriting
#    - Firstname.Lastname replacements
#    - virus scanning
#    - anything else you can think of
#
# There are at least 2 ways of using this program:
#
#    1) Replace the original qmail-queue with this program:
#
#   mv /var/qmail/bin/qmail-queue /var/qmail/bin/qmail-queue.orig
#   cp qmail-queue-wrapper /var/qmail/bin/qmail-queue
#
#    Change the value of $qmailqueue below, to reflect the new name of
#    the original qmail-queue program. For example
#
#   my $qmailqueue = "/var/qmail/bin/qmail-queue.orig";
#
#    2) Recompile qmail with Bruce Guenter's QMAILQUEUE patch. (See
#    http://www.qmail.org/qmailqueue-patch). Then any program that
#    needs to use this program can be called with the environment
#    variable QMAILQUEUE set to /var/qmail/bin/qmail-queue-wrapper
#
# The default version of this program assumes option (2) above.
#
# How does it work? The interface to the real qmail-queue is simple:
#
#     - the body of the message is read from file descriptor 0
#     - the envelope details are read from file descriptor 1.
#
# qmail-queue-wrapper also adheres to the same interface. After doing
# whatever manipulations are necessary, it calls the real qmail-queue
# and provides the message body on file descriptor 0 and the envelope
# details on file descriptor 1.
#
# Exit codes conform to those mentioned in the qmail-queue(8) manual page.
#
###########################################################################

use strict;

my $child;
my $debug = 0;
my $envelope;
my %errors;
my $qmailqueue = "/var/qmail/bin/qmail-queue.orig";
my @recipients;
my $sender;
my $tcpremoteinfo;
$ENV{"PATH"} = "/usr/bin";


###########################################################################

initialise();

if ($child = fork)
{
    # Parent

    my $timeout = 86400;        # See qmail-queue.c, line 20
    alarm $timeout;
    fatal(82) unless close MESSAGE_READER;
    fatal(82) unless close ENVELOPE_READER;
    process_message();
    process_envelope();
    waitpid $child, 0;          # Wait for the child to terminate
    exit $? % 255;          # Return with the exit status of child
}
elsif (defined $child)
{
    # Child

    fatal(82) unless close MESSAGE_WRITER;
    fatal(82) unless close ENVELOPE_WRITER;
    fatal(82) unless defined open STDIN, "<&MESSAGE_READER";
    fatal(82) unless defined open STDOUT, "<&ENVELOPE_READER";

    if ($debug)
    {
        debug_message("$$: Reading message from STDIN\n\n");

        while (<STDIN>)
        {
            debug_message("$$: $_");
        }

        fatal(82) unless close MESSAGE_READER;
        debug_message("\n$$: ####################\n\n");
        debug_message("$$: Reading envelope from STDOUT\n");

        while (<ENVELOPE_READER>)
        {
            s/\0/ /g;
            debug_message("$$: $_\n");
        }

        fatal(82) unless close ENVELOPE_READER;
        exit 0;
    }
    else
    {
        fatal(82) unless exec $qmailqueue;
    }
}
else
{
    fatal(82);              # Unable to fork
}

###########################################################################

sub initialise
{
    prepare_error_messages();
    ignore_signals();
    catch_signals();
    setup_pipes();
}

sub prepare_error_messages
{
    # These are the exit codes and their meanings, as defined by the
    # real qmail-queue manual page. Many are not used by either the
    # real qmail-queue or this wrapper program.

    %errors = (
        11  =>  "Address too long",

        31  =>  "Mail server permanently refuses to send " .
                "the message to any recipients",

                # Not used by qmail-queue, but can be used by
                # programs offering the same interface

        51  =>  "Out of memory",

        52  =>  "Timeout",

        53  =>  "Write error; e.g., disk full",

        54  =>  "Unable to read the message or envelope",

        55  =>  "Unable to read a configuration file",

                # Not used by qmail-queue

        56  =>  "Problem making a network connection from this host",

                # Not used by qmail-queue

        61  =>  "Problem with the qmail home directory",

        62  =>  "Problem with the queue directory",

        63  =>  "Problem with queue/pid",

        64  =>  "Problem with queue/mess",

        65  =>  "Problem with queue/intd",

        66  =>  "Problem with queue/todo",

        71  =>  "Mail server temporarily refuses to send " .
                "the message to any recipients",

                # Not used by qmail-queue

        72  =>  "Connection to mail server timed out",

                # Not used by qmail-queue

        73  =>  "Connection to mail server rejected",

                # Not used by qmail-queue

        74  =>  "Connection to mail server succeeded, but " .
                "communication failed",

                # Not used by qmail-queue

        81  =>  "Internal bug; e.g., segmentation fault",

        82  =>  "System resource problem",

                # Undefined in qmail-queue. Specific to this
                # wrapper program.

        91  =>  "Envelope format error",
    );
}

sub ignore_signals
{
    # The real qmail-queue ignores a bunch of signals, so we will too.

    # Ensure all signals are not being blocked.

    foreach (keys %SIG)
    {
        $SIG{$_} = 'DEFAULT';
    }

    # Ignore those signals that the real qmail-queue ignores.

    $SIG{'PIPE'}   = 'IGNORE';
    $SIG{'VTALRM'} = 'IGNORE';
    $SIG{'PROF'}   = 'IGNORE';
    $SIG{'QUIT'}   = 'IGNORE';
    $SIG{'INT'}    = 'IGNORE';
    $SIG{'HUP'}    = 'IGNORE';
    $SIG{'XCPU'}   = 'IGNORE' if (defined $SIG{'XCPU'});
    $SIG{'XFSZ'}   = 'IGNORE' if (defined $SIG{'XFSZ'});
}

sub catch_signals
{
    # The real qmail-queue catches a few signals, so we will too.

    $SIG{'ALRM'} = sub { fatal(52); };
    $SIG{'ILL'}  = sub { fatal(81); };
    $SIG{'ABRT'} = sub { fatal(81); };
    $SIG{'FPE'}  = sub { fatal(81); };
    $SIG{'BUS'}  = sub { fatal(81); };
    $SIG{'SEGV'} = sub { fatal(81); };
    $SIG{'SYS'}  = sub { fatal(81); } if (defined $SIG{'SYS'});
    $SIG{'EMT'}  = sub { fatal(81); } if (defined $SIG{'EMT'});
}

sub setup_pipes
{
    fatal(82) unless pipe(MESSAGE_READER, MESSAGE_WRITER);
    fatal(82) unless pipe(ENVELOPE_READER, ENVELOPE_WRITER);
    select(MESSAGE_WRITER); $| = 1;
    select(ENVELOPE_WRITER); $| = 1;
}

sub debug_message
{
    print STDERR shift;
}

sub fatal
{
    my $errno = shift;
    debug_message("$errors{$errno}\n") if $debug;
    exit $errno;
}

sub process_message
{
    # If you plan on doing serious massaging of the message body, such
    # as virus scanning or MIME conversions, you should probably write
    # the message to a temporary file here. Once you have finished your
    # massaging you can read from the file. You could slurp the message
    # into memory but that may be a resource problem for you. Caveat
    # emptor!

    if (defined $ENV{'TCPREMOTEINFO'} && $ENV{'TCPREMOTEINFO'} ne '') {
        $tcpremoteinfo = $ENV{'TCPREMOTEINFO'};
        print MESSAGE_WRITER "X-AuthUser: $ENV{'TCPREMOTEINFO'}\n";
    }

    while (<STDIN>)
    {
        print MESSAGE_WRITER;
    }

    fatal(82) unless close MESSAGE_WRITER;
}

sub process_envelope
{
    read_envelope();

    # If you don't want to do any rigourous checking of the envelope,
    # simply comment out the check_envelope() statement. The real
    # qmail-queue will perform the same checks anyway.

    check_envelope();
    close_envelope();
    print ENVELOPE_WRITER "$envelope";
    fatal(82) unless close ENVELOPE_WRITER;
}

sub read_envelope
{
    # Read the message envelope from file descriptor 1. At startup
    # this is already assigned to the Perl filehandle STDOUT but
    # you need to explicitly specify the file descriptor number
    # rather than the filehandle (Older versions of Perl 5 allowed
    # you to specify the filehandle).

    # Duplicate file descriptor 1 for reading.

    fatal(54) unless defined open DUP_STDOUT, "<&1";

    # Temporarily disable Perl warnings - Perl complains with
    #
    #    Filehandle DUP_STDOUT opened only for output at thisfile line 349.
    #
    # which is annoying and not a problem (at least with my testing).
    # So we'll temporarily disable it while we deal with DUP_STDOUT.

    $^W = 0;

    # Extract the envelope details. The stripping of the leading 'F'
    # and 'T' characters will be performed later.

    $envelope = <DUP_STDOUT>;
    $^W = 1;                # Re-enable Perl warnings
}

sub check_envelope
{
    # There MUST be some envelope details.

    fatal(54) unless defined $envelope;

    # The envelope details MUST be terminated by two NULLS.

    fatal(54) if ($envelope !~ /\0\0$/);

    ($sender, @recipients) = split(/\0/, $envelope);

    # If there are no recipients, we should exit here. However, the
    # real qmail-queue will quite happily accept messages with no
    # recipients, so we will too.

    # The sender address MUST begin with an 'F' and the recipient
    # address(es) MUST begin with a 'T'.

    fatal(91) if ($sender !~ /^F/);

    foreach (@recipients)
    {
        fatal(91) if ($_ !~ /^T/);
    }

    # None of the addresses may be greater than $address_length
    # characters. (Remember that each address has an extra leading
    # character at this stage, so it's just a "greater than" test,
    # rather than a "greater than or equal to" test).

    my $address_length = 1003;      # See qmail-queue.c, line 21

    foreach ($sender, @recipients)
    {
        fatal(11) if (length $_ > $address_length);
    }

    # The sender AND recipient address(es) should contain a username,
    # an @ sign and a fully qualified domain name. However, the real
    # qmail-queue does not enforce this, so we won't either.
}

sub close_envelope
{
    fatal(54) unless close DUP_STDOUT;  # Close duplicated STDOUT
}
	#!/usr/bin/perl -w
	#
	# $Id: qmail-queue-wrapper.pl,v 1.3 2007/03/06 14:55:09 psamuel Exp $
	#
	# qmail-queue wrapper program.
	#
	# This program should be used when you wish to manipulate a mail
	# message BEFORE it is placed in the queue. Possible uses include:
	#
	# - header rewriting
	# - Firstname.Lastname replacements
	# - virus scanning
	# - anything else you can think of
	#
	# There are at least 2 ways of using this program:
	#
	# 1) Replace the original qmail-queue with this program:
	#
	# mv /var/qmail/bin/qmail-queue /var/qmail/bin/qmail-queue.orig
	# cp qmail-queue-wrapper /var/qmail/bin/qmail-queue
	#
	# Change the value of $qmailqueue below, to reflect the new name of
	# the original qmail-queue program. For example
	#
	# my $qmailqueue = "/var/qmail/bin/qmail-queue.orig";
	#
	# 2) Recompile qmail with Bruce Guenter's QMAILQUEUE patch. (See
	# http://www.qmail.org/qmailqueue-patch). Then any program that
	# needs to use this program can be called with the environment
	# variable QMAILQUEUE set to /var/qmail/bin/qmail-queue-wrapper
	#
	# The default version of this program assumes option (2) above.
	#
	# How does it work? The interface to the real qmail-queue is simple:
	#
	# - the body of the message is read from file descriptor 0
	# - the envelope details are read from file descriptor 1.
	#
	# qmail-queue-wrapper also adheres to the same interface. After doing
	# whatever manipulations are necessary, it calls the real qmail-queue
	# and provides the message body on file descriptor 0 and the envelope
	# details on file descriptor 1.
	#
	# Exit codes conform to those mentioned in the qmail-queue(8) manual page.
	#
	###########################################################################

	use strict;

	my $child;
	my $debug = 0;
	my $envelope;
	my %errors;
	my $qmailqueue = "/var/qmail/bin/qmail-queue.orig";
	my @recipients;
	my $sender;
	my $tcpremoteinfo;
	$ENV{"PATH"} = "/usr/bin";


	###########################################################################

	initialise();

	if ($child = fork)
	{
	# Parent

	my $timeout = 86400; # See qmail-queue.c, line 20
	alarm $timeout;
	fatal(82) unless close MESSAGE_READER;
	fatal(82) unless close ENVELOPE_READER;
	process_message();
	process_envelope();
	waitpid $child, 0; # Wait for the child to terminate
	exit $? % 255; # Return with the exit status of child
	}
	elsif (defined $child)
	{
	# Child

	fatal(82) unless close MESSAGE_WRITER;
	fatal(82) unless close ENVELOPE_WRITER;
	fatal(82) unless defined open STDIN, "<&MESSAGE_READER";
	fatal(82) unless defined open STDOUT, "<&ENVELOPE_READER";

	if ($debug)
	{
	debug_message("$$: Reading message from STDIN\n\n");

	while (<STDIN>)
	{
	debug_message("$$: $_");
	}

	fatal(82) unless close MESSAGE_READER;
	debug_message("\n$$: ####################\n\n");
	debug_message("$$: Reading envelope from STDOUT\n");

	while (<ENVELOPE_READER>)
	{
	s/\0/ /g;
	debug_message("$$: $_\n");
	}

	fatal(82) unless close ENVELOPE_READER;
	exit 0;
	}
	else
	{
	fatal(82) unless exec $qmailqueue;
	}
	}
	else
	{
	fatal(82); # Unable to fork
	}

	###########################################################################

	sub initialise
	{
	prepare_error_messages();
	ignore_signals();
	catch_signals();
	setup_pipes();
	}

	sub prepare_error_messages
	{
	# These are the exit codes and their meanings, as defined by the
	# real qmail-queue manual page. Many are not used by either the
	# real qmail-queue or this wrapper program.

	%errors = (
	11 => "Address too long",

	31 => "Mail server permanently refuses to send " .
	"the message to any recipients",

	# Not used by qmail-queue, but can be used by
	# programs offering the same interface

	51 => "Out of memory",

	52 => "Timeout",

	53 => "Write error; e.g., disk full",

	54 => "Unable to read the message or envelope",

	55 => "Unable to read a configuration file",

	# Not used by qmail-queue

	56 => "Problem making a network connection from this host",

	# Not used by qmail-queue

	61 => "Problem with the qmail home directory",

	62 => "Problem with the queue directory",

	63 => "Problem with queue/pid",

	64 => "Problem with queue/mess",

	65 => "Problem with queue/intd",

	66 => "Problem with queue/todo",

	71 => "Mail server temporarily refuses to send " .
	"the message to any recipients",

	# Not used by qmail-queue

	72 => "Connection to mail server timed out",

	# Not used by qmail-queue

	73 => "Connection to mail server rejected",

	# Not used by qmail-queue

	74 => "Connection to mail server succeeded, but " .
	"communication failed",

	# Not used by qmail-queue

	81 => "Internal bug; e.g., segmentation fault",

	82 => "System resource problem",

	# Undefined in qmail-queue. Specific to this
	# wrapper program.

	91 => "Envelope format error",
	);
	}

	sub ignore_signals
	{
	# The real qmail-queue ignores a bunch of signals, so we will too.

	# Ensure all signals are not being blocked.

	foreach (keys %SIG)
	{
	$SIG{$_} = 'DEFAULT';
	}

	# Ignore those signals that the real qmail-queue ignores.

	$SIG{'PIPE'} = 'IGNORE';
	$SIG{'VTALRM'} = 'IGNORE';
	$SIG{'PROF'} = 'IGNORE';
	$SIG{'QUIT'} = 'IGNORE';
	$SIG{'INT'} = 'IGNORE';
	$SIG{'HUP'} = 'IGNORE';
	$SIG{'XCPU'} = 'IGNORE' if (defined $SIG{'XCPU'});
	$SIG{'XFSZ'} = 'IGNORE' if (defined $SIG{'XFSZ'});
	}

	sub catch_signals
	{
	# The real qmail-queue catches a few signals, so we will too.

	$SIG{'ALRM'} = sub { fatal(52); };
	$SIG{'ILL'} = sub { fatal(81); };
	$SIG{'ABRT'} = sub { fatal(81); };
	$SIG{'FPE'} = sub { fatal(81); };
	$SIG{'BUS'} = sub { fatal(81); };
	$SIG{'SEGV'} = sub { fatal(81); };
	$SIG{'SYS'} = sub { fatal(81); } if (defined $SIG{'SYS'});
	$SIG{'EMT'} = sub { fatal(81); } if (defined $SIG{'EMT'});
	}

	sub setup_pipes
	{
	fatal(82) unless pipe(MESSAGE_READER, MESSAGE_WRITER);
	fatal(82) unless pipe(ENVELOPE_READER, ENVELOPE_WRITER);
	select(MESSAGE_WRITER); $\| = 1;
	select(ENVELOPE_WRITER); $\| = 1;
	}

	sub debug_message
	{
	print STDERR shift;
	}

	sub fatal
	{
	my $errno = shift;
	debug_message("$errors{$errno}\n") if $debug;
	exit $errno;
	}

	sub process_message
	{
	# If you plan on doing serious massaging of the message body, such
	# as virus scanning or MIME conversions, you should probably write
	# the message to a temporary file here. Once you have finished your
	# massaging you can read from the file. You could slurp the message
	# into memory but that may be a resource problem for you. Caveat
	# emptor!

	if (defined $ENV{'TCPREMOTEINFO'} && $ENV{'TCPREMOTEINFO'} ne '') {
	$tcpremoteinfo = $ENV{'TCPREMOTEINFO'};
	print MESSAGE_WRITER "X-AuthUser: $ENV{'TCPREMOTEINFO'}\n";
	}

	while (<STDIN>)
	{
	print MESSAGE_WRITER;
	}

	fatal(82) unless close MESSAGE_WRITER;
	}

	sub process_envelope
	{
	read_envelope();

	# If you don't want to do any rigourous checking of the envelope,
	# simply comment out the check_envelope() statement. The real
	# qmail-queue will perform the same checks anyway.

	check_envelope();
	close_envelope();
	print ENVELOPE_WRITER "$envelope";
	fatal(82) unless close ENVELOPE_WRITER;
	}

	sub read_envelope
	{
	# Read the message envelope from file descriptor 1. At startup
	# this is already assigned to the Perl filehandle STDOUT but
	# you need to explicitly specify the file descriptor number
	# rather than the filehandle (Older versions of Perl 5 allowed
	# you to specify the filehandle).

	# Duplicate file descriptor 1 for reading.

	fatal(54) unless defined open DUP_STDOUT, "<&1";

	# Temporarily disable Perl warnings - Perl complains with
	#
	# Filehandle DUP_STDOUT opened only for output at thisfile line 349.
	#
	# which is annoying and not a problem (at least with my testing).
	# So we'll temporarily disable it while we deal with DUP_STDOUT.

	$^W = 0;

	# Extract the envelope details. The stripping of the leading 'F'
	# and 'T' characters will be performed later.

	$envelope = <DUP_STDOUT>;
	$^W = 1; # Re-enable Perl warnings
	}

	sub check_envelope
	{
	# There MUST be some envelope details.

	fatal(54) unless defined $envelope;

	# The envelope details MUST be terminated by two NULLS.

	fatal(54) if ($envelope !~ /\0\0$/);

	($sender, @recipients) = split(/\0/, $envelope);

	# If there are no recipients, we should exit here. However, the
	# real qmail-queue will quite happily accept messages with no
	# recipients, so we will too.

	# The sender address MUST begin with an 'F' and the recipient
	# address(es) MUST begin with a 'T'.

	fatal(91) if ($sender !~ /^F/);

	foreach (@recipients)
	{
	fatal(91) if ($_ !~ /^T/);
	}

	# None of the addresses may be greater than $address_length
	# characters. (Remember that each address has an extra leading
	# character at this stage, so it's just a "greater than" test,
	# rather than a "greater than or equal to" test).

	my $address_length = 1003; # See qmail-queue.c, line 21

	foreach ($sender, @recipients)
	{
	fatal(11) if (length $_ > $address_length);
	}

	# The sender AND recipient address(es) should contain a username,
	# an @ sign and a fully qualified domain name. However, the real
	# qmail-queue does not enforce this, so we won't either.
	}

	sub close_envelope
	{
	fatal(54) unless close DUP_STDOUT; # Close duplicated STDOUT
	}