diff options
author | Guilhem Moulin <guilhem.moulin@fripost.org> | 2012-09-08 19:49:11 +0200 |
---|---|---|
committer | Guilhem Moulin <guilhem.moulin@fripost.org> | 2012-09-08 23:40:50 +0200 |
commit | 4a0d87e642c4d97ee2a026f1207e25a001518f3a (patch) | |
tree | b742103cfbce8c7c576766f4db9016f0faa9b629 /lib | |
parent | 0dfeabffccf3695f5f270964aa8ef8e3460ae440 (diff) |
Abstracting the LDAP stuff in an OO library.
Diffstat (limited to 'lib')
-rw-r--r-- | lib/FPanel/Interface.pm | 690 | ||||
-rw-r--r-- | lib/FPanel/Login.pm | 54 | ||||
-rwxr-xr-x | lib/Fripost/Password.pm | 133 | ||||
-rw-r--r-- | lib/Fripost/Schema.pm | 202 | ||||
-rw-r--r-- | lib/Fripost/Schema/Alias.pm | 177 | ||||
-rw-r--r-- | lib/Fripost/Schema/Domain.pm | 183 | ||||
-rw-r--r-- | lib/Fripost/Schema/List.pm | 192 | ||||
-rw-r--r-- | lib/Fripost/Schema/Local.pm | 161 | ||||
-rw-r--r-- | lib/Fripost/Schema/Mailbox.pm | 203 | ||||
-rw-r--r-- | lib/Fripost/Schema/Misc.pm | 130 |
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__ |