From 981f6de7ab80579df2e7396a564e8cddc32641a9 Mon Sep 17 00:00:00 2001 From: Matt Sergeant Date: Sun, 2 Nov 2003 11:15:40 +0000 Subject: [PATCH] A non-tcpserver qpsmtpd server git-svn-id: https://svn.perl.org/qpsmtpd/trunk@182 958fd67b-6ff1-0310-b445-bb7760255be9 --- lib/Qpsmtpd/SelectServer.pm | 310 ++++++++++++++++++++++++++++++++++++ qpsmtpd-server | 28 ++++ 2 files changed, 338 insertions(+) create mode 100644 lib/Qpsmtpd/SelectServer.pm create mode 100755 qpsmtpd-server diff --git a/lib/Qpsmtpd/SelectServer.pm b/lib/Qpsmtpd/SelectServer.pm new file mode 100644 index 0000000..e38680a --- /dev/null +++ b/lib/Qpsmtpd/SelectServer.pm @@ -0,0 +1,310 @@ +package Qpsmtpd::SelectServer; +use Qpsmtpd::SMTP; +use Qpsmtpd::Constants; +use IO::Socket; +use IO::Select; +use POSIX qw(strftime); +use Socket qw(CRLF); +use Fcntl; +use Tie::RefHash; +use Net::DNS; + +@ISA = qw(Qpsmtpd::SMTP); +use strict; + +our %inbuffer = (); +our %outbuffer = (); +our %ready = (); +our %lookup = (); +our %qp = (); +our %indata = (); + +tie %ready, 'Tie::RefHash'; +my $server; +my $select; + +sub main { + my $class = shift; + my %opts = (LocalPort => 25, Reuse => 1, Listen => SOMAXCONN, @_); + $server = IO::Socket::INET->new(%opts) or die "Server: $@"; + print "Listening on $opts{LocalPort}\n"; + + nonblock($server); + + $select = IO::Select->new($server); + my $res = Net::DNS::Resolver->new; + + while (1) { + foreach my $client ($select->can_read(1)) { + if ($client == $server) { + my $client_addr; + $client = $server->accept(); + next unless $client; + my $ip = $client->sockhost; + #my $revip = join('.', reverse(split(/\./, $ip))); + #print "Looking up: $revip.in-addr.arpa\n"; + #my $bgsock = $res->bgsend("$revip.in-addr.arpa", 'PTR'); + my $bgsock = $res->bgsend($ip); + $select->add($bgsock); + $lookup{$bgsock} = $client; + } + elsif (my $qpclient = $lookup{$client}) { + my $packet = $res->bgread($client); + my $ip = $qpclient->sockhost; + my $hostname = $ip; + if ($packet) { + foreach my $rr ($packet->answer) { + if ($rr->type eq 'PTR') { + $hostname = $rr->rdatastr; + } + } + } + # $packet->print; + $select->remove($client); + delete($lookup{$client}); + my $qp = Qpsmtpd::SelectServer->new(); + $qp->client($qpclient); + $qp{$qpclient} = $qp; + $inbuffer{$qpclient} = ''; + $outbuffer{$qpclient} = ''; + $ready{$qpclient} = []; + $qp->start_connection($ip, $hostname); + $qp->load_plugins; + my $rc = $qp->start_conversation; + if ($rc != DONE) { + close($client); + next; + } + $select->add($qpclient); + nonblock($qpclient); + } + else { + my $data = ''; + my $rv = $client->recv($data, POSIX::BUFSIZ(), 0); + + unless (defined($rv) && length($data)) { + freeclient($client) + unless ($! == POSIX::EWOULDBLOCK() || + $! == POSIX::EINPROGRESS() || + $! == POSIX::EINTR()); + next; + } + $inbuffer{$client} .= $data; + + while ($inbuffer{$client} =~ s/^([^\r\n]*)\r?\n//) { + push @{$ready{$client}}, $1; + } + } + } + + foreach my $client (keys %ready) { + my $qp = $qp{$client}; + foreach my $req (@{$ready{$client}}) { + if ($indata{$client}) { + $qp->data_line($req . CRLF); + } + else { + $qp->log(1, "dispatching $req to $qp"); + defined $qp->dispatch(split / +/, $req) + or $qp->respond(502, "command unrecognized: '$req'"); + } + } + delete $ready{$client}; + } + + foreach my $client ($select->can_write(1)) { + next unless $outbuffer{$client}; + #print "Writing to $client\n"; + + my $rv = $client->send($outbuffer{$client}, 0); + unless (defined($rv)) { + warn("I was told to write, but I can't: $!\n"); + next; + } + if ($rv == length($outbuffer{$client}) || + $! == POSIX::EWOULDBLOCK()) + { + #print "Sent all, or EWOULDBLOCK\n"; + if ($qp{$client}->{__quitting}) { + freeclient($client); + next; + } + substr($outbuffer{$client}, 0, $rv, ''); + delete($outbuffer{$client}) unless length($outbuffer{$client}); + } + else { + print "Error: $!\n"; + # Couldn't write all the data, and it wasn't because + # it would have blocked. Shut down and move on. + freeclient($client); + next; + } + } + } +} + +sub freeclient { + my $client = shift; + delete $inbuffer{$client}; + delete $outbuffer{$client}; + delete $ready{$client}; + delete $qp{$client}; + $select->remove($client); + close($client); +} + +sub start_connection { + my $self = shift; + my $remote_ip = shift; + my $remote_host = shift; + + $self->log(1, "Connection from $remote_host [$remote_ip]"); + my $remote_info = 'NOINFO'; + + # if the local dns resolver doesn't filter it out we might get + # ansi escape characters that could make a ps axw do "funny" + # things. So to be safe, cut them out. + $remote_host =~ tr/a-zA-Z\.\-0-9//cd; + + $self->SUPER::connection->start(remote_info => $remote_info, + remote_ip => $remote_ip, + remote_host => $remote_host, + @_); +} + +sub client { + my $self = shift; + @_ and $self->{_client} = shift; + $self->{_client}; +} + +sub nonblock { + my $socket = shift; + my $flags = fcntl($socket, F_GETFL, 0) + or die "Can't get flags for socket: $!"; + fcntl($socket, F_SETFL, $flags | O_NONBLOCK) + or die "Can't set flags for socket: $!"; +} + +sub read_input { + my $self = shift; + die "read_input is disabled in SelectServer"; + my $timeout = $self->config('timeout'); + alarm $timeout; + while () { + alarm 0; + $_ =~ s/\r?\n$//s; # advanced chomp + $self->log(1, "dispatching $_"); + defined $self->dispatch(split / +/, $_) + or $self->respond(502, "command unrecognized: '$_'"); + alarm $timeout; + } +} + +sub respond { + my ($self, $code, @messages) = @_; + my $client = $self->client || die "No client!"; + while (my $msg = shift @messages) { + my $line = $code . (@messages?"-":" ").$msg; + $self->log(1, ">$line"); + $outbuffer{$client} .= "$line\r\n"; + # print "$line\r\n" or ($self->log(1, "Could not print [$line]: $!"), return 0); + } + return 1; +} + +sub disconnect { + my $self = shift; + $self->SUPER::disconnect(@_); + $self->{__quitting} = 1; +} + +sub data { + my $self = shift; + $self->respond(503, "MAIL first"), return 1 unless $self->transaction->sender; + $self->respond(503, "RCPT first"), return 1 unless $self->transaction->recipients; + $self->respond(354, "go ahead"); + print "Setting indata for " . $self->client . "\n"; + $indata{$self->client()} = 1; + $self->{__buffer} = ''; + $self->{__size} = 0; + $self->{__blocked} = ""; + $self->{__in_header} = 1; + $self->{__complete} = 0; + $self->{__max_size} = $self->config('databytes') || 0; +} + +sub data_line { + my $self = shift; + local $_ = shift; + + if ($_ eq ".\r\n") { + $self->log(6, "max_size: $self->{__max_size} / size: $self->{__size}"); + + my $smtp = $self->connection->hello eq "ehlo" ? "ESMTP" : "SMTP"; + + if (!$self->transaction->header) { + $self->transaction->header(Mail::Header->new(Modify => 0, MailFrom => "COERCE")); + } + $self->transaction->header->add("Received", "from ".$self->connection->remote_info + ." (HELO ".$self->connection->hello_host . ") (".$self->connection->remote_ip + . ") by ".$self->config('me')." (qpsmtpd/".$self->version + .") with $smtp; ". (strftime('%a, %d %b %Y %H:%M:%S %z', localtime)), + 0); + + #$self->respond(550, $self->transaction->blocked),return 1 if ($self->transaction->blocked); + $self->respond(552, "Message too big!"),return 1 if $self->{__max_size} and $self->{__size} > $self->{__max_size}; + + my ($rc, $msg) = $self->run_hooks("data_post"); + if ($rc == DONE) { + return 1; + } + elsif ($rc == DENY) { + $self->respond(552, $msg || "Message denied"); + } + elsif ($rc == DENYSOFT) { + $self->respond(452, $msg || "Message denied temporarily"); + } + else { + $self->queue($self->transaction); + } + + # DATA is always the end of a "transaction" + return $self->reset_transaction; + } + + $self->respond(451, "See http://develooper.com/code/qpsmtpd/barelf.html"), exit + if $_ eq ".\n"; + + # add a transaction->blocked check back here when we have line by line plugin access... + unless (($self->{__max_size} and $self->{__size} > $self->{__max_size})) { + s/\r\n$/\n/; + s/^\.\./\./; + if ($self->{__in_header} and m/^\s*$/) { + $self->{__in_header} = 0; + my @header = split /\n/, $self->{__buffer}; + + # ... need to check that we don't reformat any of the received lines. + # + # 3.8.2 Received Lines in Gatewaying + # When forwarding a message into or out of the Internet environment, a + # gateway MUST prepend a Received: line, but it MUST NOT alter in any + # way a Received: line that is already in the header. + + my $header = Mail::Header->new(Modify => 0, MailFrom => "COERCE"); + $header->extract(\@header); + $self->transaction->header($header); + $self->{__buffer} = ""; + } + + if ($self->{__in_header}) { + $self->{__buffer} .= $_; + } + else { + $self->transaction->body_write($_); + } + $self->{__size} += length $_; + } +} + +1; diff --git a/qpsmtpd-server b/qpsmtpd-server new file mode 100755 index 0000000..9e3c232 --- /dev/null +++ b/qpsmtpd-server @@ -0,0 +1,28 @@ +#!/usr/bin/perl -Tw +# Copyright (c) 2001 Ask Bjoern Hansen. See the LICENSE file for details. +# The "command dispatch" system is taken from colobus - http://trainedmonkey.com/colobus/ +# +# this is designed to be run under tcpserver (http://cr.yp.to/ucspi-tcp.html) +# or inetd if you're into that sort of thing +# +# +# For more information see http://develooper.com/code/qpsmtpd/ +# +# + +use lib 'lib'; +use Qpsmtpd::SelectServer; +use strict; +$| = 1; + +delete $ENV{ENV}; +$ENV{PATH} = '/bin:/usr/bin:/var/qmail/bin'; + +Qpsmtpd::SelectServer->main(LocalPort => 2500); + +__END__ + + + + +1;