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

Last change on this file since 477 was 477, checked in by zerodeux, 11 years ago

Release 0.3.1: gave up bearmail- prefix on config files (which are already in /etc/bearmail/)

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