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

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.

options:

=over 4

=item domain

The Active directory domain

=item server (optional)

If set, try to connect to this server, if not set, a dns query is performed
to find AD server, first responding is used.

=item ssl

If set, try to connect using ssl

=item OBJECT_container

The sub path where to find object type of OBJECT and where they should
be created

=back

=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},
        _param => { %options },
    };

    bless($self, $class);
}

sub param {
    my ($self, $var) = @_;
    return $self->{_param}{$var}
}

sub object_base_dn {
    my ($self, $otype) = @_;
    warn $otype;
    return join(',',
        ($self->param($otype . '_container') || 'cn=Users'),
        $self->top_dn,
    );
}

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 _defaults_group_attrs {
    my ($self, $entry, $attrs) = @_;
    foreach my $attr (keys %{ $attrs || {} }) {
        my $val = $attrs->{$attr};
        $entry->replace($attr => $val);
    }
}

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