source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Zimbra/User.pm @ 2270

package LATMOS::Accounts::Bases::Zimbra::User;

use 5.010000;
use strict;
use warnings;
use overload '""' => 'stringify';

use LATMOS::Accounts::Log;
use LATMOS::Accounts::Utils;
use base qw(LATMOS::Accounts::Bases::Objects);
use SOAP::Lite;

our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Ad - Perl extension for blah blah blah

=head1 DESCRIPTION

Account base access over standard unix file format.

=head1 FUNCTIONS

=cut

sub _get_attr_schema {
    my ($class, $base) = @_;

    {
        name => {
            ro => 1,
            get => sub {
                my ($self) = @_;
                return $self->object->{name}
            },
        },
        zid => { ro => 1, }, # Zimbra internal id
        uid => { ro => 1, },
        cn => { },
        sn => { },
        givenName => { },
        mail => { ro => 1, },
        displayName => { },
        objectClass => { ro => 1, multiple => 1, },
        zimbraMailDeliveryAddress => { multiple => 1, ro => 1, },
        zimbraMailAlias => { 
            multiple => 1,
            ro => 1,
        },
        aliases => {
            multiple => 1,
            get => sub {
                my ($self) = @_;
                my $domain = $self->object->base->{domain};
                return [
                    map { s/@\Q$domain\E$//; $_ }
                    ref $self->object->{zinfo}{zimbraMailAlias}
                        ? @{ $self->object->{zinfo}{zimbraMailAlias} }
                        : $self->object->{zinfo}{zimbraMailAlias}
                ]
            },
            set => sub {
                my ($self, $data) = @_;
                my @zimbraMailAlias = ref $self->object->{zinfo}{zimbraMailAlias}
                    ? @{ $self->object->{zinfo}{zimbraMailAlias} }
                    : $self->object->{zinfo}{zimbraMailAlias};
                my %currentalias = map { $_ => 1 } grep { $_ } @zimbraMailAlias;
                my %newalias;
                foreach (grep { $_ } (ref $data ? @{$data} : $data)) {
                    # Adding domain to unqualified aliases
                    $_ =~ /@/ or $_ .= '@' . $self->object->base->{domain};
                    $newalias{lc($_)} = 1;
                }
                foreach (keys %currentalias) {
                    $newalias{$_} and next;
                    my $xpath = $self->object->base->soapcall(
                        'RemoveAccountAliasRequest',
                        SOAP::Data->name('id')->value($self->object->{zinfo}{zid}),
                        SOAP::Data->name('alias')->value($_),
                    ) or do {
                        $self->object->base->la_log('Cannot remove alias $_');
                        return;
                    };
                }
                foreach (keys %newalias) {
                    $currentalias{$_} and next;
                    my $xpath = $self->object->base->soapcall(
                        'AddAccountAliasRequest',
                        SOAP::Data->name('id')->value($self->object->{zinfo}{zid}),
                        SOAP::Data->name('alias')->value($_),
                    ) or do {
                        $self->object->base->la_log('Cannot add alias $_');
                        return;
                    };
                }
            }
        },
        zimbraCOSId => { },
    }
}

sub new {
    my ($class, $base, $id) = @_;

    my %users = $class->_lists_account($base);

    if (!$users{$id}) {
        la_log(LA_DEBUG, "Cannot find user $id");
        return;
    } else {
        my $user = bless {
            _id => $id,
            name => $users{$id},
            _base => $base,
        }, $class;
        $user->_get_info();
        return $user;
    }
}

sub get_field {
    my ($self, $field) = @_;

    my $attribute = $self->attribute($field) or return;

    return $self->{zinfo}{$field};
}

sub set_fields {
    my ($self, %data) = @_;

    my @values = ();

    foreach my $key (keys %data) {
        foreach my $val (ref $data{$key} ? @{ $data{$key} } : $data{$key}) {
            push(@values, SOAP::Data->name('a')
                ->attr({ 'n' => $key })
                ->value($val)
            );
        }
    }

    my $xpath = $self->base->soapcall(
        'ModifyAccountRequest',
        SOAP::Data->name('id')->value($self->{zinfo}{zid}),
        @values,
    );

}

sub _create {
    my ($class, $base, $id, %data) = @_;

    my $pass = LATMOS::Accounts::Utils::genpassword();

    my @values = ();

    foreach my $key (keys %data) {
        foreach my $val (ref $data{$key} ? @{ $data{$key} } : $data{$key}) {
            push(@values, SOAP::Data->name('a')
                ->attr({ 'n' => $key })
                ->value($val)
            );
        }
    }

    my $xpath = $base->soapcall(
        'CreateAccountRequest',
        SOAP::Data->name('name')->value($id . '@' . $base->{domain}),
        SOAP::Data->name('password')->value($pass),
        @values,
    );

}

sub _delete {
    my ($class, $base, $id) = @_;

    my $user = $base->get_object('user', $id) or do {
        $base->log(LA_ERR, "Cannot get user $id");
        return;
    };

    my $xpath = $base->soapcall(
        'DeleteAccountRequest',
        SOAP::Data->name('id')->value($user->{zinfo}{zid}),
    );

}

sub _lists_account {
    my ($class, $base) = @_;

    my $xpath = $base->soapcall(
        'GetAllAccountsRequest',
        SOAP::Data->name('domain')->value($base->{domain})->attr({ by => 'name' }),
    ) or do {
        la_log(LA_ERR, "Error while trying to get users list");
        return;
    };

    my %users;
    foreach my $node ($xpath->findnodes('//account')) {
        my $name = $node->getAttribute('name');
        foreach ($node->getChildNodes) {
            $_->getAttribute('n') eq 'uid' and do {
                $users{$_->string_value} = $name;
                last;
            };
        }
    }

    %users
}

sub _get_info {
    my ($self) = @_;

    my $xpath = $self->base->soapcall(
        'GetAccountRequest',
        SOAP::Data->name('account')->value($self->{name})->attr({ by => 'name' }),
    ) or return;
    require Data::Dumper;
    #print Data::Dumper::Dumper($xpath);

    my ($accountnode) = $xpath->findnodes('//account');

    $self->{zinfo}{zid} = $accountnode->getAttribute('id');

    foreach my $node ($xpath->findnodes('//a')) {
        my $attr = $node->getAttribute('n');
        if ($self->{zinfo}{$attr}) {
            if (!ref $self->{zinfo}{$attr}) {
                my $buf = $self->{zinfo}{$attr};
                $self->{zinfo}{$attr} = [ $buf, $node->string_value ];
            } else {
                push(@{ $self->{zinfo}{$attr} }, $node->string_value);
            }    
        } else {
            $self->{zinfo}{$attr} = $node->string_value;
        }
    }
}

sub list {
    my ($class, $base) = @_;

    my %users = $class->_lists_account($base);
    return sort keys(%users);
}

1;

__END__

=head1 SEE ALSO

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut