Index: LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ad.pm
===================================================================
--- LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ad.pm	(revision 4)
+++ LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ad.pm	(revision 4)
@@ -0,0 +1,612 @@
+package LATMOS::Accounts::Bases::Ad;
+
+use 5.010000;
+use strict;
+use warnings;
+
+use base qw(Net::LDAP LATMOS::Accounts::Bases);
+use Net::LDAP::Entry;
+use Net::LDAP::Control::Paged;
+use Net::LDAP::Constant qw( LDAP_CONTROL_PAGED ); 
+use Net::LDAP::Util     qw( escape_filter_value );
+
+our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];
+
+
+=head1 NAME
+
+LATMOS::Ad - Perl extension for blah blah blah
+
+=head1 SYNOPSIS
+
+  use LATMOS::Ad;
+  blah blah blah
+
+=head1 DESCRIPTION
+
+Stub documentation for LATMOS::Ad, created by h2xs. It looks like the
+author of the extension was negligent enough to leave the stub
+unedited.
+
+Blah blah blah.
+
+=head1 FUNCTIONS
+
+=cut
+
+=head2 new(%options)
+
+Create a new LATMOS::Ad object for windows AD $domain.
+
+domain / server: either the Ad domain or directly the server
+
+ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>.
+
+=cut
+
+sub new {
+    my ($class, %options) = @_;
+    
+    my $ldap;
+    my ($domain, $server) = ($options{domain}, $options{server});
+
+    # At this point, if still no $server, DNS search
+    foreach my $tryserv (
+        $server
+        ? ($server)
+        : _query_zone_ads($domain)) {
+        $ldap = Net::LDAP->new($tryserv, @_) and last;
+    }
+
+    $ldap or return; # connot connect to any ldap :\
+
+    $ldap->{_ad_domain} = $domain; # possible to find domain from AD ?
+    $ldap->{_top_dn} = join(',', map { "dc=$_" } split('\.', $domain));
+    $ldap->{_lat_config} = { %options };
+
+    bless($ldap, $class);
+}
+
+sub bind {
+    my ($self, $login, %params) = @_;
+
+    if (!$login) {
+        $login = $self->config->val('ldap', 'login');
+        $login =~ m/@/ or $login .= '@' . $self->ad_domain;
+        $params{password} ||= $self->config->val('ldap', 'password');
+    }
+
+    $self->SUPER::bind($login, %params);
+}
+
+sub _query_zone_ads {
+    my ($zone) = @_;
+    require Net::DNS;
+    my @urllist;
+
+    # TODO: see how to find ldaps:// server
+
+    my $resolver = Net::DNS::Resolver->new;
+    my $query = $resolver->query("_ldap._tcp.dc._msdcs.$zone", "SRV");
+    foreach my $rr (
+        sort { $a->priority <=> $b->priority || $a->weight <=> $b->weight }
+        grep { $_->type eq 'SRV' } $query->answer) {
+        push(@urllist, 'ldap://' . $rr->target . ':' . $rr->port . '/');
+    }
+
+    @urllist
+}
+
+=head2 top_dn
+
+Return the TOP DN of the AD zone.
+
+=cut
+
+sub top_dn {
+    return $_[0]->{_top_dn}
+}
+
+=head2 ad_domain
+
+Return the active directory zone
+
+=cut
+
+sub ad_domain {
+    return $_[0]->{_ad_domain}
+}
+
+=head2 unlimited_search
+
+By default, ldap servers limit results to avoid deni of services.
+LDAP protocol provide a paging feature to fetch all results.
+
+This function works like Net::LDAP::search functions, but return nothing,
+use "callback" option to get entries.
+
+=cut
+
+sub unlimited_search {
+    my $self = shift;
+    my @args = @_;
+
+    my ($page, $cookie) = (Net::LDAP::Control::Paged->new( size => 100 ));
+
+    while (1) {
+        my $search = $self->search(
+            @args,
+            control => [ $page ],
+        );
+        if ($search->code) {
+            return $search;
+        }
+
+        ### After foreach loops ends, client checks LDAP server reponse of how many search results total.
+        ### This is a control to end the infinite while loop if there are no search results to go through 
+        ### If there are search results, this control will always return the total number of results. It is
+        ### never decremented
+        my ($resp) = $search->control( LDAP_CONTROL_PAGED ) or last;
+
+
+        ### Obtaining the cookie from the search result. When no more results, cookie will be NULL
+        ### and infinite while loop will terminate.
+        $cookie = $resp->cookie or last;
+
+        ### Sets cookie so server knows the next search result to send 
+        $page->cookie($cookie);
+    }
+    ### This is a control to check for abnormal exit of the while loop.
+    ### If this occurs ### we need to tell the LDAP server that remaining
+    ### search results are no longer needed ### by sending a search request with a page size of 0
+    if ($cookie)    {
+        $page->cookie($cookie);
+        $page->size(0);
+        $self->search(@args, control => [ $page ]);
+    }
+    return 1;
+}
+
+sub _find_next_id {
+    my ($self, $field, $id, $min) = @_;
+
+    $id ||= 500;
+    my $fid = $id;
+    $self->unlimited_search(
+        base => $self->top_dn,
+        attrs => [ $field ],
+        filter => "($field>=$id)",
+        callback => sub {
+            my ($mesg, $entry) = @_;
+            $mesg && $mesg->code and die $mesg->error;
+            ref $entry eq 'Net::LDAP::Entry' or return;
+            $id = $entry->get_value($field) + 1 if ($id <= $entry->get_value($field));
+        }
+    );
+
+    return $id
+}
+
+=head2 find_next_uid($minuid)
+
+Find next free uidNumber
+
+=cut
+
+sub find_next_uid {
+    my ($self, $minid) = @_;
+    $self->_find_next_id('uidNumber', $minid, 500);
+}
+
+=head2 find_next_gid($minuid)
+
+Find next free gidNumber
+
+=cut
+
+sub find_next_gid {
+    my ($self, $minid) = @_;
+    $self->_find_next_id('gidNumber', $minid, 500);
+}
+
+sub _username_format {
+    my ($name) = @_;
+
+    $name =~ s/[^\w]//g; # strip non alphanumeric
+    $name = substr($name, 0, 8); # keep 8 max
+    $name
+}
+
+sub find_username {
+    my ($self, $lastname, $firstname) = @_;
+    if (!ref $self) { # if call w/o ldap connection
+        ($self, $lastname, $firstname) = (undef, $self, $lastname);
+    }
+
+    my $username = _username_format($lastname);
+    if (!$self) { return $username }
+
+    if (!$self->get_user($lastname, attrs => [ 'cn' ])) {
+        return $username;
+    }
+
+    foreach $username (map { _username_format($_) } (
+            $lastname . substr($firstname, 0, 1),
+            $lastname . $firstname,
+        )) {
+        !$self->get_user($username, attrs => [ 'cn' ]) and return $username;
+    }
+
+    undef
+}
+
+sub _defaults_user_attrs {
+    my ($self, $entry, $attrs) = @_;
+
+    foreach my $attr (keys %{ $attrs || {} }) {
+        my $val = $attrs->{$attr};
+
+        $attr =~ /^homeDirectory$/ and do {
+            $entry->replace('unixHomeDirectory', $val);
+        };
+
+        $attr =~ /^(givenName|sn)$/ and do {
+            $entry->replace('displayName',
+                join(' ', map { ucfirst($_ || '') } (
+                    ($attrs->{'givenName'} || $entry->get_value('givenName')), # first name
+                    ($attrs->{'sn'} || $entry->get_value('sn')),           # last name
+                ))
+            );
+            $entry->replace('gecos', # TODO reencode to aovid accents
+                join(' ', map { ucfirst($_ || '') } (
+                    ($attrs->{'givenName'} || $entry->get_value('givenName')), # first name
+                    ($attrs->{'sn'} || $entry->get_value('sn')),           # last name
+                ))
+            );
+            $attr eq 'sn' and do { # TODO generate clean login here / UNIX uid
+                $entry->add('sAMAccountName' => $val) unless ($entry->exists('sAMAccountName'));
+            };
+        };
+
+        # nothing special to do
+        $entry->replace($attr => $val);
+    }
+}
+
+sub _defaults_group_attrs {
+    my ($self, $entry, $attrs) = @_;
+    foreach my $attr (keys %{ $attrs || {} }) {
+        my $val = $attrs->{$attr};
+        $entry->replace($attr => $val);
+    }
+}
+
+=head2 lists_users($sub, @search_args)
+
+Fetch all user and call $sub for each entry.
+
+Return ldap error message on error.
+
+$sub is call as explain in L<Net::LDAP>
+
+=cut
+
+sub lists_users {
+    my ($self, $sub, @search_args) = @_;
+
+    eval {
+    my $xx = $self->unlimited_search(
+        @search_args,
+        base => $self->top_dn,
+        filter => "(&(ObjectClass=user) (!(ObjectClass=computer)))",
+        callback => sub {
+            my ($mesg, $entry) = @_;
+            $entry or return;
+            ref $entry eq 'Net::LDAP::Entry' or return;
+            $sub->($mesg, $entry);
+        },
+    );
+    };
+
+    return $@;
+}
+
+=head2 get_user($username)
+
+Return the entry for user $username
+
+=cut
+
+sub get_user {
+    my ($self, $username, @search_args) = @_;
+
+    my $mesg = $self->search(
+        @search_args,
+        filter => "(&(ObjectClass=user) (!(ObjectClass=computer)) (cn=$username))",
+        base => $self->top_dn,
+    );
+
+    $mesg->code and return;
+
+    my ($entry, @others) = $mesg->entries;
+
+    return if(@others); # we cannot have multiple entries...
+    $entry
+}
+
+=head2 create_user($param)
+
+Create a new user with value in hashref $param
+
+=cut
+
+sub create_user {
+    my ($self, $param) = @_;
+
+    my $entry = Net::LDAP::Entry->new();
+
+    my $username = $param->{sn};
+
+    # TODO generate clean username
+    $entry->dn("cn=$username,cn=Users," . $self->top_dn);
+
+    $param->{uidNumber} ||= $self->find_next_uid;
+
+    $self->_defaults_user_attrs(
+        $entry,
+        {
+            objectClass => [ qw(top person organizationalPerson user)],
+            userAccountControl => 544,
+            accountExpires => '9223372036854775807', # TODO don't hardcode
+            homeDirectory => "/net/nfs/home/$username", # TODO no hardcode path
+            userPrincipalName => "$username\@" . $self->ad_domain,
+            %{ $param || {}},
+        }
+    );
+
+    my $mesg = $self->add($entry);
+
+    if ($mesg->code) {
+        warn $mesg->error;
+        return;
+    } else { return 1 };
+}
+
+=head2 modify_user($username, $param)
+
+=cut
+
+sub modify_user {
+    my ($self, $username, $param) = @_;
+
+    my $mesg = $self->search(
+        base => $self->{_top_dn},
+        filter => "(&(ObjectClass=user) (!(ObjectClass=computer)) (cn=$username))",
+    );
+
+    $mesg->code and do {
+        warn $mesg->error;
+        return;
+    };
+
+    my ($entry) = $mesg->entries; # TODO hopefully only one...
+
+    $self->_defaults_user_attrs(
+        $entry,
+        $param,
+    );
+
+    $mesg = $entry->update($self);
+
+    if ($mesg->code) {
+        warn $mesg->error;
+        return;
+    } else { return 1 }
+}
+
+=head2 delete_user($username)
+
+=cut
+
+sub delete_user {
+    my ($self, $username) = @_;
+
+    my $mesg = $self->search(
+        base => $self->{_top_dn},
+        filter => "(&(ObjectClass=user) (!(ObjectClass=computer)) (cn=$username))",
+    );
+
+    $mesg->code and do {
+        warn $mesg->error;
+        return;
+    };
+
+    my ($entry) = $mesg->entries; # TODO hopefully one
+
+    $mesg = $self->delete($entry->dn);
+
+    if ($mesg->code) {
+        warn $mesg->error;
+        return;
+    } else { return 1 }
+}
+
+=head2 lists_groups
+
+=cut
+
+sub lists_groups {
+    my ($self, $sub, @search_args) = @_;
+
+    eval {
+    my $xx = $self->unlimited_search(
+        @search_args,
+        base => $self->top_dn,
+        filter => "(ObjectClass=group)",
+        callback => sub {
+            my ($mesg, $entry) = @_;
+            $mesg && $mesg->code and die $mesg->error;
+            $entry or return;
+            ref $entry eq 'Net::LDAP::Entry' or return;
+            $sub->($mesg, $entry);
+        },
+    );
+    };
+
+    return $@;
+}
+
+=head2 get_group
+
+=cut
+
+sub get_group {
+    my ($self, $groupname, @search_args) = @_;
+
+    my $mesg = $self->search(
+        @search_args,
+        filter => "(&(ObjectClass=group) (cn=$groupname))",
+        base => $self->top_dn,
+    );
+
+    $mesg->code and return;
+
+    my ($entry, @others) = $mesg->entries;
+
+    return if(@others); # we cannot have multiple entries...
+    $entry
+}
+
+=head2 create_group
+
+=cut
+
+sub create_group {
+    my ($self, $param) = @_;
+
+    my $entry = Net::LDAP::Entry->new;
+
+    my $groupname = $param->{name};
+    $entry->dn("cn=$groupname,cn=Users," . $self->top_dn);
+
+    $param->{gidNumber} ||= $self->find_next_gid;
+
+    $self->_defaults_group_attrs($entry,
+        {
+            objectClass => [ qw(top group) ],
+            %{ $param || {} },
+        }
+    );
+
+    my $mesg = $self->add($entry);
+
+    if ($mesg->code) {
+        warn $mesg->error;
+        return;
+    } else { return 1 };
+}
+
+=head2 delete_group
+
+=cut
+
+sub delete_group {
+    my ($self, $groupname) = @_;
+    
+    my $mesg = $self->search(
+        base => $self->{_top_dn},
+        filter => "(&(ObjectClass=group) (cn=$groupname))",
+    );
+
+    $mesg->code and do {
+        warn $mesg->error;
+        return;
+    };
+
+    my ($entry) = $mesg->entries; # TODO hopefully one
+
+    $mesg = $self->delete($entry->dn);
+
+    if ($mesg->code) {
+        warn $mesg->error;
+        return;
+    } else { return 1 }
+}
+
+sub get_group_users {
+    my ($self, $groupname, @searchargs) = @_;
+    my $gr = $self->get_group($groupname, attrs => [ qw(cn member) ]);
+
+    my @res;
+    foreach my $dnu (@{ $gr->get_value('member', asref => 1) || [] }) {
+        my $mesg = $self->search(
+            filter => '(objectClass=*)', # TODO can we get something else than user ?
+            @searchargs,
+            base => $dnu,
+        );
+
+        $mesg->code and return; # ensure error is propagate here
+        foreach my $entry ($mesg->entries) {
+           push(@res, $entry);
+       } 
+    }
+    @res
+}
+
+sub get_user_groups {
+    my ($self, $username, @searchargs) = @_;
+    my $user = $self->get_user($username);
+
+    my @res;
+    $self->unlimited_search(
+        base => $self->top_dn,
+        filter => sprintf(
+            '(&(objectClass=group)(member=%s))',
+            escape_filter_value($user->dn),
+        ),
+        @searchargs,
+        callback => sub {
+            my ($mesg, $entry) = @_;
+            ref $entry eq 'Net::LDAP::Entry' or return;
+            push(@res, $entry);
+        },
+    );
+
+    @res
+}
+
+sub add_user_group {
+    my ($self, $username, $groupname) = @_;
+
+    my $user = $self->get_user($username) or return;
+    my $group = $self->get_group($groupname) or return;
+
+    $group->add(member => $user->dn);
+
+    my $mesg = $group->update($self);
+    if ($mesg->code) {
+        warn $mesg->error;
+        return;
+    } else { return 1 };
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+=head1 AUTHOR
+
+Olivier Thauvin, E<lt>olivier.thauvin@aerov.jussieu.frE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2008 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
