source: LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ad.pm @ 4

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