Index: /trunk/LATMOS-Accounts/Makefile.PL
===================================================================
--- /trunk/LATMOS-Accounts/Makefile.PL	(revision 2505)
+++ /trunk/LATMOS-Accounts/Makefile.PL	(revision 2506)
@@ -42,4 +42,5 @@
         'DateTime::Format::Pg' => undef,
         'Net::IDN::Encode' => undef,
+        'Digest::HMAC_SHA1' => undef,
     }, # e.g., Module::Name => 1.1
     ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
Index: /trunk/LATMOS-Accounts/latmos-accounts.spec.in
===================================================================
--- /trunk/LATMOS-Accounts/latmos-accounts.spec.in	(revision 2505)
+++ /trunk/LATMOS-Accounts/latmos-accounts.spec.in	(revision 2506)
@@ -46,4 +46,5 @@
 Buildrequires: perl(DateTime::Format::Pg)
 BuildRequires: perl(Net::IDN::Encode)
+Buildrequires: perl(Digest::HMAC_SHA1)
 
 Requires: perl(Mail::Sendmail)
Index: /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm
===================================================================
--- /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm	(revision 2505)
+++ /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Objects.pm	(revision 2506)
@@ -186,5 +186,5 @@
         $attrinfo = $self->_get_attr_schema(
             $self->base)->{$attribute}
-        or return;
+        or do { warn "$attribute EE"; return };
         $attrinfo->{name} = $attribute;
     } else {
Index: /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage.pm
===================================================================
--- /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage.pm	(revision 2506)
+++ /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage.pm	(revision 2506)
@@ -0,0 +1,155 @@
+package LATMOS::Accounts::Bases::Partage;
+
+use 5.010000;
+use strict;
+use warnings;
+
+use base qw(LATMOS::Accounts::Bases);
+use LATMOS::Accounts::Log;
+
+use LWP::UserAgent;
+use XML::Simple;
+use DateTime;
+use Digest::HMAC_SHA1;
+use XML::XPath;
+
+our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];
+
+=head1 NAME
+
+    LATMOS::Accounts::Bases::Partage - Support for Renater mail solution
+
+=head1 SYNOPSIS
+
+  use LATMOS::Accounts::Bases;
+  my $base = LATMOS::Accounts::Bases->new('partage');
+  ...
+
+=head1 DESCRIPTION
+
+Support for Renater Mail Solution called Partage
+
+=cut
+
+sub new {
+    my ($class, %config) = @_;
+
+    $config{url} =~ s:/*$:: if ( $config{url} );
+
+    my $ua  = LWP::UserAgent->new(
+        timeout => 10,
+    );
+    $ua->env_proxy;
+
+    my $base = {
+        apikey => $config{apikey},
+        url    => $config{url} || 'https://api.partage.renater.fr/service/domain',
+        domain => $config{domain},
+        lwp    => $ua,
+    };
+
+    bless($base, $class);
+    $base->_connect or return;
+
+    $base;
+}
+
+sub _sendrequest {
+    my ( $self, $subUri, %param ) = @_;
+
+    my $ua = $self->{lwp};
+    my $Uri = $self->{url} . '/' . $subUri;
+
+    $Uri .= '/' . $self->{token} unless( $subUri eq 'Auth' );
+
+    la_log(LA_DEBUG, sprintf(
+            "Sending %s, %s",
+            $subUri,
+            join(', ', map { $_ . ' => ' . $param{ $_ } } sort keys %param)
+    ));
+
+    my $response = $ua->post( $Uri, \%param );
+
+    unless ( $response->is_success ) {
+        la_log(LA_ERR, "Cannot fetch $Uri: " . $response->status_line);
+        return;
+    }
+
+    warn $response->content;
+    return $response->content;
+}
+
+sub sendrequest {
+    my ( $self, $subUri, %param ) = @_;
+
+
+    my $res = $self->_sendrequest( $subUri, %param )
+        or return;
+
+    my $ref = XMLin(
+        $res,
+        forcearray => [ qw(account) ],
+        KeyAttr => [],
+    );
+
+    $ref;
+}
+
+sub sendrequestasxpath {
+    my ( $self, $subUri, %param ) = @_;
+
+    my $xml = $self->_sendrequest( $subUri, %param );
+
+    my $xpath = XML::XPath->new(xml => $xml);
+
+    if (my $node = $xpath->findnodes('//faultstring')) {
+        la_log(LA_ERR, "Saop error: %s", $node->string_value);
+        return;
+    }
+
+    return $xpath;
+}
+
+sub _connect {
+    my ( $self ) = @_;
+
+    my $epoch = DateTime->now->epoch;
+    my $clearPreauth = $self->{domain} . '|' . $epoch;
+    my $preauth = Digest::HMAC_SHA1::hmac_sha1_hex( $clearPreauth, $self->{apikey} );
+    my $res = $self->sendrequest(
+        'Auth',
+        domain    => $self->{domain},
+        timestamp => DateTime->now->epoch,
+        preauth   => $preauth,
+    ) or return;
+
+    $self->{token} = $res->{token};
+
+    return $self->{token};
+}
+
+sub DESTROY {
+    my ($self) = @_;
+    $self->{_db} && $self->{_db}->rollback;
+}
+
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+=head1 AUTHOR
+
+Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2008-2022 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
Index: /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage/User.pm
===================================================================
--- /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage/User.pm	(revision 2506)
+++ /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Partage/User.pm	(revision 2506)
@@ -0,0 +1,312 @@
+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
Index: /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Zimbra/User.pm
===================================================================
--- /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Zimbra/User.pm	(revision 2505)
+++ /trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Zimbra/User.pm	(revision 2506)
@@ -80,5 +80,5 @@
                         SOAP::Data->name('alias')->value($_),
                     ) or do {
-                        $self->object->base->la_log('Cannot remove alias $_');
+                        $self->object->base->la_log("Cannot remove alias $_");
                         return;
                     };
@@ -91,5 +91,5 @@
                         SOAP::Data->name('alias')->value($_),
                     ) or do {
-                        $self->object->base->la_log('Cannot add alias $_');
+                        $self->object->base->la_log("Cannot add alias $_");
                         return;
                     };
@@ -223,6 +223,4 @@
         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');
