Brad Fitzpatrick posted a blurb on his blog about qpsmtpd, a SMTP server written in Perl. The whole server was designed to be controlled by plugins, so by itself, it answers connections and speaks the whole SMTP process. Each step has various hooks that can call out to different plugins, from the moment you connect, through the data stream, and through disconnect.
The cool thing about this is that you can inject certain checks to each part of the process without dealing with esoteric config files like the ones found in sendmail and postfix. With simple, short plugins with cached perl instances, you can intercept common spam tricks and viruses before it even touches your filesystem. That is cool. I played with it for a bit last night, and it looks really good. It's shockingly fast, and supports either prefork or Danga::Socket to spawn.
It appears that the primary purpose of the MTA is to act as a front end to a bigger MTA such as qmail or postfix. This is fine and dandy, but I was hoping to integrate it as a full delivery agent. There isn't much there to "seal the deal", as you can follow a mail all the way through, and then it either wants to deliver it to another SMTP server or inject it directly into another MTA's spool. There is a 'Maildir' plugin, but it will output to one Maildir. Yes. One Maildir. It seems to be best suited for a spamtrap or honeypot.
So, for anyone who is interested, I put together a quick and dirty hack based on the Maildir plugin. It requires a SQL database to check domains and users against, but you could comment that piece out if you didn't care. It still needs some work, it was created only so I can start playing with it. You have been warned. :)
The PostgreSQL Schema:
There's nothing special here, so you could use MySQL or SQLite pretty easily.
create table public.domain(
"domain_id" int4 not null default nextval('domain_domain_id_seq'::regclass) ,
"is_active" int2 not null default 1 ,
"domain_name" varchar(255) not null
)
WITHOUT OIDS;
ALTER table "public"."domain" OWNER TO "pgsql";
alter table "public"."domain" add primary key(domain_id);
create table public."user"(
"user_id" int4 not null default nextval('user_user_id_seq'::regclass) ,
"domain_id" int4 not null ,
"can_receive" int2 not null ,
"can_login" int2 not null ,
"username" varchar(255) not null
)
WITHOUT OIDS;
ALTER table "public"."user" OWNER TO "pgsql";
alter table "public"."user" add primary key(user_id);
The Perl plugin:
Stick this in plugins/queue/maildir-domain. This requires the Clone module from CPAN.
use File::Path qw(mkpath);
use Sys::Hostname qw(hostname);
use Time::HiRes qw(gettimeofday);
use Clone qw(clone);
use DBI;
sub register {
my ( $self, $qp, @args ) = @_;
$self->{_mdConfig} = {
maildirPath => '/home/smtpd/mail',
dbConnect => 'DBI:Pg:database=mail',
dbUser => 'pgsql',
dbPass => ''
};
my $hostname = ( hostname =~ m/([\w\._\-]+)/ )[0];
$self->{_hostname} = $hostname;
}
sub getDatabaseConnection {
my ( $self ) = @_;
# Cache a database handle
unless (defined $self->{_dbh}) {
$self->{_dbh} = DBI->connect(
$self->{_mdConfig}->{dbConnect},
$self->{_mdConfig}->{dbUser},
$self->{_mdConfig}->{dbPass}
);
}
# Cache used queries
unless (defined $self->{_queries}) {
$self->{_queries} = {};
# Get a domain
$self->{_queries}->{domain} = $self->{_dbh}->prepare_cached(q{
SELECT domain_id, domain_name
FROM domain
WHERE domain_name = ?
});
$self->{_queries}->{user} = $self->{_dbh}->prepare_cached(q{
SELECT user_id
FROM "user"
WHERE domain_id = ? AND username = ? AND can_receive = 1
});
}
}
# Use the stoored/prepared query to grab a domain record from a domain name
sub getDomainByName {
my ( $self, $domainName ) = @_;
my $result = {};
$self->{_queries}->{domain}->execute($domainName);
while (my $rec = $self->{_queries}->{domain}->fetchrow_hashref) {
$result->{domainId} = $rec->{domain_id};
$result->{domainName} = $rec->{domain_name};
}
if (defined $result->{domainId}) {
return $result;
}
return undef;
}
# Use the stored/prepared query to grab a user based on domain ID and username
sub getUserByName {
my ( $self, $domainId, $username ) = @_;
my $userId;
$self->{_queries}->{user}->execute($domainId, $username);
while (my $rec = $self->{_queries}->{user}->fetchrow_hashref) {
$userId = $rec->{user_id};
}
return $userId;
}
sub hook_queue {
my ( $self, $masterTransaction ) = @_;
my $maildirCounter = 0;
my $successCount = 0;
$self->getDatabaseConnection();
foreach my $recipient ($masterTransaction->recipients()) {
# Get info from database
my $domainRef = $self->getDomainByName($recipient->host);
next unless (defined $domainRef);
my $userId = $self->getUserByName($domainRef->{domainId}, $recipient->user);
next unless (defined $userId and $userId > 0);
# Get maildir, verify it exists
my $maildir = join("/",
$self->{_mdConfig}->{maildirPath},
$recipient->host,
$recipient->user
);
foreach (qw/cur tmp new/) {
my $dir = $maildir . "/" . $_;
mkpath($dir, 0, 0700) unless (-e $dir);
}
# Get a copy of the transaction for this recipient
my $transaction = clone($masterTransaction);
# Parse time
my ( $time, $microseconds ) = gettimeofday;
$time = ( $time =~ m/(\d+)/ )[0];
$microseconds =~ s/\D//g;
# Generate identifier
my $unique = "P$$" . "M$microseconds" . "Q" . $maildirCounter++;
my $file = join(".", $time, $unique, $self->{_hostname});
$transaction->header->add( 'Delivered-To', $recipient->address, 0 );
# Create new message in Maildir
open( MF, ">$maildir/tmp/$file" )
or $self->log( LOGWARN, "could not open $maildir/tmp/$file: $!" ),
return ( DECLINED, "queue error (open)" );
$transaction->header->print( \*MF );
$transaction->body_resetpos;
while ( my $line = $transaction->body_getline ) {
print MF $line;
}
close(MF)
or $self->log( LOGWARN, "could not close $maildir/tmp/$file: $!" )
and return ( DECLINED, "queue error (close)" );
# Associate as new message
link("$maildir/tmp/$file", "$maildir/new/$file")
or $self->log( LOGWARN, "could not link $maildir/tmp/$file to $maildir/new/$file: $!" )
and return ( DECLINED, "queue error (link)" );
# Remove from /tmp
unlink "$maildir/tmp/$file";
$successCount++;
}
my $messageId = ($masterTransaction->header->get('Message-Id') or '');
$messageId =~ s/[\r\n].*//s;
# If we delivered to anyone, call it good!
if ($successCount > 0) {
return ( OK, "Queued! $messageId" );
} else {
return ( DENY );
}
}
Leave a comment