qpsmtpd/plugins/queue/maildir

#!perl -w

=head1 NAME

queue/maildir

=head1 DESCRIPTION

This plugin delivers mails to a maildir spool.

=head1 CONFIG

It takes one required parameter, the location of the maildir.

A second optional parameter delivers the mail into a sub directory named by 
the recipient of the mail B<for each recipient>. Some substituions take place.
Before replacing the parts descibed below, any character of the recipient 
address, which is not one of C<-A-Za-z0-9+_.,@=> is set to a C<_>.

If a third parameter is given, it will be used as octal (!) permisson of the
newly created files and directories, any execute bits will be stripped for 
files: Use C<770> to create group writable directories and files with mode 
C<0660>.

=head2 Maildir spool directory substitutions

=over 4

=item %l

Replaced by the local part of the address (i.e. the username)

=item %d

Replaced by the domain part of the address (i.e. the domain name)

=item %u

Replaced by the full address.

=cut 

# =item %%
#
# Replaced by a single percent sign (%)
#
# =cut

=back

Examples: if the plugin is loaded with the parameters

  queue/maildir /var/spool/qpdeliver %d/%l

and the recipient is C<user@example.com> the mails will be written to
the C<new> sub directory of C</var/spool/qpdeliver/example.com/user/>.

With 

  queue/maildir /var/spool/qpdeliver %u

and a recipient of C<user@example.org> the mail goes to
C</var/spool/qpdeliver/user@example.org>.

=head1 NOTES

Names of the substitution parameters and the replaced charachters are the same
L<spamd(8)> supports, for more info see the C<--virtual-config-dir> 
option of L<spamd(8)>.

With the the second parameter being C<%d> it will still deliver one message 
for each recipient: With the two recpients C<user@example.org> and 
C<user2@example.org> you get two messages in the C<example.org/> directory.

=cut

use strict;

use File::Path qw(mkpath);
use Sys::Hostname qw(hostname);
use Time::HiRes qw(gettimeofday);

use Qpsmtpd::Constants;

sub register {
    my ($self, $qp, @args) = @_;

    if (@args > 0) {
        ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!);
    }

    if (@args > 1) {
        ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#);
        unless ($self->{_subdirs}) {
            $self->log(LOGWARN,
                           "WARNING: sub directory does not contain a "
                         . "substitution parameter"
                      );
            return 0;
        }
    }

    if (@args > 2) {
        ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/);
        unless ($self->{_perms}) {    # 000 is unfortunately true ;-)
            $self->log(LOGWARN, "WARNING: mode is not an octal number");
            return 0;
        }
        $self->{_perms} = oct($self->{_perms});
    }

    $self->{_perms} ||= 0700;

    unless ($self->{_maildir}) {
        $self->log(LOGWARN, "WARNING: maildir directory not specified");
        return 0;
    }

    unless ($self->{_subdirs}) {

        # mkpath is influenced by umask...
        my $old_umask = umask 000;
        map {
            my $d = $self->{_maildir} . "/$_";
            -e $d or mkpath $d, 0, $self->{_perms}
        } qw(cur tmp new);
        umask $old_umask;
    }

    my $hostname = (hostname =~ m/([\w\._\-]+)/)[0];
    $self->{_hostname} = $hostname;

}

my $maildir_counter = 0;

sub hook_queue {
    my ($self, $transaction) = @_;
    my ($rc, @msg);
    my $old_umask = umask($self->{_perms} ^ 0777);

    if ($self->{_subdirs}) {
        foreach my $addr ($transaction->recipients) {
            ($rc, @msg) = $self->deliver_user($transaction, $addr);
            unless ($rc == OK) {
                umask $old_umask;
                return ($rc, @msg);
            }
        }
        umask $old_umask;
        return (OK, @msg);    # last @msg is the same like any other before...
    }

    $transaction->header->add('Delivered-To', $_->address, 0)
      for $transaction->recipients;
    ($rc, @msg) = $self->write_file($transaction, $self->{_maildir});
    umask $old_umask;
    return ($rc, @msg);
}

sub write_file {
    my ($self, $transaction, $maildir, $addr) = @_;
    my ($time, $microseconds) = gettimeofday;

    $time = ($time =~ m/(\d+)/)[0];
    $microseconds =~ s/\D//g;

    my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++;
    my $file = join ".", $time, $unique, $self->{_hostname};

    open(MF, ">$maildir/tmp/$file")
      or $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
      return (DECLINED, "queue error (open)");

    print MF "Return-Path: ", $transaction->sender->format, "\n";

    print MF "Delivered-To: ", $addr->address, "\n"
      if $addr;    # else it had been added before...

    $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)");

    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)");

    unlink "$maildir/tmp/$file";

    my $msg_id = $transaction->header->get('Message-Id') || '';
    $msg_id =~ s/[\r\n].*//s;

    return (OK, "Queued! $msg_id");
}

sub deliver_user {
    my ($self, $transaction, $addr) = @_;
    my $user = $addr->user;
    $user =~ tr/-A-Za-z0-9+_.,@=/_/c;
    my $host = $addr->host;
    $host =~ tr/-A-Za-z0-9+_.,@=/_/c;
    my $rcpt = $user . '@' . $host;

    my $subdir = $self->{_subdirs};
    $subdir =~ s/\%l/$user/g;
    $subdir =~ s/\%d/$host/g;
    $subdir =~ s/\%u/$rcpt/g;

    #  $subdir =~ s/\%%/%/g;

    my $maildir   = $self->{_maildir} . "/$subdir";
    my $old_umask = umask 000;
    map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} }
      qw(cur tmp new);
    umask $old_umask;

    return $self->write_file($transaction, $maildir, $addr);
}