ACU/ACU/LDAP.pm

#! /usr/bin/env perl

package LDAP;

use v5.10.1;
use strict;
use warnings;
use Carp;

use Net::LDAPS;
use Net::LDAP::Filter;
use Net::LDAP::Util qw(ldap_error_text);

use ACU::Password;
use ACU::Right;
use ACU::Log;

use constant {
    BASE_DN => "dc=acu,dc=epita,dc=fr",
    YEAR_DN => "cn=year,dc=acu,dc=epita,dc=fr",
};

## Connection functions

our $ldaphost = "ldap.acu.epita.fr";
our $binddn = "cn=intra," . BASE_DN;
my $bindsecret = "";

sub ldap_get_password
{
    if (`hostname` eq "apl") {
	return Password::get_password "/home/2014/mercie_d/.secret_ldap";
    } else {
	return Password::get_password "/home/intradmin/.secret_ldap";
    }
}

our $secret_search = \&ldap_get_password;

sub ldap_connect()
{
    if (!$bindsecret) {
	$bindsecret = $secret_search->();
    }

    my $ldap = Net::LDAPS->new($ldaphost) or die ("$@");
    my $mesg = $ldap->bind($binddn, password => $bindsecret) or die ("$@");

    log(DEBUG, "Connect to LDAP with $binddn");

    croak ldap_error_text($mesg->code) if ($mesg->code);

    return $ldap;
}

sub ldap_connect_anon()
{
    my $ldap = Net::LDAPS->new($ldaphost) or die ("$@");
    my $mesg = $ldap->bind or die ("$@");

    log(DEBUG, "Connect to LDAP anonymously");

    croak ldap_error_text($mesg->code) if ($mesg->code);

    return $ldap;
}


## High end functions

sub add_group($$$;$)
{
    my $ldap = shift // ldap_connect();
    my $cn = shift;
    my $year = shift // get_year();
    my $ou = shift // "intra"; # expected roles or intra

    my $dn = "cn=$cn,ou=$year,ou=$ou,ou=groups," . BASE_DN;

    log(DEBUG, "Add group $dn");

    my $mesg = $ldap->add( $dn,
		attrs => [
		    objectclass => "intraGroup",
		    cn => $cn,
		]
	);
    if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; }

    return $dn;
}

sub get_year(;$)
{
    my $ldap = shift // ldap_connect_anon();

    return get_attribute($ldap, YEAR_DN, "year");
}

sub get_rights($)
{
    my $login = shift;
    my @rights;

    my $ldap = ldap_connect_anon();

    my $mesg = $ldap->search( # search
			      base   => "ou=roles,ou=groups," . BASE_DN,
			      filter => Net::LDAP::Filter->new("&(memberUid=$login)(objectClass=intraGroup)"),
			      attrs => [ 'intraRight' ],
			      scope => "sub"
	);
    if ($mesg->code != 0) { die $mesg->error; }

    for my $entry ($mesg->entries)
    {
	for my $r ($entry->get_value('intraRight'))
	{
	    if ($r =~ /^!(.*)$/) {
		@rights = grep { $r ne $_ } @rights;
	    }
	    else {
		push @rights, Right->new($r);
	    }
	}
    }


    $mesg = $ldap->search( # search
			   base   => "ou=intra,ou=groups," . BASE_DN,
			   filter => Net::LDAP::Filter->new("&(memberUid=$login)(objectClass=intraGroup)"),
			   attrs => [ 'intraRight' ],
			   scope => "sub"
	);
    if ($mesg->code != 0) { die $mesg->error; }
    if ($mesg->count != 1) { die "User $login not found or multiple presence"; }

    for my $entry ($mesg->entries)
    {
	for my $r ($entry->get_value('intraRight')) {
	    push @rights, Right->new($r);
	}
    }


    $mesg = $ldap->search( # search
			   base   => "ou=users," . BASE_DN,
			   filter => Net::LDAP::Filter->new("&(uid=$login)(objectClass=intraAccount)"),
			   attrs => [ 'intraRight' ],
			   scope => "sub"
	);
    if ($mesg->code != 0) { die $mesg->error; }
    if ($mesg->count != 1) { die "User $login not found or multiple presence"; }

    for my $r ($mesg->entry(0)->get_value('intraRight')) {
	push @rights, Right->new($r);
    }


    $ldap->unbind or die ("couldn't disconnect correctly");

    return @rights;
}

sub has_right($$)
{
    my $login = shift;
    my $right = shift;

    my $ok = 0;

    for my $r (get_rights($login))
    {
	if ($r->{right} eq $right)
	{
	    return 0 if ($r->{negate});
	    $ok = $r;
	}
    }

    return $ok;
}


