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 (I, I) Start a LDAP connection, and SASL-authenticate using proxy authentication for the given (fully-qualified) user. I 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 (I, I, I) Start a LDAP connection, and (simples-) binds the given user. I 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 Bless the object to C, to access domain-specific methods. =cut sub domain { bless shift, 'Fripost::Schema::Domain'; } =item B Bless the object to C, to access mailbox-specific methods. =cut sub mailbox { bless shift, 'Fripost::Schema::Mailbox'; } =item B Bless the object to C, to access alias-specific methods. =cut sub alias { bless shift, 'Fripost::Schema::Alias'; } =item B Bless the object to C, to access list-specific methods. =cut sub list { bless shift, 'Fripost::Schema::List'; } =item B Bless the object to C, to access local-specific (mailboxes, aliases and lists) methods. =cut sub local { bless shift, 'Fripost::Schema::Local'; } =item B 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<< >> =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__