smtpprox-1.2/0040755000076400007640000000000007560475516011411 5ustar betbetsmtpprox-1.2/smtpprox0100755000076400007640000001325007632706550013224 0ustar betbet#!/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 . # # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # 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 =head1 SYNOPSIS smtpprox [options] listen.addr:port talk.addr:port options: --children=16 --minperchild=100 --maxperchild=200 --debugtrace=filename_prefix =head1 DESCRIPTION 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 smtpprox 127.0.0.1:10025 127.0.0.1:10026 =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 hooks. =head1 PERFORMANCE NOTES 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. =cut 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.$$"); $opts{debug}->autoflush(1); } while (1) { $server->accept(%opts); my $client = MSDW::SMTP::Client->new(interface => $dstaddr, port => $dstport); my $banner = $client->hear; $banner = "220 $debugtrace.$$" if defined $debugtrace; $server->ok($banner); while (my $what = $server->chat) { if ($what eq '.') { $client->yammer($server->{data}); } else { $client->say($what); } $server->ok($client->hear); } $client = undef; delete $server->{"s"}; exit 0 if $lives-- <= 0; } smtpprox-1.2/MSDW/0040755000076400007640000000000007560475242012157 5ustar betbetsmtpprox-1.2/MSDW/SMTP/0040755000076400007640000000000007560475242012742 5ustar betbetsmtpprox-1.2/MSDW/SMTP/Server.pm0100644000076400007640000001743407632706550014553 0ustar betbet# 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 . # # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Written by Bennett Todd package MSDW::SMTP::Server; use IO::Socket; use IO::File; =head1 NAME MSDW::SMTP::Server --- SMTP server for content-scanning proxy =head1 SYNOPSIS use MSDW::SMTP::Server; my $server = MSDW::SMTP::Server->new(interface => $interface, port => $port); while (1) { # prefork here $server->accept([options]); # per-connect fork here $server->ok("220 howdy"); while (my $what = $server->chat) { if ($what =~ /^mail/i) { if (isgood($server->{from})) { $server->ok([ ack msg ]); } else { $server->fail([ fail msg ]); } } elsif ($what =~ /^rcpt/i) { if (isgood(@{$server}{qw(from to)})) { $sever->ok([ ack msg ]); } else { $server->fail([ fail msg ]); } } elsif ($what =~ /^data/i) { if (isgood(@{$server}{qw(from to)})) { # NB to is now an array of all recipients $self->ok("354 natter on."); } else { $self->fail; } } elsif ($what eq '.') { if (isgood(@server->{from,to,data})) { $server->ok; } else { $server->fail; } } else { # deal with other msg types as you will die "can't happen"; } # process $server->{from,to,data} here $server->ok; # or $server->fail; } } =head1 DESCRIPTION MSDW::SMTP::Server fills a gap in the available range of Perl SMTP servers. The existing candidates are not suitable for a high-performance, content-scanning robust SMTP proxy. They insist on heavy-weight structuring and parsing of the body, and they acknowledge receipt of the data before returning control to the caller. This server simply gathers the SMTP acquired information (envelope sender and recipient, and data) into unparsed memory buffers (or a file for the data), and returns control to the caller to explicitly acknowlege each command or request. Since acknowlegement or failure are driven explicitly from the caller, this module can be used to create a robust SMTP content scanning proxy, transparent or not as desired. =head1 METHODS =over 8 =item new(interface => $interface, port => $port); The interface and port to listen on must be specified. The interface must be a valid numeric IP address (0.0.0.0 to listen on all interfaces, as usual); the port must be numeric. If this call succeeds, it returns a server structure with an open IO::Socket::INET in it, ready to listen on. If it fails it dies, so if you want anything other than an exit with an explanatory error message, wrap the constructor call in an eval block and pull the error out of $@ as usual. This is also the case for all other methods; they succeed or they die. =item accept([debug => FD]); accept takes optional args and returns nothing. If an error occurs it dies, otherwise it returns when a client connects to this server. This is factored out as a separate entry point to allow preforking (e.g. Apache-style) or fork-per-client strategies to be implemented on the common protocol core. If a filehandle is passed for debugging it will receive a complete trace of the entire SMTP dialogue, data and all. Note that nothing in this module sends anything to the client, including the initial login banner; all such backtalk must come from the calling program. =item chat; The chat method carries the SMTP dialogue up to the point where any acknowlegement must be made. If chat returns true, then its return value is the previous SMTP command. If the return value begins with 'mail' (case insensitive), then the attribute 'from' has been filled in, and may be checked; if the return value begins with 'rcpt' then both from and to have been been filled in with scalars, and should be checked, then either 'ok' or 'fail' should be called to accept or reject the given sender/recipient pair. If the return value is 'data', then the attributes from and to are populated; in this case, the 'to' attribute is a reference to an anonymous array containing all the recipients for this data. If the return value is '.', then the 'data' attribute (which may be pre-populated in the "new" or "accept" methods if desired) is a reference to a filehandle; if it's created automatically by this module it will point to an unlinked tmp file in /tmp. If chat returns false, the SMTP dialogue has been completed and the socket closed; this server is ready to exit or to accept again, as appropriate for the server style. The return value from chat is also remembered inside the server structure in the "state" attribute. =item ok([message]); Approves of the data given to date, either the recipient or the data, in the context of the sender [and, for data, recipients] already given and available as attributes. If a message is given, it will be sent instead of the internal default. =item fail([message]); Rejects the current info; if processing from, rejects the sender; if processing 'to', rejects the current recipient; if processing data, rejects the entire message. If a message is specified it means the exact same thing as "ok" --- simply send that message to the sender. =back =cut sub new { my ($this, @opts) = @_; my $class = ref($this) || $this; my $self = bless { @opts }, $class; $self->{sock} = IO::Socket::INET->new( LocalAddr => $self->{interface}, LocalPort => $self->{port}, Proto => 'tcp', Type => SOCK_STREAM, Listen => 65536, Reuse => 1, ); die "$0: socket bind failure: $!\n" unless defined $self->{sock}; $self->{state} = 'just bound', return $self; } sub accept { my ($self, @opts) = @_; %$self = (%$self, @opts); ($self->{"s"}, $self->{peeraddr}) = $self->{sock}->accept or die "$0: accept failure: $!\n"; $self->{state} = ' accepted'; } sub chat { my ($self) = @_; local(*_); if ($self->{state} !~ /^data/i) { return 0 unless defined($_ = $self->getline); s/[\r\n]*$//; $self->{state} = $_; if (s/^helo\s+//i) { s/\s*$//;s/\s+/ /g; $self->{helo} = $_; } elsif (s/^rset\s*//i) { delete $self->{to}; delete $self->{data}; delete $self->{recipients}; } elsif (s/^mail\s+from:\s*//i) { delete $self->{to}; delete $self->{data}; delete $self->{recipients}; s/\s*$//; $self->{from} = $_; } elsif (s/^rcpt\s+to:\s*//i) { s/\s*$//; s/\s+/ /g; $self->{to} = $_; push @{$self->{recipients}}, $_; } elsif (/^data/i) { $self->{to} = $self->{recipients}; } } else { if (defined($self->{data})) { $self->{data}->seek(0, 0); $self->{data}->truncate(0); } else { $self->{data} = IO::File->new_tmpfile; } while (defined($_ = $self->getline)) { if ($_ eq ".\r\n") { $self->{data}->seek(0,0); return $self->{state} = '.'; } s/^\.\./\./; $self->{data}->print($_) or die "$0: write error saving data\n"; } return(0); } return $self->{state}; } sub getline { my ($self) = @_; local ($/) = "\r\n"; return $self->{"s"}->getline unless defined $self->{debug}; my $tmp = $self->{"s"}->getline; $self->{debug}->print($tmp) if ($tmp); return $tmp; } sub print { my ($self, @msg) = @_; $self->{debug}->print(@msg) if defined $self->{debug}; $self->{"s"}->print(@msg); } sub ok { my ($self, @msg) = @_; @msg = ("250 ok.") unless @msg; $self->print("@msg\r\n") or die "$0: write error acknowledging $self->{state}: $!\n"; } sub fail { my ($self, @msg) = @_; @msg = ("550 no.") unless @msg; $self->print("@msg\r\n") or die "$0: write error acknowledging $self->{state}: $!\n"; } 1; smtpprox-1.2/MSDW/SMTP/Client.pm0100644000076400007640000001017307560475416014520 0ustar betbet# 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 . # # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # Written by Bennett Todd package MSDW::SMTP::Client; use IO::Socket; =head1 NAME MSDW::SMTP::Client --- SMTP client for content-scanning proxy =head1 SYNOPSIS use MSDW::SMTP::Client; my $client = MSDW::SMTP::Client->new(interface => $interface, port => $port); my %response; $response{banner} = $client->hear; $client->say("helo bunky"); $response{helo} = $client->hear; $client->say("mail from: me"); $response{from} = $client->hear; $client->say("rcpt to: you"); $response{to} = $client->hear; $client->say("data"); $response{data} = $client->hear; $client->yammer(FILEHANDLE); $response{dot} = $client->hear; $client->say("quit"); $response{quit} = $client->hear; undef $client; =head1 DESCRIPTION MSDW::SMTP::Client provides a very lean SMTP client implementation; the only protocol-specific knowlege it has is the structure of SMTP multiline responses. All specifics lie in the hands of the calling program; this makes it appropriate for a semi-transparent SMTP proxy, passing commands between a talker and a listener. =head1 METHODS =over 8 =item new(interface => $interface, port => $port[, timeout = 300]); The interface and port to talk to must be specified. The interface must be a valid numeric IP address; the port must be numeric. If this call succeeds, it returns a client structure with an open IO::Socket::INET in it, ready to talk to. If it fails it dies, so if you want anything other than an exit with an explanatory error message, wrap the constructor call in an eval block and pull the error out of $@ as usual. This is also the case for all other methods; they succeed or they die. The timeout parameter is passed on into the IO::Socket::INET constructor. =item hear hear collects a complete SMTP response and returns it with trailing CRLF removed; for multi-line responses, intermediate CRLFs are left intact. Returns undef if EOF is seen before a complete reply is collected. =item say("command text") say sends an SMTP command, appending CRLF. =item yammer(FILEHANDLE) yammer takes a filehandle (which should be positioned at the beginning of the file, remember to $fh->seek(0,0) if you've just written it) and sends its contents as the contents of DATA. This should only be invoked after a $client->say("data") and a $client->hear to collect the reply to the data command. It will send the trailing "." as well. It will perform leading-dot-doubling in accordance with the SMTP protocol spec, where "leading dot" is defined in terms of CR-LF terminated lines --- i.e. the data should contain CR-LF data without the leading-dot-quoting. The filehandle will be left at EOF. =back =cut sub new { my ($this, @opts) = @_; my $class = ref($this) || $this; my $self = bless { timeout => 300, @opts }, $class; $self->{sock} = IO::Socket::INET->new( PeerAddr => $self->{interface}, PeerPort => $self->{port}, Timeout => $self->{timeout}, Proto => 'tcp', Type => SOCK_STREAM, ); die "$0: socket connect failure: $!\n" unless defined $self->{sock}; return $self; } sub hear { my ($self) = @_; my ($tmp, $reply); return undef unless $tmp = $self->{sock}->getline; while ($tmp =~ /^\d{3}-/) { $reply .= $tmp; return undef unless $tmp = $self->{sock}->getline; } $reply .= $tmp; $reply =~ s/\r\n$//; return $reply; } sub say { my ($self, @msg) = @_; return unless @msg; $self->{sock}->print("@msg", "\r\n") or die "$0: write error: $!"; } sub yammer { my ($self, $fh) = (@_); local (*_); local ($/) = "\r\n"; while (<$fh>) { s/^\./../; $self->{sock}->print($_) or die "$0: write error: $!\n"; } $self->{sock}->print(".\r\n") or die "$0: write error: $!\n"; } 1; smtpprox-1.2/TODO0100644000076400007640000000023407560475242012071 0ustar betbetsleep 120 instead of die if parent can't fork? have children check if getppid==1 and if so, close $server->{sock} and exit after completing the current msg smtpprox-1.2/README0100644000076400007640000000161407560475313012263 0ustar betbet 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 . This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. smtpprox is a trivial transparent SMTP proxy, an SMTP server and client combination. It uses its own SMTP server and client modules which are designed to expose every step of the protocol dialogue to the calling program, which provides for the greatest flexibility in hooking in envelope and content controls and scanning. For efficiency reasons, it pre-forks and serves from a pool of servers, Apache-style. smtpprox was written by Bennett Todd, . smtpprox-1.2/ChangeLog0100644000076400007640000000027007632706630013151 0ustar betbet1.0 2001-03-01 Initial Release 1.1 2002-11-01 Added authorship info 1.2 2003-03-09 Applied debugtrace patches from Kyle Dent