source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Ldap.pm @ 1904

package LATMOS::Accounts::Bases::Ldap;

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 );
use Unicode::Map8;
use LATMOS::Accounts::Log;

our $VERSION = (q$Rev: 653 $ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Ldap - Perl extension for blah blah blah

=head1 SYNOPSIS

  use LATMOS::Ldap;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for LATMOS::Ldap, 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(%config)

Create a new LATMOS::Ldap object for windows AD $domain.

config:

=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, %config) = @_;
    
    my $self = {
        _top_dn => $config{topdn},
    };

    bless($self, $class);
}

=head2 object_base_dn ($otype)

Return the dn of obecjt containers

=cut

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

=head2 sambaSID($id)

Return the base samba SID set in the config or a default one if none is set.

If C<$id> is given return the full SID suitable for an object.

=cut

sub sambaSID {
    my ($self, $id) = @_;

    my $ssid = $self->config('sambaSID') || 'S-2016-01-07';
    if (defined($id)) {
        $ssid .= '-' . $id;
    }
    return $ssid;
}

sub load {
    my ($self) = @_;

    # If already loaded, just say ok !
    $self->{_ldap} and return 1;

    my $ldapurl = $self->_ldap_url($self->config('server'));
    my $ldap = Net::LDAP->new($ldapurl, async => 0);
        

    if($ldap) {
        $self->log(LA_DEBUG, "Connected to ldap server %s", $ldapurl);
    } else {
        $self->log(LA_ERR, "Cannot connect to %s", $ldapurl);
        return; # cannot connect to any ldap :\
    };


    my $msg = $ldap->bind($self->config('login'), password => $self->config('password'));
    $msg->code and do {
        $self->log(LA_ERR, "Cannot bind ldap: %s", $msg->error);
        return;
    };

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

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

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

=head2 ldap

Return the L<Net::LDAP> handle

=cut

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

=head2 top_dn

Return the TOP DN of the AD zone.

=cut

sub top_dn {
    return $_[0]->{_top_dn}
}

# _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.

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->ldap->search(@args, control => [ $page ]);
    }
    return 1;
}

# _get_object_from_dn($dn)
#
# Return Net::LDAP::Entry for $dn

sub _get_object_from_dn {
    my ($self, $dn) = @_;

    my $mesg = $self->ldap->search(
        base => $dn,
        scope => 'base',
        filter => '(objectClass=*)',
    );
    if ($mesg->code) {
        $self->log(LA_ERR, "Cannot get object %s: %s", $dn, $mesg->error);
        return;
    }

    return ($mesg->entries)[0];
}

sub authenticate_user {
    my ($self, $username, $passwd) = @_;
    $username or return;

    # Basically, connect and if bind succeed, user is authenticated !
    my $ldapurl = $self->ldap->uri;
    my $ldap = Net::LDAP->new($ldapurl);

    my $obj = $self->get_object('user', $username) or do {
        $self->log(LA_ERR, "Cannot find user %s", $username);
        return;
    };

    if ($ldap) {
        $self->log(LA_DEBUG, "Connected to ldap server %s", $ldapurl);
    } else {
        $self->log(LA_ERR, "Cannot connect to %s", $ldapurl);
        return; # cannot connect to any ldap :\
    };


    my $msg = $ldap->bind($obj->get_attributes('dn'), password => $passwd);
    if ($msg->code) {
        $self->log(LA_ERR, "Cannot bind ldap: %s", $msg->error);
        return;
    } else {
        return 1; # Success !! \o/
    }
}

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