diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Fripost/Panel/Interface.pm | 38 | ||||
| -rw-r--r-- | lib/Fripost/Panel/Login.pm | 6 | ||||
| -rw-r--r-- | lib/Fripost/Schema.pm | 3 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Auth.pm | 5 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Domain.pm | 58 | ||||
| -rw-r--r-- | lib/Fripost/Schema/Util.pm | 79 |
6 files changed, 107 insertions, 82 deletions
diff --git a/lib/Fripost/Panel/Interface.pm b/lib/Fripost/Panel/Interface.pm index eb9d69a..a0c9dd9 100644 --- a/lib/Fripost/Panel/Interface.pm +++ b/lib/Fripost/Panel/Interface.pm @@ -19,7 +19,7 @@ use Fripost::Password; use HTML::Entities 'encode_entities'; use URI::Escape::XS 'encodeURIComponent'; use Net::IDN::Encode qw/email_to_unicode email_to_ascii domain_to_ascii/; -use Encode; +use Encode (); # This method is called right before the 'setup' method below. It @@ -139,12 +139,11 @@ sub EditDomain : Runmode { my $self = shift; my %CFG = $self->cfg; - # Get the domain name from the URL. - my $domainname = ($self->split_path)[1]; - my $q = $self->query; return $self->redirect('./') if defined $q->param('cancel'); # Cancellation + # Get the domain name from the URL. + my $domainname = ($self->split_path)[1]; my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); my $error; # Tells whether the change submission has failed. @@ -185,10 +184,13 @@ sub ListLocals : Runmode { my $self = shift; my %CFG = $self->cfg; + my $q = $self->query; + return $self->redirect('./') if defined $q->param('cancel'); # Cancellation + + # Get the domain name from the URL. my $domainname = ($self->split_path)[1]; my $fp = Fripost::Schema::->SASLauth( $self->authen->username, %CFG ); - my $q = $self->query; if (defined $q->param('unlock')) { # Unlock the domain, and come back to the home page. # Errors are thrown away. @@ -512,37 +514,18 @@ sub mkURL { join '/', ($host, @path); } -sub mkLink { - my $k = shift; - my $d = shift; - ( $k => encode_entities($d), - $k.'URL' => &mkURL('.', $d) ) -} - sub userInfo { my $self = shift; my ($l,$d) = split_addr( $self->authen->username, -encode => 'unicode' ); my $root = $ENV{SCRIPT_NAME} // $self->cfg->{'cgi-bin'} // ''; $root =~ s@/$@@s; - ( user_localpart => encode_entities($l) + ( user_localpart => encode_entities($l) , user_domainpart => encode_entities($d) - , userURL => &mkURL ($root, $d, $l) + , user_URL => &mkURL ($root, $d, $l) ) } -sub mkFormContentE { # TODO delete - &mkFormContent (map { encode_entities ($_) } @_); -} - -sub mkFormContent { # TODO delete - join ("\x{0D}\x{0A}", @_); -} - -sub mkDesc { # TODO delete - my $desc = shift // return ''; - join '<br>', map {encode_entities($_)} @$desc; -} my @single_valued_keys = qw/isActive quota/; my @multi_valued_keys = qw/description catchAll @@ -561,7 +544,8 @@ sub fill_HTML_template_from_entry { if ($key eq 'name') { $vars{$key} = encode_entities($entry->{$key}); } - elsif (grep {$key eq $_} ('URL', 'listURL', @single_valued_keys)) { + elsif (grep {$key eq $_} (qw/URL list_URL transport/, + @single_valued_keys)) { $vars{$key} = $entry->{$key}; } elsif (grep {$key eq $_} @multi_valued_keys) { diff --git a/lib/Fripost/Panel/Login.pm b/lib/Fripost/Panel/Login.pm index 1eabafb..22a870a 100644 --- a/lib/Fripost/Panel/Login.pm +++ b/lib/Fripost/Panel/Login.pm @@ -23,7 +23,7 @@ use Fripost::Schema::Util 'split_addr'; use HTML::Entities 'encode_entities'; use URI::Escape::XS 'decodeURIComponent'; -use Encode; +use Encode (); # This method is called right before the 'setup' method below. It # initializes the session and authentication configurations. @@ -56,9 +56,7 @@ sub cgiapp_init { $self->authen->config( DRIVER => [ 'Generic', sub { my ($u,$p) = @_; - my $d = (split_addr($u))[1]; - - unless (defined $d) { + unless ($u =~ /\@/) { $CFG{default_realm} // return 0; $u .= '@'.$CFG{default_realm}; } diff --git a/lib/Fripost/Schema.pm b/lib/Fripost/Schema.pm index 7526077..42ebac5 100644 --- a/lib/Fripost/Schema.pm +++ b/lib/Fripost/Schema.pm @@ -19,15 +19,12 @@ use warnings; use utf8; use parent 'Fripost::Schema::Auth'; -use Net::LDAP; -use Authen::SASL; use Fripost::Schema::Util qw/canonical_dn ldap_explode_dn split_addr/; use Fripost::Schema::Domain; use Fripost::Schema::User; use Fripost::Schema::Alias; use Fripost::Schema::List; use Fripost::Schema::Local; -use Net::IDN::Encode 'email_to_ascii'; =head1 METHODS diff --git a/lib/Fripost/Schema/Auth.pm b/lib/Fripost/Schema/Auth.pm index c6325b8..d9c0267 100644 --- a/lib/Fripost/Schema/Auth.pm +++ b/lib/Fripost/Schema/Auth.pm @@ -253,10 +253,7 @@ converted to ASCII. sub mail2dn { my $self = shift; - my $user = shift // return; - - $user =~ s/^([^\@]+)$/\@$1/; - my ($l,$d) = split_addr($user, -encode => 'ascii'); + my ($l,$d) = split_addr(shift, -encode => 'ascii') or return; my @dn = ({fvd => $d}, @{$self->suffix}); unshift @dn, {fvl => $l} if $l; diff --git a/lib/Fripost/Schema/Domain.pm b/lib/Fripost/Schema/Domain.pm index 3caffb5..4cc12e4 100644 --- a/lib/Fripost/Schema/Domain.pm +++ b/lib/Fripost/Schema/Domain.pm @@ -18,11 +18,12 @@ use utf8; use parent 'Fripost::Schema'; use Fripost::Schema::Util qw/softdie dn2mail email_valid domain_valid - canonical_dn ldap_explode_dn ldap_error/; + canonical_dn ldap_explode_dn ldap_error + ldap_assert_absent/; use Fripost::Schema::Mail; use Net::IDN::Encode qw/domain_to_ascii domain_to_unicode email_to_unicode/; use URI::Escape::XS 'encodeURIComponent'; -use Encode; +use Encode (); use Net::Domain::TLD 'tld_exists'; use Net::DNS::Dig; use Net::Whois::Parser 'parse_whois'; @@ -280,7 +281,7 @@ sub _entries_to_domains { if not @$keys or grep { $_ eq 'description' } @$keys; } else { - die "Missing translation for domain attribute ‘".$attr."’."; + die "Missing translation for domain attribute ‘".$attr."’"; } } @@ -327,7 +328,7 @@ sub _keys_to_attrs { ); my %attrs; foreach my $k (@_) { - die "Missing translation for key ‘".$k."’." + die "Missing translation for key ‘".$k."’" unless exists $map{$k}; if (ref $map{$k} eq 'ARRAY') { $attrs{$_} = 1 for @{$map{$k}}; @@ -410,7 +411,7 @@ sub list_owner_emails { my $domain; until ( tld_exists($tld) ) { - softdie ("‘".$domainname."’ has an Invalid TLD.", %options) // return + softdie ("‘".$domainname."’ has an Invalid TLD", %options) // return unless $tld =~ /\./; $domain = $tld; @@ -495,25 +496,33 @@ sub add { my $domainname = $domain->{name}; # Check domain validity. - &_is_valid($domain, %options) // return; - my $dn = $self->mail2dn( $domain->{name} ); - - # Search for an existing domain with the same name. - my $count = $self->search($domain->{name}, %options, '-count' => 1); - softdie ( "Domain ‘".$domainname."’ already exists.", %options ) // return - if not $options{'-append'} and $count; - # Stop here in dry-run mode. - return 1 if $options{'-dry-run'}; + &_assert_valid($domain, %options) // return; + + my $exists; + if ($options{'-dry-run'} or $options{'-append'}) { + # Search for an existing domain with the same name. We can't + # use our previously defined method here, since the current user + # may not have read access to the entry. There is a race + # condition since someone could modify the directory between + # this check and the actual insertion, but then the insertion + # would fail. + $exists = ldap_assert_absent( $self, $domain->{name}, undef, %options) + // return; + return 1 if $options{'-dry-run'}; + } # Convert the domain into a LDAP entry, and remove keys to empty values. my %attrs = $self->_domain_to_entry (%$domain); - Fripost::Schema::Util::clean_ldap_entry( \%attrs ); + Fripost::Schema::Util::ldap_clean_entry( \%attrs ); my ($mesg, $token); - if ($options{'-append'} and $count) { + my $dn = $self->mail2dn( $domain->{name} ); + if ($options{'-append'} and $exists) { # Replace single valued attributes; Add other attributes. - my %unique = ( fripostIsStatusActive => $attrs{fripostIsStatusActive} ); - delete $attrs{$_} for (keys %unique); + my %unique; + foreach (qw/fripostIsStatusActive/) { + $unique{$_} = delete $attrs{$_} if exists $attrs{$_}; + } $mesg = $self->ldap->modify( $dn, replace => \%unique, add => \%attrs ); } else { @@ -528,6 +537,10 @@ sub add { } # The default owner is the current user. $attrs{fripostOwner} //= [ $self->whoami ]; + $options{'-die'} = { Net::LDAP::Constant::LDAP_ALREADY_EXISTS => + "‘".$domainname."’ exists" + , Net::LDAP::Constant::LDAP_SUCCESS => 0 } + unless exists $options{'-die'}; $mesg = $self->ldap->add( $dn, attrs => [ %attrs ] ); } @@ -594,7 +607,7 @@ sub _domain_to_entry { [ map { $self->mail2dn($_) } @{$domain{postmaster}} ]; } else { - die "Missing translation for domain key ‘".$key."’."; + die "Missing translation for domain key ‘".$key."’"; } } return %entry; @@ -681,7 +694,7 @@ sub replace { return if $options{'-error'} && ${$options{'-error'}}; # Check domain validity. - &_is_valid($domain, %options) // return; + &_assert_valid($domain, %options, -replace => 1) // return; return 1 if $options{'-dry-run'}; my %entry = $self->_domain_to_entry (%$domain); @@ -693,11 +706,12 @@ sub replace { # Ensure that the given domain is valid. -sub _is_valid { +sub _assert_valid { my $d = shift; my %options = @_; eval { - Fripost::Schema::Util::must_attrs( $d, qw/name isActive/ ); + Fripost::Schema::Util::must_attrs( $d, qw/name isActive/ ) + unless $options{'-append'} or $options{'-replace'}; $d->{name} = domain_valid( domain_to_ascii ($d->{name}) ); $d->{catchAll} = [ map { email_valid($_, -prefix => 'fake') } @{$d->{catchAll}} ] diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm index 59d724f..b3439cc 100644 --- a/lib/Fripost/Schema/Util.pm +++ b/lib/Fripost/Schema/Util.pm @@ -15,10 +15,11 @@ use Exporter 'import'; our @EXPORT_OK = qw /concat get_perms explode must_attrs domain_valid email_valid split_addr dn2mail canonical_dn ldap_explode_dn ldap_error ldap_and_filter - clean_ldap_entry - assert softdie/; + ldap_clean_entry + assert ldap_assert_absent softdie/; use Email::Valid; -use Net::IDN::Encode qw/domain_to_unicode email_to_unicode/; +use Net::IDN::Encode qw/domain_to_unicode email_to_unicode + domain_to_ascii email_to_ascii/; use Net::LDAP::Util; use Encode; @@ -89,7 +90,7 @@ sub get_perms { sub must_attrs { my $h = shift; foreach (@_) { - die 'Missing attribute: ‘'.$_."’\n" + die 'Missing value: ‘'.$_."’\n" unless defined $h->{$_} and (ref $h->{$_} eq 'ARRAY' ? @{$h->{$_}} : $h->{$_} ne '') } @@ -110,14 +111,17 @@ sub email_valid { $in = $options{'-prefix'}.$i if defined $options{'-prefix'}; Encode::_utf8_on($in); Encode::_utf8_on($i); - $in = Net::IDN::Encode::email_to_ascii($in); - - my $addr = Email::Valid::->address( -address => $in, - -tldcheck => 1, - -fqdn => 1 ); - my $match = defined $addr; - $match &&= $addr eq $in if $options{'-exact'}; - unless ($match) { + + my ($addr, $match); + eval { + $in = Net::IDN::Encode::email_to_ascii($in); + $addr = Email::Valid::->address( -address => $in, + -tldcheck => 1, + -fqdn => 1 ); + $match = defined $addr; + $match &&= $addr eq $in if $options{'-exact'}; + }; + if ($@ || !$match) { return if $options{'-nodie'}; die $mesg." ‘".$i."’\n"; } @@ -157,24 +161,33 @@ sub split_addr { my $addr = shift // return; my %options = @_; - $addr =~ /^(.*)\@([^\@]+)$/s; - my ($l,$d) = ($1, $2); - + Encode::_utf8_on($addr); + my $mesg = $addr =~ /\@/ ? "Invalid e-mail ‘".$addr."’" : + "Invalid domain ‘".$addr."’"; + my $ret; if (defined $options{'-encode'}) { my $e = $options{'-encode'}; if ($e eq 'ascii') { - Encode::_utf8_on($d); - $d = Net::IDN::Encode::domain_to_ascii($d); + eval { $addr = $addr =~ /\@/ ? email_to_ascii($addr) + : domain_to_ascii($addr); + }; + $ret = $@; } elsif ($e eq 'unicode') { - $d = Net::IDN::Encode::domain_to_unicode($d); + eval { $addr = $addr =~ /\@/ ? email_to_unicode($addr) + : domain_to_unicode($addr); + }; + $ret = $@; } else { - softdie ("Unknown encoding: ". $e, %options); - return; + die "Unknown encoding ‘".$e."’"; } } - return ($l,$d); + softdie ($mesg, %options) // return if $ret; + return ('',$addr) unless $addr =~ /\@/; + + $addr =~ /^(.*)\@([^\@]+)$/; + return ($1,$2); } sub ldap_error { @@ -252,7 +265,7 @@ sub ldap_and_filter { } -sub clean_ldap_entry { +sub ldap_clean_entry { my $attrs = shift; foreach (keys %$attrs) { @@ -270,6 +283,28 @@ sub clean_ldap_entry { } } +sub ldap_assert_absent { + my $self = shift; + my $name = shift; + my $found = shift // "‘".$name."’ exists"; + my %options = @_; + + my $mesg = $self->ldap->search( base => $self->mail2dn( $name ) + , scope => 'base' + , deref => 'never' + , filter => '(objectClass=*)' + , attrs => [ '1.1' ] + ); + $options{'-die'} = { Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT => 0 + , Net::LDAP::Constant::LDAP_SUCCESS => + $options{'-append'} ? 0 : $found + }; + ldap_error($mesg, %options) // return; + return $mesg->code eq Net::LDAP::Constant::LDAP_SUCCESS ? 1 : + $mesg->code eq Net::LDAP::Constant::LDAP_NO_SUCH_OBJECT ? 0 : + undef +} + =head1 AUTHOR Guilhem Moulin C<< <guilhem at fripost.org> >> |