[Koha-patches] [PATCH] C4::Auth_with_ldap.pm refactoring
Henri-Damien LAURENT
henridamien.laurent at biblibre.com
Fri Feb 11 16:54:26 CET 2011
Here is a patch I am sending in order to support multiple branches for LDAP
This enables the user to add a PM with transformation rules, you find a direct exemple in the patch
Package::Stash is a module that comes with PERL core
In C4::Auth
use C4::Auth_with_ldap was replaced by
require C4::Auth_with_ldap
so the checkpw_ldap symbol wasn't resolved anymore. As i guess there was a good reason, the call of checkpw_ldap is
now fully qualified.
syncho_ldap.pl is a script for
LDAP filter for synchronisation
It allows to have multiple branches in configuration
<ldapserver
uri="ldap://ldap.domain.fr"
manager="uid=username,ou=domain,dc=a,dc=b,dc=c"
password="Mypass"
replicate="1" update="1"
authmethod="search_dn" >
<transformation module="LDAPSupelec" />
<mapping> <userid is="uid" />
</mapping>
<branch dn="ou=domain,dc=a,dc=b,dc=c" />
<branch dn="ou=domain,dc=e,dc=b,dc=c" />
<branch dn="ou=domain,dc=d,dc=b,dc=c" />
</ldapserver>
Feel free to comment if you can test on a server
or are interested in such a thing.
---
C4/Auth.pm | 4 +-
C4/Auth_with_ldap.pm | 467 +++++++++++++++++++++++++++++++++--------
C4/LDAPAuthMethodTutorial.pod | 80 +++++++
LDAPSupelec.pm | 291 +++++++++++++++++++++++++
syncho_ldap.pl | 41 ++++
t/auth_with_ldap_ng.t | 11 +
6 files changed, 805 insertions(+), 89 deletions(-)
create mode 100644 C4/LDAPAuthMethodTutorial.pod
create mode 100644 LDAPSupelec.pm
create mode 100644 syncho_ldap.pl
create mode 100644 t/auth_with_ldap_ng.t
diff --git a/C4/Auth.pm b/C4/Auth.pm
index fc4e3e2..dce3590 100644
--- a/C4/Auth.pm
+++ b/C4/Auth.pm
@@ -1354,8 +1354,8 @@ sub checkpw {
my ( $dbh, $userid, $password, $query ) = @_;
if ($ldap) {
$debug and print "## checkpw - checking LDAP\n";
- my ($retval,$retcard) = checkpw_ldap(@_); # EXTERNAL AUTH
- ($retval) and return ($retval,$retcard);
+ my ( $retval, $retcard ) = C4::Auth_with_ldap::checkpw_ldap(@_); # EXTERNAL AUTH
+ ($retval) and return ( $retval, $retcard );
}
if ($cas && $query->param('ticket')) {
diff --git a/C4/Auth_with_ldap.pm b/C4/Auth_with_ldap.pm
index b25697c..9f6c4a3 100644
--- a/C4/Auth_with_ldap.pm
+++ b/C4/Auth_with_ldap.pm
@@ -1,5 +1,4 @@
package C4::Auth_with_ldap;
-
# Copyright 2000-2002 Katipo Communications
#
# This file is part of Koha.
@@ -17,27 +16,35 @@ package C4::Auth_with_ldap;
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-use strict;
-#use warnings; FIXME - Bug 2505
+use Modern::Perl;
use Digest::MD5 qw(md5_base64);
-
use C4::Debug;
use C4::Context;
-use C4::Members qw(AddMember changepassword);
-use C4::Members::Attributes;
+use C4::Members qw/ GetMember AddMember changepassword /;
+use C4::Members::Attributes qw/ SetBorrowerAttributes /;
use C4::Members::AttributeTypes;
use C4::Utils qw( :all );
use List::MoreUtils qw( any );
use Net::LDAP;
use Net::LDAP::Filter;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
-
-BEGIN {
- require Exporter;
- $VERSION = 3.10; # set the version for version checking
- @ISA = qw(Exporter);
- @EXPORT = qw( checkpw_ldap );
+use parent 'Exporter';
+require YAML;
+
+our $VERSION = 3.10; # set the version for version checking
+our @ISA = qw(Exporter);
+our @EXPORT = qw( checkpw_ldap );
+
+# return the ref of the subroutine
+sub load_subroutine {
+ require Package::Stash;
+ my ( $module, $sub ) = @_;
+ my $stash = Package::Stash->new($module);
+ unless ( %{ $stash->namespace } ) {
+ eval "require $module";
+ $@ and die $@;
+ }
+ $stash->get_package_symbol('&'.$sub);
}
# Redefine checkpw_ldap:
@@ -51,14 +58,28 @@ sub ldapserver_error ($) {
return sprintf('No ldapserver "%s" defined in KOHA_CONF: ' . $ENV{KOHA_CONF}, shift);
}
+# constants
+sub DEBUG { 0 }
+sub LDAP_CANTBIND { 'LDAP_CANTBIND' }
+
+sub debug_msg { DEBUG and say STDERR @_ }
+sub logger { say STDERR YAML::Dump @_ }
+
use vars qw($mapping @ldaphosts $base $ldapname $ldappassword);
-my $context = C4::Context->new() or die 'C4::Context->new failed';
-my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
-my $prefhost = $ldap->{hostname} or die ldapserver_error('hostname');
-my $base = $ldap->{base} or die ldapserver_error('base');
-$ldapname = $ldap->{user} ;
-$ldappassword = $ldap->{pass} ;
-our %mapping = %{$ldap->{mapping}}; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
+my $context = C4::Context->new() or die 'C4::Context->new failed';
+my $ldap = C4::Context->config("ldapserver") or die 'No "ldapserver" in server hash from KOHA_CONF: ' . $ENV{KOHA_CONF};
+
+my ( $prefhost, $base ) = ('')x2;
+
+unless ( $$ldap{authmethod} ) {
+ say STDERR "deprecated ldap configuration, see documentation";
+ $base = $$ldap{base} or die ldapserver_error('base');
+ $prefhost = $$ldap{hostname} or die ldapserver_error('hostname');
+}
+
+$ldapname = $ldap->{user};
+$ldappassword = $ldap->{pass};
+our %mapping = %{ $ldap->{mapping} || {} }; # FIXME dpavlin -- don't die because of || (); from 6eaf8511c70eb82d797c941ef528f4310a15e9f9
my @mapkeys = keys %mapping;
$debug and print STDERR "Got ", scalar(@mapkeys), " ldap mapkeys ( total ): ", join ' ', @mapkeys, "\n";
@mapkeys = grep {defined $mapping{$_}->{is}} @mapkeys;
@@ -78,13 +99,28 @@ sub description ($) {
}
sub search_method {
- my $db = shift or return;
- my $userid = shift or return;
- my $uid_field = $mapping{userid}->{is} or die ldapserver_error("mapping for 'userid'");
- my $filter = Net::LDAP::Filter->new("$uid_field=$userid") or die "Failed to create new Net::LDAP::Filter";
- my $res = ($config{anonymous}) ? $db->bind : $db->bind($ldapname, password=>$ldappassword);
- if ($res->code) { # connection refused
- warn "LDAP bind failed as ldapuser " . ($ldapname || '[ANONYMOUS]') . ": " . description($res);
+ my $db = shift or return;
+ my $userid = shift or return;
+ my $uid_field = $mapping{userid}->{is} or die ldapserver_error("mapping for 'userid'");
+ my $filter = Net::LDAP::Filter->new("$uid_field=$userid") or die "Failed to create new Net::LDAP::Filter";
+ my $res = ( $config{anonymous} ) ? $db->bind : $db->bind( $ldapname, password => $ldappassword );
+ if ( $res->code ) { # connection refused
+ warn "LDAP bind failed as ldapuser " . ( $ldapname || '[ANONYMOUS]' ) . ": " . description($res);
+ return 0;
+ }
+ my $search = $db->search(
+ base => $base,
+ filter => $filter,
+
+ # attrs => ['*'],
+ ) or die "LDAP search failed to return object.";
+ my $count = $search->count;
+ if ( $search->code > 0 ) {
+ warn sprintf( "LDAP Auth rejected : %s gets %d hits\n", $filter->as_string, $count ) . description($search);
+ return 0;
+ }
+ if ( $count != 1 ) {
+ warn sprintf( "LDAP Auth rejected : %s gets %d his\n", $filter->as_string, $count );
return 0;
}
my $search = $db->search(
@@ -104,84 +140,341 @@ sub search_method {
return $search;
}
+# $cnx is an Net::LDAP object that dies when error occurs
+# $search_params are params for the search method (default base is the one set in the config)
+
+# TODO:
+# this function name suck: find something more generic around koha manager auth and anonymous one
+
+sub _anon_search {
+
+ my ( $cnx, $search ) = @_;
+
+ my $entry;
+ for my $branch ( @{ $$ldap{branch} } ) {
+ debug_msg "search $$search{filter} at $$branch{dn}";
+
+ my $branch_search = { %$search, base => $$branch{dn}, search => "ObjectClass=*" };
+ $entry = eval {
+ $cnx
+ ->search( %$branch_search )
+ ->shift_entry
+ };
+
+ if ( $entry ) {
+ debug_msg "found ", $entry->dn;
+ return { entry => $entry, branch => $branch }
+ }
+ elsif ( $@ ) { return { qw/ error UNKNOWN msg /, $@ } }
+ else { DEBUG and logger { "failed search" => $branch_search } }
+ }
+}
+
+sub set_xattr {
+ my ( $id, $borrower ) = @_;
+ if ( my $x = $$borrower{xattr} ) {
+#SetBorrowerAttributes is not managing when being sent an Array ref
+ my $attrs = [ map
+ {
+ my $key=$_;
+ my @listattributes;
+ if (ref ($$x{$key}) eq "ARRAY"){
+ foreach my $value (@{$$x{$key}}){
+ push @listattributes, { code => $key, value => $value }
+ }
+ }
+ else {
+ push @listattributes,{ code => $key, value => $$x{$key} }
+ }
+ @listattributes;
+ }
+ keys %$x ];
+ DEBUG and logger { "creating $id" => $attrs };
+ SetBorrowerAttributes( $id, $attrs );
+ }
+}
+
+# sub raising_error (&) {
+# my ( $block ) = @_;
+# my $RaiseError;
+# my $dbh = C4::Context->dbh;
+# $RaiseError = $$dbh{RaiseError};
+# $$dbh{RaiseError} = 1;
+# eval { $block->() };
+# $$dbh{RaiseError} = $RaiseError;
+# }
+
+sub accept_borrower {
+ my ($borrower,$userid) = @_;
+ for ( $$borrower{column}{userid} ) {
+ $userid ||= $_ or die;
+ unless ( $_ ) {
+ $_ = $userid;
+ next;
+ }
+ unless ( $userid ~~ $_ ) {
+ warn "userid $_ don't match authentication credential $userid";
+ return 0;
+ }
+ }
+
+ my $id = ( GetMember( userid => $userid ) || {} )->{borrowernumber}
+ or debug_msg "$userid is newcommer";
+
+ my $newcommer = not defined $id;
+
+ # for ($$ldap{dry_run}) {
+ # if ( $_ && not /no/) {
+ # DEBUG and logger
+ # { ( $newcommer ? 'newcommer' : 'existing_user' )
+ # , { map { $_, $$borrower{$_} } qw/ column xattr / }
+ # };
+ # return 0;
+ # }
+ # }
+
+ if ( $newcommer ) {
+ return 0 unless $config{update};
+ DEBUG and logger { Member => $$borrower{column} };
+ $id = AddMember( %{ $$borrower{column} } ) or return 0;
+ # raising_error { AddMember( %{ $$borrower{column} } ) };
+ # if ( $@ || not defined $id ) {
+ # DEBUG and logger { $@, $$borrower{column} };
+ # return 0;
+ # }
+ } else {
+ if ( $config{replicate} ) {
+ delete $$borrower{column}{dateenrolled};
+ my $cardnumber = update_local
+ ( $userid, $$borrower{column}{password}, $id, $$borrower{column} );
+ if ( my $old_cardnumber = $$borrower{column}{cardnumber} ) {
+ if ( $cardnumber ne $cardnumber ) {
+ warn "update_local returned cardnumber '$cardnumber' instead of '$old_cardnumber'";
+ return 0;
+ }
+ }
+ }
+ }
+
+ if ( $newcommer || $config{update} ) {
+ DEBUG and logger { "changing attrs for $id" => $$borrower{xattr} };
+ set_xattr $id,$borrower;
+ }
+
+ return 1
+}
+
+sub cnx {
+ state $cnx = Net::LDAP->new( $$ldap{uri}, qw/ onerror die / ) or do {
+ warn "ldap error: $!";
+ };
+ # bind MUST success
+ my $msg = eval { $cnx->bind ( $$ldap{manager}, password => $$ldap{password} ) };
+ debug_msg "ldap $_:", $msg->$_ for qw/ error code /;
+ if ( $@ ) { return {qw/ error LDAP_CANTBIND msg /, $@} };
+ $cnx;
+}
+
+
+
sub checkpw_ldap {
- my ($dbh, $userid, $password) = @_;
- my @hosts = split(',', $prefhost);
- my $db = Net::LDAP->new(\@hosts);
- #$debug and $db->debug(5);
+ my ( $dbh, $userid, $password ) = @_;
+ my @hosts = split( ',', $prefhost );
+ my $db = Net::LDAP->new( \@hosts );
+ my $to_borrower = {};
+
+ my $uattr
+ = $$ldap{userid_from}
+ || $$ldap{mapping}{userid}{is}
+ or die "userid mapping not set";
+
+ # $userldapentry is a crappy global value user at bottom
+ # of this fonction to build the koha user
my $userldapentry;
+
+ if ( $$ldap{authmethod} ) {
+
+ # TODO: do this test sooner ?
+ for ( $$ldap{branch} ) {
+ $_ or die "no branch, no auth";
+ ref $_ ~~ 'HASH' and $_ = [$_];
+ }
+
+ # This code is an attempt to introduce a new codebase that can be hookable
+ # and can mangage more cases than the old way
+
+ # if the filter isn't set, userid mapping is used
+ $$ldap{filter} ||= "$uattr=%s";
+
+ my $cnx = cnx or return 0;
+
+ # login can be either ...
+ my $login = do {
+
+ # An Active Directory principal_name. Just replace the %s by the userid
+ # well ... don't try if not AD
+ if ( $$ldap{authmethod} ~~ [qw/ principal_name principalname principalName /] ) {
+ sprintf( $$ldap{principal_name}, $userid )
+ }
+
+ # for other LDAP implementation, the standard way is to
+ # A) Bind with the manager account and search for the DN of the user entry
+ # B) Bind with the user DN and password.
+ # Auth is completed if bind success.
+ # so in this code;
+ # - i fill $userldapentry for later use
+ # - i return the DN
+
+ elsif ( $$ldap{authmethod} ~~ [qw/ searchdn searchDn search_dn /] ) {
+
+ $to_borrower = _anon_search
+ ( $cnx
+ , { filter => sprintf( $$ldap{filter}, $userid ) }
+ ) or do {
+ debug_msg "no answer from ldap";
+ return 0;
+ };
+
+ if ( $$to_borrower{error} ) {
+ say STDERR $$to_borrower{msg};
+ return 0;
+ }
+
+ # TODO:
+ # here comes the branch by branch mapping
+ # $$result{branch}{mapping}
+
+ $userldapentry = $$to_borrower{entry} or do {
+ debug_msg "no entry returned? weird ...";
+ };
+
+ # login is the dn of the entry
+ if ( $userldapentry ) { $userldapentry->dn }
+ else {
+ say STDERR "can't authenticate $userid";
+ return 0;
+ }
+ } else {
+ say STDERR "$$ldap{authmethod} authmethod is invalid,"
+ , "please check your ldap configuration in $ENV{KOHA_CONF}"
+ ;
+ return 0;
+ }
+ };
+
+ eval { $cnx->bind( $login, password => $password ) };
+ if ( $@ ) {
+ say STDERR "ldap bind with $login failed: $@";
+ return 0;
+ }
+ debug_msg "congrats, you're one of us";
+ } else {
+ # This is the old stuff:
+ #
+ #$debug and $db->debug(5);
if ( $ldap->{auth_by_bind} ) {
- my $principal_name = $ldap->{principal_name};
- if ($principal_name and $principal_name =~ /\%/) {
- $principal_name = sprintf($principal_name,$userid);
- } else {
- $principal_name = $userid;
- }
- my $res = $db->bind( $principal_name, password => $password );
- if ( $res->code ) {
- $debug and warn "LDAP bind failed as kohauser $principal_name: ". description($res);
- return 0;
- }
+ my $principal_name = $ldap->{principal_name};
+ if ( $principal_name and $principal_name =~ /\%/ ) {
+ $principal_name = sprintf( $principal_name, $userid );
+ } else {
+ $principal_name = $userid;
+ }
+ my $res = $db->bind( $principal_name, password => $password );
+ if ( $res->code ) {
+ $debug and warn "LDAP bind failed as kohauser $principal_name: " . description($res);
+ return 0;
+ }
- # FIXME dpavlin -- we really need $userldapentry leater on even if using auth_by_bind!
- my $search = search_method($db, $userid) or return 0; # warnings are in the sub
- $userldapentry = $search->shift_entry;
+ # FIXME dpavlin -- we really need $userldapentry leater on even if using auth_by_bind!
+ my $search = search_method( $db, $userid ) or return 0; # warnings are in the sub
+ $userldapentry = $search->shift_entry;
} else {
- my $search = search_method($db, $userid) or return 0; # warnings are in the sub
- $userldapentry = $search->shift_entry;
- my $cmpmesg = $db->compare( $userldapentry, attr=>'userpassword', value => $password );
- if ($cmpmesg->code != 6) {
- warn "LDAP Auth rejected : invalid password for user '$userid'. " . description($cmpmesg);
- return 0;
- }
+ # i wish this would NEVER EVER BE !
+ say STDERR "deprecated kludge: use authmethod search_dn instead";
+ my $search = search_method( $db, $userid ) or return 0; # warnings are in the sub
+ $userldapentry = $search->shift_entry;
+ my $cmpmesg = $db->compare( $userldapentry, attr => 'userpassword', value => $password );
+ if ( $cmpmesg->code != 6 ) {
+ warn "LDAP Auth rejected : invalid password for user '$userid'. " . description($cmpmesg);
+ return 0;
+ }
}
+ }
+
+ if ( my $t = $$ldap{transformation} ) {
+ $$t{subroutine} ||= 'get_borrower';
+ my $get_borrower = load_subroutine ( @$t{qw/ module subroutine /} );
+ unless ( $get_borrower ) {
+ warn "no get_borrower $$t{subroutine} subroutine in $$t{module}";
+ return 0;
+ }
+ debug_msg "$$t{subroutine} subroutine loaded from $$t{module}";
+ if ( my $b = $get_borrower->( $$to_borrower{entry} ) ) {
+ return accept_borrower $b,$userid;
+ }
+ else { return 0 }
+ }
# To get here, LDAP has accepted our user's login attempt.
# But we still have work to do. See perldoc below for detailed breakdown.
- my (%borrower);
- my ($borrowernumber,$cardnumber,$local_userid,$savedpw) = exists_local($userid);
+ my %borrower;
+ my ( $borrowernumber, $cardnumber, $local_userid, $savedpw ) = exists_local($userid);
- if (( $borrowernumber and $config{update} ) or
- (!$borrowernumber and $config{replicate}) ) {
- %borrower = ldap_entry_2_hash($userldapentry,$userid);
- $debug and print STDERR "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join(' ', keys %borrower), "\n";
+ if ( ( $borrowernumber and $config{update} )
+ or ( !$borrowernumber and $config{replicate} ) ) {
+ %borrower = ldap_entry_2_hash( $userldapentry, $userid );
+ $debug and print STDERR "checkpw_ldap received \%borrower w/ " . keys(%borrower), " keys: ", join( ' ', keys %borrower ), "\n";
}
if ($borrowernumber) {
- if ($config{update}) { # A1, B1
- my $c2 = &update_local($local_userid,$password,$borrowernumber,\%borrower) || '';
- ($cardnumber eq $c2) or warn "update_local returned cardnumber '$c2' instead of '$cardnumber'";
- } else { # C1, D1
- # maybe update just the password?
- return(1, $cardnumber); # FIXME dpavlin -- don't destroy ExtendedPatronAttributes
+ if ( $config{update} ) { # A1, B1
+ delete $borrower{dateenrolled};
+ my $c2 = &update_local( $local_userid, $password, $borrowernumber, \%borrower ) || '';
+ ( $cardnumber eq $c2 ) or warn "update_local returned cardnumber '$c2' instead of '$cardnumber'";
+ } else { # C1, D1
+ # maybe update just the password?
+ return ( 1, $cardnumber ); # FIXME dpavlin -- don't destroy ExtendedPatronAttributes
}
- } elsif ($config{replicate}) { # A2, C2
- $borrowernumber = AddMember(%borrower) or die "AddMember failed";
- } else {
- return 0; # B2, D2
+ } elsif ( $config{replicate} ) { # A2, C2
+ debug_msg "$borrower{userid} # = $borrowernumber";
+ AddMember(%borrower);
+ # $borrowernumber = eval { AddMember(%borrower) };
+ # if ( $@ || not defined $borrowernumber ) {
+ # die logger { $@ => \%borrower };
+ # if (DEBUG) { logger { $@ => \%borrower } }
+ # else { say STDERR "ldap account $borrower{userid} can't be replicated in koha" }
+ # return 0;
+ # }
+ } else {
+ return 0; # B2, D2
+ }
+ if ( C4::Context->preference('ExtendedPatronAttributes') && $borrowernumber && ( $config{update} || $config{replicate} ) ) {
+ my @types = C4::Members::AttributeTypes::GetAttributeTypes();
+ my @attributes = grep {
+ my $key = $_;
+ any { $_ eq $key } @types;
+ } keys %borrower;
+ my $extended_patron_attributes = map { { code => $_, value => $borrower{$_} } } @attributes;
+ $extended_patron_attributes = [] unless $extended_patron_attributes;
+ my @errors;
+
+ #Check before add
+ for ( my $i ; $i < scalar(@$extended_patron_attributes) - 1 ; $i++ ) {
+ my $attr = $extended_patron_attributes->[$i];
+ unless ( C4::Members::Attributes::CheckUniqueness( $attr->{code}, $attr->{value}, $borrowernumber ) ) {
+ unshift @errors, $i;
+ warn "ERROR_extended_unique_id_failed $attr->{code} $attr->{value}";
+ }
+ }
+
+ #Removing erroneous attributes
+ foreach my $index (@errors) {
+ @$extended_patron_attributes = splice( @$extended_patron_attributes, $index, 1 );
+ }
+ C4::Members::Attributes::SetBorrowerAttributes( $borrowernumber, $extended_patron_attributes );
}
- if (C4::Context->preference('ExtendedPatronAttributes') && $borrowernumber && ($config{update} ||$config{replicate})) {
- my @types = C4::Members::AttributeTypes::GetAttributeTypes();
- my @attributes = grep{my $key=$_; any{$_ eq $key}@types;} keys %borrower;
- my $extended_patron_attributes = map{{code=>$_,value=>$borrower{$_}}}@attributes;
- my $extended_patron_attributes = [] unless $extended_patron_attributes;
- my @errors;
- #Check before add
- for (my $i; $i< scalar(@$extended_patron_attributes)-1;$i++) {
- my $attr=$extended_patron_attributes->[$i];
- unless (C4::Members::Attributes::CheckUniqueness($attr->{code}, $attr->{value}, $borrowernumber)) {
- unshift @errors, $i;
- warn "ERROR_extended_unique_id_failed $attr->{code} $attr->{value}";
- }
- }
- #Removing erroneous attributes
- foreach my $index (@errors){
- @$extended_patron_attributes=splice(@$extended_patron_attributes,$index,1);
- }
- C4::Members::Attributes::SetBorrowerAttributes($borrowernumber, $extended_patron_attributes);
- }
return(1, $cardnumber);
}
diff --git a/C4/LDAPAuthMethodTutorial.pod b/C4/LDAPAuthMethodTutorial.pod
new file mode 100644
index 0000000..b4dd6c8
--- /dev/null
+++ b/C4/LDAPAuthMethodTutorial.pod
@@ -0,0 +1,80 @@
+=head1 LDAP auth_method configuration
+
+This document is a step by step explaination for the new LDAP configuration method. The old one ( see C4::Auth_with_ldap ) still exists and you should give it a try if your needs of mappings and transformations are low.
+
+=head2 What do I have to ask to the directory administrator
+
+=head3 How to reach the service
+
+What we need is build the url of the ldap service we want to reach. so ask him for the URL. If he don't know, ask for the scheme (or protocol), the hostname and the port of the directory. Only hostname and scheme are mandatory.
+
+The scheme must be ldap or ldaps ( ldaps is for crypted ldap, ldap over SSL). the url construction is
+
+ scheme://hostname:port
+ scheme://hostname
+
+examples
+
+ host=directory.example.com port=389 scheme=ldap
+
+gives you
+
+ ldap://directory.example.com:389
+
+Also: Active Directory (the Microsoft implementation) is an LDAP alike directory but Koha have to know it's active directory to use it. so please ask.
+
+=head3 What is the binding method ?
+
+Are anonymous allowed to make some searches on the server? If not, what is the credentials for the koha account ?
+Credentials are a pair ( DN, password )
+
+ uid=koha,ou=people,dc=example,dc=com MYS3CRET
+
+in Active Directory, it can be a login at example.com with a password
+
+ koha at example.com MYS3CRET
+
+=head3 Now configure koha
+
+This is a basic exemple of things you will add in the C</config> part of C<koha-conf.xml>.
+
+First of all, you need to tell koha that ldap authentication is now relevant
+
+ <useldapserver>1</useldapserver>
+ </ldapserver>
+
+If you use anonymous method, you have to give credentials of koha account
+
+ <ldapserver url="ldap://directory.example.com"
+ manager="uid=koha,ou=people,dc=example,dc=com"
+ password="MYS3CRET"
+ authmethod="search_dn" >
+
+Also, you can set the values for replication and update (documented in legacy pod):
+
+ <ldapserver url="ldap://directory.example.com"
+ manager="uid=koha,ou=people,dc=example,dc=com"
+ password="MYS3CRET"
+ authmethod="search_dn"
+ replicate="1" update="1"
+ >
+
+You must now tell koha the ldap branches where find users
+
+ <useldapserver>1</useldapserver>
+ <ldapserver url="ldap://directory.example.com"
+ manager="uid=koha,ou=people,dc=example,dc=com"
+ password="MYS3CRET"
+ authmethod="search_dn"
+ replicate="1" update="1"
+ >
+ <branch dn="ou=people,dc=site1,dc=example,dc=com" />
+ <branch dn="ou=people,dc=site2,dc=example,dc=com" />
+ <branch dn="ou=people,dc=site4,dc=example,dc=com" />
+
+The best part of this new config is that you don't have to rely on simple mappings anymore: you can use a perl module to write much sofisticated transformations directly in perl:
+
+ <transformation module="LDAPSupelec" />
+
+
+
diff --git a/LDAPSupelec.pm b/LDAPSupelec.pm
new file mode 100644
index 0000000..0f88b42
--- /dev/null
+++ b/LDAPSupelec.pm
@@ -0,0 +1,291 @@
+#! /usr/bin/perl
+package LDAPSupelec;
+use Modern::Perl;
+use C4::Members;
+use YAML;
+use Net::LDAP::LDIF;
+
+# attributs trouvés dans le ldapsearch:
+# ldapsearch | perl -F: -wlanE ' END { say for sort keys %a } $F[0] ~~ /^\S/ and $a{$F[0]} = 1'
+
+our %rapport;
+our @ATTRS = qw/
+ givenName
+ mail
+ sn
+ supelecBibCaution
+ supelecCampusRattachement
+ supelecDateEntree
+ supelecDatePrevueSortie
+ supelecDepartement
+ supelecMatriculeEleve
+ supelecNiveauScolaire
+ supelecPromo
+ supelecTypePersonne
+ supelecUid
+ supelecVoie
+ uid
+/;
+
+our $VALID_LDAP_ATTRS = [qw/
+cn
+description
+displayName
+dn
+gidNumber
+givenName
+homeDirectory
+loginShell
+mail
+objectClass
+sn
+supelecBibCaution
+supelecCampusRattachement
+supelecDepartement
+supelecEtatDuCompte
+supelecMatricule
+supelecMatriculeEleve
+supelecMembreDe
+supelecPromo
+supelecTypePersonne
+supelecUid
+uid
+uidNumber
+/];
+
+our $supelecTypePersonne =
+{ categorycode =>
+ {qw/
+ personnel PSUPELEC
+ personnel-cdd PERSLABO
+ personnel-ext PERSLABO
+ vacataire VAC
+ eleve ETU
+ eleve_ecp ETU
+ doctorant DOCTSUP
+ doctorant-cdi DOCTSUP
+ doctorant-nonsupelec DOCTLABO
+ post-doctorant PSUPELEC
+ post-doctorant-cdi PSUPELEC
+ post-doctorant-nonsupelec PERSLABO
+ stagiaire STAGEXT
+ stagiaire-cdd STAGSUP
+ mastere ETU
+ master ETU
+ /}
+, to_ignore =>
+ [qw/
+ MISSING
+ c3s
+ exterieur
+ fc
+ moniteur
+ moodle
+ service
+ test
+ /]
+, with_caution => [qw/
+ eleve_ecp
+ doctorant-nonsupelec
+ post-doctorant
+ post-doctorant-cdi
+ post-doctorant-nonsupelec
+ stagiaire
+ stagiaire-cdd
+ /]
+};
+
+our %cardnumber_attribute_for_categorycode = qw/
+DOCTLABO supelecMatriculeEleve
+DOCTSUP supelecMatriculeEleve
+ETU supelecMatriculeEleve
+PERSLABO supelecUid
+PSUPELEC supelecUid
+STAGEXT supelecUid
+STAGSUP supelecUid
+VAC supelecUid
+/;
+
+sub set_category_code (_) {
+ my $user = shift;
+ my $type = lc $$user{src}{supelecTypePersonne};
+ return if $type ~~ /$$supelecTypePersonne{to_ignore}/i;
+
+ $$user{column}{categorycode} = $$supelecTypePersonne{categorycode}{$type}
+ || do {
+ push @{ $rapport{'supelecTypePersonne sans categorycode'}{$type}
+ }, $$user{column}{userid};
+ 'ETU';
+ };
+
+}
+
+sub set_cardnumber (_) {
+ my $user = shift;
+ my $cc = $$user{column}{categorycode}
+ or die 'set_category_code must be called before set_cardnumber';
+
+ my $cn_attr = $cardnumber_attribute_for_categorycode{ $cc }
+ || do {
+ $rapport{'pas de cardnumber attr pour categorycode'}{$cc}++;
+ 'MISSING';
+ };
+
+ my $cn = $$user{src}{$cn_attr}
+ || ($cc =~/DOCTSUP|DOCTLABO|ETU/?$$user{src}{supelecUid}:undef)
+ || do {
+ $rapport{'valeur manquante pour le cardnumber'}{$cc}{$cn_attr}++;
+ return;
+ };
+
+ for my $v ( $$user{column}{cardnumber} ) {
+ $v && $cn ne $v
+ and $rapport{'divergence dans la detection du cardnumber'}{$v}{$cn}++;
+ $v = $cn;
+ }
+
+}
+
+sub set_branchcode (_) {
+ my $user = shift;
+ state $branchcode_for = {qw/
+ gif BGIF
+ Gif BGIF
+ metz BMTZ
+ Metz BMTZ
+ rennes BREN
+ Rennes BREN
+ /};
+
+ my $campus = $$user{src}{supelecCampusRattachement} or do {
+ push @{ $rapport{supelecCampusRattachement}{missing} }
+ , $$user{src}{dn};
+ return
+ };
+
+ $$user{column}{branchcode} = $$branchcode_for{$campus} or do {
+ $rapport{supelecCampusRattachement}{'with no branchcode'}{$campus}++;
+ return
+ };
+}
+
+sub set_xattrs (_) {
+ state $attr_for_ldap = {qw/
+ supelecDateEntree ENTRE
+ supelecDatePrevueSortie SORTIE
+ supelecPromo PROMO
+ supelecNiveauScolaire NIVSCOl
+ supelecVoie VOIE
+ supelecDepartement SUPDPT
+ supelecUid SUPUID
+ /};
+
+ my $user = shift;
+ while ( my ( $ldap , $attr ) = each %$attr_for_ldap ) {
+ if ( my $v = $$user{src}{$ldap} ) {
+ if ( $attr ~~ [qw/ ENTRE SORTIE /] ) {
+ $v =~ s/
+ (?<year> \d{4} )
+ (?<month> \d{2} )
+ (?<day> \d{2} )
+ .*
+ 000000Z
+ /$+{year}-$+{month}-$+{day}/x
+ or $rapport{"date pe foireuse"}{$v}++;
+ }
+ $$user{xattr}{$attr} = $v;
+ }
+ }
+
+}
+
+sub set_caution_and_debarring (_) {
+ my $user = shift;
+ my $debarring_date = '9999-12-31';
+
+ return unless (lc $$user{src}{supelecCampusRattachement} ne "gif");
+ if ( my $caution = $$user{src}{supelecBibCaution} ) {
+ 'N' eq ($$user{xattr}{CAUTION} = $caution)
+ and $$user{column}{debarred} = $debarring_date;
+ return
+ }
+
+ if ( $$user{src}{supelecTypePersonne} ~~ $$supelecTypePersonne{with_caution} ) {
+ for ( $$user{column} ) {
+ $$_{cardnumber} = $$user{src}{supelecUid};
+ $$_{debarred} = $debarring_date;
+ }
+ }
+}
+
+sub HashLdapEntry(_) {
+ my $e = shift;
+ $e->isa('Net::LDAP::Entry') or die;
+ { dn => $e->dn
+ , map {
+ my @v = $e->get_value( $_ );
+ $_ => @v > 1 ? \@v : shift @v;
+ } $e->attributes(qw/ nooptions 1 /)
+ };
+}
+
+sub get_borrower {
+ state $today = (map { chomp; $_ } `date +%F`)[0];
+ my $ldap_entry = shift;
+ my $user = { src => HashLdapEntry( $ldap_entry ) };
+
+ for
+ ( [qw/ givenName firstname /]
+ , [qw/ sn surname /]
+ , [qw/ uid userid /]
+ , [qw/ mail email /]
+ ) { my ( $from, $to ) = @$_;
+ $$user{column}{$to}
+ = $$user{src}{$from};
+ }
+
+ set_category_code( $user ) or return;
+ for ( $$user{column} ) {
+ $$_{dateexpiry} = GetExpiryDate
+ ( $$_{categorycode}
+ , $$_{dateenrolled} = $today
+ )
+ }
+
+ set_cardnumber( $user );
+ set_branchcode( $user )
+ or push @{ $rapport{'missing cardnumber'} }, $$user{src}{dn};
+ set_xattrs( $user );
+ #I Hate doing this... It relies on the knowledge of the data... and a previous process... But Should do what it is supposed to do
+ $$user{column}{dateenrolled}=$$user{'xattr'}{'ENTRE'} if ($$user{'xattr'}{'ENTRE'});
+ $$user{column}{dateexpiry}=$$user{'xattr'}{'SORTIE'} if ($$user{'xattr'}{'SORTIE'});
+ set_caution_and_debarring( $user );
+ my @missing_important_informations = grep { not defined $$user{column}{$_} } qw/
+ userid cardnumber firstname surname categorycode branchcode
+ /;
+
+ if ( @missing_important_informations ) {
+ # 0 and
+ say STDERR YAML::Dump(
+ { missing => \@missing_important_informations
+ # , src => $$user{src}
+ , column => $$user{column}
+ }
+ );
+ }
+
+ $user;
+}
+
+# unless (caller) {
+# my $ldif = Net::LDAP::LDIF->new( 'out.ldif', qw/ onerror die /);
+# while ( not $ldif->eof ) {
+# my $e = $ldif->read_entry
+# or die $ldif->error . ' at ' . $ldif->error_lines;
+# get_borrower( $e );
+# }
+# say Dump \%rapport;
+# }
+
+1;
+
diff --git a/syncho_ldap.pl b/syncho_ldap.pl
new file mode 100644
index 0000000..6208ad7
--- /dev/null
+++ b/syncho_ldap.pl
@@ -0,0 +1,41 @@
+#! /usr/bin/perl
+# vim: sw=4 ai
+use Modern::Perl;
+use Net::LDAP;
+use Net::LDAP::LDIF;
+use C4::Auth_with_ldap;
+use LDAPSupelec;
+my $ldap = C4::Auth_with_ldap->cnx;
+my $out = Net::LDAP::LDIF->new(qw/ out.ldif w onerror die /);
+
+my $config = C4::Context->config("ldapserver")
+ or die qq[No "ldapserver" in server from KOHA_CONF: $ENV{KOHA_CONF}];
+
+for my $site ( @{ $$config{branch} } ) {
+ my $m = $ldap->search
+ ( base => $$site{dn}
+ , filter => '(&(objectClass=supelecPerson)(uid=*))'
+ # , filter => '(&(objectClass=supelecPerson)(|(uid=valanou)(uid=oalassad)))'
+ #, filter => '(&(objectClass=supelecPerson)(uid=*)(!(|(supelecMembreDe=cn=ACCT-doublonCampus*)(supelecMembreDe=cn=ACCT-fantome*)(supelecMembreDe=cn=ACCT-dfantome*))))'
+ # , filter => 'uid=missoffe'
+# , filter => 'supelecMatriculeEleve=13262'
+ , attrs => \@LDAPSupelec::ATTRS
+ , callback => sub {
+ my ( $m, $e ) = @_;
+ $e or return;
+ $e->dump;
+ my $b = LDAPSupelec::get_borrower($e) or return;
+# say YAML::Dump(
+# { c => $$b{column}
+# , x => $$b{xattr}
+# }
+# );
+ C4::Auth_with_ldap::accept_borrower( $b );
+ $LDAPSupelec::rapport{ $$site{dn} }++;
+ $m->shift_entry;
+ }
+);
+ $m->code and die $m->error;
+}
+
+say YAML::Dump(\%LDAPSupelec::rapport);
diff --git a/t/auth_with_ldap_ng.t b/t/auth_with_ldap_ng.t
new file mode 100644
index 0000000..161239b
--- /dev/null
+++ b/t/auth_with_ldap_ng.t
@@ -0,0 +1,11 @@
+#! /usr/bin/perl
+use Modern::Perl;
+# use Test::More 'no_plan';
+# use Devel::SimpleTrace;
+use C4::Auth_with_ldap;
+
+my $dbh = C4::Context->dbh;
+C4::Auth_with_ldap::checkpw_ldap($dbh, qw/ toto tata /);
+C4::Auth_with_ldap::checkpw_ldap($dbh, qw/ lefaucheur_lau Koha01Supelec2011 /);
+
+# filter="(&(objectClass=supelecPerson)(uid=%s))"
--
1.7.1
More information about the Koha-patches
mailing list