Connection handler for mod_perl/apache 2.0
git-svn-id: https://svn.perl.org/qpsmtpd/trunk@334 958fd67b-6ff1-0310-b445-bb7760255be9
This commit is contained in:
Matt Sergeant
parent
8ea1b6b06c
commit
e2bb53901d
219
lib/Apache/Qpsmtpd.pm
Normal file
219
lib/Apache/Qpsmtpd.pm
Normal file
@ -0,0 +1,219 @@
|
|||||||
|
# $Id$
|
||||||
|
|
||||||
|
package Apache::Qpsmtpd;
|
||||||
|
|
||||||
|
use 5.006001;
|
||||||
|
use strict;
|
||||||
|
use warnings FATAL => 'all';
|
||||||
|
|
||||||
|
use Apache::ServerUtil ();
|
||||||
|
use Apache::Connection ();
|
||||||
|
use Apache::Const -compile => qw(OK MODE_GETLINE);
|
||||||
|
use APR::Const -compile => qw(SO_NONBLOCK EOF SUCCESS);
|
||||||
|
use APR::Error ();
|
||||||
|
use APR::Brigade ();
|
||||||
|
use APR::Bucket ();
|
||||||
|
use APR::Socket ();
|
||||||
|
use Apache::Filter ();
|
||||||
|
use ModPerl::Util ();
|
||||||
|
# use Apache::TieBucketBrigade;
|
||||||
|
|
||||||
|
our $VERSION = '0.01';
|
||||||
|
|
||||||
|
sub handler {
|
||||||
|
my Apache::Connection $c = shift;
|
||||||
|
$c->client_socket->opt_set(APR::SO_NONBLOCK => 0);
|
||||||
|
|
||||||
|
my $qpsmtpd = Qpsmtpd::Apache->new();
|
||||||
|
$qpsmtpd->start_connection(
|
||||||
|
ip => $c->remote_ip,
|
||||||
|
host => $c->remote_host,
|
||||||
|
info => undef,
|
||||||
|
dir => $c->base_server->dir_config('QpsmtpdDir'),
|
||||||
|
conn => $c,
|
||||||
|
);
|
||||||
|
|
||||||
|
$qpsmtpd->run($c);
|
||||||
|
|
||||||
|
return Apache::OK;
|
||||||
|
}
|
||||||
|
|
||||||
|
package Qpsmtpd::Apache;
|
||||||
|
|
||||||
|
use Qpsmtpd::Constants;
|
||||||
|
use base qw(Qpsmtpd::SMTP);
|
||||||
|
|
||||||
|
sub start_connection {
|
||||||
|
my $self = shift;
|
||||||
|
my %opts = @_;
|
||||||
|
|
||||||
|
$self->{qpdir} = $opts{dir};
|
||||||
|
$self->{conn} = $opts{conn};
|
||||||
|
$self->{conn}->client_socket->timeout_set($self->config('timeout') * 1_000_000);
|
||||||
|
$self->{bb_in} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
|
||||||
|
$self->{bb_out} = APR::Brigade->new($self->{conn}->pool, $self->{conn}->bucket_alloc);
|
||||||
|
|
||||||
|
my $remote_host = $opts{host} || ( $opts{ip} ? "[$opts{ip}]" : "[noip!]");
|
||||||
|
my $remote_info = $opts{info} ? "$opts{info}\@$remote_host" : $remote_host;
|
||||||
|
my $remote_ip = $opts{ip};
|
||||||
|
|
||||||
|
$self->log(LOGNOTICE, "Connection from $remote_info [$remote_ip]");
|
||||||
|
|
||||||
|
$self->SUPER::connection->start(
|
||||||
|
remote_info => $remote_info,
|
||||||
|
remote_ip => $remote_ip,
|
||||||
|
remote_host => $remote_host,
|
||||||
|
@_);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub config {
|
||||||
|
my $self = shift;
|
||||||
|
my ($param, $type) = @_;
|
||||||
|
if (!$type) {
|
||||||
|
my $opt = $self->{conn}->base_server->dir_config("qpsmtpd.$param");
|
||||||
|
return $opt if defined($opt);
|
||||||
|
}
|
||||||
|
return $self->SUPER::config(@_);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub run {
|
||||||
|
my $self = shift;
|
||||||
|
|
||||||
|
# should be somewhere in Qpsmtpd.pm and not here...
|
||||||
|
$self->load_plugins;
|
||||||
|
|
||||||
|
my $rc = $self->start_conversation;
|
||||||
|
return if $rc != DONE;
|
||||||
|
|
||||||
|
# this should really be the loop and read_input should just
|
||||||
|
# get one line; I think
|
||||||
|
$self->read_input();
|
||||||
|
}
|
||||||
|
|
||||||
|
sub config_dir {
|
||||||
|
my $self = shift;
|
||||||
|
return "$self->{qpdir}/config";
|
||||||
|
}
|
||||||
|
|
||||||
|
sub plugin_dir {
|
||||||
|
my $self = shift;
|
||||||
|
return "$self->{qpdir}/plugins";
|
||||||
|
}
|
||||||
|
|
||||||
|
sub getline {
|
||||||
|
my $self = shift;
|
||||||
|
my $c = $self->{conn} || die "Cannot getline without a conn";
|
||||||
|
|
||||||
|
return if $c->aborted;
|
||||||
|
|
||||||
|
my $bb = $self->{bb_in};
|
||||||
|
|
||||||
|
while (1) {
|
||||||
|
my $rc = $c->input_filters->get_brigade($bb, Apache::MODE_GETLINE);
|
||||||
|
return if $rc == APR::EOF;
|
||||||
|
die APR::Error::strerror($rc) unless $rc == APR::SUCCESS;
|
||||||
|
|
||||||
|
while (!$bb->is_empty) {
|
||||||
|
my $b = $bb->first;
|
||||||
|
$b->remove;
|
||||||
|
$b->read(my $data);
|
||||||
|
return $data if index($data, "\n") >= 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return '';
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_input {
|
||||||
|
my $self = shift;
|
||||||
|
my $c = $self->{conn};
|
||||||
|
|
||||||
|
while (defined(my $data = $self->getline)) {
|
||||||
|
$data =~ s/\r?\n$//s; # advanced chomp
|
||||||
|
$self->log(LOGDEBUG, "dispatching $data");
|
||||||
|
defined $self->dispatch(split / +/, $data)
|
||||||
|
or $self->respond(502, "command unrecognized: '$data'");
|
||||||
|
last if $self->{_quitting};
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub respond {
|
||||||
|
my ($self, $code, @messages) = @_;
|
||||||
|
my $c = $self->{conn};
|
||||||
|
while (my $msg = shift @messages) {
|
||||||
|
my $bb = $self->{bb_out};
|
||||||
|
my $line = $code . (@messages?"-":" ").$msg;
|
||||||
|
$self->log(LOGDEBUG, $line);
|
||||||
|
my $bucket = APR::Bucket->new("$line\r\n");
|
||||||
|
$bb->insert_tail($bucket);
|
||||||
|
$c->output_filters->fflush($bb);
|
||||||
|
$bucket->remove;
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub disconnect {
|
||||||
|
my $self = shift;
|
||||||
|
$self->SUPER::disconnect(@_);
|
||||||
|
$self->{_quitting} = 1;
|
||||||
|
$self->{conn}->client_socket->close();
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
Apache::Qpsmtpd - a mod_perl-2 connection handler for qpsmtpd
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
Listen 0.0.0.0:25
|
||||||
|
|
||||||
|
LoadModule perl_module modules/mod_perl.so
|
||||||
|
|
||||||
|
<Perl>
|
||||||
|
use lib qw( /path/to/qpsmtpd/lib );
|
||||||
|
use Apache::Qpsmtpd;
|
||||||
|
</Perl>
|
||||||
|
|
||||||
|
<VirtualHost _default_:25>
|
||||||
|
PerlSetVar QpsmtpdDir /path/to/qpsmtpd
|
||||||
|
PerlModule Apache::Qpsmtpd
|
||||||
|
PerlProcessConnectionHandler Apache::Qpsmtpd
|
||||||
|
PerlSetVar qpsmtpd.loglevel 4
|
||||||
|
</VirtualHost>
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
This module implements a mod_perl/apache 2.0 connection handler
|
||||||
|
that turns Apache into an SMTP server using Qpsmtpd.
|
||||||
|
|
||||||
|
It also allows you to set single-valued config options (such
|
||||||
|
as I<loglevel>, as seen above) using C<PerlSetVar> in F<httpd.conf>.
|
||||||
|
|
||||||
|
This module should be considered beta software as it is not yet
|
||||||
|
widely tested. However it is currently the fastest way to run
|
||||||
|
Qpsmtpd, so if performance is important to you then consider this
|
||||||
|
module.
|
||||||
|
|
||||||
|
=head1 BUGS
|
||||||
|
|
||||||
|
Currently the F<check_early_talker> plugin will not work because it
|
||||||
|
relies on being able to do C<select()> on F<STDIN> which does not
|
||||||
|
work here. It should be possible with the next release of mod_perl
|
||||||
|
to do a C<poll()> on the socket though, so we can hopefully get
|
||||||
|
that working in the future.
|
||||||
|
|
||||||
|
Other operations that perform directly on the STDIN/STDOUT filehandles
|
||||||
|
will not work.
|
||||||
|
|
||||||
|
=head1 AUTHOR
|
||||||
|
|
||||||
|
Matt Sergeant, <matt@sergeant.org>
|
||||||
|
|
||||||
|
Some credit goes to <mock@obscurity.org> for Apache::SMTP which gave
|
||||||
|
me the inspiration to do this.
|
||||||
|
|
||||||
|
=cut
|
||||||
Loading…
Reference in New Issue
Block a user