1# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
2#
3# Copyright (C) 2006-2008 Michael Daum http://michaeldaumconsulting.com
4# Portions Copyright (C) 2006 Spanlink Communications
5#
6# This program is free software; you can redistribute it and/or
7# modify it under the terms of the GNU General Public License
8# as published by the Free Software Foundation; either version 2
9# of the License, or (at your option) any later version. For
10# more details read LICENSE in the root of this distribution.
11#
12# This program is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15#
16# As per the GPL, removal of this notice is prohibited.
17
18package TWiki::Contrib::LdapContrib;
19
20use strict;
21use Net::LDAP;
22use Net::LDAP::Constant qw(LDAP_SUCCESS LDAP_SIZELIMIT_EXCEEDED LDAP_CONTROL_PAGED);
23use Digest::MD5 qw(md5_hex);
24use Unicode::MapUTF8 qw(from_utf8 to_utf8);
25use DB_File;
26use Net::LDAP::Control::Paged;
27use TWiki::Func;
28
29use vars qw($VERSION $RELEASE %sharedLdapContrib);
30
31$VERSION = '$Rev$';
32$RELEASE = 'v2.99.5';
33
34=begin text
35
36---+++ TWiki::Contrib::LdapContrib
37
38General LDAP services for TWiki. This class encapsulates the TWiki-specific
39means to integrate an LDAP directory service.  Used by TWiki::Users::LdapUser
40for authentication, TWiki::Users::LdapUserMapping for group definitions and
41TWiki::Plugins::LdapNgPlugin to interface general query services.
42
43Typical usage:
44<verbatim>
45my $ldap = new TWiki::Contrib::LdapContrib;
46
47my $result = $ldap->search(filter=>'mail=*@gmx*');
48my $errorMsg = $ldap->getError();
49
50my $count = $result->count();
51
52my @entries = $result->sorted('sn');
53my $entry = $result->entry(0);
54
55my $value = $entry->get_value('cn');
56my @emails = $entry->get_value('mail');
57</verbatim>
58
59=cut
60
61=begin text
62
63---+++ writeDebug($msg, $level)
64
65Method to write a debug messages. The $msg is only
66written if the given current debug level is high enough
67($level <= $TWiki::cfg{Ldap}{Debug}). The higher the
68debug level, the more verbose the debug output.
69
70Debug output is written to STDERR.
71
72=cut
73
74sub writeDebug {
75  my ($this, $msg, $level) = @_;
76
77  $level ||= 1;
78
79  print STDERR $msg."\n" if $level <= $this->{debug};
80}
81
82
83=begin text
84
85---+++ writeWarning($msg, $level)
86
87Method to write a warning messages. Works also
88if TWiki::Plugins::SESSION isn't initialized yet.
89
90=cut
91
92sub writeWarning {
93  my ($this, $msg) = @_;
94
95  my $session = $TWiki::Plugins::SESSION || $this->{session};
96  if ($session) {
97    $session->writeWarning("LdapContrib - $msg");
98  } else {
99    print STDERR "LdapContrib - $msg\n";
100  }
101}
102
103
104=begin text
105
106---++++ new($session, host=>'...', base=>'...', ...) -> $ldap
107
108Construct a new TWiki::Contrib::LdapContrib object
109
110Possible options are:
111   * host: ip address (or hostname)
112   * base: the base DN to use in searches
113   * port: port address used when binding to the LDAP server
114   * version: protocol version
115   * userBase: sub-tree DN of user accounts
116   * groupBase: sub-tree DN of group definitions
117   * loginAttribute: user login name attribute
118   * loginFilter: filter to be used to find login accounts
119   * groupAttribute: the group name attribute
120   * groupFilter: filter to be used to find groups
121   * memberAttribute: the attribute that should be used to collect group members
122   * bindDN: the dn to use when binding to the LDAP server
123   * bindPassword: the password used when binding to the LDAP server
124
125Options not passed to the constructor are taken from the global settings
126in =lib/LocalSite.cfg=.
127
128=cut
129
130sub new {
131  my $class = shift;
132  my $session = shift;
133
134  my $this = {
135    ldap=>undef,# connect later
136    error=>undef,
137    debug=>$TWiki::cfg{Ldap}{Debug} || 0,
138    host=>$TWiki::cfg{Ldap}{Host} || 'localhost',
139    base=>$TWiki::cfg{Ldap}{Base} || '',
140    port=>$TWiki::cfg{Ldap}{Port} || 389,
141    version=>$TWiki::cfg{Ldap}{Version} || 3,
142
143    userBase=>$TWiki::cfg{Ldap}{UserBase}
144      || $TWiki::cfg{Ldap}{BasePasswd} # DEPRECATED
145      || $TWiki::cfg{Ldap}{Base}
146      || '',
147
148    groupBase=>$TWiki::cfg{Ldap}{GroupBase}
149      || $TWiki::cfg{Ldap}{BaseGroup} # DEPRECATED
150      || $TWiki::cfg{Ldap}{Base}
151      || '',
152
153    loginAttribute=>$TWiki::cfg{Ldap}{LoginAttribute} || 'uid',
154    allowChangePassword=>$TWiki::cfg{Ldap}{AllowChangePassword} || 0,
155
156    wikiNameAttribute=>$TWiki::cfg{Ldap}{WikiNameAttributes}
157      || $TWiki::cfg{Ldap}{WikiNameAttribute} || 'cn',
158
159    wikiNameAliases=>$TWiki::cfg{Ldap}{WikiNameAliases} || '',
160
161    normalizeWikiName=>$TWiki::cfg{Ldap}{NormalizeWikiNames},
162    normalizeLoginName=>$TWiki::cfg{Ldap}{NormalizeLoginNames},
163    normalizeGroupName=>$TWiki::cfg{Ldap}{NormalizeGroupNames},
164
165    loginFilter=>$TWiki::cfg{Ldap}{LoginFilter} || 'objectClass=posixAccount',
166    groupAttribute=>$TWiki::cfg{Ldap}{GroupAttribute} || 'cn',
167    groupFilter=>$TWiki::cfg{Ldap}{GroupFilter} || 'objectClass=posixGroup',
168    memberAttribute=>$TWiki::cfg{Ldap}{MemberAttribute} || 'memberUid',
169    memberIndirection=>$TWiki::cfg{Ldap}{MemberIndirection} || 0,
170    twikiGroupsBackoff=>$TWiki::cfg{Ldap}{TWikiGroupsBackoff} || 0,
171    bindDN=>$TWiki::cfg{Ldap}{BindDN} || '',
172    bindPassword=>$TWiki::cfg{Ldap}{BindPassword} || '',
173    mapGroups=>$TWiki::cfg{Ldap}{MapGroups} || 0,
174
175    mailAttribute=>$TWiki::cfg{Ldap}{MailAttribute} || 'mail',
176
177    exclude=>$TWiki::cfg{Ldap}{Exclude} ||
178      'TWikiGuest, TWikiContributor, TWikiRegistrationAgent, TWikiAdminGroup, NobodyGroup',
179
180    pageSize=>$TWiki::cfg{Ldap}{PageSize} || 200,
181    isConnected=>0,
182    maxCacheAge=>$TWiki::cfg{Ldap}{MaxCacheAge} || 86400,
183
184    useSASL=>$TWiki::cfg{Ldap}{UseSASL} || 0,
185    saslMechanism=>$TWiki::cfg{Ldap}{SASLMechanism} || 'PLAIN CRAM-MD4 EXTERNAL ANONYMOUS',
186
187    secondaryPasswordManager=>$TWiki::cfg{Ldap}{SecondaryPasswordManager} || '',
188    @_
189  };
190  bless($this, $class);
191
192  $this->{session} = $session;
193
194  if ($this->{useSASL}) {
195    #$this->writeDebug("will use SASL authentication");
196    require Authen::SASL;
197  }
198
199  # protect against actidental misconfiguration, that might lead
200  # to an infinite loop during authorization etc.
201  if ($this->{secondaryPasswordManager} eq 'TWiki::Users::LdapUser') {
202    $this->writeWarning("hey, you want infinite loops? naw.");
203    $this->{secondaryPasswordManager} = '';
204  }
205
206  if ($this->{secondaryPasswordManager} eq 'none') {
207    $this->{secondaryPasswordManager} = '';
208  }
209
210  my $workArea = $session->{store}->getWorkArea('LdapContrib');
211  mkdir $workArea unless -d $workArea;
212  $this->{cacheFile} = $workArea.'/cache.db';
213
214  # normalize normalization flags
215  $this->{normalizeWikiName} = $TWiki::cfg{Ldap}{NormalizeWikiName}
216    unless defined $this->{normalizeWikiName};
217  $this->{normalizeLoginName} = $TWiki::cfg{Ldap}{NormalizeLoginName}
218    unless defined $this->{normalizeLoginName};
219  $this->{normalizeGroupName} = $TWiki::cfg{Ldap}{NormalizeGroupName}
220    unless defined $this->{normalizeGroupName};
221  $this->{normalizeWikiName} = 1 unless defined $this->{normalizeWikiName};
222
223  @{$this->{wikiNameAttributes}} = split(/,\s*/, $this->{wikiNameAttribute});
224
225  # create exclude map
226  my %excludeMap = map {$_ => 1} split(/,\s*/, $this->{exclude});
227  $this->{excludeMap} = \%excludeMap;
228
229  # creating alias map
230  my %aliasMap = ();
231  foreach my $alias (split(/,\s*/, $this->{wikiNameAliases})) {
232    if ($alias =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/) {
233      $aliasMap{$1} = $2;
234    }
235  }
236  $this->{wikiNameAliases} = \%aliasMap;
237
238  # default value for cache expiration is every 24h
239  $this->{maxCacheAge} = 86400 unless defined $this->{maxCacheAge};
240
241  $this->writeDebug("constructed a new LdapContrib object");
242
243  return $this;
244}
245
246=begin text
247
248---++++ getLdapContrib($session) -> $ldap
249
250Returns a standard singleton TWiki::Contrib::LdapContrib object based on the site-wide
251configuration.
252
253=cut
254
255sub getLdapContrib {
256  my $session = shift;
257
258  my $obj = $sharedLdapContrib{$session};
259  return $obj if $obj;
260
261  $obj = new TWiki::Contrib::LdapContrib($session);
262  $obj->initCache();
263  $sharedLdapContrib{$session} = $obj;
264
265  return $obj;
266}
267
268=begin text
269
270---++++ connect($login, $passwd) -> $boolean
271
272Connect to LDAP server. If a $login name and a $passwd is given then a bind is done.
273Otherwise the communication is anonymous. You don't have to connect() explicitely
274by calling this method. The methods below will do that automatically when needed.
275
276=cut
277
278sub connect {
279  my ($this, $dn, $passwd) = @_;
280
281  $this->writeDebug("called connect");
282  #$this->writeDebug("dn=$dn", 2) if $dn;
283  #$this->writeDebug("passwd=***", 2) if $passwd;
284
285  $this->{ldap} = Net::LDAP->new($this->{host},
286    port=>$this->{port},
287    version=>$this->{version},
288  );
289  unless ($this->{ldap}) {
290    $this->{error} = "failed to connect to $this->{host}";
291    $this->{error} .= ": $@" if $@;
292    return 0;
293  }
294
295  # authenticated bind
296  my $msg;
297  if (defined($dn)) {
298    die "illegal call to connect()" unless defined($passwd);
299    $msg = $this->{ldap}->bind($dn, password=>$passwd);
300    $this->writeDebug("bind for $dn");
301  }
302
303  # proxy user
304  elsif ($this->{bindDN} && $this->{bindPassword}) {
305
306    if ($this->{useSASL}) {
307      # sasl bind
308      my $sasl = Authen::SASL->new(
309	mechanism => $this->{saslMechanism}, #'DIGEST-MD5 PLAIN CRAM-MD5 EXTERNAL ANONYMOUS',
310	callback => {
311	  user => $this->{bindDN},
312	  pass => $this->{bindPassword},
313	},
314      );
315      $this->writeDebug("sasl bind to $this->{bindDN}");
316      $msg = $this->{ldap}->bind($this->{bindDN}, sasl=>$sasl, version=>$this->{version} );
317    } else {
318      # simple bind
319      $this->writeDebug("proxy bind");
320      $msg = $this->{ldap}->bind($this->{bindDN},password=>$this->{bindPassword});
321    }
322  }
323
324  # anonymous bind
325  else {
326    #$this->writeDebug("anonymous bind");
327    $msg = $this->{ldap}->bind;
328  }
329
330  $this->{isConnected} = ($this->checkError($msg) == LDAP_SUCCESS)?1:0;
331  $this->writeDebug("failed to bind") unless $this->{isConnected};
332  return $this->{isConnected};
333}
334
335=begin text
336
337---++++ disconnect()
338
339Unbind the LDAP object from the server. This method can be used to force
340a reconnect and possibly rebind as a different user.
341
342=cut
343
344sub disconnect {
345  my $this = shift;
346
347  return unless defined($this->{ldap}) && $this->{isConnected};
348
349  $this->writeDebug("called disconnect()");
350  $this->{ldap}->unbind();
351  $this->{ldap} = undef;
352  $this->{isConnected} = 0;
353}
354
355=begin text
356
357---++++ finish
358
359finalize this ldap object.
360
361=cut
362
363sub finish {
364  my $this = shift;
365
366  return if $this->{isFinished};
367  $this->{isFinished} = 1;
368
369  $this->writeDebug("finishing");
370  $this->disconnect();
371  delete $sharedLdapContrib{$this->{session}};
372  undef $this->{cacheDB};
373  untie %{$this->{data}};
374}
375
376
377=begin text
378
379---++++ checkError($msg) -> $errorCode
380
381Private method to check a Net::LDAP::Message object for an error, sets
382$ldap->{error} and returns the ldap error code. This method is called
383internally whenever a message object is returned by the server. Use
384$ldap->getError() to return the actual error message.
385
386=cut
387
388sub checkError {
389  my ($this, $msg) = @_;
390
391  my $code = $msg->code();
392  if ($code == LDAP_SUCCESS) {
393    $this->{error} = undef;
394  } else {
395    $this->{error} = $code.': '.$msg->error();
396    $this->writeDebug($this->{error});
397  }
398
399  return $code;
400}
401
402=begin text
403
404---++++ getError() -> $errorMsg
405
406Returns the error message of the last LDAP action or undef it no
407error occured.
408
409=cut
410
411sub getError {
412  my $this = shift;
413  return $this->{error};
414}
415
416
417=begin text
418
419---++++ getAccount($login) -> Net::LDAP::Entry object
420
421Fetches an account entry from the database and returns a Net::LDAP::Entry
422object on success and undef otherwise. Note, the login name is match against
423the attribute defined in $ldap->{loginAttribute}. Account records are
424search using $ldap->{loginFilter} in the subtree defined by $ldap->{userBase}.
425
426=cut
427
428sub getAccount {
429  my ($this, $login) = @_;
430
431  $login = lc($login);
432  $this->writeDebug("called getAccount($login)");
433  return undef if $this->{excludeMap}{$login};
434
435  my $filter = '(&('.$this->{loginFilter}.')('.$this->{loginAttribute}.'='.$login.'))';
436  my $msg = $this->search(
437    filter=>$filter,
438    base=>$this->{userBase}
439  );
440  unless ($msg) {
441    #$this->writeDebug("no such account");
442    return undef;
443  }
444  if ($msg->count() != 1) {
445    $this->{error} = 'Login invalid';
446    #$this->writeDebug($this->{error});
447    return undef;
448  }
449
450  return $msg->entry(0);
451}
452
453
454=begin text
455
456---++++ search($filter, %args) -> $msg
457
458Returns an Net::LDAP::Search object for the given query on success and undef
459otherwise. If $args{base} is not defined $ldap->{base} is used.  If $args{scope} is not
460defined 'sub' is used (searching down the subtree under $args{base}. If no $args{limit} is
461set all matching records are returned.  The $attrs is a reference to an array
462of all those attributes that matching entries should contain.  If no $args{attrs} is
463defined all attributes are returned.
464
465If undef is returned as an error occured use $ldap->getError() to get the
466cleartext message of this search() operation.
467
468Typical usage:
469<verbatim>
470my $result = $ldap->search(filter=>'uid=TestUser');
471</verbatim>
472
473=cut
474
475sub search {
476  my ($this, %args) = @_;
477
478  $args{base} = $this->{base} unless $args{base};
479  $args{scope} = 'sub' unless $args{scope};
480  $args{limit} = 0 unless $args{limit};
481  $args{attrs} = ['*'] unless $args{attrs};
482
483  $args{filter} = to_utf8(-string=> $args{filter}, -charset=>$TWiki::cfg{Site}{CharSet})
484    if $args{filter} && $TWiki::cfg{Site}{CharSet} !~ /^utf-?8$/i;
485
486  if ($this->{debug}) {
487    my $attrString = join(',', @{$args{attrs}});
488    $this->writeDebug("called search(filter=$args{filter}, base=$args{base}, scope=$args{scope}, limit=$args{limit}, attrs=$attrString)");
489  }
490
491  unless ($this->{ldap}) {
492    unless ($this->connect()) {
493      $this->writeDebug("error in search: ".$this->getError());
494      return undef;
495    }
496  }
497
498  my $msg = $this->{ldap}->search(%args);
499  my $errorCode = $this->checkError($msg);
500
501  # we set a limit so it is ok that it exceeds
502  if ($args{limit} && $errorCode == LDAP_SIZELIMIT_EXCEEDED) {
503    $this->writeDebug("limit exceeded");
504    return $msg;
505  }
506
507  if ($errorCode != LDAP_SUCCESS) {
508    #$this->writeDebug("error in search: ".$this->getError());
509    return undef;
510  }
511  $this->writeDebug("found ".$msg->count." entries");
512
513  return $msg;
514}
515
516=begin text
517
518---++++ cacheBlob($entry, $attribute, $refresh) -> $pubUrlPath
519
520Takes an Net::LDAP::Entry and an $attribute name, and stores its value into a
521file. Returns the pubUrlPath to it. This can be used to store binary large
522objects like images (jpegPhotos) into the filesystem accessible to the httpd
523which can serve it in return to the client browser.
524
525Filenames containing the blobs are named using a hash value that is generated
526using its DN and the actual attribute name whose value is extracted from the
527database. If the blob already exists in the cache it is _not_ extracted once
528again except the $refresh parameter is defined.
529
530Typical usage:
531<verbatim>
532my $blobUrlPath = $ldap->cacheBlob($entry, $attr);
533</verbatim>
534
535=cut
536
537sub cacheBlob {
538  my ($this, $entry, $attr, $refresh) = @_;
539
540  #$this->writeDebug("called cacheBlob()");
541
542  my $twikiWeb = &TWiki::Func::getTwikiWebname();
543  my $dir = &TWiki::Func::getPubDir().'/'.$twikiWeb.'/LdapContrib';
544  my $key = md5_hex($entry->dn().$attr);
545  my $fileName = $dir.'/'.$key;
546
547  if ($refresh || !-f $fileName) {
548    #$this->writeDebug("caching blob");
549    my $value = $entry->get_value($attr);
550    return undef unless defined $value;
551    mkdir($dir, 0775) unless -e $dir;
552
553    open (FILE, ">$fileName");
554    binmode(FILE);
555    print FILE $value;
556    close (FILE);
557  } else {
558    #$this->writeDebug("already got blob");
559  }
560
561  #$this->writeDebug("done cacheBlob()");
562  return &TWiki::Func::getPubUrlPath().'/'.$twikiWeb.'/LdapContrib/'.$key;
563}
564
565=begin text
566
567---++++ initCache()
568
569loads/connects to the LDAP cache
570
571=cut
572
573sub initCache {
574  my $this = shift;
575
576  return unless $TWiki::cfg{UserMappingManager} =~ /LdapUserMapping/ ||
577                $TWiki::cfg{PasswordManager} =~ /LdapUser/;
578
579  $this->writeDebug("called initCache");
580
581  # open database
582  #$this->writeDebug("opening ldap cache from $this->{cacheFile}");
583  $this->{cacheDB} =
584    tie %{$this->{data}}, 'DB_File', $this->{cacheFile}, O_CREAT|O_RDWR, 0664, $DB_HASH
585    or die "Cannot open file $this->{cacheFile}: $!";
586
587  # refresh by user interaction
588  my $refresh = '';
589  my $session = $this->{session}->{cgiQuery};
590  $refresh = $session->param('refreshldap') || '' if $session;
591  $refresh = $refresh eq 'on'?1:0;
592  $this->writeDebug("refreshing cache explicitly") if $refresh;
593
594  if ($this->{maxCacheAge} > 0) { # is cache expiration enabled
595
596    # compute age of data
597    my $cacheAge = 9999999999;
598    my $now = time();
599    my $lastUpdate = $this->{data}{lastUpdate} || 0;
600    $cacheAge = $now - $lastUpdate if $lastUpdate;
601
602    # don't refresh within 60 seconds
603    if ($cacheAge < 10) {
604      $refresh = 0;
605      $this->writeDebug("suppressing cache refresh within 10 seconds");
606    } else {
607      $refresh = 1 if $cacheAge > $this->{maxCacheAge}
608    }
609
610    $this->writeDebug("cacheAge=$cacheAge, maxCacheAge=$this->{maxCacheAge}, lastUpdate=$lastUpdate, refresh=$refresh");
611  }
612
613  # clear to reload it
614  if ($refresh) {
615    $this->writeDebug("updating cache");
616    $this->refreshCache();
617  }
618}
619
620=pod
621
622---++++ refreshCache() -> $boolean
623
624download all relevant records from the LDAP server and
625store it into a database
626
627=cut
628
629sub refreshCache {
630  my ($this) = @_;
631
632  $this->writeDebug("called refreshCache");
633
634  # create a temporary tie
635  my $tempCacheFile = $this->{cacheFile}.'_tmp';
636  my %tempData;
637  my $tempCache =
638    tie %tempData, 'DB_File', $tempCacheFile, O_CREAT|O_RDWR, 0664, $DB_HASH
639    or die "Cannot open file $tempCacheFile: $!";
640
641  my $isOk = $this->refreshUsersCache(\%tempData);
642  if ($isOk && $this->{mapGroups}) {
643    $isOk = $this->refreshGroupsCache(\%tempData);
644  }
645
646  if (!$isOk) { # we had an error: keep the old cache til the error is resolved
647    undef $tempCache;
648    untie %tempData;
649    unlink $tempCacheFile;
650    return 0;
651  }
652
653  $this->writeDebug("flushing db to disk");
654  $tempData{lastUpdate} = time();
655  $tempCache->sync();
656  undef $tempCache;
657  untie %tempData;
658
659  # try to be transactional
660  undef $this->{cacheDB};
661  untie %{$this->{data}};
662
663  $this->writeDebug("replacing working copy");
664  rename $tempCacheFile,$this->{cacheFile};
665
666  # reconnect hash
667  $this->{cacheDB} =
668    tie %{$this->{data}}, 'DB_File', $this->{cacheFile}, O_CREAT|O_RDWR, 0664, $DB_HASH
669    or die "Cannot open file $this->{cacheFile}: $!";
670
671  return 1;
672}
673
674=pod
675
676---++++ refreshUsersCache($data) -> $boolean
677
678download all user records from the LDAP server and cache it into the
679given hash reference
680
681returns true if new records have been loaded
682
683=cut
684
685sub refreshUsersCache {
686  my ($this, $data) = @_;
687
688  $this->writeDebug("called refreshUsersCache()");
689  $data ||= $this->{data};
690
691  # prepare search
692  my $page = Net::LDAP::Control::Paged->new(size=>$this->{pageSize});
693  my $cookie;
694  my @args = (
695    filter=>$this->{loginFilter},
696    base=>$this->{userBase},
697    attrs=>[$this->{loginAttribute},
698            $this->{mailAttribute},
699            @{$this->{wikiNameAttributes}}
700          ],
701    control=>[$page],
702  );
703
704  # read pages
705  my $nrRecords = 0;
706  my %wikiNames = ();
707  my %loginNames = ();
708  my $gotError = 0;
709  while (1) {
710
711    # perform search
712    my $mesg = $this->search(@args);
713    unless ($mesg) {
714      #$this->writeDebug("oops, no result");
715      $this->writeWarning("error refeshing the user cashe: ".
716        $this->getError());
717      $gotError = 1;
718      last;
719    }
720
721    # process each entry on a page
722    while (my $entry = $mesg->pop_entry()) {
723      $this->cacheUserFromEntry($entry, $data, \%wikiNames, \%loginNames) && $nrRecords++;
724    }
725
726    # get cookie from paged control to remember the offset
727    my ($resp) = $mesg->control(LDAP_CONTROL_PAGED) or last;
728    $cookie = $resp->cookie or last;
729    if ($cookie) {
730      # set cookie in paged control
731      $page->cookie($cookie);
732    } else {
733      # found all
734      $this->writeDebug("ok, no more cookie");
735      last;
736    }
737  } # end reading pages
738  $this->writeDebug("done reading pages");
739
740  # clean up
741  if ($cookie) {
742    $page->cookie($cookie);
743    $page->size(0);
744    $this->search(@args);
745  }
746
747  # check for error
748  return 0 if $gotError;
749
750  # remember list of all user names
751  $data->{WIKINAMES} = join(',', keys %wikiNames);
752  $data->{LOGINNAMES} = join(',', keys %loginNames);
753
754  $this->writeDebug("got $nrRecords keys in cache");
755
756  return 1;
757}
758
759=pod
760
761---++++ refreshGroups($data) -> $boolean
762
763download all group records from the LDAP server
764
765returns true if new records have been loaded
766
767=cut
768
769sub refreshGroupsCache {
770  my ($this, $data) = @_;
771
772  $data ||= $this->{data};
773
774  # prepare search
775  my $page = Net::LDAP::Control::Paged->new(size=>$this->{pageSize});
776  my $cookie;
777  my @args = (
778    filter=>$this->{groupFilter},
779    base=>$this->{groupBase},
780    attrs=>[$this->{groupAttribute}, $this->{memberAttribute}],
781    control=>[$page],
782  );
783
784  # read pages
785  my $nrRecords = 0;
786  my %groupNames;
787  my $gotError = 0;
788  while (1) {
789
790    # perform search
791    my $mesg = $this->search(@args);
792    unless ($mesg) {
793      #$this->writeDebug("oops, no result");
794      $this->writeWarning("error refeshing the groups cashe: ".
795        $this->getError());
796      last;
797    }
798
799    # process each entry on a page
800    while (my $entry = $mesg->pop_entry()) {
801      $this->cacheGroupFromEntry($entry, $data, \%groupNames) && $nrRecords++;
802    }
803    # get cookie from paged control to remember the offset
804    my ($resp) = $mesg->control(LDAP_CONTROL_PAGED) or last;
805    $cookie = $resp->cookie or last;
806    if ($cookie) {
807      # set cookie in paged control
808      $page->cookie($cookie);
809    } else {
810      # found all
811      #$this->writeDebug("ok, no more cookie");
812      last;
813    }
814  } # end reading pages
815
816  # clean up
817  if ($cookie) {
818    $page->cookie($cookie);
819    $page->size(0);
820    $this->search(@args);
821  }
822
823  # check for error
824  return 0 if $gotError;
825
826  # remember list of all groups
827  $data->{GROUPS} = join(',', keys %groupNames);
828
829  #$this->writeDebug("got $nrRecords keys in cache");
830
831  return 1;
832}
833
834=pod
835
836---++++ cacheUserFromEntry($entry, $data, $wikiNames, $loginNames) -> $boolean
837
838store a user LDAP::Entry to our internal cache
839
840returns true if new records have been created
841
842=cut
843
844sub cacheUserFromEntry {
845  my ($this, $entry, $data, $wikiNames, $loginNames) = @_;
846
847  #$this->writeDebug("called cacheUserFromEntry()");
848
849  $data ||= $this->{data};
850  $wikiNames ||= {};
851  $loginNames ||= {};
852
853  my $dn = $entry->dn();
854  my $loginName = $entry->get_value($this->{loginAttribute});
855  unless ($loginName) {
856    $this->writeDebug("no loginName for $dn ... skipping");
857    return 0;
858  }
859
860  $loginName = lc($loginName);
861  $loginName = from_utf8(-string=>$loginName, -charset=>$TWiki::cfg{Site}{CharSet})
862    unless $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i;
863
864  if ($this->{normalizeLoginName}) {
865    $loginName = $this->normalizeLoginName($loginName);
866  }
867
868  # construct the wikiName
869  my $wikiName;
870  foreach my $attr (@{$this->{wikiNameAttributes}}) {
871    my $value = $entry->get_value($attr);
872    next unless $value;
873
874    $value = from_utf8(-string=>$value, -charset=>$TWiki::cfg{Site}{CharSet})
875      unless $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i;
876
877    #$this->writeDebug("$attr=$value");
878
879    if ($this->{normalizeWikiName}) {
880      $wikiName .= $this->normalizeWikiName($value);
881    } else {
882      $wikiName .= $value;
883    }
884  }
885  $wikiName ||= $loginName;
886  if (defined($wikiNames->{$wikiName})) {
887    $this->writeWarning("$dn clashes with wikiName $wikiNames->{$wikiName} on $wikiName");
888    return 0;
889  }
890  $wikiNames->{$wikiName} = $dn;
891  if (defined($loginNames->{$loginName})) {
892    $this->writeWarning("$dn clashes with loginName $loginNames->{$loginName} on $loginName");
893    return 0;
894  }
895  $loginNames->{$loginName} = $dn;
896
897  # get email addrs
898  my $emails;
899  @{$emails} = $entry->get_value($this->{mailAttribute});
900
901  # store it
902  $this->writeDebug("adding wikiName='$wikiName', loginName='$loginName', dn=$dn");
903  $data->{"U2W::$loginName"} = $wikiName;
904  $data->{"W2U::$wikiName"} = $loginName;
905  $data->{"DN2U::$dn"} = $loginName;
906  $data->{"U2DN::$loginName"} = $dn;
907  $data->{"U2EMAILS::$loginName"} = join(',',@$emails);
908
909  return 1;
910}
911
912=pod
913
914---++++ cacheGroupFromEntry($entry, $data, $groupNames) -> $boolean
915
916store a group LDAP::Entry to our internal cache
917
918returns true if new records have been created
919
920=cut
921
922sub cacheGroupFromEntry {
923  my ($this, $entry, $data, $groupNames) = @_;
924
925  $data ||= $this->{data};
926  $groupNames ||= {};
927
928  my $dn = $entry->dn();
929
930  my $groupName = $entry->get_value($this->{groupAttribute});
931  unless ($groupName) {
932    $this->writeDebug("no groupName for $dn ... skipping");
933    return 0;
934  }
935
936  $groupName = from_utf8(-string=>$groupName, -charset=>$TWiki::cfg{Site}{CharSet})
937    unless $TWiki::cfg{Site}{CharSet} =~ /^utf-?8$/i;
938
939  if ($this->{normalizeGroupName}) {
940    $groupName = $this->normalizeWikiName($groupName);
941  }
942
943  if (defined($groupNames->{$groupName})) {
944    $this->writeWarning("$dn clashes with group $groupNames->{$groupName} on $groupName");
945    return 0;
946  }
947
948  if (defined($data->{"U2W::$groupName"}) || defined($data->{"W2U::$groupName"})) {
949    my $groupSuffix = '';
950    if ($this->{normalizeGroupName}) {
951      $groupSuffix = 'Group';
952    } else {
953      $groupSuffix = '_group';
954    }
955    $this->writeWarning("group $dn clashes with user $groupName ... appending $groupSuffix");
956    $groupName .= $groupSuffix;
957  }
958
959  # fetch all members of this group
960  my %members = ();
961  foreach my $member ($entry->get_value($this->{memberAttribute})) {
962
963    # groups may store DNs to members instead of a memberUid, in this case we
964    # have to lookup the corresponding loginAttribute
965    if ($this->{memberIndirection}) {
966      #$this->writeDebug("following indirection for $member");
967      my $userName = $data->{"DN2U::$member"};
968      if ($userName) {
969	$members{$userName} = 1;
970      } else {
971        $this->writeDebug("oops, $member not found, but member of $groupName");
972      }
973    } else {
974      $members{$member} = 1;
975    }
976  }
977
978  # store it
979  $this->writeDebug("adding groupName='$groupName', dn=$dn");
980  $data->{"GROUPS::$groupName"} = join(',', keys %members);
981  $groupNames->{$groupName} = 1;
982
983  return 1;
984}
985
986=pod
987
988---++++ normalizeWikiName($name) -> $string
989
990normalizes a string to form a proper <nop>WikiName
991
992=cut
993
994sub normalizeWikiName {
995  my ($this, $name) = @_;
996
997  # remove a trailing mail domain
998  $name =~ s/@.*//o;
999
1000  # remove @mydomain.com part for special mail attrs
1001  # SMELL: you may have a different attribute name for the email address
1002
1003  # replace umlaute
1004  $name =~ s/�/ae/go;
1005  $name =~ s/�/oe/go;
1006  $name =~ s/�/ue/go;
1007  $name =~ s/�/Ae/go;
1008  $name =~ s/�/Oe/go;
1009  $name =~ s/�/Ue/go;
1010  $name =~ s/�/ss/go;
1011
1012  my $wikiName = '';
1013  foreach my $part (split(/[^$TWiki::regex{mixedAlphaNum}]/, $name)) {
1014    $wikiName .= ucfirst($part);
1015  }
1016
1017  return $wikiName;
1018}
1019
1020=pod
1021
1022---++++ normalizeLoginName($name) -> $string
1023
1024normalizes a string to form a proper login
1025
1026=cut
1027
1028sub normalizeLoginName {
1029  my ($this, $name) = @_;
1030
1031  # remove a trailing mail domain
1032  $name =~ s/@.*//o;
1033
1034  # remove @mydomain.com part for special mail attrs
1035  # SMELL: you may have a different attribute name for the email address
1036
1037  # replace umlaute
1038  $name =~ s/�/ae/go;
1039  $name =~ s/�/oe/go;
1040  $name =~ s/�/ue/go;
1041  $name =~ s/�/Ae/go;
1042  $name =~ s/�/Oe/go;
1043  $name =~ s/�/Ue/go;
1044  $name =~ s/�/ss/go;
1045  $name =~ s/[^$TWiki::cfg{LoginNameFilterIn}]//;
1046
1047  return $name;
1048}
1049
1050
1051=begin text
1052
1053---++++ getGroupNames() -> @array
1054
1055Returns a list of known group names.
1056
1057=cut
1058
1059sub getGroupNames {
1060  my $this = shift;
1061
1062  #$this->writeDebug("called getGroupNames()");
1063
1064  my $groupNames = TWiki::Sandbox::untaintUnchecked($this->{data}{GROUPS}) || '';
1065  my @groupNames = split(/,/,$groupNames);
1066
1067  return \@groupNames;
1068}
1069
1070=begin text
1071
1072---++++ isGroup($wikiName) -> $boolean
1073
1074check if a given user is an ldap group actually
1075
1076=cut
1077
1078sub isGroup {
1079  my ($this, $wikiName) = @_;
1080
1081  #$this->writeDebug("called isGroup($wikiName)");
1082  return undef if $this->{excludeMap}{$wikiName};
1083  return 1 if defined($this->{data}{"GROUPS::$wikiName"});
1084  return undef;
1085}
1086
1087=begin text
1088
1089---++++ getEmails($login) -> @emails
1090
1091fetch emails from LDAP
1092
1093=cut
1094
1095sub getEmails {
1096  my ($this, $login) = @_;
1097
1098  my $emails = TWiki::Sandbox::untaintUnchecked($this->{data}{"U2EMAILS::".lc($login)}) || '';
1099  my @emails = split(/,/,$emails);
1100  return \@emails;
1101}
1102
1103=begin text
1104
1105---++++ getGroupMembers($groupName) -> \@array
1106
1107=cut
1108
1109sub getGroupMembers {
1110  my ($this, $groupName) = @_;
1111  return undef if $this->{excludeMap}{$groupName};
1112
1113  my $members = TWiki::Sandbox::untaintUnchecked($this->{data}{"GROUPS::$groupName"}) || '';
1114  my @members = split(/,/, $members);
1115
1116  return \@members;
1117}
1118
1119=pod
1120
1121---++++ getWikiNameOfLogin($loginName) -> $wikiName
1122
1123returns the wikiName of a loginName or undef if it does not exist
1124
1125=cut
1126
1127sub getWikiNameOfLogin {
1128  my ($this, $loginName) = @_;
1129  $loginName = lc($loginName);
1130  return TWiki::Sandbox::untaintUnchecked($this->{data}{"U2W::$loginName"});
1131}
1132
1133=pod
1134
1135---++++ getLoginOfWikiName($wikiName) -> $loginName
1136
1137returns the loginNAme of a wikiName or undef if it does not exist
1138
1139=cut
1140
1141sub getLoginOfWikiName {
1142  my ($this, $wikiName) = @_;
1143
1144  my $loginName = TWiki::Sandbox::untaintUnchecked($this->{data}{"W2U::$wikiName"});
1145
1146  unless ($loginName) {
1147    my $alias = $this->{wikiNameAliases}{$wikiName};
1148    $loginName = TWiki::Sandbox::untaintUnchecked($this->{data}{"W2U::$alias"})
1149      if defined($alias);
1150  }
1151
1152  return $loginName;
1153}
1154
1155=pod
1156
1157---++++ getAllWikiNames() -> \@array
1158
1159returns a list of all known wikiNames
1160
1161=cut
1162
1163sub getAllWikiNames {
1164  my $this = shift;
1165
1166  my $wikiNames = TWiki::Sandbox::untaintUnchecked($this->{data}{WIKINAMES}) || '';
1167  my @wikiNames = split(/,/,$wikiNames);
1168  return \@wikiNames;
1169}
1170
1171=pod
1172
1173---++++ getAllLoginNames() -> \@array
1174
1175returns a list of all known loginNames
1176
1177=cut
1178
1179sub getAllLoginNames {
1180  my $this = shift;
1181
1182  my $loginNames = TWiki::Sandbox::untaintUnchecked($this->{data}{LOGINNAMES}) || '';
1183  my @loginNames = split(/,/,$loginNames);
1184  return \@loginNames;
1185}
1186
1187=pod
1188
1189---++++ getDnOfLogin($loginName) -> $dn
1190
1191returns the Distinguished Name of the LDAP record of the given name
1192
1193=cut
1194
1195sub getDnOfLogin {
1196  my ($this, $loginName) = @_;
1197  $loginName = lc($loginName);
1198  return TWiki::Sandbox::untaintUnchecked($this->{data}{"U2DN::$loginName"});
1199}
1200
1201=pod
1202
1203---++++ changePassword($loginName, $newPassword, $oldPassword) -> $boolean
1204
1205=cut
1206
1207sub changePassword {
1208  my ($this, $loginName, $newPassword, $oldPassword ) = @_;
1209
1210  return undef unless
1211    $this->{allowChangePassword} && defined($oldPassword) && $oldPassword ne '1';
1212
1213  my $dn = $this->getDnOfLogin($loginName);
1214  return undef unless $dn;
1215
1216  return undef unless $this->connect($dn, $oldPassword);
1217
1218  my $msg = $this->{ldap}->modify( $dn,
1219    replace => { 'userPassword' => $newPassword }
1220  );
1221
1222  my $errorCode = $this->checkError($msg);
1223
1224  if ($errorCode != LDAP_SUCCESS) {
1225    $this->writeDebug("error in changePassword: ".$this->getError());
1226    return undef;
1227  }
1228
1229  return 1;
1230}
1231
1232=pod
1233
1234---++++ checkCacheForLoginName($loginName) -> $boolean
1235
1236grant that the current loginName is cached. If not, it will download the LDAP
1237record for this specific user and update the LDAP cache with this single record.
1238
1239This happens when the user is authenticated externally, e.g. using apache's
1240mod_authz_ldap or some other SSO, and TWiki's internal cache
1241is not yet updated. It is completely updated regularly on a specific time
1242interval (default every 24h). See the LdapContrib settings.
1243
1244=cut
1245
1246sub checkCacheForLoginName {
1247  my ($this, $loginName) = @_;
1248
1249  $this->writeDebug("called checkCacheForLoginName($loginName)");
1250
1251  my $wikiName = $this->getWikiNameOfLogin($loginName);
1252
1253  return 1 if $wikiName;
1254
1255  # update cache selectively
1256  $this->writeDebug("warning, $loginName is unknown, need to refresh part of the ldap cache");
1257  my $entry = $this->getAccount($loginName);
1258  unless ($entry) {
1259    $this->writeDebug("oops, no result");
1260  } else {
1261    # merge this user record
1262
1263    my %wikiNames = map {$_ => 1} @{$this->getAllWikiNames()};
1264    my %loginNames = map {$_ => 1} @{$this->getAllLoginNames()};
1265    $this->cacheUserFromEntry($entry, $this->{data}, \%wikiNames, \%loginNames);
1266
1267    $this->{data}{WIKINAMES} = join(',', keys %wikiNames);
1268    $this->{data}{LOGINNAMES} = join(',', keys %loginNames);
1269  }
1270
1271  return 0;
1272}
1273
12741;
1275