1#!perl -w
2
3=head1 NAME
4
5queue/maildir
6
7=head1 DESCRIPTION
8
9This plugin delivers mails to a maildir spool.
10
11=head1 CONFIG
12
13It takes one required parameter, the location of the maildir.
14
15A second optional parameter delivers the mail into a sub directory named by
16the recipient of the mail B<for each recipient>. Some substituions take place.
17Before replacing the parts descibed below, any character of the recipient
18address, which is not one of C<-A-Za-z0-9+_.,@=> is set to a C<_>.
19
20If a third parameter is given, it will be used as octal (!) permisson of the
21newly created files and directories, any execute bits will be stripped for
22files: Use C<770> to create group writable directories and files with mode
23C<0660>.
24
25=head2 Maildir spool directory substitutions
26
27=over 4
28
29=item %l
30
31Replaced by the local part of the address (i.e. the username)
32
33=item %d
34
35Replaced by the domain part of the address (i.e. the domain name)
36
37=item %u
38
39Replaced by the full address.
40
41=cut 
42
43# =item %%
44#
45# Replaced by a single percent sign (%)
46#
47# =cut
48
49=back
50
51Examples: if the plugin is loaded with the parameters
52
53  queue/maildir /var/spool/qpdeliver %d/%l
54
55and the recipient is C<user@example.com> the mails will be written to
56the C<new> sub directory of C</var/spool/qpdeliver/example.com/user/>.
57
58With
59
60  queue/maildir /var/spool/qpdeliver %u
61
62and a recipient of C<user@example.org> the mail goes to
63C</var/spool/qpdeliver/user@example.org>.
64
65=head1 NOTES
66
67Names of the substitution parameters and the replaced charachters are the same
68L<spamd(8)> supports, for more info see the C<--virtual-config-dir>
69option of L<spamd(8)>.
70
71When called with more than one parameter, this plugin is probably not usable
72with qpsmtpd-async.
73
74With the the second parameter being C<%d> it will still deliver one message
75for each recipient: With the two recpients C<user@example.org> and
76C<user2@example.org> you get two messages in the C<example.org/> directory.
77
78=cut
79
80use File::Path qw(mkpath);
81use Sys::Hostname qw(hostname);
82use Time::HiRes qw(gettimeofday);
83
84sub register {
85    my ($self, $qp, @args) = @_;
86
87    if (@args > 0) {
88        ($self->{_maildir}) = ($args[0] =~ m!([-/\w\.]+)!);
89    }
90
91    if (@args > 1) {
92        ($self->{_subdirs}) = ($args[1] =~ m#^(.*\%[ldu].*)$#);
93        unless ($self->{_subdirs}) {
94            $self->log(LOGWARN,
95                           "WARNING: sub directory does not contain a "
96                         . "substitution parameter"
97                      );
98            return 0;
99        }
100    }
101
102    if (@args > 2) {
103        ($self->{_perms}) = ($args[2] =~ /^([0-7]{3})$/);
104        unless ($self->{_perms}) {    # 000 is unfortunately true ;-)
105            $self->log(LOGWARN, "WARNING: mode is not an octal number");
106            return 0;
107        }
108        $self->{_perms} = oct($self->{_perms});
109    }
110
111    $self->{_perms} = 0700
112      unless $self->{_perms};
113
114    unless ($self->{_maildir}) {
115        $self->log(LOGWARN, "WARNING: maildir directory not specified");
116        return 0;
117    }
118
119    unless ($self->{_subdirs}) {
120
121        # mkpath is influenced by umask...
122        my $old_umask = umask 000;
123        map {
124            my $d = $self->{_maildir} . "/$_";
125            -e $d or mkpath $d, 0, $self->{_perms}
126        } qw(cur tmp new);
127        umask $old_umask;
128    }
129
130    my $hostname = (hostname =~ m/([\w\._\-]+)/)[0];
131    $self->{_hostname} = $hostname;
132
133}
134
135my $maildir_counter = 0;
136
137sub hook_queue {
138    my ($self, $transaction) = @_;
139    my ($rc, @msg);
140    my $old_umask = umask($self->{_perms} ^ 0777);
141
142    if ($self->{_subdirs}) {
143        foreach my $addr ($transaction->recipients) {
144            ($rc, @msg) = $self->deliver_user($transaction, $addr);
145            unless ($rc == OK) {
146                umask $old_umask;
147                return ($rc, @msg);
148            }
149        }
150        umask $old_umask;
151        return (OK, @msg);    # last @msg is the same like any other before...
152    }
153
154    $transaction->header->add('Delivered-To', $_->address, 0)
155      for $transaction->recipients;
156    ($rc, @msg) = $self->write_file($transaction, $self->{_maildir});
157    umask $old_umask;
158    return ($rc, @msg);
159}
160
161sub write_file {
162    my ($self, $transaction, $maildir, $addr) = @_;
163    my ($time, $microseconds) = gettimeofday;
164
165    $time = ($time =~ m/(\d+)/)[0];
166    $microseconds =~ s/\D//g;
167
168    my $unique = "P$$" . "M$microseconds" . "Q" . $maildir_counter++;
169    my $file = join ".", $time, $unique, $self->{_hostname};
170
171    open(MF, ">$maildir/tmp/$file")
172      or $self->log(LOGWARN, "could not open $maildir/tmp/$file: $!"),
173      return (DECLINED, "queue error (open)");
174
175    print MF "Return-Path: ", $transaction->sender->format, "\n";
176
177    print MF "Delivered-To: ", $addr->address, "\n"
178      if $addr;    # else it had been added before...
179
180    $transaction->header->print(\*MF);
181    $transaction->body_resetpos;
182    while (my $line = $transaction->body_getline) {
183        print MF $line;
184    }
185    close MF
186      or $self->log(LOGWARN, "could not close $maildir/tmp/$file: $!")
187      and return (DECLINED, "queue error (close)");
188
189    link "$maildir/tmp/$file",
190      "$maildir/new/$file"
191      or $self->log(LOGWARN,
192                  "could not link $maildir/tmp/$file to $maildir/new/$file: $!")
193      and return (DECLINED, "queue error (link)");
194
195    unlink "$maildir/tmp/$file";
196
197    my $msg_id = $transaction->header->get('Message-Id') || '';
198    $msg_id =~ s/[\r\n].*//s;
199
200    return (OK, "Queued! $msg_id");
201}
202
203sub deliver_user {
204    my ($self, $transaction, $addr) = @_;
205    my $user = $addr->user;
206    $user =~ tr/-A-Za-z0-9+_.,@=/_/c;
207    my $host = $addr->host;
208    $host =~ tr/-A-Za-z0-9+_.,@=/_/c;
209    my $rcpt = $user . '@' . $host;
210
211    my $subdir = $self->{_subdirs};
212    $subdir =~ s/\%l/$user/g;
213    $subdir =~ s/\%d/$host/g;
214    $subdir =~ s/\%u/$rcpt/g;
215
216    #  $subdir =~ s/\%%/%/g;
217
218    my $maildir   = $self->{_maildir} . "/$subdir";
219    my $old_umask = umask 000;
220    map { my $d = $maildir . "/$_"; -e $d or mkpath $d, 0, $self->{_perms} }
221      qw(cur tmp new);
222    umask $old_umask;
223
224    return $self->write_file($transaction, $maildir, $addr);
225}
226
227