Skip to content


Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

executable file 163 lines (139 sloc) 5.8 kb
#!/usr/bin/perl -w
# This code is Copyright (C) 2001 Morgan Stanley Dean Witter, and
# is distributed according to the terms of the GNU Public License
# as found at <URL:>.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# GNU General Public License for more details.
# Written by Bennett Todd <>
use strict;
use Getopt::Long;
use IO::File;
use lib '.';
use MSDW::SMTP::Server;
use MSDW::SMTP::Client;
=head1 NAME
smtprox -- Transparent SMTP proxy
smtpprox [options] listen.addr:port talk.addr:port
smtpprox listens on the addr and port specified by its first arg,
and sends the traffic unmodified to the SMTP server whose addr and
port are listed as its second arg. The SMTP dialogue is propogated
literally, all commands from the client are copied to the server and
the responses from the server are copied back from to the client,
but the envelope info and message bodies are captured for analysis,
and code has the option of modifying the body before sending it on,
manipulating the envelope, or intervening in the SMTP dialogue to
reject senders, recipients, or content at the SMTP level. The
children option, defaulting to 16, allows adjusting how many child
processes will be maintained in the service pool. Each child will
kill itself after servicing some random number of messages between
minperchild and maxperchild (100-200 default), after which the
parent will immediately fork another child to pick up its share of
the load. If debugtrace is specified, the prefix will have the PID
appended to it for a separate logfile for each child, which will
capture all the SMTP dialogues that child services. It looks like a
snooper on the client side of the proxy. And if debugtracefile is
defined, it returns its own banner including its PID for debugging
at startup, otherwise it copies the server's banner back to the
client transparently.
=head1 EXAMPLE
=head1 WARNING
While the richness or lack thereof in the SMTP dialect spoken lies
in the hands of the next SMTP server down the chain, this proxy was
not designed to run on the front lines listening for traffic from
the internet; neither its performance characteristics nor its
paranoia were tuned for that role. Rather, it's designed as an
intermediate component, suitable for use as the framework for a
content-scanning proxy for use with Postfix's content-filtering
This proxy is tuned to some specific assumptions: execing perl is
wickedly expensive, forking perl is fairly expensive, messages will
vary rather widely in size, and memory footprint efficiency is
somewhat more important than CPU utilization. It uses Apache-style
preforking to almost entirely eliminate the need to fork perls,
with controlled child restart to defend against resource leaks in
children; it stores the body of the message in an unlinked file
under /tmp, which should be a tmpfs; this prevents the allocation
overhead associated with large strings (often 2-3x) and ensures that
space will be returned to the OS as soon as it's not needed.
my $syntax = "syntax: $0 [--children=16] [--minperchild=100] ".
"[--maxperchild=200] [--debugtrace=undef] ".
"listen.addr:port talk.addr:port\n";
my $children = 16;
my $minperchild = 100;
my $maxperchild = 200;
my $debugtrace = undef;
GetOptions("children=n" => \$children,
"minperchild=n" => \$minperchild,
"maxperchild=n" => \$maxperchild,
"debugtrace=s" => \$debugtrace) or die $syntax;
die $syntax unless @ARGV == 2;
my ($srcaddr, $srcport) = split /:/, $ARGV[0];
my ($dstaddr, $dstport) = split /:/, $ARGV[1];
die $syntax unless defined($srcport) and defined($dstport);
my $server = MSDW::SMTP::Server->new(interface => $srcaddr, port => $srcport);
# This should allow a kill on the parent to also blow away the
# children, I hope
my %children;
use vars qw($please_die);
$please_die = 0;
$SIG{TERM} = sub { $please_die = 1; };
# This block is the parent daemon, never does an accept, just herds
# a pool of children who accept and service connections, and
# occasionally kill themselves off
PARENT: while (1) {
while (scalar(keys %children) >= $children) {
my $child = wait;
delete $children{$child} if exists $children{$child};
if ($please_die) { kill 15, keys %children; exit 0; }
my $pid = fork;
die "$0: fork failed: $!\n" unless defined $pid;
last PARENT if $pid == 0;
$children{$pid} = 1;
select(undef, undef, undef, 0.1);
if ($please_die) { kill 15, keys %children; exit 0; }
# This block is a child service daemon. It inherited the bound
# socket created by SMTP::Server->new, it will service a random
# number of connection requests in [minperchild..maxperchild] then
# exit
my $lives = $minperchild + (rand($maxperchild - $minperchild));
my %opts;
if (defined $debugtrace) {
$opts{debug} = IO::File->new(">$debugtrace.$$");
while (1) {
my $client = MSDW::SMTP::Client->new(interface => $dstaddr, port => $dstport);
my $banner = $client->hear;
$banner = "220 $debugtrace.$$" if defined $debugtrace;
while (my $what = $server->chat) {
if ($what eq '.') {
} else {
$client = undef;
delete $server->{"s"};
exit 0 if $lives-- <= 0;
Jump to Line
Something went wrong with that request. Please try again.