source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage/User.pm @ 2506

package LATMOS::Accounts::Bases::Partage::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 DateTime;

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

=head1 NAME

    LATMOS::Accounts::Bases::Partage::User - Support for Partage users

=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, iname => 'id' }, # Zimbra internal id
        uid => { ro => 1, },
        cn => { },
        sn => { },
        givenName => { },
        mail => { ro => 1, get => sub { return $_[0]->object->{_zid} } },
        displayName => { },
        objectClass => { ro => 1, multiple => 1, },
        zimbraMailDeliveryAddress => { multiple => 1, ro => 1, },
        zimbraMailAlias => { 
            multiple => 1,
            ro => 1,
            get => sub {
                my ($self) = @_;
                my $domain = $self->base->{domain};
                return [
                    map { s/@\Q$domain\E$//; $_ }
                    grep { $_ }
                    ref $self->object->{zinfo}{zimbraMailAlias}
                        ? @{ $self->object->{zinfo}{zimbraMailAlias} }
                        : $self->object->{zinfo}{zimbraMailAlias}
                ]
            },
        },
        aliases => {
            multiple => 1,
            get => sub {
                my ($self) = @_;
                my $domain = $self->base->{domain};
                return [
                    map { s/@\Q$domain\E$//; $_ }
                    grep { $_ }
                    ref $self->object->{zinfo}{zimbraMailAlias}
                        ? @{ $self->object->{zinfo}{zimbraMailAlias} }
                        : $self->object->{zinfo}{zimbraMailAlias}
                ]
            },
            set => sub {
                my ($self, $data) = @_;
                my $domain = $self->object->base->{domain};
                $self->object->_get_info();
                my @zimbraMailAlias =
                    map { s/@\Q$domain\E$//; $_ }
                    grep { $_ }
                    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
                    s/@.*//;
                    $newalias{lc($_)} = 1;
                }
                foreach (keys %currentalias) {
                    $newalias{$_} and next;
                    warn "Del $_";
                    my $res = $self->object->base->sendrequest(
                        'RemoveAccountAlias',
                        name  => $self->object->{_zid},
                        alias => "$_\@$domain",
                    ) or do {
                        $self->object->base->la_log("Cannot remove alias $_");
                        return;
                    };
                    $self->object->{zinfo} = undef;
                }
                foreach (keys %newalias) {
                    $currentalias{$_} and next;
                    warn "Add $_";
                    my $res = $self->object->base->sendrequest(
                        'AddAccountAlias',
                        name  => $self->object->{_zid},
                        alias => "$_\@$domain",
                    ) or do {
                        $self->object->base->la_log("Cannot add alias $_");
                        return;
                    };
                    $self->object->{zinfo} = undef;
                }
            }
        },
        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 {
            name  => $id,
            _id   => $id,
            _zid  => $users{$id},
            _base => $base,
        }, $class;
        $user->_get_info();
        return $user;
    }
}
 
sub get_field {
    my ($self, $field) = @_;

    $self->_get_info();

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

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

    my @values = ();

    my $res = $self->base->sendrequest(
        'ModifyAccount',
        name => $self->{_zid},
        %data,
    );

    $self->{zinfo} = undef;

    $res ? 1 : 0;
}

sub _set_password {
    my ($self, $clear_pass) = @_;

    my $res = $self->base->sendrequest(
        'SetPassword',
        name     => $self->{_zid},
        password => $clear_pass,
    );

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

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

    my %cdata;

    my $aliases = $data{ 'aliases' };
    delete( $data{ 'aliases' } );

    foreach my $attr ( keys %data ) {
        $data{ $attr } or next;
        my $Attr = $base->attribute( 'user', $attr ) or next;
        $Attr->ro and next;
        $cdata{ $attr } = $data{ $attr };
    }

    my $res = $base->sendrequest(
        'CreateAccount',
        name     => $id . '@' . $base->{domain},
        password => $pass,
        %cdata,
    );

    if ( $aliases ) {
        my $user = $base->get_object( 'user', $id ) or return;

        return $user->_set_c_fields( aliases => $aliases );
    }

    1;
}

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

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

    $base->sendrequest(
        'DeleteAccount',
        name => $id . '@' . $base->{domain},
    );
}
 
sub _lists_account {
    my ($class, $base) = @_;

    my %users;
    my $offset =   0;
    my $limit  = 500;
    while ( 1 ) {
        my $res = $base->sendrequest(
            'GetAllAccounts',
            offset => $offset,
            limit  => $limit,
        ) or do {
            la_log(LA_ERR, "Error while trying to get users list");
            return;
        };

        my @accounts = @{ $res->{accounts}{account} || [] }
            or last;

        require Data::Dumper;
        warn Data::Dumper::Dumper( $res );
        foreach my $node (@accounts) {
            my $name = $node->{name};
            $name =~ s/@.*$//;
            $users{$name} = $node->{name}
        }

        scalar( @accounts ) < $limit and last;

        $offset += $limit;
    }

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

    if ( $self->{zinfo}{cacheTime} ) {
        return 1;
    }

    my $res = $self->base->sendrequest(
        'GetAccount',
        name => $self->{_zid},
    ) or return;
    require Data::Dumper;
    print Data::Dumper::Dumper($res);

    my $elem = $res->{account}[0];
    $self->{zinfo} = { cacheTime => DateTime->now };

    foreach my $attr (sort keys %{ $elem || {} }) {
        if ( ref $elem->{ $attr } eq 'HASH' ) {
            $self->{zinfo}{ $attr } = $elem->{ $attr }{ $attr };
        } else {
            $self->{zinfo}{ $attr } = $elem->{ $attr };
        }
    }
}

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