From 8663144f1f5a3d163119f17a7f9c06655e32727a Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Tue, 17 Apr 2012 01:25:28 +0200 Subject: OO Perl library for our LDAP schema. --- lib/Fripost/Schema.pm | 241 +++++++++++++++++++++++++++++++++-- lib/Fripost/Schema/Result/Alias.pm | 52 -------- lib/Fripost/Schema/Result/Domain.pm | 51 -------- lib/Fripost/Schema/Result/Mailbox.pm | 72 ----------- lib/Fripost/Schema/Search.pm | 111 ++++++++++++++++ lib/Fripost/Schema/Type.pm | 48 +++++++ 6 files changed, 387 insertions(+), 188 deletions(-) delete mode 100644 lib/Fripost/Schema/Result/Alias.pm delete mode 100644 lib/Fripost/Schema/Result/Domain.pm delete mode 100644 lib/Fripost/Schema/Result/Mailbox.pm create mode 100644 lib/Fripost/Schema/Search.pm create mode 100644 lib/Fripost/Schema/Type.pm (limited to 'lib') diff --git a/lib/Fripost/Schema.pm b/lib/Fripost/Schema.pm index 8124a54..5b57cd3 100755 --- a/lib/Fripost/Schema.pm +++ b/lib/Fripost/Schema.pm @@ -1,17 +1,33 @@ package Fripost::Schema; use 5.010_000; +use warnings; use strict; +use Fripost::Schema::Search; +use Fripost::Schema::Type; + use base qw/Net::LDAP/; our $VERSION = '0.01'; -# Initialize a connection to the LDAP host. + +####################################################################### +# Public methods + + +# Change the context of the object. +sub user { $_[0]->Fripost::Schema::Type::_set_type(MAILBOX); } +sub domain { $_[0]->Fripost::Schema::Type::_set_type(DOMAIN); } +sub alias { $_[0]->Fripost::Schema::Type::_set_type(ALIAS); } + + +# Create the oject, and initialize a connection to the LDAP +# host. sub new { my $class = shift; my $h = shift; - my $self = {options => $h}; + my $self = {_options => $h}; bless $self, $class; my $ldap = Net::LDAP->new ( $h->{server_host} ) @@ -29,23 +45,72 @@ sub new { } die "Error: " .$mesg->error. "\n" if $mesg->code; - $self->{ldap} = $ldap; + $self->{_ldap} = $ldap; return $self; } +# Search. Returns a `Fripost::Schema::Search'. +sub search { + my $self = shift; + my $res; + if ( $self->{_type} == MAILBOX ) { + $res = $self->_searchUser(@_) + } + elsif ( $self->{_type} == DOMAIN ) { + $res = $self->_searchDomain(@_) + } + elsif ( $self->{_type} == ALIAS ) { + $res = $self->_searchAlias(@_) + } + else { + die "Something weird happened. Please report." + } + my $result = {_res => $res, _type => $self->{_type}}; + bless $result, 'Fripost::Schema::Search'; + return $result; +} + + +# Add. +sub add { + my $self = shift; + if ( $self->{_type} == MAILBOX ) { + $self->_addUser(@_) + } + elsif ( $self->{_type} == DOMAIN ) { + $self->_addDomain(@_) + } + elsif ( $self->{_type} == ALIAS ) { + $self->_addAlias(@_) + } + else { + die "Something weird happened. Please report." + } +} + + +# Disconnect to the LDAP server. +sub unbind { + $_[0]->{_ldap}->unbind(); +} + + +####################################################################### +# Search + # Search a user, and return the corresponding entries if found. If no # user is given, returns all users. -sub searchUser { +sub _searchUser { my $self = shift; - my $base = join ',', ('ou=mailboxes',$self->{options}->{base_dn}); + my $base = join ',', ('ou=mailboxes',$self->{_options}->{base_dn}); my $filter = "(ObjectClass=virtualMailbox)"; $filter = "(&" .$filter. "(uid=" .$_[0]. ")" .")" if defined $_[0]; - my $res = $self->{ldap}->search( + my $res = $self->{_ldap}->search( base => $base, scope => 'one', attrs => [ 'uid', 'gn' , 'sn', 'maildir', 'isActive' ], @@ -56,14 +121,99 @@ sub searchUser { return $res; } + +# Search a domain, and return the corresponding entries if found. If no +# domain is given, returns all domains. If the given domain has a +# defined owner, scope the search for this very owner only. If the +# owner is undefined, but still exists, scope the search to the "global" +# domains only. +sub _searchDomain { + my $self = shift; + + my $base = $self->{_options}->{base_dn}; + if (exists $_[0]->{owner}) { + if (defined $_[0]->{owner}) { + $base = join ',', ('uid='.$_[0]->{owner},'ou=mailboxes',$base); + } + else { + $base = join ',', ('ou=domains',$base); + } + } + + my $filter = '(ObjectClass=virtualDomain)'; + $filter = "(&" .$filter. "(dc=" .$_[0]->{domain}. ")" .")" + if defined $_[0]->{domain}; + + my $res = $self->{_ldap}->search( + base => $base, + scope => 'subtree', + attrs => [ 'dc', 'isActive' ], + filter => $filter + ); + die "Error: " .$res->error. "\n" if $res->code; + + return $res; +} + + +# Search an alias, and return the corresponding entries if found. If no +# alias is given, returns all aliases. If the given alias has a +# defined owner, scope the search for this very owner only. If the +# owner is undefined, but still exists, scope the search to the "global" +# domains only. +sub _searchAlias { + my $self = shift; + + my $base = $self->{_options}->{base_dn}; + if (exists $_[0]->{owner}) { + if (defined $_[0]->{owner}) { + $base = join ',', ('uid='.$_[0]->{owner},'ou=mailboxes',$base); + } + else { + $base = join ',', ('ou=domains',$base); + } + } + $base = 'dc=' .$_[0]->{domain}. ',' .$base + if (exists $_[0]->{owner}) and (defined $_[0]->{domain}); + + my @filters = '(ObjectClass=virtualAliases)'; + push @filters, '(mailLocalAddress=' .$_[0]->{address}. ')' + if defined $_[0]->{address}; + push @filters, '(mailTarget=' .$_[0]->{goto}. ')' + if defined $_[0]->{goto}; + + my $filter; + if ($#filters == 0 ) { + $filter = $filters[0]; + } + elsif ($#filters > 0) { + $filter = '(&' . (join '', @filters) . ')'; + } + + my $res = $self->{_ldap}->search( + base => $base, + scope => 'subtree', + attrs => [ 'mailLocalAddress', 'mailTarget', 'isActive' ], + filter => $filter + ); + die "Error: " .$res->error. "\n" if $res->code; + + return $res; +} + + + +####################################################################### +# Add + # Add a user -sub addUser { +sub _addUser { my $self = shift; my $user = shift; - my $base = join ',', ('ou=mailboxes',$self->{options}->{base_dn}); + my $base = join ',', ('ou=mailboxes',$self->{_options}->{base_dn}); - my $res = $self->{ldap}->add( 'uid=' .$user->{username}. ',' .$base, + my $res = $self->{_ldap}->add( 'uid=' .$user->{username}. ',' .$base, attrs => [ uid => $user->{username}, objectClass => [ 'top', 'virtualMailbox' ], userPassword => $user->{userPassword}, @@ -76,16 +226,81 @@ sub addUser { } -# Disconnect to the LDAP server. -sub unbind { - $_[0]->{ldap}->unbind(); +# Add a domain. +sub _addDomain { + my $self = shift; + my $domain = shift; + + my $base = $self->{_options}->{base_dn}; + if (defined $domain->{owner}) { + $base = join ',', ('uid=' .$domain->{owner},'ou=mailboxes',$base) + } + else { + $base = join ',', ('ou=domains',$base); + } + + my $res = $self->{_ldap}->add( 'dc=' .$domain->{domain}. ',' .$base, + attrs => [ dc => $domain->{domain}, + objectClass => [ 'top', 'virtualDomain' ], + isActive => $domain->{isActive} + ] + ); + die "Error: " .$res->error. "\n" if $res->code; + return $res; } +# Add an alias +sub _addAlias { + my $self = shift; + my $alias = shift; + + # TODO: detect cycles + die "Error: Cannot create alias `" .$alias->{address}. + "' targetting to itself.\n" + if $alias->{address} eq $alias->{goto}; + + my $base = $self->{_options}->{base_dn}; + if (defined $alias->{owner}) { + $base = join ',', ('uid=' .$alias->{owner},'ou=mailboxes',$base) + } + else { + $base = join ',', ('ou=domains',$base); + } + $base = 'mailTarget='.$alias->{goto}. + ','.'dc='. (split /\@/, $alias->{address}, 2)[1]. + ','.$base; + + my @attrs = ( mailLocalAddress => $alias->{address} + , isActive => $alias->{isActive} ); + my $res; + if ($self->_searchAlias($alias)->count) { + $res = $self->{_ldap}->modify( $base, attrs => [ @attrs ] ); + } + else { + $res = $self->{_ldap}->add( $base, + attrs => [ mailTarget => $alias->{goto} + , objectClass => [ 'top', + 'inetLocalMailRecipient', + 'virtualAliases' ], + @attrs + ] + ); + } + die "Error: " .$res->error. "\n" if $res->code; + return $res; +} + + + +####################################################################### +# Miscellaneous + # Debug print. sub _dsay { my $self = shift; - return unless (exists $self->{options}->{debug}) and $self->{options}->{debug}; + return unless (exists $self->{_options}->{debug}) + and $self->{_options}->{debug}; print STDERR "Debug: "; say STDERR @_; } diff --git a/lib/Fripost/Schema/Result/Alias.pm b/lib/Fripost/Schema/Result/Alias.pm deleted file mode 100644 index 4d9306c..0000000 --- a/lib/Fripost/Schema/Result/Alias.pm +++ /dev/null @@ -1,52 +0,0 @@ -package Fripost::Schema::Result::Alias; - -use 5.010_000; -use warnings; -use strict; - -use base qw/DBIx::Class::Core/; - -# mysql> describe alias; -# +-------------+--------------+------+-----+---------------------+-------+ -# | Field | Type | Null | Key | Default | Extra | -# +-------------+--------------+------+-----+---------------------+-------+ -# | address | varchar(255) | NO | PRI | | | -# | goto | text | NO | | NULL | | -# | domain | varchar(255) | NO | | | | -# | create_date | datetime | NO | | 0000-00-00 00:00:00 | | -# | change_date | timestamp | NO | | CURRENT_TIMESTAMP | | -# | active | tinyint(4) | NO | | 1 | | -# +-------------+--------------+------+-----+---------------------+-------+ -# 6 rows in set (0.00 sec) - -__PACKAGE__->load_components(qw/InflateColumn::DateTime/); - -__PACKAGE__->table('alias'); -__PACKAGE__->add_columns(qw/ address goto domain create_date change_date active /); -__PACKAGE__->add_columns( - create_date => { data_type => 'datetime', timezone => "Europe/Stockholm", locale => "se_SV" }, - change_date => { data_type => 'datetime', timezone => "Europe/Stockholm", locale => "se_SV" }, -); - -__PACKAGE__->set_primary_key('address'); - -=head1 NAME - -Fripost::Schema::Result::Alias - - -=head1 AUTHOR - -Stefan Kangas C<< >> - -=head1 COPYRIGHT - -Copyright 2010,2011 Stefan Kangas, 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. - -=cut - -1; # End of Alias.pm diff --git a/lib/Fripost/Schema/Result/Domain.pm b/lib/Fripost/Schema/Result/Domain.pm deleted file mode 100644 index 36649de..0000000 --- a/lib/Fripost/Schema/Result/Domain.pm +++ /dev/null @@ -1,51 +0,0 @@ -package Fripost::Schema::Result::Domain; - -use 5.010_000; -use warnings; -use strict; - -use base qw/DBIx::Class::Core/; - -# mysql> describe domain; -# +-------------+--------------+------+-----+---------------------+-------+ -# | Field | Type | Null | Key | Default | Extra | -# +-------------+--------------+------+-----+---------------------+-------+ -# | domain | varchar(255) | NO | PRI | | | -# | description | varchar(255) | NO | | | | -# | create_date | datetime | NO | | 0000-00-00 00:00:00 | | -# | change_date | timestamp | NO | | CURRENT_TIMESTAMP | | -# | active | tinyint(4) | NO | | 1 | | -# +-------------+--------------+------+-----+---------------------+-------+ -# 5 rows in set (0.00 sec) - -__PACKAGE__->load_components(qw/InflateColumn::DateTime/); - -__PACKAGE__->table('domain'); -__PACKAGE__->add_columns(qw/ domain description create_date change_date active /); -__PACKAGE__->add_columns( - create_date => { data_type => 'datetime', timezone => "Europe/Stockholm", locale => "se_SV" }, - change_date => { data_type => 'datetime', timezone => "Europe/Stockholm", locale => "se_SV" }, -); - -__PACKAGE__->set_primary_key('domain'); - -=head1 NAME - -Fripost::Schema::Result::Domain - - -=head1 AUTHOR - -Stefan Kangas C<< >> - -=head1 COPYRIGHT - -Copyright 2010, 2011 Stefan Kangas, 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. - -=cut - -1; # End of Domain.pm diff --git a/lib/Fripost/Schema/Result/Mailbox.pm b/lib/Fripost/Schema/Result/Mailbox.pm deleted file mode 100644 index 48d81fb..0000000 --- a/lib/Fripost/Schema/Result/Mailbox.pm +++ /dev/null @@ -1,72 +0,0 @@ -package Fripost::Schema::Result::Mailbox; - -use 5.010_000; -use warnings; -use strict; - -use base qw/DBIx::Class::Core/; - -use Fripost::Password; - -# mysql> describe mailbox; -# +-------------+--------------+------+-----+---------------------+-------+ -# | Field | Type | Null | Key | Default | Extra | -# +-------------+--------------+------+-----+---------------------+-------+ -# | username | varchar(255) | NO | PRI | | | -# | password | varchar(255) | NO | | | | -# | name | varchar(255) | NO | | | | -# | maildir | varchar(255) | NO | | | | -# | domain | varchar(255) | NO | | | | -# | create_date | datetime | NO | | 0000-00-00 00:00:00 | | -# | change_date | timestamp | NO | | CURRENT_TIMESTAMP | | -# | active | tinyint(4) | NO | | 1 | | -# +-------------+--------------+------+-----+---------------------+-------+ -# 8 rows in set (0.00 sec) - -__PACKAGE__->load_components(qw/InflateColumn::DateTime/); - -__PACKAGE__->table('mailbox'); -__PACKAGE__->add_columns(qw/ username password name maildir domain active /); -__PACKAGE__->add_columns( - create_date => { data_type => 'datetime', timezone => "Europe/Stockholm", locale => 'sv_SE' }, - change_date => { data_type => 'datetime', timezone => "Europe/Stockholm", locale => 'sv_SE' } -); - -__PACKAGE__->set_primary_key('username'); - -=head2 store_column - -override store_column to encrypt the password when stored - -=cut - -sub store_column { - my ($self, $col, $val) = @_; - - if ($col eq 'password') { - $val = smd5($val); - } - - return $self->next::method($col,$val); -} - -=head1 NAME - -Fripost::Schema::Result::Mailbox - - -=head1 AUTHOR - -Stefan Kangas C<< >> - -=head1 COPYRIGHT - -Copyright 2010,2011 Stefan Kangas, 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. - -=cut - -1; # End of Mailbox.pm diff --git a/lib/Fripost/Schema/Search.pm b/lib/Fripost/Schema/Search.pm new file mode 100644 index 0000000..30d92d6 --- /dev/null +++ b/lib/Fripost/Schema/Search.pm @@ -0,0 +1,111 @@ +package Fripost::Schema::Search; + +use 5.010_000; +use warnings; +use strict; + +use Fripost::Schema::Type; + +use base qw/Net::LDAP::Search/; +our $VERSION = '0.01'; + +# Count the entries got out from the query. +sub count { $_[0]->{_res}->count } + +# Create a hash out of the LDAP entry. Keys depend on the context +# of the object. +# The value can be an array reference (multi-valued attributes) or +# a scalar (otherwise). +sub entries { + my $self = shift; + + my $dumpEntry; + if ( $self->{_type} == MAILBOX ) { + $dumpEntry = "_userEntry"; + } + elsif ( $self->{_type} == DOMAIN ) { + $dumpEntry = "_domainEntry"; + } + elsif ( $self->{_type} == ALIAS ) { + $dumpEntry = "_aliasEntry"; + } + else { + die "Something weird happened. Please report." + } + + no strict "refs"; + return (map {&$dumpEntry($_)} $self->{_res}->entries); +} + + +sub _userEntry { + my $entry = shift; + my %user; + &_get_values( $entry, \%user, 'username', 'uid'); + map { &_get_values($entry, \%user, $_) } + qw /maildir isActive userPassword/; + return \%user; +} + +sub _domainEntry { + my $entry = shift; + my %domain; + &_get_values( $entry, \%domain, 'domain', 'dc'); + &_get_values( $entry, \%domain, 'isActive'); + my $parent = &_get_dn($entry)->[1]; + unless ($parent eq 'ou=domains') { + $domain{owner} = (split /=/, $parent, 2)[1]; + } + return \%domain; +} + +sub _aliasEntry { + my $entry = shift; + my %alias; + &_get_values( $entry, \%alias, 'address', 'mailLocalAddress'); + &_get_values( $entry, \%alias, 'goto', 'mailTarget'); + &_get_values( $entry, \%alias, 'isActive'); + return \%alias; +} + +sub _get_values { + my ($entry, $h, $attr, $attr2) = @_; + $attr2 //= $attr; + my $values = $entry->get_value ( $attr2, asref => 1 ); + + return unless defined $values; + if ($#$values == 0) { + $h->{$attr} = $values->[0]; + } + else { + $h->{$attr} = $values; + } +} + +sub _get_dn { + return [split ',', $_[0]->dn()]; +} + + +=head1 NAME + +Fripost::Schema::Search - Class for the result of LDAP queries. + +=head1 AUTHOR + +Guilhem Moulin C<< >> + +=head1 COPYRIGHT + +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. + +=cut + +1; # End of Search.pm + +__END__ diff --git a/lib/Fripost/Schema/Type.pm b/lib/Fripost/Schema/Type.pm new file mode 100644 index 0000000..bfa8f73 --- /dev/null +++ b/lib/Fripost/Schema/Type.pm @@ -0,0 +1,48 @@ +package Fripost::Schema::Type; + +use 5.010_000; +use warnings; +use strict; + +use Exporter; + +our $VERSION = '0.01'; + +our @EXPORT = qw/MAILBOX DOMAIN ALIAS/; +our @ISA = qw(Exporter); + +use constant { + MAILBOX => 0, + DOMAIN => 1, + ALIAS => 2 +}; + +# Change the context of the object. +sub _set_type { + $_[0]->{_type} = $_[1]; + return $_[0]; +} + + +=head1 NAME + +Fripost::Schema::Type - Context of Fripost::Schema objects. + +=head1 AUTHOR + +Guilhem Moulin C<< >> + +=head1 COPYRIGHT + +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. + +=cut + +1; # End of Type.pm + +__END__ -- cgit v1.2.3