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