source: bearmail/lib/BearMail/Backend/Files.pm

Last change on this file was 532, checked in by zecrazytux, 10 years ago

Do not override Perl's builtin stat method with the File::stat one

File size: 12.9 KB
Line 
1package BearMail::Backend::Files;
2
3# Copyright (C) 2009 Bearstech - http://bearstech.com/
4#
5# This program is free software: you can redistribute it and/or modify
6# it under the terms of the GNU General Public License as published by
7# the Free Software Foundation, either version 3 of the License, or
8# (at your option) any later version.
9#
10# This program is distributed in the hope that it will be useful,
11# but WITHOUT ANY WARRANTY; without even the implied warranty of
12# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13# GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License
16# along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18use Digest::MD5 qw(md5 md5_hex md5_base64);
19use Carp;
20use Exporter 'import';
21use Fcntl ':flock';
22use File::stat ();
23@EXPORT_OK = qw(get_accounts new commit apply get_domains get_users get_user set_domain set_address add_domain add_address del_domain del_address get_postmasters get_postmaster_domains); 
24
25# Implement mail-platform configuration via a plain file storage schema.
26#
27# All informations is stored in a 'mailmap' (default: /etc/bearmail/mailmap)
28# which is a simple passwd-style text file, with one entry per line and fields
29# separated by semi-colons. An entry is a mail account definition (address,
30# password, routing).
31#
32# FIXME: there is no locking mechanism. Between the time where mailmap is read
33# (at object construction time) and written again (via the commit() method,
34# nobody should be hable to access (read and write) the mailmap. This should
35# be fixed easily since this backend is meant to be used with an 'instant'
36# read/modify/write cycle (from web or cli).
37
38# 2009-12-09 vcaron@bearstech.com : this is a simple API over the existing code
39# from 'bearmail-update' which has been stashed in the 'Implementation' part
40# of this package.
41
42
43#
44### Exported methods
45#
46
47sub new() {
48  my ($class, %args) = @_;
49
50  croak("Please set mailmap's path in your bearmail.conf configuration file") if not defined $args{'mailmap'};
51
52  my $self = {
53    records => {},
54    by_domain => {},
55    domains => [],
56    mailmap => $args{'mailmap'},
57    debug => 0 + defined $args{'debug'},
58    mtime => 0, #FIXME
59    files => {},
60    allowed => {
61      'addr_normal pw_md5 local'           => 'regular_account',
62      'addr_normal pw_none aliases'        => 'alias',
63      'addr_normal pw_none pipe'           => 'pipe',
64      'addr_catchall pw_none aliases'      => 'catchall',
65      'addr_catchall pw_none domain_alias' => 'domain_alias',
66    },
67  };
68
69
70  bless $self, $class;
71
72  $self->_read_mailmap();
73  return $self;
74}
75
76sub commit() {
77  my ($self) = @_;
78  $self->_sort_mailmap();
79  $self->_write_mailmap();
80}
81
82sub apply() {
83  my ($self) = @_;
84  $self->_sort_mailmap();
85  $self->_prepare_postfix_conf();
86  $self->_prepare_dovecot_conf();
87  $self->_write_conf();
88}
89
90sub get_domains() {
91  my ($self) = @_;
92  return @{$self->{domains}};
93}
94
95sub get_users() {
96  my ($self, $domain) = @_;
97  return @{$self->{by_domain}{$domain}};
98}
99
100sub get_user() {
101  my ($self, $user) = @_;
102  return $self->{records}{lc $user};
103}
104
105sub set_domain() {
106}
107sub set_address() {
108}
109
110sub add_domain() {
111  my ($self, $domain, $postmaster, $password) = @_;
112
113  if(exists($self->{by_domain}->{$domain})) {
114    carp "Domain $domain already exist !";
115    return 0;
116  }
117
118  if($postmaster eq "postmaster@".$domain) {
119    $self->add_address($postmaster, $password, "local");
120  } else {
121    $self->add_address("postmaster@".$domain, '', $postmaster);
122  }
123}
124
125sub add_address() {
126  my ($self, $address, $password, $target) = @_;
127  my @types;
128  $password = md5_hex($password)
129    if((not $password =~ /^[0-9a-f]{32}$/) and ($target eq "local"));
130
131  push @types, $self->_check_field("address", $address);
132  push @types, $self->_check_field("password", $password);
133  push @types, $self->_check_field("target", $target);
134
135  if(!exists($self->{allowed}{"@types"})) {
136    carp "Bad configuration\n";
137    return 0;
138  } else {
139    $self->{records}->{"$address"} = { 
140              address => $address,
141              password => $password,
142              target => $target
143    }; 
144  }
145}
146
147sub del_domain() {
148  my ($self, $domain) = @_;
149  if(scalar(@{$self->{by_domain}->{$domain}}) le 1) {
150    delete($self->{records}->{"postmaster\@$domain"});
151  } else {
152    carp "There are remaining email addresses for this domain !\n";
153    carp "Delete them first !\n";
154  }
155}
156
157sub del_address() {
158  my ($self, $address) = @_;
159  delete($self->{records}->{"$address"});
160}
161
162sub get_postmasters() {
163  my ($self) = @_;
164  my %npostmasters;
165  foreach(keys(%{$self->{postmasters}})) {
166    $npostmasters{$_} = $self->{postmasters}->{$_}->{password};
167  }
168#my %npostmasters = map { $_ => $postmasters{$_}->{password} } %postmasters;
169  return \%npostmasters;
170}
171
172sub get_postmaster_domains() {
173  my ($self, $user) = @_;
174  my @hashed;
175  push(@hashed, { name => $_ }) foreach @{$self->{postmasters}->{$user}->{domains}};
176  return @hashed;
177}
178
179
180
181#
182### Implementation (non-exported methods)
183#
184
185
186# Read a simple "mailmap" configuration file, where:
187#  - empty lines are ignored
188#  - lines beginning with a '#' are ignored
189#  - all other lines are counted as a 'record'.
190#
191# A record is ':'-delimited field list, with currently in this order:
192#  - a (source) email 'adresss' (*@domain.com for catch-all)
193#  - a MD5-hashed 'password' (128bits hexa)
194#  - a 'target' (local delivery, aliases, domain alias, program)
195#
196sub _read_mailmap {
197  my ($self) = @_;
198
199#FIXME  return if defined($self->{records}); # Parse mailmap only once
200  open(MAILMAP, "<$self->{mailmap}") or croak "$self->{mailmap}: $!";
201  flock(MAILMAP, LOCK_NB);
202  $self->{mtime} = File::stat::stat($self->{mailmap})->mtime;
203
204  while(<MAILMAP>) {
205    chomp;
206    next if /^$/ or /^#/;  # Ignore empty lines and comments
207
208    my @fields = split /:/;
209    croak "got ".scalar(@fields)." fields, expected 3" if @fields != 3;
210
211    my %rec;
212    my @types;
213    foreach ('address', 'password', 'target') {
214      my $field = shift @fields;
215      push @types, $self->_check_field($_, $field);
216      $rec{$_} = $field;
217    }
218
219    my $type = $self->{allowed}->{"@types"};
220    croak "unsupported configuration (@types)" if !defined $type;
221
222    # Users are key'ed by lowercase address (must be unique)
223    $self->{records}->{lc $rec{'address'}} = \%rec;
224  }
225
226  flock(MAILMAP, LOCK_UN);
227  close(MAILMAP);
228  $self->_sort_mailmap();
229}
230
231sub _write_mailmap {
232  my ($self) = @_;
233
234  my $m = File::stat::stat($self->{mailmap})->mtime;
235  if($m ne $self->{mtime}) {
236    warn "File was modified by a non-locking friendly program since last parsing, won't merge";
237    return 0;
238  }
239
240  open(MAILMAP, ">$self->{mailmap}") or croak "$self->{mailmap}: $!";
241  flock(MAILMAP, LOCK_EX | LOCK_NB)
242    or croak "Can't get exclusive lock on $mailmap: $!";
243
244  foreach(keys %{$self->{records}}) {
245    print MAILMAP $self->{records}->{$_}->{"address"}, ":", $self->{records}->{$_}->{"password"},
246       ":", $self->{records}->{$_}->{"target"}, "\n"
247       or croak("Can't write mailmap $self->{mailmap}: $!");
248  }
249
250  flock(MAILMAP, LOCK_UN);
251  close(MAILMAP);
252}
253
254# Field constraints. See https://scratch.bearstech.com/trac/ticket/34
255#
256sub _check_field {
257  my ($self, $key, $val) = @_;
258
259  if ($key eq 'address') {
260    my $addr = $val;
261    $addr =~ s/^\*@/x@/;  # Allow catch-all
262    croak "malformed address: $val" if not $self->_check_address($addr);
263    croak "non-unique address: $val" if defined $records{lc $val};
264
265    return $val =~ m/^\*@/ ? 'addr_catchall' : 'addr_normal';
266  }
267  elsif ($key eq 'password') {
268    return 'pw_none' if $val eq '';  # Non-login account
269    croak "malformed password hash: $val" if not $val =~ /^[0-9a-f]{32}$/;
270
271    return 'pw_md5';
272  }
273  elsif ($key eq 'target') {
274    return 'local' if $val eq 'local';  # Regular local IMAP account
275    return 'pipe'  if $val =~ /^\|/;    # Pipe to a program (path unchecked)
276    my $type = ($val =~ s/^\*@/x@/) ?   # Allow domain aliases (a single *@-like address)
277      'domain_alias' : 'aliases';
278    my @aliases = split(/,/, $val);
279    croak "can ony alias one domain at once" if @aliases > 1 && $type eq 'domain_alias';
280
281    foreach (@aliases) {
282      croak "malformed address: $_" if not $self->_check_address($_);
283    }
284    return $type;
285  }
286}
287
288# Email address basic check. It's a (small) RFC822 subset.
289#
290sub _check_address {
291  my ($self, $address) = @_;
292  return $address =~ /^[A-Za-z0-9\-\._]+@[A-Za-z0-9\-\.]+$/;
293}
294
295# Conf generators will have a prettier output if they sord records
296# by domains, then by local part. Fill in @domains also.
297#
298sub _sort_mailmap {
299  my ($self) = @_;
300
301  #FIXME ok ?
302  # Reset data structures before sorting (to be able to re-sort on modifications)
303  $self->{by_domain} = ();
304  $self->{domains} = [];
305
306  foreach(keys %{$self->{records}}) {
307    /^([^@]+)@([^@]+)$/;
308    my ($local, $domain) = ($1, $2);
309
310    $self->{by_domain}->{$domain} = [] if !defined $self->{by_domain}->{$domain};
311    $self->{records}->{$_}->{'address_local'} = $local;
312    push @{$self->{by_domain}->{$domain}}, $self->{records}->{$_};
313  }
314
315  foreach my $dom (keys %{$self->{by_domain}}) {
316    @{$self->{by_domain}->{$dom}} = sort { $a->{'address'} cmp $b->{'address'} } @{$self->{by_domain}->{$dom}};
317    foreach(@{$self->{by_domain}->{$dom}}) {
318      next if ($_->{address_local} ne 'postmaster');
319      if($_->{password}) {
320        if(exists($self->{postmasters}->{$_->{address}})) {
321          push(@{$self->{postmasters}->{$_->{address}}->{domains}}, $dom);
322        } else {
323          $self->{postmasters}->{$_->{address}} = { password => $_->{password}, domains => [ $dom ] };
324        }
325      } else {
326        foreach(split(',', $_->{target})) {
327          if(exists($self->{records}->{$_})) {
328            next unless defined($self->{records}->{$_}->{password}); # FIXME: keep ? Security purpose: don't keep postmasters without passwords
329            if(exists($self->{postmasters}->{$_})) {
330              push(@{$self->{postmasters}->{$_}->{domains}}, $dom);
331            } else {
332              $self->{postmasters}->{$_} = { password => $self->{records}->{$_}->{password}, domains => [ $dom ] };
333            }
334          }
335        }
336      }
337    }
338  }
339  @{$self->{domains}} = sort keys %{$self->{by_domain}};
340}
341
342# Postfix conf files, expected settings in main.cf:
343#   virtual_mailbox_domains   = hash:/etc/bearmail/postfix/virtual_domains
344#   virtual_mailbox_mailboxes = hash:/etc/bearmail/postfix/virtual_mailboxes
345#   virtual_alias_maps        = hash:/etc/bearmail/postfix/virtual_aliases
346#   alias_maps                = hash:/etc/aliases,
347#                               hash:/etc/bearmail/postfix/virtual_pipes
348sub _prepare_postfix_conf {
349  my ($self) = @_;
350  my $virtual_domains   = join("\n", map { "$_ dummy" } @{$self->{domains}});
351  my $virtual_mailboxes = '';
352  my $virtual_aliases   = '';
353  my $virtual_pipes     = '';
354
355  foreach my $d (@{$self->{domains}}) {
356    my $comment = $virtual_mailboxes eq '' ? "" : "\n";
357    $comment .= "# $d\n#\n";
358    $virtual_mailboxes .= $comment;
359    $virtual_aliases   .= $comment;
360
361    foreach (@{$self->{by_domain}->{$d}}) {
362      my $address = $_->{'address'};
363      my $target  = $_->{'target'};
364      $address =~ s/^\*//;    # Fix catch-all syntax
365      $target  =~ s/\*@/@/g;  # Fix domain aliasing syntax
366
367      if ($target eq 'local') {
368        $virtual_mailboxes .= "$address $d/$_->{'address_local'}/Maildir/\n";
369        $virtual_aliases   .= "$address $address\n";
370      }
371      elsif ($target =~ /^\|/) {
372        my $alias = "$_->{'address_local'}-$d-pipe";
373        $virtual_aliases .= "$address $alias\n";
374        $virtual_pipes   .= "$alias $target\n";
375      }
376      else {
377        $virtual_aliases .= "$address $target\n";
378      }
379    }
380  }
381
382  $self->{files}->{'/etc/bearmail/postfix/virtual_domains'}   = $virtual_domains;
383  $self->{files}->{'/etc/bearmail/postfix/virtual_mailboxes'} = $virtual_mailboxes;
384  $self->{files}->{'/etc/bearmail/postfix/virtual_aliases'}   = $virtual_aliases;
385  $self->{files}->{'/etc/bearmail/postfix/virtual_pipes'}     = $virtual_pipes;
386}
387
388# Dovecot auth files, expected settings in dovecot.cf:
389#   passdb passwd-file {
390#     args = /etc/dovecot/passwd
391#   }
392#   userdb passwd-file {
393#     args = /etc/dovecot/passwd
394#   }
395#
396sub _prepare_dovecot_conf {
397  my ($self) = @_;
398  my $passwd = '';
399
400  foreach my $d (@{$self->{domains}}) {
401
402    foreach (@{$self->{by_domain}->{$d}}) {
403      my $password = $_->{'password'};
404      next if $password eq '';
405
406      my $address  = $_->{'address'};
407      my $local    = $_->{'address_local'};
408      $passwd .= "$address:{PLAIN-MD5}$password:bearmail:bearmail::/var/spool/bearmail/$d/${local}::\n";
409    }
410  }
411  $self->{files}->{"/etc/bearmail/dovecot/passwd"} = $passwd;
412}
413
414sub _write_conf {
415  my ($self) = @_;
416  my $header = "# Generated by BearMail::Backend::Files.\n# Please edit $mailmap instead of this file.\n\n";
417
418  foreach (sort keys %{$self->{files}}) {
419    if (!$debug) {
420      open(CONF, ">$_") or croak "$_: $!";
421      select CONF;
422    } else {
423      print "--\n-- $_\n--\n";
424    }
425
426    print $header.$self->{files}->{$_}."\n";
427
428    if (!$debug) {
429      close(CONF);
430      `postmap $_` if m:/etc/bearmail/postfix/:;
431    }
432  }
433  select STDOUT;
434}
435
4361;
Note: See TracBrowser for help on using the repository browser.