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

package LATMOS::Accounts::Bases::Ad;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases);
use Net::LDAP;
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) = @_;
    
    $options{domain} or return;
    my $self = {
        _server => $options{server},
        _ad_domain => $options{domain},
        _top_dn => join(',', map { "dc=$_" } split('\.', $options{domain})),
        _login => $options{login},
        _password => $options{password},
        _ssl => $options{ssl},
    };

    bless($self, $class);
}

sub load {
    my ($self) = @_;
    # At this point, if still no $server, DNS search

    my $ldap;
    foreach my $tryserv (
        $self->{server}
        ? ($self->_ldap_url($self->{_server}))
        : $self->_query_zone_ads) {
        $ldap = Net::LDAP->new(
            $tryserv,
        ) and last;
    }

    $ldap or return; # connot connect to any ldap :\

    my $login = $self->{_login};
    $login =~ m/@/ or $login .= '@' . $self->ad_domain;

    my $msg = $ldap->bind($login, password => $self->{_password}) or return;
    $msg->code and do {
        warn $msg->error;
        return;
    };

    $self->{_ldap} = $ldap;
    return 1;
}

sub _ldap_url {
    my ($self, $host, $port) = @_;

    sprintf(
        '%s://%s%s/',
        $self->{_ssl} ? 'ldaps' : 'ldap',
        $host,
        $port ? ":$port" : '',
    )
}

sub _query_zone_ads {
    my ($self) = @_;
    require Net::DNS;
    my @urllist;

    my $resolver = Net::DNS::Resolver->new;
    my $query = $resolver->query("_ldap._tcp.dc._msdcs." . $self->ad_domain, "SRV");
    foreach my $rr (
        sort { $a->priority <=> $b->priority || $a->weight <=> $b->weight }
        grep { $_->type eq 'SRV' } $query->answer) {
        push(@urllist, $self->_ldap_url($rr->target, $rr->port));
    }

    @urllist
}

sub ldap {
    return $_[0]->{_ldap};
}

=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->ldap->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_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 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 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 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