From 1f35ed5ce38525af78508b46eea67a4f41c74a4a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Fri, 18 Jan 2013 21:44:37 +0100 Subject: =?UTF-8?q?Fripost::Schema::Misc=20=E2=86=92=20Fripost::Schema::Ut?= =?UTF-8?q?il?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Fripost/Schema/Alias.pm | 11 ++- lib/Fripost/Schema/Domain.pm | 5 +- lib/Fripost/Schema/List.pm | 15 ++-- lib/Fripost/Schema/Local.pm | 6 +- lib/Fripost/Schema/Misc.pm | 172 ------------------------------------------ lib/Fripost/Schema/User.pm | 13 ++-- lib/Fripost/Schema/Util.pm | 173 +++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 196 insertions(+), 199 deletions(-) delete mode 100644 lib/Fripost/Schema/Misc.pm create mode 100644 lib/Fripost/Schema/Util.pm (limited to 'lib/Fripost/Schema') diff --git a/lib/Fripost/Schema/Alias.pm b/lib/Fripost/Schema/Alias.pm index d121929..817f4a6 100644 --- a/lib/Fripost/Schema/Alias.pm +++ b/lib/Fripost/Schema/Alias.pm @@ -17,10 +17,9 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Misc qw/concat explode must_attrs email_valid +use Fripost::Schema::Util qw/concat explode must_attrs email_valid split_addr canonical_dn/; -use Net::IDN::Encode qw/domain_to_ascii - email_to_ascii email_to_unicode/; +use Net::IDN::Encode qw/domain_to_ascii email_to_ascii email_to_unicode/; =head1 METHODS @@ -80,7 +79,7 @@ sub replace { } eval { - my ($l,$d) = split_addr( $a->{alias}, -encoding => 'ascii' ); + my ($l,$d) = split_addr( $a->{alias}, -encode => 'ascii' ); &_is_valid($a); my $mesg = $self->ldap->modify( canonical_dn({fva => $l}, {fvd => $d}, @{$self->suffix}), @@ -113,7 +112,7 @@ sub add { eval { die "Missing alias name\n" unless $a->{alias} =~ /^.+\@.+$/; - my ($l,$d) = split_addr( $a->{alias}, -encoding => 'ascii' ); + my ($l,$d) = split_addr( $a->{alias}, -encode => 'ascii' ); &_is_valid($a); die "‘".$a->{alias}."’ already exists\n" if $self->local->exists($a->{alias},%options); @@ -145,7 +144,7 @@ Delete the given alias. sub delete { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my %options = @_; my $mesg = $self->ldap->delete( canonical_dn( {fva => $l}, {fvd => $d}, diff --git a/lib/Fripost/Schema/Domain.pm b/lib/Fripost/Schema/Domain.pm index c36cea8..fc80b4c 100644 --- a/lib/Fripost/Schema/Domain.pm +++ b/lib/Fripost/Schema/Domain.pm @@ -17,9 +17,8 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Misc qw/concat get_perms explode - must_attrs email_valid - canonical_dn/; +use Fripost::Schema::Util qw/concat get_perms explode must_attrs + email_valid canonical_dn/; use Net::IDN::Encode qw/domain_to_ascii domain_to_unicode email_to_ascii email_to_unicode/; diff --git a/lib/Fripost/Schema/List.pm b/lib/Fripost/Schema/List.pm index 58d198c..7753bd1 100644 --- a/lib/Fripost/Schema/List.pm +++ b/lib/Fripost/Schema/List.pm @@ -17,10 +17,9 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Misc qw/concat explode must_attrs email_valid +use Fripost::Schema::Util qw/concat explode must_attrs email_valid split_addr canonical_dn ldap_explode_dn/; -use Net::IDN::Encode qw/domain_to_ascii - email_to_ascii email_to_unicode/; +use Net::IDN::Encode qw/domain_to_ascii email_to_ascii email_to_unicode/; use Mail::GnuPG; use MIME::Entity; @@ -85,7 +84,7 @@ sub replace { if defined $l->{description}; eval { - my ($l2,$d) = split_addr( $l->{list}, -encoding => 'ascii' ); + my ($l2,$d) = split_addr( $l->{list}, -encode => 'ascii' ); &_is_valid($l); my $l3 = { fripostIsStatusActive => $l->{isactive} ? 'TRUE' : 'FALSE' , description => $l->{description} }; @@ -117,7 +116,7 @@ sub add { eval { die "Missing list name\n" unless $l->{list} =~ /^.+\@.+$/; - my ($l2,$d) = split_addr ( $l->{list}, -encoding => 'ascii' ); + my ($l2,$d) = split_addr ( $l->{list}, -encode => 'ascii' ); must_attrs( $l, 'transport' ); &_is_valid($l); die "‘".$l->{list}."’ already exists\n" @@ -177,7 +176,7 @@ the ListCreator entity, and the list is not known by the list manager. sub is_pending { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my %options = @_; my $dn = canonical_dn({fvl => $l}, {fvd => $d}, @{$self->suffix}); @@ -209,7 +208,7 @@ Add the lists commands, and remove the pending status. sub add_commands { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my $cmds = shift; my %options = @_; @@ -243,7 +242,7 @@ disk, but merely delete the list entry in the LDAP directory. sub delete { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my %options = @_; my $dn = canonical_dn( {fvl => $l}, {fvd => $d}, @{$self->suffix} ); diff --git a/lib/Fripost/Schema/Local.pm b/lib/Fripost/Schema/Local.pm index d8a71ef..5ca833c 100644 --- a/lib/Fripost/Schema/Local.pm +++ b/lib/Fripost/Schema/Local.pm @@ -17,7 +17,7 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Misc qw/concat split_addr canonical_dn/; +use Fripost::Schema::Util qw/concat split_addr canonical_dn/; use Net::IDN::Encode qw/email_to_ascii email_to_unicode/; use Net::LDAP::Util 'escape_filter_value'; @@ -40,7 +40,7 @@ sub get { my %options = @_; my $concat = $options{'-concat'}; - my ($l,$d) = split_addr( $loc, -encoding => 'ascii' ); + my ($l,$d) = split_addr( $loc, -encode => 'ascii' ); $l = escape_filter_value($l); my $locals = $self->ldap->search( base => canonical_dn({fvd => $d}, @{$self->suffix}), @@ -110,7 +110,7 @@ attribute. sub exists { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my %options = @_; # We may not have read access to the list commands diff --git a/lib/Fripost/Schema/Misc.pm b/lib/Fripost/Schema/Misc.pm deleted file mode 100644 index aec2618..0000000 --- a/lib/Fripost/Schema/Misc.pm +++ /dev/null @@ -1,172 +0,0 @@ -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 - canonical_dn ldap_explode_dn - split_addr/; -use Email::Valid; -use Net::IDN::Encode; -use Net::LDAP::Util; -use Encode; - - -# 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 @dn = @{ldap_explode_dn ($dn)}; - shift @dn; - my $dn2 = canonical_dn (@dn); - my $perms = ''; - - $perms .= 'a' - if grep { $dn eq $_ or $dn2 eq $_ } - $entry->get_value ('fripostCanCreateAlias'); - - $perms .= 'l' - if grep { $dn eq $_ or $dn2 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 " is not -# allowed). -sub email_valid { - my $in = shift; - my %options = @_; - - my $i = $in; - $i =~ s/^[^<>]+\s<([^>]+)>/$1/; - my $mesg = $options{'-error'} // "Invalid e-mail"; - $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'}; - die $mesg." ‘".$i."’\n" unless $match; - $addr =~ s/^$options{'-prefix'}// if defined $options{'-prefix'}; - return $addr; -} - -sub canonical_dn { - Net::LDAP::Util::canonical_dn(\@_, casefold => 'lower' - , mbcescape => 1 - , reverse => 0 - , separator => ','); -}; - -sub ldap_explode_dn { - Net::LDAP::Util::ldap_explode_dn( join (',', @_), casefold => 'lower' ) -} - -sub split_addr { - my $addr = shift; - my %options = @_; - - if (defined $options{'-encoding'}) { - if ($options{'-encoding'} eq 'ascii') { - $addr = Net::IDN::Encode::email_to_ascii($addr); - } - elsif ($options{'-encoding'} eq 'unicode') { - $addr = Net::IDN::Encode::email_to_unicode($addr); - } - else { - die "Unknown encoding: ". $options{'-encoding'}; - } - } - - split /\@/, $addr, 2; -} - - -=head1 AUTHOR - -Guilhem Moulin C<< >> - -=head1 COPYRIGHT - -Copyright 2012,2013 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/User.pm b/lib/Fripost/Schema/User.pm index ff8691f..7d79e69 100644 --- a/lib/Fripost/Schema/User.pm +++ b/lib/Fripost/Schema/User.pm @@ -17,10 +17,9 @@ use warnings; use utf8; use parent 'Fripost::Schema'; -use Fripost::Schema::Misc qw/concat explode must_attrs email_valid +use Fripost::Schema::Util qw/concat explode must_attrs email_valid split_addr canonical_dn/; -use Net::IDN::Encode qw/domain_to_ascii - email_to_ascii email_to_unicode/; +use Net::IDN::Encode qw/domain_to_ascii email_to_ascii email_to_unicode/; =head1 METHODS @@ -82,7 +81,7 @@ sub replace { } eval { - my ($l,$d) = split_addr( $m->{user}, -encoding => 'ascii' ); + my ($l,$d) = split_addr( $m->{user}, -encode => 'ascii' ); &_is_valid($m); my $mesg = $self->ldap->modify( canonical_dn( {fvu => $l}, {fvd => $d}, @{$self->suffix} ), @@ -106,7 +105,7 @@ may want to hash it before hand. sub passwd { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my $pw = shift; my %options = @_; @@ -137,7 +136,7 @@ sub add { eval { die "Missing user name\n" unless $m->{user} =~ /^.+\@.+$/; - my ($l,$d) = split_addr( $m->{user}, -encoding => 'ascii' ); + my ($l,$d) = split_addr( $m->{user}, -encode => 'ascii' ); &_is_valid($m); die "‘".$m->{user}."’ already exists\n" if $self->local->exists($m->{user},%options); @@ -174,7 +173,7 @@ but merely delete its entry in the LDAP directory. sub delete { my $self = shift; - my ($l,$d) = split_addr( shift, -encoding => 'ascii' ); + my ($l,$d) = split_addr( shift, -encode => 'ascii' ); my %options = @_; my $mesg = $self->ldap->delete( canonical_dn( {fvu => $l}, {fvd => $d}, diff --git a/lib/Fripost/Schema/Util.pm b/lib/Fripost/Schema/Util.pm new file mode 100644 index 0000000..8d75a3a --- /dev/null +++ b/lib/Fripost/Schema/Util.pm @@ -0,0 +1,173 @@ +package Fripost::Schema::Util; + +=head1 NAME + +Util.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 + canonical_dn ldap_explode_dn + split_addr/; +use Email::Valid; +use Net::IDN::Encode; +use Net::LDAP::Util; +use Encode; + + +# 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 @dn = @{ldap_explode_dn ($dn)}; + shift @dn; + my $dn2 = canonical_dn (@dn); + my $perms = ''; + + $perms .= 'a' + if grep { $dn eq $_ or $dn2 eq $_ } + $entry->get_value ('fripostCanCreateAlias'); + + $perms .= 'l' + if grep { $dn eq $_ or $dn2 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 " is not +# allowed). +sub email_valid { + my $in = shift; + my %options = @_; + + my $i = $in; + $i =~ s/^[^<>]+\s<([^>]+)>/$1/; + my $mesg = $options{'-error'} // "Invalid e-mail"; + $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'}; + die $mesg." ‘".$i."’\n" unless $match; + $addr =~ s/^$options{'-prefix'}// if defined $options{'-prefix'}; + return $addr; +} + +sub canonical_dn { + Net::LDAP::Util::canonical_dn(\@_, casefold => 'lower' + , mbcescape => 1 + , reverse => 0 + , separator => ','); +}; + +sub ldap_explode_dn { + Net::LDAP::Util::ldap_explode_dn( join (',', @_), casefold => 'lower' ) +} + +sub split_addr { + my $addr = shift; + my %options = @_; + + if (defined $options{'-encode'}) { + my $e = $options{'-encode'}; + if ($e eq 'ascii') { + $addr = Net::IDN::Encode::email_to_ascii($addr); + } + elsif ($e eq 'unicode') { + $addr = Net::IDN::Encode::email_to_unicode($addr); + } + else { + die "Unknown encoding: ". $e; + } + } + + split /\@/, $addr, 2; +} + + +=head1 AUTHOR + +Guilhem Moulin C<< >> + +=head1 COPYRIGHT + +Copyright 2012,2013 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__ -- cgit v1.2.3