package Apache::SMTP;
use 5.006001;
use strict;
use warnings FATAL => 'all';
use Apache::Server ();
use Apache::ServerUtil ();
use Apache::Connection ();
use Apache::Const -compile => 'OK';
use Apache::TieBucketBrigade;
use Apache::SMTP::Server;
use Net::SMTP;
our $VERSION = '0.01';
sub handler {
my $c = shift;
my $ath = Apache::TieBucketBrigade->new_tie($c);
my $smtp = Apache::SMTP::Server->new(
handle_in => $ath,
handle_out => $ath,
);
$smtp->my_config($c);
$smtp->set_callback(HELO => \&validate_hostname);
$smtp->set_callback(RCPT => \&validate_recipient);
$smtp->set_callback(DATA => \&queue_message);
$smtp->set_callback(MAIL => \&validate_sender);
$smtp->process;
Apache::OK;
}
sub validate_hostname {
my ($session, $hostname) = @_;
return(1, 250, "ok");
}
sub validate_recipient {
my ($session, $recipient) = @_;
return(1, 250, "ok");
}
sub validate_sender {
my ($session, $sender) = @_;
return(1, 250, "ok");
}
sub queue_message {
my($session, $data) = @_;
my $sender = $session->get_sender();
my @recipients = $session->get_recipients();
my $mailhost = $session->get_mailhost();
my $mailport = $session->get_mailport();
my $mailip = $session->get_local_ip();
return(0, 554, 'Error: no valid recipients')
unless(@recipients);
my $msgid = add_queue({mailhost => $mailhost,
mailport => $mailport,
mailip => $mailip,
sender => $sender,
recipients => \@recipients,
data => $$data});
return(0) unless defined $msgid;
return(1, 250, "message queued $msgid");
}
sub add_queue {
my $args = shift;
my @recipients = @{$args->{recipients}};
my $smtp;
foreach (@recipients) {
return undef unless $smtp = Net::SMTP->new($args->{mailhost},
Port => $args->{mailport},
LocalAddr => $args->{mailip},);
return undef unless $smtp->mail($args->{sender});
return undef unless $smtp->to($_);
return undef unless $smtp->data();
return undef unless $smtp->datasend($args->{data});
return undef unless $smtp->dataend();
return undef unless $smtp->quit;
}
return (localtime())[0]; # lies that we tell - not a real msgid
}
1;
__END__
=head1 NAME
Apache::SMTP - A simple SMTP server using Apache and mod_perl made simple with
Apache::TieBucketBrigade
=head1 SYNOPSIS
Listen 127.0.0.1:25
<VirtualHost _default_:25>
PerlSetVar MailHost some.smtp.server
PerlSetVar MailPort 25
PerlModule Apache::SMTP
PerlProcessConnectionHandler Apache::SMTP
</VirtualHost>
=head1 DESCRIPTION
This implements a very simple SMTP server using Apache and mod_perl 2. The
current behavior is to immediately send (using Net::SMTP) any mail it
receives to the server set using
PerlSetVar MailHost
on
port PerlSetVar MailPort
Because of the above behavior, this module _may_ act as an ***OPEN RELAY***
which is a bad thing. So please do not configure it as such. Instead,
subclass this module and write your own validate_sender() and
validate_recipient() methods. Alternatively, do not have your mail server
allow relaying from this server's ip, and you should be ok.
Also, this module, despite the methods "add_queue" and "queue_message" does
not actually implement a queue in the normal MTA sense of the word. Maybe
you would like to implement one?
=head2 SUBCLASS
=over 4
You may want to subclass this module and write your own version of the
following
=item validate_hostname
sub validate_hostname {
my ($session, $hostname) = @_;
return(1, 250, "ok");
}
=item validate_sender
sub validate_sender {
my ($session, $sender) = @_;
return(1, 250, "ok");
}
=item validate_recipient
sub validate_recipient {
my ($session, $recipient) = @_;
return(1, 250, "ok");
}
=item queue_message
sub queue_message {
my($session, $data) = @_;
my $msgid = add_queue({mailhost => 'hostname',
mailport => '25',
mailip => '127.0.0.1',
sender => 'foo@example.com',
recipients => \('bar@example.com'),
data => $$data});
return(1, 250, "message queued $msgid");
}
=item add_queue
my $msgid = add_queue({mailhost => 'hostname',
mailport => '25',
mailip => '127.0.0.1',
sender => 'foo@example.com',
recipients => \('bar@example.com'),
data => 'somestuff'});
=head1 SEE ALSO
Apache::SMTP::Server
Apache::TieBucketBrigade
Net::Server::Mail::SMTP
Net::SMTP
mod_perl 2
=head1 AUTHOR
mock, E<lt>mock@obscurity.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2004 by Will Whittaker and Ken Simpson
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.
=cut