## Low level functions

sub get_dn($$@)
{
    my $ldap = shift // ldap_connect();
    my $dn = shift;

    my $base = BASE_DN;
    $dn = "$dn," . BASE_DN if ($dn !~ /$base$/);

    my $mesg = $ldap->search( # search
			      base   => "$dn",
			      filter => Net::LDAP::Filter->new("(objectClass=*)"),
			      attrs => \@_,
			      scope => "base"
	);
    return undef if ($mesg->code != 0);
    if ($mesg->count != 1) { log(WARN, "$dn not found or multiple entries match"); return undef; }

    return $mesg->entry(0);
}

sub add_attribute($$$@)
{
    my $ldap = shift // ldap_connect();
    my $dn = shift;
    my $what = shift;

    my $mod = 0;

    my $entry = get_dn($ldap, $dn, $what);
    if (!$entry) {
	log(WARN, "Trying to add attributes ($what) to an unexisting entry: $dn");
	log(TRACE, @_);
	return undef;
    }
    my @data = $entry->get_value($what);
    for my $value (@_)
    {
	if (! grep { $value eq $_ } @data)
	{
	    $mod = 1;

	    log(DEBUG, "Add attribute $value to $dn");

	    push @data, $value;
	}
	else {
	    log(WARN, "Attribute $what with value $value for $dn already exists.");
	}
    }

    if ($mod)
    {
	$entry->replace($what => \@data) or die $!;
	my $mesg = $entry->update($ldap) or die $!;

	if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; }

	return 1;
    }
    else {
	return 0;
    }
}

sub delete_attribute($$$@)
{
    my $ldap = shift // ldap_connect();
    my $dn = shift;
    my $what = shift;

    my $mod = 0;

    my $entry = get_dn($ldap, $dn, $what);
    my @data = $entry->get_value($what);
    for my $value (@_)
    {
	if (grep { $value eq $_ } @data)
	{
	    log(DEBUG, "Remove attribute $what ($value) from $dn");

	    @data = grep { $value ne $_ } @data;
	    $mod = 1;
	}
	else {
	    log(WARN, "No attribute $what with value $value for $dn");
	}
    }

    if ($mod)
    {
	$entry->replace($what => \@data) or die $!;
	my $mesg = $entry->update($ldap) or die $!;
	if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; }
	return 1;
    }
    else {
	return 0;
    }
}

sub delete_entry($$)
{
    my $ldap = shift // ldap_connect();

    my $mesg = $ldap->delete( shift );

    if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; }

    return 1;
}

sub flush_attribute($$@)
{
    my $ldap = shift // ldap_connect();
    my $dn = shift;

    my $mesg = $ldap->modify($dn, delete => \@_);

    if ($mesg->code != 0) { log(WARN, $mesg->error); return 0; }

    return 1;
}

sub get_attribute($$$)
{
    my $ldap = shift // ldap_connect();
    my $dn = shift;
    my $what = shift;

    if (!$dn) { return undef; }

    return get_dn($ldap, $dn, $what)->get_value($what);
}

sub search_dn($$@)
{
    my $ldap = shift // ldap_connect();
    my $base = shift;
    my $filter = shift;

    $base .= "," if ($base);

    log (DEBUG, "Looking for $filter in $base" . BASE_DN);

    my $mesg = $ldap->search( # search
			      base   => $base . BASE_DN,
			      filter => Net::LDAP::Filter->new($filter),
			      attrs => [ ],
			      scope => "sub"
	);
    return undef if ($mesg->code != 0);
    croak("$filter not found") if ($mesg->count == 0);
    croak("$filter not unique") if ($mesg->count > 1);

    return $mesg->entry(0)->dn;
}

sub search_dns($$$@)
{
    my $ldap = shift // ldap_connect();
    my $base = shift;
    my $filter = shift;

    $base .= "," if ($base);

    my $mesg = $ldap->search( # search
			      base   => $base . BASE_DN,
			      filter => Net::LDAP::Filter->new($filter),
			      attrs => \@_,
			      scope => "sub"
	);
    if ($mesg->code != 0) { log(WARN, $mesg->error); return []; }

    return $mesg->entries;
}

sub update_attribute($$$@)
{
    my $ldap = shift // ldap_connect();
    my $dn = shift;
    my $what = shift;

    my $entry = get_dn($ldap, $dn, $what);
    $entry->replace($what => \@_);
    my $mesg = $entry->update($ldap);

    if ($mesg->code != 0) {
	log(WARN, $mesg->error);
	return 0;
    }

    return 1;
}

1;