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 Net::IDN::Encode qw/domain_to_ascii domain_to_unicode email_to_ascii email_to_unicode/; =head1 METHODS =over 4 =item B (I) 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."\n"; } return map { { domain => domain_to_unicode($_->get_value('fvd')) , isactive => $_->get_value('fripostIsStatusActive') eq 'TRUE' , description => concat($concat, $_->get_value('description')) } } $domains->sorted('fvd') } =item B (I, I) Returns a hash with all the (visible) attributes for the given domain. =cut sub get { my $self = shift; my $d = domain_to_ascii(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."\n"; } # 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_to_unicode($domain->get_value('fvd')) , isactive => $domain->get_value('fripostIsStatusActive') eq 'TRUE' , description => concat($concat, $domain->get_value('description')) , catchalls => concat($concat, map { _email_to_unicode ($_) } $domain->get_value('fripostOptionalMaildrop')) , permissions => get_perms($domain, $self->whoami) ) } =item B (I, I) 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/ ); $d->{domain} = email_valid( $d->{domain}, -prefix => 'fake@', -error => 'Invalid domain', -exact => 1 ); $d->{catchalls} = [ map { email_valid($_, -prefix => 'fake') } @{$d->{catchalls}} ]; } # A variante of email_to_unicode that also takes care of domain aliases. sub _email_to_unicode { my $email = shift; return '@'.domain_to_unicode($email) if $email =~ s/^\@//; return email_to_unicode($email); } =head1 AUTHOR Guilhem Moulin C<< >> =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__