aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem.moulin@fripost.org>2012-09-08 19:49:11 +0200
committerGuilhem Moulin <guilhem.moulin@fripost.org>2012-09-08 23:40:50 +0200
commit4a0d87e642c4d97ee2a026f1207e25a001518f3a (patch)
treeb742103cfbce8c7c576766f4db9016f0faa9b629 /lib
parent0dfeabffccf3695f5f270964aa8ef8e3460ae440 (diff)
Abstracting the LDAP stuff in an OO library.
Diffstat (limited to 'lib')
-rw-r--r--lib/FPanel/Interface.pm690
-rw-r--r--lib/FPanel/Login.pm54
-rwxr-xr-xlib/Fripost/Password.pm133
-rw-r--r--lib/Fripost/Schema.pm202
-rw-r--r--lib/Fripost/Schema/Alias.pm177
-rw-r--r--lib/Fripost/Schema/Domain.pm183
-rw-r--r--lib/Fripost/Schema/List.pm192
-rw-r--r--lib/Fripost/Schema/Local.pm161
-rw-r--r--lib/Fripost/Schema/Mailbox.pm203
-rw-r--r--lib/Fripost/Schema/Misc.pm130
10 files changed, 1677 insertions, 448 deletions
diff --git a/lib/FPanel/Interface.pm b/lib/FPanel/Interface.pm
index 1c1f9ee..8087cb9 100644
--- a/lib/FPanel/Interface.pm
+++ b/lib/FPanel/Interface.pm
@@ -11,15 +11,16 @@ Interface.pm -
=cut
-use lib 'lib';
-use base 'FPanel::Login';
+use Fripost::Schema;
+use Fripost::Password;
+use parent 'FPanel::Login';
+use HTML::Entities;
# This method is called right before the 'setup' method below. It
# inherits the configuration from the super class.
sub cgiapp_init {
my $self = shift;
-
$self->SUPER::cgiapp_init;
# Every single Run Mode here is protected
@@ -32,253 +33,161 @@ sub cgiapp_init {
sub ListDomains : StartRunmode {
my $self = shift;
my %CFG = $self->cfg;
- my $suffix = join ',', @{$CFG{ldap_suffix}};
-
- my ($l,$d) = split /@/, $self->authen->username, 2;
- my $authzDN = "fvu=$l,fvd=$d,". $suffix;
- my $ldap = $self->ldap_from_auth_user($authzDN);
-
- my $domains = $ldap->search( base => $suffix
- , scope => 'one'
- , filter => 'objectClass=FripostVirtualDomain'
- , deref => 'never'
- , attrs => [ qw/fvd description
- fripostIsStatusActive
- fripostCanCreateAlias
- fripostCanCreateList
- fripostOwner
- fripostPostmaster/ ]
- );
- die "403\n" if $domains->code;
- $ldap->unbind;
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+
+ my $fp = Fripost::Schema->SASLauth( $self->authen->username, %CFG );
+ my @domains = $fp->domain->search( -concat => "\n", -die => 403);
+ $fp->done;
my $template = $self->load_tmpl( 'list-domains.html', cache => 1, utf8 => 1
, loop_context_vars => 1
, global_vars => 1 );
- $template->param( URL => $self->query->url );
- $template->param( USER_LOCALPART => $l, USER_DOMAINPART => $d);
- $template->param( DOMAINS => [
- map { { DOMAIN => $_->get_value('fvd')
- # TODO: do we really want to list the permissions?
- , PERMS => &list_perms_long($_, $authzDN)
- , DESCRIPTION => join ("\n", $_->get_value('description'))
- , ISACTIVE => $_->get_value('fripostIsStatusActive') eq 'TRUE'
- };
- }
- $domains->sorted('fvd')
- ]);
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domains => [ @domains ]
+ );
return $template->output;
}
-# This Run Mode lists the known mailboxes, aliases and lists in the current
+# This Run Mode lists the known mailboxes, aliases and lists under the current
# domain.
sub ListLocals : Runmode {
my $self = shift;
my %CFG = $self->cfg;
- my $suffix = join ',', @{$CFG{ldap_suffix}};
-
- my ($l,$d) = split /@/, $self->authen->username, 2;
- my $authzDN = "fvu=$l,fvd=$d,". $suffix;
- my $ldap = $self->ldap_from_auth_user($authzDN);
- my $domainname = (split /\//, $ENV{PATH_INFO}, 3)[1];
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
# Query *the* matching domain
- my $domains = $ldap->search( base => "fvd=$domainname,$suffix"
- , scope => 'base'
- , filter => 'objectClass=FripostVirtualDomain'
- , deref => 'never'
- , attrs => [ qw/fvd description
- fripostIsStatusActive
- fripostOptionalMaildrop
- fripostCanCreateAlias
- fripostCanCreateList
- fripostOwner
- fripostPostmaster/ ]
- );
- die "404\n" if $domains->code;
- # The following is not supposed to happen.
- die "Error: Multiple matching entries found." if $domains->count > 1;
- my $domain = $domains->pop_entry or die "404\n";
-
-
- # Query the mailboxes under the given domain
- my $mailboxes = $ldap->search( base => "fvd=$domainname,$suffix"
- , scope => 'one'
- , filter => 'objectClass=FripostVirtualMailbox'
- , deref => 'never'
- , attrs => [ qw/fvu description
- fripostIsStatusActive
- fripostOptionalMaildrop
- fripostMailboxQuota/ ]
- );
- # We don't return 403 or 404 here, since it's not supposed to crash.
- die $mailboxes->error if $mailboxes->code;
-
- # Query the aliases under the given domain
- my $aliases = $ldap->search( base => "fvd=$domainname,$suffix"
- , scope => 'one'
- , filter => 'objectClass=FripostVirtualAlias'
- , deref => 'never'
- , attrs => [ qw/fva description
- fripostIsStatusActive
- fripostOwner
- fripostMaildrop/ ]
- );
- # We don't return 403 or 404 here, since it's not supposed to crash.
- die $aliases->error if $aliases->code;
-
- # Query the lists under the given domain
- my $lists = $ldap->search( base => "fvd=$domainname,$suffix"
- , scope => 'one'
- , filter => 'objectClass=FripostVirtualList'
- , deref => 'never'
- , attrs => [ qw/fvl description
- fripostIsStatusActive
- fripostOwner
- fripostListManager/ ]
- );
- # We don't return 403 or 404 here, since it's not supposed to crash.
- die $lists->error if $lists->code;
-
- $ldap->unbind;
-
- # Get the perms of the autenticated user, so that we know where
- # should put "add" and "edit" links (the LDAP ACLs back that up
- # eventually, anyway).
- my $perms = &list_perms($domain, $authzDN);
+ my %domain = $fp->domain->get( $d, -die => 404 );
+
+ # Query the mailboxes, aliases and lists under the given domain. We
+ # don't die with a HTTP error code here, as it is not supposed to
+ # crash.
+ my @mailboxes = $fp->mailbox->search( $d );
+ my @aliases = $fp->alias->search( $d );
+ my @lists = $fp->list->search( $d );
+
+ $fp->done;
my $template = $self->load_tmpl( 'list-locals.html', cache => 1, utf8 => 1
, loop_context_vars => 1
, global_vars => 1 );
- $template->param( URL => $self->query->url );
- $template->param( DOMAIN => $domainname );
- $template->param( USER_LOCALPART => $l, USER_DOMAINPART => $d);
- $template->param( DESCRIPTION =>
- join ("\n", $domain->get_value('description')) );
- $template->param( ISACTIVE =>
- $domain->get_value('fripostIsStatusActive') eq 'TRUE' );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ );
+ $template->param( domain => $domain{domain}
+ , isactive => $domain{isactive}
+ , description => join ("\n", @{$domain{description}}) );
# Can the user edit the domain (change description, toggle
# activation, modify catchalls?)
- $template->param( CANEDIT => $perms =~ /[op]/ );
+ $template->param( canEditDomain => $domain{permissions} =~ /[op]/ );
# Can the user add mailboxes?
- $template->param( CANADDMAILBOX => $perms =~ /p/ );
+ $template->param( canAddMailbox => $domain{permissions} =~ /p/ );
# Should we list mailboxes?
- $template->param( LISTMAILBOXES => $mailboxes->count || $perms =~ /p/ );
- $template->param( MAILBOXES => [
- map { { USER => $_->get_value('fvu')
- , DESCRIPTION => join ("\n", $_->get_value('description'))
- , ISACTIVE => $_->get_value('fripostIsStatusActive') eq 'TRUE'
- , FORWARDS => [ map { {FORWARD => $_} }
- $_->get_value('fripostOptionalMaildrop') ]
- , QUOTA => $_->get_value('fripostMailboxQuota') // ''
+ $template->param( listMailboxes => $#mailboxes >= 0 ||
+ $domain{permissions} =~ /p/ );
+ $template->param( mailboxes => [
+ map { { user => $_->{user}
+ , description => join ("\n", @{$_->{description}})
+ , isactive => $_->{isactive}
+ , forwards => [ map { {forward => $_} } @{$_->{forwards}} ]
+ , quota => $_->{quota}
};
}
- $mailboxes->sorted('fvu')
+ @mailboxes
]);
# Can the user add aliases?
- $template->param( CANADDALIAS => $perms =~ /[aop]/ );
+ $template->param( canAddalias => $domain{permissions} =~ /[aop]/ );
# Should we list aliases?
- $template->param( LISTALIASES => $aliases->count || $perms =~ /[aop]/ );
- $template->param( ALIASES => [
- map { { ALIAS => $_->get_value('fva')
- , DESCRIPTION => join ("\n", $_->get_value('description'))
- , ISACTIVE => $_->get_value('fripostIsStatusActive') eq 'TRUE'
- # TODO: do we really want to list the owners?
- , OWNERS => [ map { {OWNER => &dn2email($_)} }
- $_->get_value('fripostOwner') ]
- , DESTINATIONS => [ map { {DESTINATION => $_} }
- $_->get_value('fripostMaildrop') ]
+ $template->param( listAliases => $#aliases >= 0 ||
+ $domain{permissions} =~ /[aop]/ );
+ $template->param( aliases => [
+ map { { alias => $_->{alias}
+ , description => join ("\n", @{$_->{description}})
+ , isactive => $_->{isactive}
+ , destinations => [ map { {destination => $_} }
+ @{$_->{maildrop}} ]
};
}
- $aliases->sorted('fva')
+ @aliases
]);
- $template->param( CATCHALLS => [ map { {CATCHALL => $_} }
- $domain->get_value('fripostOptionalMaildrop') ]
- # TODO: do we really want to list the owners?
- , OWNERS => [ ( map { {OWNER => &dn2email($_)} }
- $domain->get_value('fripostOwner') )
- , ( map { {OWNER => &dn2email($_)} }
- $domain->get_value('fripostPostmaster') ) ]
- , CAODD => $aliases->count % 2 );
+ $template->param( catchalls => [ map { {catchall => $_} }
+ @{$domain{catchalls}} ]
+ , CAodd => not $#aliases % 2);
# Can the user add lists?
- $template->param( CANADDLIST => $perms =~ /[lop]/ );
+ $template->param( canAddList => $domain{permissions} =~ /[lop]/ );
# Should we list lists?
- $template->param( LISTLISTS => $lists->count || $perms =~ /[lop]/ );
- $template->param( LISTS => [
- map { { LIST => $_->get_value('fvl')
- , DESCRIPTION => join ("\n", $_->get_value('description'))
- , ISACTIVE => $_->get_value('fripostIsStatusActive') eq 'TRUE'
- # TODO: do we really want to list the owners?
- , OWNERS => [ map { {OWNER => &dn2email($_)} }
- $_->get_value('fripostOwner') ]
- , TRANSPORT => $_->get_value('fripostListManager')
+ $template->param( listLists => $#lists >= 0 || $domain{permissions} =~ /[lop]/ );
+ $template->param( lists => [
+ map { { list => $_->{list}
+ , description => join ("\n", @{$_->{description}})
+ , isactive => $_->{isactive}
+ , transport => $_->{transport}
};
}
- $lists->sorted('fvl')
+ @lists
]);
return $template->output;
}
# In this Run Mode authenticated users can edit the domain description
-# and catchall, and toggle activation (if they have the permission).
+# and catchalls, and toggle activation (if they have the permission).
sub EditDomain : Runmode {
my $self = shift;
my %CFG = $self->cfg;
- my $suffix = join ',', @{$CFG{ldap_suffix}};
-
- my ($l,$d) = split /@/, $self->authen->username, 2;
- my $authzDN = "fvu=$l,fvd=$d,". $suffix;
- my $ldap = $self->ldap_from_auth_user($authzDN);
- my $domainname = (split /\//, $ENV{PATH_INFO}, 3)[1];
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
- my $error; # Tells wether the change submission has fails.
- if (defined $self->query->param('submit')) {
+ my $q = $self->query;
+ my $error; # Tells whether the change submission has failed.
+ if (defined $q->param('submit')) {
# Changes have been submitted: process them
- my %changes;
- my $q = $self->query;
- $changes{fripostIsStatusActive} = $q->param('status') eq 'active' ?
- 'TRUE' : 'FALSE';
- $changes{description} = [ split /\n/, $q->param('description') ];
- $changes{fripostOptionalMaildrop} = [ &form2EmailList($q->param('maildrop')) ];
- my $mesg = $ldap->modify( "fvd=$domainname,$suffix",
- replace => \%changes );
- $error = $mesg->error if $mesg->code;
+ $error = $fp->domain->replace({
+ domain => $d,
+ isactive => $q->param('isactive'),
+ description => $q->param('description'),
+ catchalls => $q->param('catchalls')
+ }, -concat => "(\n|\x{0D}\x{0A})");
}
-
- my $domains = $ldap->search( base => "fvd=$domainname,$suffix"
- , scope => 'base'
- , filter => 'objectClass=FripostVirtualDomain'
- , deref => 'never'
- );
- die "404\n" if $domains->code;
- # The following is not supposed to happen.
- die "Error: Multiple matching entries found." if $domains->count > 1;
- my $domain = $domains->pop_entry or die "404\n";
-
- $ldap->unbind;
+ my %domain = $fp->domain->get( $d, -die => 404 );
+ $fp->done;
my $template = $self->load_tmpl( 'edit-domain.html', cache => 1, utf8 => 1
, loop_context_vars => 1
, global_vars => 1 );
- $template->param( URL => $self->query->url );
- $template->param( USER_LOCALPART => $l, USER_DOMAINPART => $d);
- $template->param( DOMAIN => $domainname );
- $template->param( DESCRIPTION =>
- join ("\n",$domain->get_value('description')) );
- $template->param( MAILDROP =>
- join ("\n",$domain->get_value('fripostOptionalMaildrop')) );
- $template->param( ISACTIVE => $domain->get_value('fripostIsStatusActive') eq 'TRUE' );
- $template->param( NEWCHANGES => defined $self->query->param('submit') );
- $template->param( ERROR => $error );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domain => $d
+ );
+ if ($error) {
+ # Preserve the (incorrect) form
+ $template->param( isactive => $q->param('isactive')
+ , description => $q->param('description')
+ , catchalls => $q->param('catchalls')
+ , error => encode_entities ($error, "‘‘") );
+ }
+ else {
+ $template->param( isactive => $domain{isactive}
+ , description => join ("\x{0D}\x{0A}",
+ @{$domain{description}})
+ , catchalls => join ("\x{0D}\x{0A}",
+ @{$domain{catchalls}}) );
+ }
+ $template->param( newChanges => defined $self->query->param('submit') );
return $template->output;
}
@@ -288,128 +197,125 @@ sub EditDomain : Runmode {
sub EditLocal : Runmode {
my $self = shift;
my %CFG = $self->cfg;
- my $suffix = join ',', @{$CFG{ldap_suffix}};
- my ($l,$d) = split /@/, $self->authen->username, 2;
- my $authzDN = "fvu=$l,fvd=$d,". $suffix;
- my $ldap = $self->ldap_from_auth_user($authzDN);
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my ($null,$d,$l,$crap) = split /\//, $ENV{PATH_INFO}, 4;
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
- my ($null,$domainname,$localname,$crap) = split /\//, $ENV{PATH_INFO}, 4;
-
- my $error; # Tells wether the change submission has fails.
- if (defined $self->query->param('submit')) {
+ my $q = $self->query;
+ my $error; # Tells whether the change submission has failed.
+ if (defined $q->param('submit')) {
# Changes have been submitted: process them
- my (%changes, $t2);
- my $q = $self->query;
- my $t = lc $q->param('t') // die "Error: Unknown type";
-
+ my $t = $q->param('t') // die "Undefined type";
+ my %entry;
if ($t eq 'mailbox') {
- $t2 = 'fvu';
- if ($q->param('oldpassword') ne '' or
- $q->param('newpassword') ne '' or
- $q->param('newpassword2') ne '') {
+ $entry{user} = $l.'@'.$d;
+ $entry{forwards} = $q->param('forwards');
+
+ if ($q->param('oldpw') ne '' or
+ $q->param('newpw') ne '' or
+ $q->param('newpw2') ne '') {
# If the user tries to change the password, we make her
# bind first, to prevent an attacker from setting a
# custom password and accessing the emails.
-
- if ($q->param('newpassword') eq $q->param('newpassword2')) {
- my $ldap2 = Net::LDAP->new( $CFG{ldap_uri} );
- my $mesg = $ldap2->bind ( "fvu=$l,fvd=$d,$suffix",
- password => $q->param('oldpassword') );
- if ($mesg->code) {
- $error = "Wrong password (for ".$self->authen->username.").";
- }
- else {
- my $pw = $q->param('newpassword');
- # TODO: hash it.
- $mesg = $ldap2->modify( "fvu=$localname,fvd=$domainname,$suffix",
- replace => { userPassword => $pw } );
- $error = $mesg->error if $mesg->code;
- }
- $ldap2->unbind;
+ if ($q->param('newpw') ne $q->param('newpw2')) {
+ $error = "Passwords do not match";
+ }
+ elsif (length $q->param('newpw') < $CFG{password_min_length}) {
+ $error = "Password should be at least "
+ .$CFG{password_min_length}
+ ." characters long.";
}
else {
- $error = "Password don't match.";
+ my $fp;
+ eval {
+ $fp = Fripost::Schema::->auth(
+ $self->authen->username,
+ $q->param('oldpw'),
+ ldap_uri => $CFG{ldap_uri},
+ ldap_suffix => $CFG{ldap_suffix},
+ -die => "Wrong password (for ‘"
+ .$self->authen->username."‘)." );
+ };
+ $error = $@ || $fp->mailbox->passwd(
+ $entry{user},
+ Fripost::Password::hash($q->param('newpw'))
+ );
+ $fp->done if defined $fp;
}
}
-
- $changes{fripostOptionalMaildrop} = [ &form2EmailList($q->param('maildrop')) ];
}
-
elsif ($t eq 'alias') {
- $t2 = 'fva';
- $changes{fripostMaildrop} = [ &form2EmailList($q->param('maildrop')) ];
+ $entry{alias} = $l.'@'.$d;
+ $entry{maildrop} = $q->param('maildrop');
}
-
elsif ($t eq 'list') {
- $t2 = 'fvl';
+ $entry{list} = $l.'@'.$d;
+ $entry{transport} = $q->param('transport');
}
-
else {
- die "Error: Unknown type";
- }
-
- # Global parameters
- $changes{fripostIsStatusActive} = $q->param('status') eq 'active' ?
- 'TRUE' : 'FALSE';
- $changes{description} = [ split /\n/, $q->param('description') ];
-
- unless (defined $error) {
- my $mesg = $ldap->modify( "$t2=$localname,fvd=$domainname,$suffix",
- replace => \%changes );
- $error = $mesg->error if $mesg->code;
+ # Unknown type
+ return $self->redirect($q->url .'/'. $d .'/');
}
+ $entry{isactive} = $q->param('isactive');
+ $entry{description} = $q->param('description');
+ $error = $fp->$t->replace( \%entry, -concat => "(\n|\x{0D}\x{0A})")
+ unless $error;
}
- # Query *the* matching mailbox, alias or list.
- my $locals = $ldap->search( base => "fvd=$domainname,$suffix"
- , scope => 'one'
- , filter => "(|(&(objectClass=FripostVirtualMailbox)
- (fvu=$localname))
- (&(objectClass=FripostVirtualAlias)
- (fva=$localname))
- (&(objectClass=FripostVirtualList)
- (fvl=$localname))
- )"
- , deref => 'never'
- , attrs => [ qw/fvu description
- fripostIsStatusActive
- fripostOptionalMaildrop
- fripostMailboxQuota
- fva fripostMaildrop
- fvl fripostListManager/ ]
- );
- die "404\n" if $locals->code;
- # The following is not supposed to happen.
- die "Error: Multiple matching entries found." if $locals->count > 1;
- my $local = $locals->pop_entry or die "404\n";
-
- my $template;
- if ($local->dn =~ /^fvu=/) {
- $template = $self->load_tmpl( 'edit-mailbox.html', cache => 1, utf8 => 1 );
- $template->param( MAILBOX => $local->get_value('fvu') );
- $template->param( MAILDROP =>
- join ("\n",$local->get_value('fripostOptionalMaildrop')) );
- }
- elsif ($local->dn =~ /^fva=/) {
- $template = $self->load_tmpl( 'edit-alias.html', cache => 1, utf8 => 1 );
- $template->param( ALIAS => $local->get_value('fva') );
- $template->param( MAILDROP =>
- join ("\n",$local->get_value('fripostMaildrop')) );
+ # Search for *the* matching mailbox, alias or list.
+ my %local = $fp->local->get ($l, $d, -die => 404,
+ -concat => "\x{0D}\x{0A}");
+ $fp->done;
+
+ my $template = $self->load_tmpl( "edit-$local{type}.html",
+ cache => 1, utf8 => 1 );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domain => $d
+ );
+ if ($error) {
+ # Preserve the (incorrect) form, except the passwords
+ if ($local{type} eq 'mailbox') {
+ $template->param( user => $l
+ , forwards => $q->param('forwards') );
+ }
+ elsif ($local{type} eq 'alias') {
+ $template->param( alias => $l
+ , maildrop => $q->param('maildrop') );
+ }
+ elsif ($local{type} eq 'list') {
+ $template->param( list => $l );
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $template->param( isactive => $q->param('isactive')
+ , description => $q->param('description')
+ , error => encode_entities ($error, "‘‘") );
}
- elsif ($local->dn =~ /^fvl=/) {
- $template = $self->load_tmpl( 'edit-list.html', cache => 1, utf8 => 1 );
- $template->param( LIST => $local->get_value('fvl') );
+ else {
+ if ($local{type} eq 'mailbox') {
+ $template->param( user => $local{user}
+ , forwards => $local{forwards} );
+ }
+ elsif ($local{type} eq 'alias') {
+ $template->param( alias => $local{alias}
+ , maildrop => $local{maildrop} );
+ }
+ elsif ($local{type} eq 'list') {
+ $template->param( list => $local{list} );
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $template->param( isactive => $local{isactive}
+ , description => $local{description} );
}
-
- $template->param( URL => $self->query->url );
- $template->param( DOMAIN => $domainname );
- $template->param( USER_LOCALPART => $l, USER_DOMAINPART => $d);
- $template->param( DESCRIPTION =>
- join ("\n",$local->get_value('description')) );
- $template->param( ISACTIVE => $local->get_value('fripostIsStatusActive') eq 'TRUE' );
- $template->param( NEWCHANGES => defined $self->query->param('submit') );
- $template->param( ERROR => $error );
+ $template->param( newChanges => defined $self->query->param('submit') );
return $template->output;
}
@@ -419,143 +325,87 @@ sub EditLocal : Runmode {
sub AddLocal : Runmode {
my $self = shift;
my %CFG = $self->cfg;
- my $suffix = join ',', @{$CFG{ldap_suffix}};
-
- my ($l,$d) = split /@/, $self->authen->username, 2;
- my $authzDN = "fvu=$l,fvd=$d,". $suffix;
- my $ldap = $self->ldap_from_auth_user($authzDN);
- my $domainname = (split /\//, $ENV{PATH_INFO}, 3)[1];
- my $localname;
+ my ($ul,$ud) = split /\@/, $self->authen->username, 2;
+ my $d = (split /\//, $ENV{PATH_INFO}, 3)[1];
- my $error;
my $q = $self->query;
- if (defined $self->query->param('submit')) {
- # A new alias has been submitted: process it
- my %new;
- $localname = $q->param('alias');
- $new{objectClass} = 'FripostVirtualAlias';
- $new{fripostIsStatusActive} = $q->param('status') eq 'active' ?
- 'TRUE' : 'FALSE';
- $new{fripostOwner} = $authzDN;
- my @desc = split /\n/, $q->param('description');
- $new{description} = [ @desc ] if @desc;
- my @maildrop = &form2EmailList($q->param('maildrop'));
- $new{fripostMaildrop} = [ @maildrop ] if @maildrop;
-
- # TODO: more checks
- my $mesg = $ldap->add( "fva=$localname,fvd=$domainname,$suffix",
- attrs => [ %new ] );
- if ($mesg->code) {
- $error = $mesg->error;
+ my $t = $q->param('t') // die "Undefined type";
+ my $error; # Tells whether the change submission has failed.
+ if (defined $q->param('submit')) {
+ # Changes have been submitted: process them
+ my %entry;
+ if ($t eq 'mailbox') {
+ $entry{user} = $q->param('user').'@'.$d;
+ $entry{forwards} = $q->param('forwards');
+ if ($q->param('password') ne $q->param('password2')) {
+ $error = "Passwords do not match";
+ }
+ elsif (length $q->param('password') < $CFG{password_min_length}) {
+ $error = "Password should be at least "
+ .$CFG{password_min_length}
+ ." characters long.";
+ }
+ else {
+ $entry{password} = Fripost::Password::hash($q->param('password'));
+ }
+ # TODO: inherit the quota from the postmaster's?
+ }
+ elsif ($t eq 'alias') {
+ $entry{alias} = $q->param('alias').'@'.$d;
+ $entry{maildrop} = $q->param('maildrop');
+ }
+ elsif ($t eq 'list') {
+ $entry{list} = $q->param('list').'@'.$d;
+ $entry{transport} = $q->param('transport');
}
else {
- return $self->redirect($q->url .'/'. $domainname .'/');
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $entry{isactive} = $q->param('isactive');
+ $entry{description} = $q->param('description');
+
+ unless ($error) {
+ my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG );
+ $error = $fp->$t->add( \%entry, -concat => "(\n|\x{0D}\x{0A})");
+ $fp->done;
+ return $self->redirect($q->url.'/'.$d.'/') unless $error;
}
}
- my $template = $self->load_tmpl( 'add-alias.html', cache => 1, utf8 => 1 );
- $template->param( URL => $self->query->url );
- $template->param( DOMAIN => $domainname );
- $template->param( USER_LOCALPART => $l, USER_DOMAINPART => $d);
- if (defined $error) {
- $template->param( ALIAS => $q->param('alias') );
- $template->param( ISACTIVE => $q->param('status') eq 'active');
- $template->param( DESCRIPTION => join ("\n",$q->param('description')) );
- $template->param( MAILDROP => join ("\n",$q->param('maildrop')) );
- $template->param( ERROR => $error );
- }
- return $template->output;
-}
-
-
-# This subroutine displays the access that the given DN has on the entry
-# (long version). Possible values are :
-# - "can create aliases" (a)
-# - "can create lists" (l)
-# - "can create aliases & lists" (al)
-# - "owner" (o)
-# - "postmaster" (p)
-sub list_perms_long {
- my $perms = &list_perms(@_);
-
- if ( $perms =~ /a/) {
- return 'can create aliases & lists' if $perms =~ /l/;
- return 'can create aliases';
- }
- elsif ( $perms eq 'l' ) {
- return 'can create lists';
- }
- elsif ( $perms eq 'o' ) {
- return 'owner';
- }
- elsif ( $perms eq 'p' ) {
- return 'postmaster';
+ my $template = $self->load_tmpl( "add-$t.html", cache => 1, utf8 => 1 );
+ $template->param( url => $self->query->url
+ , user_localpart => $ul
+ , user_domainpart => $ud
+ , domain => $d
+ );
+ if ($error) {
+ # Preserve the (incorrect) form, except the passwords
+ if ($t eq 'mailbox') {
+ $template->param( user => $q->param('user')
+ , forwards => $q->param('forwards') );
+ }
+ elsif ($t eq 'alias') {
+ $template->param( alias => $q->param('alias')
+ , maildrop => $q->param('maildrop') );
+ }
+ elsif ($t eq 'list') {
+ $template->param( list => $q->param('list')
+ , isenc => $q->param('transport') eq 'schleuder' );
+ }
+ else {
+ # Unknown type
+ return $self->redirect($q->url.'/'.$d.'/');
+ }
+ $template->param( isactive => $q->param('isactive')
+ , description => $q->param('description')
+ , error => encode_entities ($error, "‘‘") );
}
-}
-
-# This subroutine displays the access that the given DN has on the entry
-# (short version).
-sub list_perms {
- my ($entry, $dn) = @_;
- my $perms = '';
-
- $perms .= 'a'
- if grep { $dn eq $_ or (split /,/,$dn,2)[1] eq $_ }
- $entry->get_value ('fripostCanCreateAlias');
-
- $perms .= 'l'
- if grep { $dn eq $_ or (split /,/,$dn,2)[1] eq $_ }
- $entry->get_value ('fripostCanCreateList');
-
- $perms = 'o'
- if grep { $dn eq $_ } $entry->get_value('fripostOwner');
-
- $perms = 'p'
- if grep { $dn eq $_ } $entry->get_value('fripostPostmaster');
-
- return $perms;
-}
-
-
-# This method SASL binds the web application and uses the provided
-# authorization DN.
-sub ldap_from_auth_user {
- my $self = shift;
- my $authzDN = shift;
-
- my $ldap = Net::LDAP->new( $self->cfg('ldap_uri'),
- async => 1, onerror => 'die' );
- my $sasl = Authen::SASL->new(
- mechanism => 'DIGEST-MD5',
- callback => { user => $self->cfg('ldap_authcID')
- , pass => $self->cfg('ldap_authcPW')
- , authname => "dn:$authzDN" }
- );
- my $mesg = $ldap->bind( sasl => $sasl );
- die $mesg->error if $mesg->code;
-
- return $ldap;
-}
-
-# Converts a DN into an email.
-sub dn2email {
- my $dn = shift;
- $dn =~ /^fv[ual]=([^,]+),fvd=([^,]+),/ or return '';
- return "$1\@$2";
-}
-
-
-# Produces an e-mail list from a form: split the new lines and strip out
-# the spaces.
-sub form2EmailList {
- my $str = shift;
- my @list;
- foreach my $e (split /\n/, $str) {
- $e =~ s/\s//g;
- push @list, $e unless $e =~ /^$/;
+ else {
+ $template->param( isactive => 1 );
}
- return @list;
+ return $template->output;
}
diff --git a/lib/FPanel/Login.pm b/lib/FPanel/Login.pm
index 9be724a..3a44768 100644
--- a/lib/FPanel/Login.pm
+++ b/lib/FPanel/Login.pm
@@ -11,17 +11,18 @@ Login.pm -
=cut
-use base 'CGI::Application';
+use parent 'CGI::Application';
use CGI::Application::Plugin::AutoRunmode;
use CGI::Application::Plugin::Session;
use CGI::Application::Plugin::Authentication;
use CGI::Application::Plugin::Redirect;
-use CGI::Application::Plugin::ConfigAuto qw/cfg/;
+use CGI::Application::Plugin::ConfigAuto 'cfg';
use Net::LDAP;
use Authen::SASL;
use File::Spec::Functions qw/catfile catdir/;
+use HTML::Entities;
# This method is called right before the 'setup' method below. It
@@ -50,12 +51,12 @@ sub cgiapp_init {
},
SEND_COOKIE => 1,
);
-
+
# Configure authentication parameters
$self->authen->config(
DRIVER => [ 'Generic', sub {
my ($u,$p) = @_;
- my ($l,$d) = split /@/, $u, 2;
+ my ($l,$d) = split /\@/, $u, 2;
unless (defined $d) {
$CFG{default_realm} // return 0;
@@ -72,10 +73,10 @@ sub cgiapp_init {
STORE => 'Session',
LOGIN_RUNMODE => 'login',
RENDER_LOGIN => \&login_box,
- LOGIN_SESSION_TIMEOUT => { IDLE_FOR => $CFG{timeout} },
+ LOGIN_SESSION_TIMEOUT => { IDLE_FOR => $CFG{timeout} },
LOGOUT_RUNMODE => 'logout',
);
-
+
# The run modes that require authentication
$self->authen->protected_runmodes( qw /okay error_rm/ );
}
@@ -86,6 +87,7 @@ sub cgiapp_init {
# on the URL and query string.
sub setup {
my $self = shift;
+ $self->header_props( -charset=>'utf-8' );
$self->tmpl_path( catdir ( $self->cfg('pwd'), $self->cfg('tmpl_path') ) );
@@ -121,11 +123,7 @@ sub setup {
return 'ListLocals';
}
- unless (defined $crap and $crap ne '') {
- return 'EditLocal';
- }
-
- return 'error_404';
+ return 'EditLocal';
});
}
@@ -142,20 +140,20 @@ sub okay : Runmode {
# This is the login Run Mode.
sub login : Runmode {
- my $self = shift;
-
+ my $self = shift;
+
# A logged user has no reason to ask for a relogin, so s/he is seen as
# an intruder
$self->authen->logout if $self->authen->is_authenticated;
-
+
# Do not come back here on the next Run Mode
$self->query->delete('a') if (defined $self->query->param('a')) and
$self->query->param('a') eq 'login';
-
+
# Where the users wants to go
$self->query->param( destination => $self->query->self_url)
unless defined $self->query->param('destination');
-
+
return $self->login_box;
}
@@ -163,11 +161,11 @@ sub login : Runmode {
# This method loads the login form.
sub login_box {
my $self = shift;
-
+
my $template = $self->load_tmpl( 'login.html', cache => 1, utf8 => 1 );
- $template->param( ERROR => $self->authen->login_attempts );
- $template->param( DESTINATION => $self->query->param('destination') );
-
+ $template->param( error => $self->authen->login_attempts );
+ $template->param( destination => $self->query->param('destination') );
+
return $template->output;
}
@@ -175,18 +173,18 @@ sub login_box {
# This is the logout Run Mode.
sub logout : Runmode {
my $self = shift;
-
+
if ($self->authen->is_authenticated) {
# Log out the user, delete the session and flush it off the disk
$self->authen->logout;
$self->session->delete;
$self->session->flush;
}
-
+
# Do not come back here on the next Run Mode
$self->query->delete('a') if (defined $self->query->param('a')) and
$self->query->param('a') eq 'logout';
-
+
return $self->redirect($self->query->self_url);
}
@@ -207,17 +205,17 @@ sub error_rm : ErrorRunmode {
elsif ($error eq '404' ) {
$mesg = 'Not found'
}
- $template->param( CODE => $error );
- $template->param( MESSAGE => $mesg );
+ $template->param( code => $error );
+ $template->param( message => encode_entities ($mesg, "‘‘") );
return $template->output;
}
else {
# Users are not supposed to see that unless the CGI crashes :P
my $template = $self->load_tmpl( 'error.html', cache => 1, utf8 => 1 );
- $template->param( EMAIL => $self->cfg('report_email') );
- $template->param( MESSAGE => $error );
- $template->param( URL => $self->query->url . '/');
+ $template->param( email => $self->cfg('report_email') );
+ $template->param( message => $error );
+ $template->param( url => $self->query->url . '/');
return $template->output;
}
}
diff --git a/lib/Fripost/Password.pm b/lib/Fripost/Password.pm
new file mode 100755
index 0000000..c2905b2
--- /dev/null
+++ b/lib/Fripost/Password.pm
@@ -0,0 +1,133 @@
+package Fripost::Password;
+
+use 5.010_000;
+use strict;
+use warnings;
+
+=head1 NAME
+
+Password.pm - Hash and generate passwords
+
+=cut
+
+our $VERSION = '0.02';
+
+use Exporter 'import';
+use String::MkPasswd;
+use Digest::SHA;
+use MIME::Base64;
+
+our @EXPORT_OK = qw/hash pwgen/;
+
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item B<hash> ([I<salt>])
+
+SHA-1 hash the given password. I<salt>, if defined and not empty, is
+used to salt the password. If I<salt> is not defined, a random 4 bytes
+salt is used. If I<salt> is the empty string, the hash is not salted.
+
+The used scheme precedes the hash, so the output is ready to be inserted
+in a LDAP entry for instance.
+
+=cut
+
+sub hash {
+ my ($pw, $salt) = @_;
+
+ $salt //= &_make_salt();
+ my $str = 'SHA';
+ $str = 'SSHA' if &_is_salted( $salt );
+
+ { no strict "refs";
+ $str = '{' .$str. '}' .
+ &_pad_base64( MIME::Base64::encode(
+ Digest::SHA::sha1( $pw.$salt ) . $salt,
+ '' ) );
+ };
+ return $str;
+}
+
+
+sub _is_salted { return ( not ( defined $_[0] ) or $_[0] ne '' ) };
+
+
+# Generate a (random) 4 bytes salt. We only generates 4 bytes here to
+# match the other way to hash & salt passwords (`slappasswd' and the
+# RoundCube passwords).
+sub _make_salt {
+ my $len = 4;
+ my @bytes = ();
+ for my $i ( 1 .. $len ) {
+ push( @bytes, rand(255) );
+ }
+ return pack( 'C*', @bytes );
+}
+
+
+# Add trailing `='s to the input string to ensure its length is a
+# multiple of 4.
+sub _pad_base64 {
+ my $b64_digest = shift;
+ while ( length($b64_digest) % 4 ) {
+ $b64_digest .= '=';
+ }
+ return $b64_digest;
+}
+
+
+=item B<pwgen>
+
+Generate a random password that complies to B<Fripost>'s password
+policy.
+
+=cut
+
+sub pwgen {
+ return String::MkPasswd::mkpasswd(
+ -length => 12,
+ -minnum => 2,
+ -minspecial => 1
+ );
+}
+
+=back
+
+=cut
+
+
+=head1 AUTHORS
+
+Stefan Kangas C<< <skangas at skangas.se> >>
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 BUGS
+
+Please report any bugs to C<< <skangas at skangas.se> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2010 Dominik Schulz (dominik.schulz@gauner.org). All rights reserved.
+
+Copyright 2010,2011 Stefan Kangas, all rights reserved.
+
+Copyright 2012 Guilhem Moulin, all rights reserved.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema.pm b/lib/Fripost/Schema.pm
new file mode 100644
index 0000000..36b7d54
--- /dev/null
+++ b/lib/Fripost/Schema.pm
@@ -0,0 +1,202 @@
+package Fripost::Schema;
+
+=head1 NAME
+
+Schema.pm -
+
+=cut
+
+=head1 DESCRIPTION
+
+Schema.pm abstracts the LDAP schema definition and provides methods to
+add, list or delete virtual domains, mailboxes, aliases or lists.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use Net::LDAP;
+use Authen::SASL;
+use Fripost::Schema::Domain;
+use Fripost::Schema::Mailbox;
+use Fripost::Schema::Alias;
+use Fripost::Schema::List;
+use Fripost::Schema::Local;
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<SASLauth> (I<username>, I<CFG>)
+
+Start a LDAP connection, and SASL-authenticate using proxy
+authentication for the given (fully-qualified) user. I<CFG> should
+contain definitions for the LDAP suffix and the authentication ID.
+
+=cut
+
+sub SASLauth {
+ my $class = shift;
+ my ($l,$d) = split /\@/, shift, 2;
+ my %cfg = @_;
+
+ my $self = bless {}, $class;
+ $self->suffix( join ',', @{$cfg{ldap_suffix}} );
+ $self->whoami( "fvu=$l,fvd=$d,".$self->suffix );
+ $self->ldap( Net::LDAP::->new( $cfg{ldap_uri}, async => 1 ) );
+
+ my $sasl = Authen::SASL::->new(
+ mechanism => 'DIGEST-MD5',
+ callback => { user => $cfg{ldap_authcID}
+ , pass => $cfg{ldap_authcPW}
+ , authname => 'dn:'.$self->whoami }
+ );
+ my $mesg = $self->ldap->bind( sasl => $sasl );
+ # This is not supposed to happen.
+ die $mesg->error if $mesg->code;
+
+ return $self;
+}
+
+
+=item B<auth> (I<username>, I<password>, I<CFG>)
+
+Start a LDAP connection, and (simples-) binds the given user.
+I<CFG> should contain definitions for the LDAP suffix and URI.
+
+=cut
+
+sub auth {
+ my $class = shift;
+ my ($l,$d) = split /\@/, shift, 2;
+ my $pw = shift;
+ my %cfg = @_;
+
+ my $self = bless {}, $class;
+ $self->suffix( join ',', @{$cfg{ldap_suffix}} );
+ $self->whoami( "fvu=$l,fvd=$d,".$self->suffix );
+ $self->ldap( Net::LDAP::->new( $cfg{ldap_uri}, async => 1 ) );
+
+ my $mesg = $self->ldap->bind( $self->whoami, password => $pw );
+ if ($mesg->code) {
+ die $cfg{'-die'}."\n" if defined $cfg{'-die'};
+ die $mesg->error;
+ }
+ return $self;
+}
+
+
+
+# The DN of the authorization ID
+sub whoami { shift->_set_or_get('_whoami',@_); }
+
+# The LDAP object (of class Net::LDAP)
+sub ldap { shift->_set_or_get('_ldap',@_); }
+
+# The suffix under which virtual domains are.
+sub suffix { shift->_set_or_get('_suffix',@_); }
+
+
+# Set or get a key (the first argument), depending on whether a second
+# argument is given or not.
+sub _set_or_get {
+ my $self = shift;
+ my $what = shift;
+
+ if (@_) {
+ $self->{$what} = $_[0];
+ }
+ else {
+ return $self->{$what};
+ }
+}
+
+
+
+=item B<domain>
+
+Bless the object to C<Fripost::Schema::Domain>, to access
+domain-specific methods.
+
+=cut
+
+sub domain { bless shift, 'Fripost::Schema::Domain'; }
+
+
+=item B<mailbox>
+
+Bless the object to C<Fripost::Schema::Mailbox>, to access
+mailbox-specific methods.
+
+=cut
+
+sub mailbox { bless shift, 'Fripost::Schema::Mailbox'; }
+
+
+=item B<alias>
+
+Bless the object to C<Fripost::Schema::Alias>, to access
+alias-specific methods.
+
+=cut
+
+sub alias { bless shift, 'Fripost::Schema::Alias'; }
+
+
+=item B<list>
+
+Bless the object to C<Fripost::Schema::List>, to access
+list-specific methods.
+
+=cut
+
+sub list { bless shift, 'Fripost::Schema::List'; }
+
+
+=item B<local>
+
+Bless the object to C<Fripost::Schema::Local>, to access
+local-specific (mailboxes, aliases and lists) methods.
+
+=cut
+
+sub local { bless shift, 'Fripost::Schema::Local'; }
+
+
+
+=item B<done>
+
+Unbinds from the LDAP server.
+
+=cut
+
+sub done {
+ my $self = shift;
+ $self->ldap->unbind if defined $self and defined $self->ldap;
+}
+
+
+=back
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/Alias.pm b/lib/Fripost/Schema/Alias.pm
new file mode 100644
index 0000000..c413257
--- /dev/null
+++ b/lib/Fripost/Schema/Alias.pm
@@ -0,0 +1,177 @@
+package Fripost::Schema::Alias;
+
+=head1 NAME
+
+Alias.pm -
+
+=head1 DESCRIPTION
+
+Alias.pm abstracts the LDAP schema definition and provides methods to
+add, list or delete virtual aliases.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use parent 'Fripost::Schema';
+use Fripost::Schema::Misc qw/concat explode must_attrs email_valid/;
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<search> (I<domain>, I<OPTIONS>)
+
+List every known (and visible) alias under the given domain. The output
+is a array of hash references, sorted by alias.
+
+=cut
+
+sub search {
+ my $self = shift;
+ my $domain = shift;
+ my %options = @_;
+ my $concat = $options{'-concat'};
+
+ my $aliases = $self->ldap->search(
+ base => "fvd=$domain,".$self->suffix,
+ scope => 'one',
+ deref => 'never',
+ filter => 'objectClass=FripostVirtualAlias',
+ attrs => [ qw/fva description fripostIsStatusActive
+ fripostMaildrop/ ]
+ );
+ if ($aliases->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $aliases->error;
+ }
+ return map { { alias => $_->get_value('fva')
+ , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE'
+ , description => concat($concat, $_->get_value('description'))
+ , maildrop => concat($concat, $_->get_value('fripostMaildrop'))
+ }
+ }
+ $aliases->sorted('fva')
+}
+
+
+=item B<replace> (I<alias>, I<OPTIONS>)
+
+Replace an existing alias with the given one.
+
+=cut
+
+sub replace {
+ my $self = shift;
+ my $a = shift;
+ my %options = @_;
+
+ foreach (qw/description maildrop/) {
+ $a->{$_} = explode ($options{'-concat'}, $a->{$_})
+ if defined $a->{$_};
+ }
+
+ my ($l,$d) = split /\@/, $a->{alias}, 2;
+
+ eval {
+ &_is_valid($a);
+ my $mesg = $self->ldap->modify(
+ "fva=$l,fvd=$d,".$self->suffix,
+ replace => { fripostIsStatusActive => $a->{isactive} ?
+ 'TRUE' : 'FALSE'
+ , description => $a->{description}
+ , fripostMaildrop => $a->{maildrop}
+ } );
+ die $mesg->error."\n" if $mesg->code;
+ };
+ return $@;
+}
+
+
+=item B<add> (I<alias>, I<OPTIONS>)
+
+Add the given alias.
+
+=cut
+
+sub add {
+ my $self = shift;
+ my $a = shift;
+ my %options = @_;
+
+ foreach (qw/description maildrop/) {
+ $a->{$_} = explode ($options{'-concat'}, $a->{$_})
+ if defined $a->{$_};
+ }
+
+ my ($l,$d) = split /\@/, $a->{alias}, 2;
+
+ eval {
+ die "Missing alias name\n" if $l eq '';
+ &_is_valid($a);
+ die "‘".$a->{alias}."‘ alread exists\n"
+ if $self->local->exists($l,$d,%options);
+
+ my %attrs = ( objectClass => 'FripostVirtualAlias'
+ , fripostIsStatusActive => $a->{isactive} ? 'TRUE' : 'FALSE'
+ , fripostMaildrop => $a->{maildrop}
+ , fripostOwner => $self->whoami
+ );
+ $attrs{description} = $a->{description}
+ if defined $a->{description} and @{$a->{description}};
+
+ my $mesg = $self->ldap->add( "fva=$l,fvd=$d,".$self->suffix,
+ attrs => [ %attrs ] );
+ if ($mesg->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $mesg->error;
+ }
+ };
+ return $@;
+}
+
+=back
+
+=head1 GLOBAL OPTIONS
+
+If the B<-concat> option is present, it will intersperse multi-valued
+attributes. Otherwise, an array reference containing every values will
+be returned for these attributes.
+
+The B<-die> option, if present, overides LDAP croaks and errors.
+
+=cut
+
+
+# Ensure that the given alias is valid.
+sub _is_valid {
+ my $a = shift;
+ must_attrs( $a, qw/alias isactive maildrop/ );
+ email_valid( $a->{alias}, -exact => 1 );
+ $a->{maildrop} = [ map { email_valid($_) } @{$a->{maildrop}} ];
+ # TODO: check for cycles?
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/Domain.pm b/lib/Fripost/Schema/Domain.pm
new file mode 100644
index 0000000..3ff2c25
--- /dev/null
+++ b/lib/Fripost/Schema/Domain.pm
@@ -0,0 +1,183 @@
+package Fripost::Schema::Domain;
+
+=head1 NAME
+
+Domain.pm -
+
+=head1 DESCRIPTION
+
+Domain.pm abstracts the LDAP schema definition and provides methods to
+add, list or delete virtual domains.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use parent 'Fripost::Schema';
+use Fripost::Schema::Misc qw/concat get_perms explode must_attrs email_valid/;
+use Email::Valid;
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<search> (I<OPTIONS>)
+
+List every known (and visible) domain. The output is a array of hash
+references, sorted by domain names.
+
+=cut
+
+sub search {
+ my $self = shift;
+ my %options = @_;
+ my $concat = $options{'-concat'};
+
+ my $domains = $self->ldap->search(
+ base => $self->suffix,
+ scope => 'one',
+ deref => 'never',
+ filter => 'objectClass=FripostVirtualDomain',
+ attrs => [ qw/fvd description fripostIsStatusActive/ ]
+ );
+ if ($domains->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $domains->error;
+ }
+ return map { { domain => $_->get_value('fvd')
+ , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE'
+ , description => concat($concat, $_->get_value('description'))
+ }
+ }
+ $domains->sorted('fvd')
+}
+
+
+=item B<get> (I<domain>, I<OPTIONS>)
+
+Returns a hash with all the (visible) attributes for the given domain.
+
+=cut
+
+sub get {
+ my $self = shift;
+ my $d = shift;
+ my %options = @_;
+ my $concat = $options{'-concat'};
+
+ my $domains = $self->ldap->search(
+ base => "fvd=$d,".$self->suffix,
+ scope => 'base',
+ deref => 'never',
+ filter => 'objectClass=FripostVirtualDomain',
+ attrs => [ qw/fvd description
+ fripostIsStatusActive
+ fripostOptionalMaildrop
+ fripostCanCreateAlias
+ fripostCanCreateList
+ fripostOwner
+ fripostPostmaster/ ]
+ );
+ if ($domains->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $domains->error;
+ }
+
+ # The following is not supposed to happen.
+ die "Error: Multiple matching entries found." if $domains->count > 1;
+ my $domain = $domains->pop_entry;
+ unless (defined $domain) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die "No such such domain ‘$d‘.\n";
+ }
+
+ return ( domain => $domain->get_value('fvd')
+ , isactive => $domain->get_value('fripostIsStatusActive') eq 'TRUE'
+ , description => concat($concat, $domain->get_value('description'))
+ , catchalls => concat($concat, $domain->get_value('fripostOptionalMaildrop'))
+ , permissions => get_perms($domain, $self->whoami)
+ )
+}
+
+
+=item B<replace> (I<domain>, I<OPTIONS>)
+
+Replace an existing domain with the given one.
+
+=cut
+
+sub replace {
+ my $self = shift;
+ my $d = shift;
+ my %options = @_;
+
+ foreach (qw/description catchalls/) {
+ $d->{$_} = explode ($options{'-concat'}, $d->{$_})
+ if defined $d->{$_};
+ }
+
+ eval {
+ &_is_valid($d);
+ my $mesg = $self->ldap->modify(
+ 'fvd='.$d->{domain}.','.$self->suffix,
+ replace => { fripostIsStatusActive => $d->{isactive} ?
+ 'TRUE' : 'FALSE'
+ , description => $d->{description}
+ , fripostOptionalMaildrop => $d->{catchalls}
+ } );
+ die $mesg->error."\n" if $mesg->code;
+ };
+ return $@;
+}
+
+
+sub add {
+ die "TODO";
+}
+
+=back
+
+=head1 GLOBAL OPTIONS
+
+If the B<-concat> option is present, it will intersperse multi-valued
+attributes. Otherwise, an array reference containing every values will
+be returned for these attributes.
+
+The B<-die> option, if present, overides LDAP croaks and errors.
+
+=cut
+
+
+
+# Ensure that the given domain is valid.
+sub _is_valid {
+ my $d = shift;
+ must_attrs( $d, qw/domain isactive/ );
+ email_valid( $d->{domain}, -prefix => 'fake@', -error => 'Invalid domain',
+ -exact => 1 );
+ $d->{catchalls} = [ map { email_valid($_) } @{$d->{catchalls}} ];
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/List.pm b/lib/Fripost/Schema/List.pm
new file mode 100644
index 0000000..f3ce4b8
--- /dev/null
+++ b/lib/Fripost/Schema/List.pm
@@ -0,0 +1,192 @@
+package Fripost::Schema::List;
+
+=head1 NAME
+
+List.pm -
+
+=head1 DESCRIPTION
+
+List.pm abstracts the LDAP schema definition and provides methods to
+add, list or delete virtual mailing lists.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use parent 'Fripost::Schema';
+use Fripost::Schema::Misc qw/concat explode must_attrs email_valid/;
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<search> (I<domain>, I<OPTIONS>)
+
+List every known (and visible) list under the given domain. The output
+is a array of hash references, sorted by list.
+
+=cut
+
+sub search {
+ my $self = shift;
+ my $domain = shift;
+ my %options = @_;
+ my $concat = $options{'-concat'};
+
+ my $lists = $self->ldap->search(
+ base => "fvd=$domain,".$self->suffix,
+ scope => 'one',
+ deref => 'never',
+ filter => 'objectClass=FripostVirtualList',
+ attrs => [ qw/fvl description fripostIsStatusActive
+ fripostListManager/ ]
+ );
+ if ($lists->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $lists->error;
+ }
+ return map { { list => $_->get_value('fvl')
+ , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE'
+ , description => concat($concat, $_->get_value('description'))
+ , transport => $_->get_value('fripostListManager')
+ }
+ }
+ $lists->sorted('fvl')
+}
+
+
+=item B<replace> (I<list>, I<OPTIONS>)
+
+Replace an existing list with the given one.
+
+=cut
+
+sub replace {
+ my $self = shift;
+ my $l = shift;
+ my %options = @_;
+
+ $l->{description} = explode ($options{'-concat'}, $l->{description})
+ if defined $l->{description};
+
+ my ($l2,$d) = split /\@/, $l->{list}, 2;
+
+ eval {
+ &_is_valid($l);
+ my $l3 = { fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE'
+ , description => $l->{description} };
+ $l3->{fripostListManager} = $l->{transport} if defined $l->{transport};
+ my $mesg = $self->ldap->modify(
+ "fvl=$l2,fvd=$d,".$self->suffix,
+ replace => $l3 );
+ die $mesg->error."\n" if $mesg->code;
+ };
+ return $@;
+}
+
+
+=item B<add> (I<list>, I<OPTIONS>)
+
+Add the given list.
+
+=cut
+
+sub add {
+ my $self = shift;
+ my $l = shift;
+ my %options = @_;
+
+ $l->{description} = explode ($options{'-concat'}, $l->{description})
+ if defined $l->{description};
+
+ my ($l2,$d) = split /\@/, $l->{list}, 2;
+
+ eval {
+ die "Missing list name\n" if $l eq '';
+ must_attrs( $l, 'transport' );
+ &_is_valid($l);
+ die "‘".$l->{list}."‘ alread exists\n"
+ if $self->local->exists($l2,$d,%options);
+
+ my %attrs = ( objectClass => 'FripostVirtualList'
+ , fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE'
+ , fripostOwner => $self->whoami
+ , fripostListManager => $l->{transport}
+ );
+ if ($l->{transport} eq 'mailman') {
+ $attrs{fripostListCommand} =
+ [ map { $l2.'-'.$_ }
+ qw/admin bounces confirm join leave loop owner
+ request subscribe unsubscribe/ ];
+ }
+ elsif ($l->{transport} eq 'schleuder') {
+ $attrs{fripostListCommand} =
+ [ map { $l2.'-'.$_ }
+ # TODO: check that
+ qw/request bounce sendkey owner/ ];
+ }
+ $attrs{description} = $l->{description}
+ if defined $l->{description} and @{$l->{description}};
+
+ my $mesg = $self->ldap->add( "fvl=$l2,fvd=$d,".$self->suffix,
+ attrs => [ %attrs ] );
+ if ($mesg->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $mesg->error;
+ }
+ };
+ return $@;
+}
+
+
+
+=back
+
+=head1 GLOBAL OPTIONS
+
+If the B<-concat> option is present, it will intersperse multi-valued
+attributes. Otherwise, an array reference containing every values will
+be returned for these attributes.
+
+The B<-die> option, if present, overides LDAP croaks and errors.
+
+=cut
+
+
+# Ensure that the given alias is valid.
+sub _is_valid {
+ my $l = shift;
+ must_attrs( $l, qw/list isactive/ );
+ email_valid( $l->{list}, -exact => 1 );
+
+ say STDERR $l->{transport};
+
+ die "Invalid transport: ‘".$l->{transport}."‘\n"
+ if defined $l->{transport} and
+ $l->{transport} !~ /^(schleuder|mailman)$/;
+ # TODO: check commands
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/Local.pm b/lib/Fripost/Schema/Local.pm
new file mode 100644
index 0000000..79c5420
--- /dev/null
+++ b/lib/Fripost/Schema/Local.pm
@@ -0,0 +1,161 @@
+package Fripost::Schema::Local;
+
+=head1 NAME
+
+Local.pm -
+
+=head1 DESCRIPTION
+
+Local.pm abstracts the LDAP schema definition and provides methods to
+search for virtual mailboxes, aliases or lists alltogether.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use parent 'Fripost::Schema';
+use Fripost::Schema::Misc 'concat';
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<get> (I<local>,I<domain>, I<OPTIONS>)
+
+Returns a hash with all the (visible) attributes for the given entry. An
+additional 'type' attribute gives the type of *the* found entry
+(possible values are 'mailbox', 'alias', and 'list').
+
+=cut
+
+sub get {
+ my $self = shift;
+ my $l = shift;
+ my $d = shift;
+ my %options = @_;
+ my $concat = $options{'-concat'};
+
+ my $locals = $self->ldap->search(
+ base => "fvd=$d,".$self->suffix,
+ scope => 'one',
+ deref => 'never',
+ filter => "(|(&(objectClass=FripostVirtualMailbox)(fvu=$l))
+ (&(objectClass=FripostVirtualAlias)(fva=$l))
+ (&(objectClass=FripostVirtualList)(fvl=$l)))",
+ attrs => [ qw/fvu description
+ fripostIsStatusActive
+ fripostOptionalMaildrop
+ fripostMailboxQuota
+ fva fripostMaildrop
+ fvl fripostListManager/ ]
+ );
+ if ($locals->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $locals->error;
+ }
+
+ # The following is not supposed to happen. Note that there is
+ # nothing in the LDAP schema to prevent that, but it's not too
+ # critical as Postfix search for mailboxes, aliases and lists in
+ # that order.
+ die "Error: Multiple matching entries found." if $locals->count > 1;
+ my $local = $locals->pop_entry;
+
+ unless (defined $local) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die "No such such entry ‘".$l.'@'.$d."‘.\n";
+ }
+
+ my %ret;
+ if ($local->dn =~ /^fvu=/) {
+ $ret{type} = 'mailbox';
+ $ret{user} = $local->get_value('fvu');
+ $ret{forwards} = concat($concat, $local->get_value('fripostOptionalMaildrop'))
+ }
+ elsif ($local->dn =~ /^fva=/) {
+ $ret{type} = 'alias';
+ $ret{alias} = $local->get_value('fva');
+ $ret{maildrop} = concat($concat, $local->get_value('fripostMaildrop'))
+ }
+ elsif ($local->dn =~ /^fvl=/) {
+ $ret{type} = 'list';
+ $ret{list} = $local->get_value('fvl');
+ }
+ $ret{isactive} = $local->get_value('fripostIsStatusActive') eq 'TRUE';
+ $ret{description} = concat($concat, $local->get_value('description'));
+
+ return %ret;
+}
+
+
+=item B<exists> (I<local>,I<domain>, I<OPTIONS>)
+
+Returns 1 if the given I<local>@I<domain> exists, and 0 otherwise.
+The authenticated user needs to have search access to the 'entry'
+attribute.
+
+=cut
+
+sub exists {
+ my $self = shift;
+ my $l = shift;
+ my $d = shift;
+ my %options = @_;
+
+ # We may not have read access to the list commands
+ # The trick is somewhat dirty, but it's safe enough since postfix
+ # delivers to mailboxes, aliases, and lists with different
+ # priorities (and lists have the lowest).
+# $l =~ s/(.*)-(admin|bounces|confirm|join|leave|loop|owner|request|subscribe|unsubscribe|bounce|sendkey)$/$1/;
+ # ^ TODO
+
+ foreach my $t (qw/fvu fva fvl/) {
+ my $mesg = $self->ldap->search( base => "$t=$l,fvd=$d,".$self->suffix,
+ scope => 'base',
+ deref => 'never',
+ filter => 'objectClass=*'
+ );
+ return 1 unless $mesg->code; # 0 Success
+ unless ($mesg->code == 32) { # 32 No such object
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $mesg->error;
+ }
+ }
+ return 0;
+}
+
+=back
+
+=head1 GLOBAL OPTIONS
+
+If the B<-concat> option is present, it will intersperse multi-valued
+attributes. Otherwise, an array reference containing every values will
+be returned for these attributes.
+
+The B<-die> option, if present, overides LDAP croaks and errors.
+
+=cut
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/Mailbox.pm b/lib/Fripost/Schema/Mailbox.pm
new file mode 100644
index 0000000..61d86a0
--- /dev/null
+++ b/lib/Fripost/Schema/Mailbox.pm
@@ -0,0 +1,203 @@
+package Fripost::Schema::Mailbox;
+
+=head1 NAME
+
+Mailbox.pm -
+
+=head1 DESCRIPTION
+
+Mailbox.pm abstracts the LDAP schema definition and provides methods to
+add, list or delete virtual mailboxes.
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use parent 'Fripost::Schema';
+use Fripost::Schema::Misc qw/concat explode must_attrs email_valid/;
+
+
+=head1 METHODS
+
+=over 4
+
+=item B<search> (I<domain>, I<OPTIONS>)
+
+List every known (and visible) mailbox under the given domain. The
+output is a array of hash references, sorted by mailbox.
+
+=cut
+
+sub search {
+ my $self = shift;
+ my $domain = shift;
+ my %options = @_;
+ my $concat = $options{'-concat'};
+
+ my $mailboxes = $self->ldap->search(
+ base => "fvd=$domain,".$self->suffix,
+ scope => 'one',
+ deref => 'never',
+ filter => 'objectClass=FripostVirtualMailbox',
+ attrs => [ qw/fvu description fripostIsStatusActive
+ fripostOptionalMaildrop
+ fripostMailboxQuota/ ]
+ );
+ if ($mailboxes->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $mailboxes->error;
+ }
+ return map { { user => $_->get_value('fvu')
+ , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE'
+ , description => concat($concat, $_->get_value('description'))
+ , forwards => concat($concat, $_->get_value('fripostOptionalMaildrop'))
+ , quota => $_->get_value('fripostMailboxQuota') // undef
+ }
+ }
+ $mailboxes->sorted('fvu')
+}
+
+
+=item B<replace> (I<mailbox>, I<OPTIONS>)
+
+Replace an existing account with the given one.
+
+=cut
+
+sub replace {
+ my $self = shift;
+ my $m = shift;
+ my %options = @_;
+
+ foreach (qw/description forwards/) {
+ $m->{$_} = explode ($options{'-concat'}, $m->{$_})
+ if defined $m->{$_};
+ }
+
+ my ($l,$d) = split /\@/, $m->{user}, 2;
+
+ eval {
+ &_is_valid($m);
+ my $mesg = $self->ldap->modify(
+ "fvu=$l,fvd=$d,".$self->suffix,
+ replace => { fripostIsStatusActive => $m->{isactive} ?
+ 'TRUE' : 'FALSE'
+ , description => $m->{description}
+ , fripostOptionalMaildrop => $m->{forwards}
+ } );
+ die $mesg->error."\n" if $mesg->code;
+ };
+ return $@;
+}
+
+
+=item B<passwd> (I<username>, I<password>, I<OPTIONS>)
+
+Change the password of the given user. I<password> is used raw, so you
+may want to hash it before hand.
+
+=cut
+
+sub passwd {
+ my $self = shift;
+ my ($l,$d) = split /\@/, shift, 2;
+ my $pw = shift;
+ my %options = @_;
+
+ my $mesg = $self->ldap->modify(
+ "fvu=$l,fvd=$d,".$self->suffix,
+ replace => { userPassword => $pw } );
+ return "Cannot change password" if $mesg->code;
+}
+
+
+
+=item B<add> (I<mailbox>, I<OPTIONS>)
+
+Add the given account.
+
+=cut
+
+sub add {
+ my $self = shift;
+ my $m = shift;
+ my %options = @_;
+
+ foreach (qw/description forwards/) {
+ $m->{$_} = explode ($options{'-concat'}, $m->{$_})
+ if defined $m->{$_};
+ }
+
+ my ($l,$d) = split /\@/, $m->{user}, 2;
+
+ eval {
+ die "Missing user name\n" if $l eq '';
+ &_is_valid($m);
+ die "‘".$m->{user}."‘ alread exists\n"
+ if $self->local->exists($l,$d,%options);
+
+ my %attrs = ( objectClass => 'FripostVirtualMailbox'
+ , fripostIsStatusActive => $m->{isactive} ? 'TRUE' : 'FALSE'
+ , userPassword => $m->{password}
+ );
+ $attrs{description} = $m->{description}
+ if defined $m->{description} and @{$m->{description}};
+ $attrs{fripostMailboxQuota} = $m->{quota} if defined $m->{quota};
+ $attrs{fripostOptionalMaildrop} = $m->{forwards}
+ if defined $m->{forwards} and @{$m->{forwards}};
+
+ my $mesg = $self->ldap->add( "fvu=$l,fvd=$d,".$self->suffix,
+ attrs => [ %attrs ] );
+ if ($mesg->code) {
+ die $options{'-die'}."\n" if defined $options{'-die'};
+ die $mesg->error;
+ }
+ };
+ return $@;
+}
+
+
+=back
+
+=head1 GLOBAL OPTIONS
+
+If the B<-concat> option is present, it will intersperse multi-valued
+attributes. Otherwise, an array reference containing every values will
+be returned for these attributes.
+
+The B<-die> option, if present, overides LDAP croaks and errors.
+
+=cut
+
+
+# Ensure that the given mailbox is valid.
+sub _is_valid {
+ my $m = shift;
+ must_attrs( $m, qw/user isactive/ );
+ email_valid( $m->{user}, -exact => 1);
+ $m->{forwards} = [ map { email_valid($_) } @{$m->{forwards}} ];
+ # TODO: match 'quota' against the Dovecot specifications
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__
diff --git a/lib/Fripost/Schema/Misc.pm b/lib/Fripost/Schema/Misc.pm
new file mode 100644
index 0000000..be88385
--- /dev/null
+++ b/lib/Fripost/Schema/Misc.pm
@@ -0,0 +1,130 @@
+package Fripost::Schema::Misc;
+
+=head1 NAME
+
+Misc.pm -
+
+=cut
+
+use 5.010_000;
+use strict;
+use warnings;
+use utf8;
+
+use Exporter 'import';
+our @EXPORT_OK = qw /concat get_perms explode
+ must_attrs email_valid/;
+use Email::Valid;
+
+
+# Let the first argument, if defined, intersperse the other arguments.
+sub concat {
+ my $concat = shift;
+
+ if (defined $concat) {
+ return join ($concat, @_);
+ }
+ else {
+ return [ @_ ];
+ }
+}
+
+# The reverse of 'concat': takes a single line, and split it along
+# "concat", if defined. Returns an array reference in any case.
+sub explode {
+ my $concat = shift;
+
+ my $out;
+ if (defined $concat) {
+ $out = [ split /$concat/, $_[0] ];
+ }
+ else {
+ $out = [ @_ ];
+ }
+ [ grep { !/^\s*$/ } @$out ];
+}
+
+
+# This subroutine displays the access that the given DN has on the entry.
+# Possible values are :
+# - '': no rights
+# - a: can create aliases
+# - l: can create lists
+# - al: can create aliases & lists
+# - o: owner
+# - p: postmaster
+sub get_perms {
+ my ($entry, $dn) = @_;
+ my $perms = '';
+
+ $perms .= 'a'
+ if grep { $dn eq $_ or (split /,/,$dn,2)[1] eq $_ }
+ $entry->get_value ('fripostCanCreateAlias');
+
+ $perms .= 'l'
+ if grep { $dn eq $_ or (split /,/,$dn,2)[1] eq $_ }
+ $entry->get_value ('fripostCanCreateList');
+
+ $perms = 'o'
+ if grep { $dn eq $_ } $entry->get_value('fripostOwner');
+
+ $perms = 'p'
+ if grep { $dn eq $_ } $entry->get_value('fripostPostmaster');
+
+ return $perms;
+}
+
+
+# "&must_att $h qw/a b c .../" ensures that attributes a b c... are all
+# defined in the hash reference.
+sub must_attrs {
+ my $h = shift;
+ foreach (@_) {
+ die '‘'.$_."‘: Missing attribute.\n"
+ unless defined $h->{$_} and
+ (ref $h->{$_} eq 'ARRAY' ? @{$h->{$_}} : $h->{$_} ne '')
+ }
+}
+
+
+# Ensure that the first argument is a valid email. Can also be used to
+# check the validity of domains using the '-prefix' option.
+# '-exact' forces the input to be a bare email, ("name <email>" is not
+# allowed).
+sub email_valid {
+ my $in = shift;
+ my %options = @_;
+
+ my $i = $in;
+ $i =~ s/.*<([^>]+)>.*/$1/;
+ my $mesg = $options{'-error'} // "Invalid e-mail";
+ $in = $options{'-prefix'}.$in if defined $options{'-prefix'};
+
+ my $addr = Email::Valid::->address( -address => $in,
+ -tldcheck => 1,
+ -fqdn => 1 );
+ my $match = defined $addr;
+ $match &&= $addr eq $in if $options{'-exact'};
+ die $mesg." ‘".$i."‘\n" unless $match;
+ return $addr;
+}
+
+
+=head1 AUTHOR
+
+Guilhem Moulin C<< <guilhem at fripost.org> >>
+
+=head1 COPYRIGHT
+
+Copyright 2012 Guilhem Moulin.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=cut
+
+1;
+
+__END__