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

Last change on this file since 505 was 505, checked in by zerodeux, 10 years ago

Releasing bearmail 0.3.3, mainly fixes non-hosted-domain-loophole bug, see #17

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