Project

General

Profile

metacat / src / perl / ldapweb.cgi @ 8176

1
#!/usr/bin/perl -w
2
#
3
#  '$RCSfile$'
4
#  Copyright: 2001 Regents of the University of California 
5
#
6
#   '$Author: tao $'
7
#     '$Date: 2013-09-10 07:52:25 -0700 (Tue, 10 Sep 2013) $'
8
# '$Revision: 8176 $' 
9
# 
10
# This program is free software; you can redistribute it and/or modify
11
# it under the terms of the GNU General Public License as published by
12
# the Free Software Foundation; either version 2 of the License, or
13
# (at your option) any later version.
14
#
15
# This program is distributed in the hope that it will be useful,
16
# but WITHOUT ANY WARRANTY; without even the implied warranty of
17
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18
# GNU General Public License for more details.
19
#
20
# You should have received a copy of the GNU General Public License
21
# along with this program; if not, write to the Free Software
22
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
23
#
24

    
25
#
26
# This is a web-based application for allowing users to register a new
27
# account for Metacat access.  We currently only support LDAP even
28
# though metacat could potentially support other types of directories.
29

    
30
use lib '../WEB-INF/lib';
31
use strict;             # turn on strict syntax checking
32
use Template;           # load the template-toolkit module
33
use CGI qw/:standard :html3/; # load the CGI module 
34
use Net::LDAP;          # load the LDAP net libraries
35
use Net::SMTP;          # load the SMTP net libraries
36
use Digest::SHA1;       # for creating the password hash
37
use MIME::Base64;       # for creating the password hash
38
use URI;                # for parsing URL syntax
39
use Config::Properties; # for parsing Java .properties files
40
use File::Basename;     # for path name parsing
41
use Captcha::reCAPTCHA; # for protection against spams
42
use Cwd 'abs_path';
43

    
44
# Global configuration paramters
45
# This entire block (including skin parsing) could be pushed out to a separate .pm file
46
my $cgiUrl = $ENV{'SCRIPT_FILENAME'};
47
my $workingDirectory = dirname($cgiUrl);
48
my $metacatProps = "${workingDirectory}/../WEB-INF/metacat.properties";
49
my $properties = new Config::Properties();
50
unless (open (METACAT_PROPERTIES, $metacatProps)) {
51
    print "Content-type: text/html\n\n";
52
    print "Unable to locate Metacat properties. Working directory is set as " . 
53
        $workingDirectory .", is this correct?";
54
    exit(0);
55
}
56

    
57
$properties->load(*METACAT_PROPERTIES);
58

    
59
# local directory configuration
60
my $skinsDir = "${workingDirectory}/../style/skins";
61
my $templatesDir = abs_path("${workingDirectory}/../style/common/templates");
62
my $tempDir = $properties->getProperty('application.tempDir');
63

    
64
# url configuration
65
my $server = $properties->splitToTree(qr/\./, 'server');
66
my $protocol = 'http://';
67
if ( $properties->getProperty('server.httpPort') eq '443' ) {
68
	$protocol = 'https://';
69
}
70
my $contextUrl = $protocol . $properties->getProperty('server.name');
71
if ($properties->getProperty('server.httpPort') ne '80') {
72
        $contextUrl = $contextUrl . ':' . $properties->getProperty('server.httpPort');
73
}
74
$contextUrl = $contextUrl . '/' .  $properties->getProperty('application.context');
75

    
76
my $metacatUrl = $contextUrl . "/metacat";
77
my $cgiPrefix = "/" . $properties->getProperty('application.context') . "/cgi-bin";
78
my $styleSkinsPath = $contextUrl . "/style/skins";
79
my $styleCommonPath = $contextUrl . "/style/common";
80

    
81
#recaptcha key information
82
my $recaptchaPublicKey=$properties->getProperty('ldap.recaptcha.publickey');
83
my $recaptchaPrivateKey=$properties->getProperty('ldap.recaptcha.privatekey');
84

    
85
my @errorMessages;
86
my $error = 0;
87

    
88
# Import all of the HTML form fields as variables
89
import_names('FORM');
90

    
91
# Must have a config to use Metacat
92
my $skinName = "";
93
if ($FORM::cfg) {
94
    $skinName = $FORM::cfg;
95
} elsif ($ARGV[0]) {
96
    $skinName = $ARGV[0];
97
} else {
98
    debug("No configuration set.");
99
    print "Content-type: text/html\n\n";
100
    print 'LDAPweb Error: The registry requires a skin name to continue.';
101
    exit();
102
}
103

    
104
# Metacat isn't initialized, the registry will fail in strange ways.
105
if (!($metacatUrl)) {
106
    debug("No Metacat.");
107
    print "Content-type: text/html\n\n";
108
    'Registry Error: Metacat is not initialized! Make sure' .
109
        ' MetacatUrl is set correctly in ' .  $skinName . '.properties';
110
    exit();
111
}
112

    
113
my $skinProperties = new Config::Properties();
114
if (!($skinName)) {
115
    $error = "Application misconfigured.  Please contact the administrator.";
116
    push(@errorMessages, $error);
117
} else {
118
    my $skinProps = "$skinsDir/$skinName/$skinName.properties";
119
    unless (open (SKIN_PROPERTIES, $skinProps)) {
120
        print "Content-type: text/html\n\n";
121
        print "Unable to locate skin properties at $skinProps.  Is this path correct?";
122
        exit(0);
123
    }
124
    $skinProperties->load(*SKIN_PROPERTIES);
125
}
126

    
127
my $config = $skinProperties->splitToTree(qr/\./, 'registry.config');
128

    
129
# XXX HACK: this is a temporary fix to pull out the UCNRS password property from the
130
#           NRS skin instead of metacat.properties. The intent is to prevent editing
131
#           of our core properties file, which is manipulated purely through the web.
132
#           Once organizations are editable, this section should be removed as should
133
#           the properties within nrs/nrs.properties.
134
my $nrsProperties = new Config::Properties();
135
my $nrsProps = "$skinsDir/nrs/nrs.properties";
136
unless (open (NRS_PROPERTIES, $nrsProps)) {
137
    print "Content-type: text/html\n\n";
138
    print "Unable to locate skin properties at $nrsProps.  Is this path correct?";
139
    exit(0);
140
}
141
$nrsProperties->load(*NRS_PROPERTIES);
142

    
143
my $nrsConfig = $nrsProperties->splitToTree(qr/\./, 'registry.config');
144

    
145
# XXX END HACK
146

    
147

    
148
my $searchBase;
149
my $ldapUsername;
150
my $ldapPassword;
151
# TODO: when should we use surl instead? Is there a setting promoting one over the other?
152
# TODO: the default tree for accounts should be exposed somewhere, defaulting to unaffiliated
153
my $ldapurl = $properties->getProperty('auth.url');
154

    
155
# Java uses miliseconds, Perl expects whole seconds
156
my $timeout = $properties->getProperty('ldap.connectTimeLimit') / 1000;
157

    
158
# Get the CGI input variables
159
my $query = new CGI;
160
my $debug = 1;
161

    
162
#--------------------------------------------------------------------------80c->
163
# Set up the Template Toolkit to read html form templates
164

    
165
# templates hash, imported from ldap.templates tree in metacat.properties
166
my $templates = $properties->splitToTree(qr/\./, 'ldap.templates');
167
$$templates{'header'} = $skinProperties->getProperty("registry.templates.header");
168
$$templates{'footer'} = $skinProperties->getProperty("registry.templates.footer");
169

    
170
# set some configuration options for the template object
171
my $ttConfig = {
172
             INCLUDE_PATH => $templatesDir,
173
             INTERPOLATE  => 0,
174
             POST_CHOMP   => 1,
175
             DEBUG        => 1, 
176
             };
177

    
178
# create an instance of the template
179
my $template = Template->new($ttConfig) || handleGeneralServerFailure($Template::ERROR);
180

    
181
# custom LDAP properties hash
182
my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');
183

    
184
my $orgProps = $properties->splitToTree(qr/\./, 'organization');
185
my $orgNames = $properties->splitToTree(qr/\./, 'organization.name');
186
# pull out properties available e.g. 'name', 'base'
187
my @orgData = keys(%$orgProps);
188

    
189
my @orgList;
190
while (my ($oKey, $oVal) = each(%$orgNames)) {
191
    push(@orgList, $oKey);
192
}
193

    
194
my $authBase = $properties->getProperty("auth.base");
195
my $ldapConfig;
196
foreach my $o (@orgList) {
197
    foreach my $d (@orgData) {
198
        $ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");
199
    }
200

    
201
    # XXX hack, remove after 1.9
202
    if ($o eq 'UCNRS') {
203
        $ldapConfig->{'UCNRS'}{'base'} = $nrsConfig->{'base'};
204
        $ldapConfig->{'UCNRS'}{'user'} = $nrsConfig->{'username'};
205
        $ldapConfig->{'UCNRS'}{'password'} = $nrsConfig->{'password'};
206
    }
207

    
208
    # set default base
209
    if (!$ldapConfig->{$o}{'base'}) {
210
        $ldapConfig->{$o}{'base'} = $authBase;
211
    }
212

    
213
    # include filter information. By default, our filters are 'o=$name', e.g. 'o=NAPIER'
214
    # these can be overridden by specifying them in metacat.properties. Non-default configs
215
    # such as UCNRS must specify all LDAP properties.
216
    if ($ldapConfig->{$o}{'base'} eq $authBase) {
217
        my $filter = "o=$o";
218
        if (!$ldapConfig->{$o}{'org'}) {
219
            $ldapConfig->{$o}{'org'} = $filter;
220
        }
221
        if (!$ldapConfig->{$o}{'filter'}) {
222
            $ldapConfig->{$o}{'filter'} = $filter;
223
        }
224
        # also include DN, which is just org + base
225
        if ($ldapConfig->{$o}{'org'}) {
226
            $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'org'} . "," . $ldapConfig->{$o}{'base'};
227
        }
228
    } else {
229
        $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'base'};
230
    }
231
    
232
    # set LDAP administrator user account
233
    if (!$ldapConfig->{$o}{'user'}) {
234
        $ldapConfig->{$o}{'user'} = $ldapConfig->{'unaffiliated'}{'user'};
235
    }
236
    # check for a fully qualified LDAP name. If it doesn't exist, append base.
237
    my @userParts = split(',', $ldapConfig->{$o}{'user'});
238
    if (scalar(@userParts) == 1) {
239
        $ldapConfig->{$o}{'user'} = $ldapConfig->{$o}{'user'} . "," . $ldapConfig->{$o}{'base'};
240
    }
241

    
242
    if (!$ldapConfig->{$o}{'password'}) {
243
        $ldapConfig->{$o}{'password'} = $ldapConfig->{'unaffiliated'}{'password'};
244
    }
245
}
246

    
247
#--------------------------------------------------------------------------80c->
248
# Define the main program logic that calls subroutines to do the work
249
#--------------------------------------------------------------------------80c->
250

    
251
# The processing step we are handling
252
my $stage = $query->param('stage') || $templates->{'stage'};
253

    
254
my $cfg = $query->param('cfg');
255
debug("started with stage $stage, cfg $cfg");
256

    
257
# define the possible stages
258
my %stages = (
259
              'initregister'      => \&handleInitRegister,
260
              'register'          => \&handleRegister,
261
              'registerconfirmed' => \&handleRegisterConfirmed,
262
              'simplesearch'      => \&handleSimpleSearch,
263
              'initaddentry'      => \&handleInitAddEntry,
264
              'addentry'          => \&handleAddEntry,
265
              'initmodifyentry'   => \&handleInitModifyEntry,
266
              'modifyentry'       => \&handleModifyEntry,
267
              'changepass'        => \&handleChangePassword,
268
              'initchangepass'    => \&handleInitialChangePassword,
269
              'resetpass'         => \&handleResetPassword,
270
              'initresetpass'     => \&handleInitialResetPassword,
271
              'createtemppass'    => \&createTemporaryAccount,
272
             );
273

    
274
# call the appropriate routine based on the stage
275
if ( $stages{$stage} ) {
276
  $stages{$stage}->();
277
} else {
278
  &handleResponseMessage();
279
}
280

    
281
#--------------------------------------------------------------------------80c->
282
# Define the subroutines to do the work
283
#--------------------------------------------------------------------------80c->
284

    
285
sub fullTemplate {
286
    my $templateList = shift;
287
    my $templateVars = setVars(shift);
288
    my $c = Captcha::reCAPTCHA->new;
289
    my $captcha = 'captcha';
290
    #my $error=null;
291
    my $use_ssl= 1;
292
    #my $options=null;
293
    $templateVars->{$captcha} = $c->get_html($recaptchaPublicKey,undef, $use_ssl, undef);
294
    $template->process( $templates->{'header'}, $templateVars );
295
    foreach my $tmpl (@{$templateList}) {
296
        $template->process( $templates->{$tmpl}, $templateVars );
297
    }
298
    $template->process( $templates->{'footer'}, $templateVars );
299
}
300

    
301
#
302
# create the initial registration form 
303
#
304
sub handleInitRegister {
305
  my $vars = shift;
306
  print "Content-type: text/html\n\n";
307
  # process the template files:
308
  fullTemplate(['register'], {stage => "register"}); 
309
  exit();
310
}
311

    
312
#
313
# process input from the register stage, which occurs when
314
# a user submits form data to create a new account
315
#
316
sub handleRegister {
317
    
318
    print "Content-type: text/html\n\n";
319
    
320
    
321
    my $allParams = { 'givenName' => $query->param('givenName'), 
322
                      'sn' => $query->param('sn'),
323
                      'o' => $query->param('o'), 
324
                      'mail' => $query->param('mail'), 
325
                      'uid' => $query->param('uid'), 
326
                      'userPassword' => $query->param('userPassword'), 
327
                      'userPassword2' => $query->param('userPassword2'), 
328
                      'title' => $query->param('title'), 
329
                      'telephoneNumber' => $query->param('telephoneNumber') };
330
    
331
    # Check the recaptcha
332
    my $c = Captcha::reCAPTCHA->new;
333
    my $challenge = $query->param('recaptcha_challenge_field');
334
    my $response = $query->param('recaptcha_response_field');
335
    # Verify submission
336
    my $result = $c->check_answer(
337
        $recaptchaPrivateKey, $ENV{'REMOTE_ADDR'},
338
        $challenge, $response
339
    );
340

    
341
    if ( $result->{is_valid} ) {
342
        #print "Yes!";
343
        #exit();
344
    }
345
    else {
346
        my $errorMessage = "The verification code is wrong. Please input again.";
347
        fullTemplate(['register'], { stage => "register",
348
                                     allParams => $allParams,
349
                                     errorMessage => $errorMessage });
350
        exit();
351
    }
352
    
353
    
354
    # Check that all required fields are provided and not null
355
    my @requiredParams = ( 'givenName', 'sn', 'o', 'mail', 
356
                           'uid', 'userPassword', 'userPassword2');
357
    if (! paramsAreValid(@requiredParams)) {
358
        my $errorMessage = "Required information is missing. " .
359
            "Please fill in all required fields and resubmit the form.";
360
        fullTemplate(['register'], { stage => "register",
361
                                     allParams => $allParams,
362
                                     errorMessage => $errorMessage });
363
        exit();
364
    } else {
365
        my $o = $query->param('o');    
366
        $searchBase = $ldapConfig->{$o}{'base'};  
367
    }
368

    
369
    # Search LDAP for matching entries that already exist
370
    # Some forms use a single text search box, whereas others search per
371
    # attribute.
372
    my $filter;
373
    if ($query->param('searchField')) {
374

    
375
      $filter = "(|" . 
376
                "(uid=" . $query->param('searchField') . ") " .
377
                "(mail=" . $query->param('searchField') . ")" .
378
                "(&(sn=" . $query->param('searchField') . ") " . 
379
                "(givenName=" . $query->param('searchField') . "))" . 
380
                ")";
381
    } else {
382
      $filter = "(|" . 
383
                "(uid=" . $query->param('uid') . ") " .
384
                "(mail=" . $query->param('mail') . ")" .
385
                "(&(sn=" . $query->param('sn') . ") " . 
386
                "(givenName=" . $query->param('givenName') . "))" . 
387
                ")";
388
    }
389

    
390
    my @attrs = [ 'uid', 'o', 'cn', 'mail', 'telephoneNumber', 'title' ];
391
    my $found = findExistingAccounts($ldapurl, $searchBase, $filter, \@attrs);
392

    
393
    # If entries match, send back a request to confirm new-user creation
394
    if ($found) {
395
      fullTemplate( ['registerMatch', 'register'], { stage => "registerconfirmed",
396
                                                     allParams => $allParams,
397
                                                     foundAccounts => $found });
398
    # Otherwise, create a new user in the LDAP directory
399
    } else {
400
        createAccount($allParams);
401
    }
402

    
403
    exit();
404
}
405

    
406
#
407
# process input from the registerconfirmed stage, which occurs when
408
# a user chooses to create an account despite similarities to other
409
# existing accounts
410
#
411
sub handleRegisterConfirmed {
412
  
413
    my $allParams = { 'givenName' => $query->param('givenName'), 
414
                      'sn' => $query->param('sn'),
415
                      'o' => 'unaffiliated', # only accept unaffiliated registration
416
                      'mail' => $query->param('mail'), 
417
                      'uid' => $query->param('uid'), 
418
                      'userPassword' => $query->param('userPassword'), 
419
                      'userPassword2' => $query->param('userPassword2'), 
420
                      'title' => $query->param('title'), 
421
                      'telephoneNumber' => $query->param('telephoneNumber') };
422
    print "Content-type: text/html\n\n";
423
    createAccount($allParams);
424
    exit();
425
}
426

    
427
#
428
# change a user's password upon request
429
#
430
sub handleChangePassword {
431

    
432
    print "Content-type: text/html\n\n";
433

    
434
    my $allParams = { 'test' => "1", };
435
    if ($query->param('uid')) {
436
        $$allParams{'uid'} = $query->param('uid');
437
    }
438
    if ($query->param('o')) {
439
        $$allParams{'o'} = $query->param('o');
440
        my $o = $query->param('o');
441
        
442
        $searchBase = $ldapConfig->{$o}{'base'};
443
    }
444

    
445

    
446
    # Check that all required fields are provided and not null
447
    my @requiredParams = ( 'uid', 'o', 'oldpass', 
448
                           'userPassword', 'userPassword2');
449
    if (! paramsAreValid(@requiredParams)) {
450
        my $errorMessage = "Required information is missing. " .
451
            "Please fill in all required fields and submit the form.";
452
        fullTemplate( ['changePass'], { stage => "changepass",
453
                                        allParams => $allParams,
454
                                        errorMessage => $errorMessage });
455
        exit();
456
    }
457

    
458
    # We have all of the info we need, so try to change the password
459
    if ($query->param('userPassword') =~ $query->param('userPassword2')) {
460

    
461
        my $o = $query->param('o');
462
        $searchBase = $ldapConfig->{$o}{'base'};
463
        $ldapUsername = $ldapConfig->{$o}{'user'};
464
        $ldapPassword = $ldapConfig->{$o}{'password'};
465

    
466
        my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};;
467
        if ($query->param('o') =~ "LTER") {
468
            fullTemplate( ['registerLter'] );
469
        } else {
470
            my $errorMessage = changePassword(
471
                    $dn, $query->param('userPassword'), 
472
                    $dn, $query->param('oldpass'), $query->param('o'));
473
            if ($errorMessage) {
474
                fullTemplate( ['changePass'], { stage => "changepass",
475
                                                allParams => $allParams,
476
                                                errorMessage => $errorMessage });
477
                exit();
478
            } else {
479
                fullTemplate( ['changePassSuccess'], { stage => "changepass",
480
                                                       allParams => $allParams });
481
                exit();
482
            }
483
        }
484
    } else {
485
        my $errorMessage = "The passwords do not match. Try again.";
486
        fullTemplate( ['changePass'], { stage => "changepass",
487
                                        allParams => $allParams,
488
                                        errorMessage => $errorMessage });
489
        exit();
490
    }
491
}
492

    
493
#
494
# change a user's password upon request - no input params
495
# only display chagepass template without any error
496
#
497
sub handleInitialChangePassword {
498
    print "Content-type: text/html\n\n";
499

    
500
    my $allParams = { 'test' => "1", };
501
    my $errorMessage = "";
502
    fullTemplate( ['changePass'], { stage => "changepass",
503
                                    errorMessage => $errorMessage });
504
    exit();
505
}
506

    
507
#
508
# reset a user's password upon request
509
#
510
sub handleResetPassword {
511

    
512
    print "Content-type: text/html\n\n";
513

    
514
    my $allParams = { 'test' => "1", };
515
    if ($query->param('uid')) {
516
        $$allParams{'uid'} = $query->param('uid');
517
    }
518
    if ($query->param('o')) {
519
        $$allParams{'o'} = $query->param('o');
520
        my $o = $query->param('o');
521
        
522
        $searchBase = $ldapConfig->{$o}{'base'};
523
        $ldapUsername = $ldapConfig->{$o}{'user'};
524
        $ldapPassword = $ldapConfig->{$o}{'password'};
525
    }
526

    
527
    # Check that all required fields are provided and not null
528
    my @requiredParams = ( 'uid', 'o' );
529
    if (! paramsAreValid(@requiredParams)) {
530
        my $errorMessage = "Required information is missing. " .
531
            "Please fill in all required fields and submit the form.";
532
        fullTemplate( ['resetPass'],  { stage => "resetpass",
533
                                        allParams => $allParams,
534
                                        errorMessage => $errorMessage });
535
        exit();
536
    }
537

    
538
    # We have all of the info we need, so try to change the password
539
    my $o = $query->param('o');
540
    my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};
541
    debug("handleResetPassword: dn: $dn");
542
    if ($query->param('o') =~ "LTER") {
543
        fullTemplate( ['registerLter'] );
544
        exit();
545
    } else {
546
        my $errorMessage = "";
547
        my $recipient;
548
        my $userPass;
549
        my $entry = getLdapEntry($ldapurl, $searchBase, 
550
                $query->param('uid'), $query->param('o'));
551

    
552
        if ($entry) {
553
            $recipient = $entry->get_value('mail');
554
            $userPass = getRandomPassword();
555
            $errorMessage = changePassword($dn, $userPass, $ldapUsername, $ldapPassword, $query->param('o'));
556
        } else {
557
            $errorMessage = "User not found in database.  Please try again.";
558
        }
559

    
560
        if ($errorMessage) {
561
            fullTemplate( ['resetPass'], { stage => "resetpass",
562
                                           allParams => $allParams,
563
                                           errorMessage => $errorMessage });
564
            exit();
565
        } else {
566
            my $errorMessage = sendPasswordNotification($query->param('uid'),
567
                    $query->param('o'), $userPass, $recipient, $cfg);
568
            fullTemplate( ['resetPassSuccess'], { stage => "resetpass",
569
                                                  allParams => $allParams,
570
                                                  errorMessage => $errorMessage });
571
            exit();
572
        }
573
    }
574
}
575

    
576
#
577
# reset a user's password upon request- no initial params
578
# only display resetpass template without any error
579
#
580
sub handleInitialResetPassword {
581
    print "Content-type: text/html\n\n";
582
    my $errorMessage = "";
583
    fullTemplate( ['resetPass'], { stage => "resetpass",
584
                                   errorMessage => $errorMessage });
585
    exit();
586
}
587

    
588
#
589
# Construct a random string to use for a newly reset password
590
#
591
sub getRandomPassword {
592
    my $length = shift;
593
    if (!$length) {
594
        $length = 8;
595
    }
596
    my $newPass = "";
597

    
598
    my @chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(! @ $ ^) );
599
    $newPass = join("", @chars[ map { rand @chars } ( 1 .. $length ) ]);
600
    return $newPass;
601
}
602

    
603
#
604
# Change a password to a new value, binding as the provided user
605
#
606
sub changePassword {
607
    my $userDN = shift;
608
    my $userPass = shift;
609
    my $bindDN = shift;
610
    my $bindPass = shift;
611
    my $o = shift;
612

    
613
    my $searchBase = $ldapConfig->{$o}{'base'};
614

    
615
    my $errorMessage = 0;
616
    my $ldap;
617

    
618
    #if main ldap server is down, a html file containing warning message will be returned
619
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
620
    
621
    if ($ldap) {
622
        #$ldap->start_tls( verify => 'require',
623
                      #cafile => '/usr/share/ssl/ldapcerts/cacert.pem');
624
        $ldap->start_tls( verify => 'none');
625
        debug("changePassword: attempting to bind to $bindDN");
626
        my $bindresult = $ldap->bind( version => 3, dn => $bindDN, 
627
                                  password => $bindPass );
628
        if ($bindresult->code) {
629
            $errorMessage = "Failed to log in. Are you sure your connection credentails are " .
630
                            "correct? Please correct and try again...";
631
            return $errorMessage;
632
        }
633

    
634
    	# Find the user here and change their entry
635
    	my $newpass = createSeededPassHash($userPass);
636
    	my $modifications = { userPassword => $newpass };
637
      debug("changePass: setting password for $userDN to $newpass");
638
    	my $result = $ldap->modify( $userDN, replace => { %$modifications });
639
    
640
    	if ($result->code()) {
641
            debug("changePass: error changing password: " . $result->error);
642
        	$errorMessage = "There was an error changing the password:" .
643
                           "<br />\n" . $result->error;
644
    	} 
645
    	$ldap->unbind;   # take down session
646
    }
647

    
648
    return $errorMessage;
649
}
650

    
651
#
652
# generate a Seeded SHA1 hash of a plaintext password
653
#
654
sub createSeededPassHash {
655
    my $secret = shift;
656

    
657
    my $salt = "";
658
    for (my $i=0; $i < 4; $i++) {
659
        $salt .= int(rand(10));
660
    }
661

    
662
    my $ctx = Digest::SHA1->new;
663
    $ctx->add($secret);
664
    $ctx->add($salt);
665
    my $hashedPasswd = '{SSHA}' . encode_base64($ctx->digest . $salt ,'');
666

    
667
    return $hashedPasswd;
668
}
669

    
670
#
671
# Look up an ldap entry for a user
672
#
673
sub getLdapEntry {
674
    my $ldapurl = shift;
675
    my $base = shift;
676
    my $username = shift;
677
    my $org = shift;
678

    
679
    my $entry = "";
680
    my $mesg;
681
    my $ldap;
682
    debug("ldap server: $ldapurl");
683

    
684
    #if main ldap server is down, a html file containing warning message will be returned
685
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
686
    
687
    if ($ldap) {
688
    	$ldap->start_tls( verify => 'none');
689
    	my $bindresult = $ldap->bind;
690
    	if ($bindresult->code) {
691
        	return $entry;
692
    	}
693

    
694
    	if($ldapConfig->{$org}{'filter'}){
695
            debug("getLdapEntry: filter set, searching for base=$base, " .
696
                  "(&(uid=$username)($ldapConfig->{$org}{'filter'})");
697
        	$mesg = $ldap->search ( base   => $base,
698
                filter => "(&(uid=$username)($ldapConfig->{$org}{'filter'}))");
699
    	} else {
700
            debug("getLdapEntry: no filter, searching for $base, (uid=$username)");
701
        	$mesg = $ldap->search ( base   => $base, filter => "(uid=$username)");
702
    	}
703
    
704
    	if ($mesg->count > 0) {
705
        	$entry = $mesg->pop_entry;
706
        	$ldap->unbind;   # take down session
707
    	} else {
708
        	$ldap->unbind;   # take down session
709
        	# Follow references by recursive call to self
710
        	my @references = $mesg->references();
711
        	for (my $i = 0; $i <= $#references; $i++) {
712
            	my $uri = URI->new($references[$i]);
713
            	my $host = $uri->host();
714
            	my $path = $uri->path();
715
            	$path =~ s/^\///;
716
            	$entry = &getLdapEntry($host, $path, $username, $org);
717
            	if ($entry) {
718
                    debug("getLdapEntry: recursion found $host, $path, $username, $org");
719
                	return $entry;
720
            	}
721
        	}
722
    	}
723
    }
724
    return $entry;
725
}
726

    
727
# 
728
# send an email message notifying the user of the pw change
729
#
730
sub sendPasswordNotification {
731
    my $username = shift;
732
    my $org = shift;
733
    my $newPass = shift;
734
    my $recipient = shift;
735
    my $cfg = shift;
736

    
737
    my $errorMessage = "";
738
    if ($recipient) {
739
        my $mailhost = $properties->getProperty('email.mailhost');
740
        my $sender =  $properties->getProperty('email.sender');
741
        # Send the email message to them
742
        my $smtp = Net::SMTP->new($mailhost);
743
        $smtp->mail($sender);
744
        $smtp->to($recipient);
745

    
746
        my $message = <<"        ENDOFMESSAGE";
747
        To: $recipient
748
        From: $sender
749
        Subject: KNB Password Reset
750
        
751
        Somebody (hopefully you) requested that your KNB password be reset.  
752
        This is generally done when somebody forgets their password.  Your 
753
        password can be changed by visiting the following URL:
754

    
755
        $contextUrl/cgi-bin/ldapweb.cgi?stage=changepass&cfg=$cfg
756

    
757
            Username: $username
758
        Organization: $org
759
        New Password: $newPass
760

    
761
        Thanks,
762
            The KNB Development Team
763
    
764
        ENDOFMESSAGE
765
        $message =~ s/^[ \t\r\f]+//gm;
766
    
767
        $smtp->data($message);
768
        $smtp->quit;
769
    } else {
770
        $errorMessage = "Failed to send password because I " .
771
                        "couldn't find a valid email address.";
772
    }
773
    return $errorMessage;
774
}
775

    
776
#
777
# search the LDAP directory to see if a similar account already exists
778
#
779
sub findExistingAccounts {
780
    my $ldapurl = shift;
781
    my $base = shift;
782
    my $filter = shift;
783
    my $attref = shift;
784
    my $ldap;
785
    my $mesg;
786

    
787
    my $foundAccounts = 0;
788

    
789
    #if main ldap server is down, a html file containing warning message will be returned
790
    debug("findExistingAccounts: connecting to $ldapurl, $timeout");
791
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
792
    if ($ldap) {
793
    	$ldap->start_tls( verify => 'none');
794
    	$ldap->bind( version => 3, anonymous => 1);
795
		$mesg = $ldap->search (
796
			base   => $base,
797
			filter => $filter,
798
			attrs => @$attref,
799
		);
800

    
801
	    if ($mesg->count() > 0) {
802
			$foundAccounts = "";
803
			my $entry;
804
			foreach $entry ($mesg->all_entries) { 
805
                # a fix to ignore 'ou=Account' properties which are not usable accounts within Metacat.
806
                # this could be done directly with filters on the LDAP connection, instead.
807
                if ($entry->dn !~ /ou=Account/) {
808
                    $foundAccounts .= "<p>\n<b><u>Account:</u> ";
809
                    $foundAccounts .= $entry->dn();
810
                    $foundAccounts .= "</b><br />\n";
811
                    foreach my $attribute ($entry->attributes()) {
812
                        my $value = $entry->get_value($attribute);
813
                        $foundAccounts .= "$attribute: ";
814
                        $foundAccounts .= $value;
815
                        $foundAccounts .= "<br />\n";
816
                    }
817
                    $foundAccounts .= "</p>\n";
818
                }
819
			}
820
        }
821
    	$ldap->unbind;   # take down session
822

    
823
    	# Follow references
824
    	my @references = $mesg->references();
825
    	for (my $i = 0; $i <= $#references; $i++) {
826
        	my $uri = URI->new($references[$i]);
827
        	my $host = $uri->host();
828
        	my $path = $uri->path();
829
        	$path =~ s/^\///;
830
        	my $refFound = &findExistingAccounts($host, $path, $filter, $attref);
831
        	if ($refFound) {
832
            	$foundAccounts .= $refFound;
833
        	}
834
    	}
835
    }
836

    
837
    #print "<p>Checking referrals...</p>\n";
838
    #my @referrals = $mesg->referrals();
839
    #print "<p>Referrals count: ", scalar(@referrals), "</p>\n";
840
    #for (my $i = 0; $i <= $#referrals; $i++) {
841
        #print "<p>Referral: ", $referrals[$i], "</p>\n";
842
    #}
843

    
844
    return $foundAccounts;
845
}
846

    
847
#
848
# Validate that we have the proper set of input parameters
849
#
850
sub paramsAreValid {
851
    my @pnames = @_;
852

    
853
    my $allValid = 1;
854
    foreach my $parameter (@pnames) {
855
        if (!defined($query->param($parameter)) || 
856
            ! $query->param($parameter) ||
857
            $query->param($parameter) =~ /^\s+$/) {
858
            $allValid = 0;
859
        }
860
    }
861

    
862
    return $allValid;
863
}
864

    
865
#
866
# Create a temporary account for a user and send an email with a link which can click for the
867
# verification. This is used to protect the ldap server against spams.
868
#
869
sub createTemporaryAccount {
870
    my $allParams = shift;
871
    #my $org = $query->param('o'); 
872
    my $org = 'LTER';
873
    my $ou = $query->param('ou');
874
    #my $ou = 'LTER';
875
    my $uid = $query->param('uid');
876
    
877
    #to see if the organizaton exist
878
    my $tmpSearchBase = 'dc=tmp,' . $authBase; 
879
    print "Content-type: text/html\n\n";
880

    
881
    my $filter;
882
    # Search LDAP for matching o or ou that already exist
883
    if($org) {
884
        $filter = "(o" 
885
                  . "=" . $org .
886
                 ")";
887
    } else {
888
        $filter = "(ou" 
889
                  . "=" . $ou .
890
                 ")";
891
    }
892
    debug("search filer " . $filter);
893
    debug("ldap server ". $ldapurl);
894
    debug("sesarch base " . $tmpSearchBase);
895
    my @attrs = ['o', 'ou' ];
896
    my $found = searchDirectory($ldapurl, $tmpSearchBase, $filter, \@attrs);
897
    if(!$found) {
898
        #need to generate the subtree o or ou
899
        my $ldapUsername = $ldapConfig->{$org}{'user'};
900
        my $ldapPassword = $ldapConfig->{$org}{'password'};
901
        debug("LDAP connection to $ldapurl...");    
902
        #if main ldap server is down, a html file containing warning message will be returned
903
        my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
904
        
905
        if ($ldap) {
906
            $ldap->start_tls( verify => 'none');
907
            debug("Attempting to bind to LDAP server with dn = $ldapUsername, pwd = $ldapPassword");
908
            $ldap->bind( version => 3, dn => $ldapUsername, password => $ldapPassword );
909

    
910
            # Do the insertion
911
            my $additions;
912
             if($org) {
913
                $additions = [ 
914
                'o'   => $org,
915
                'objectclass' => ['top', 'organization']
916
                ];
917
             } else {
918
                $additions = [ 
919
                'ou'   => $ou,
920
                'objectclass' => ['top', 'organizationalUnit']
921
                ];
922
             }
923
            
924
            my $result = $ldap->add ( 'dn' => $tmpSearchBase, 'attr' => [ @$additions ]);
925
            if ($result->code()) {
926
                fullTemplate( ['registerFailed', 'register'], { stage => "register",
927
                                                            allParams => $allParams,
928
                                                            errorMessage => $result->error });
929
                # TODO SCW was included as separate errors, test this
930
                #$templateVars    = setVars({ stage => "register",
931
                #                     allParams => $allParams });
932
                #$template->process( $templates->{'register'}, $templateVars);
933
            } 
934
            $ldap->unbind;   # take down session
935
         } else {
936
            fullTemplate( ['registerFailed', 'register'], { stage => "register",
937
                                                            allParams => $allParams,
938
                                                            errorMessage => "The ldap server is not available now. Please try it later"});
939
            exit(0);
940
         }
941
    } 
942
    
943
    
944
    
945
    #$query->param('o','tmp');
946
    #createAccount($allParams);
947
    #$query->param('o',$org);
948
    #constrct url
949
    #my $link =
950
    #print "Content-type: text/html\n\n";
951
    #print $query->param('o');
952
}
953

    
954
#
955
# Bind to LDAP and create a new account using the information provided
956
# by the user
957
#
958
sub createAccount {
959
    my $allParams = shift;
960

    
961
    if ($query->param('o') =~ "LTER") {
962
        fullTemplate( ['registerLter'] );
963
    } else {
964

    
965
        # Be sure the passwords match
966
        if ($query->param('userPassword') !~ $query->param('userPassword2')) {
967
            my $errorMessage = "The passwords do not match. Try again.";
968
            fullTemplate( ['registerFailed', 'register'], { stage => "register",
969
                                                            allParams => $allParams,
970
                                                            errorMessage => $errorMessage });
971
            exit();
972
        }
973

    
974
        my $o = $query->param('o');
975

    
976
        my $searchBase = $ldapConfig->{$o}{'base'};
977
        my $dnBase = $ldapConfig->{$o}{'dn'};
978
        my $ldapUsername = $ldapConfig->{$o}{'user'};
979
        my $ldapPassword = $ldapConfig->{$o}{'password'};
980
        debug("LDAP connection to $ldapurl...");    
981
        #if main ldap server is down, a html file containing warning message will be returned
982
        my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
983
        
984
        if ($ldap) {
985
        	$ldap->start_tls( verify => 'none');
986
        	debug("Attempting to bind to LDAP server with dn = $ldapUsername, pwd = $ldapPassword");
987
        	$ldap->bind( version => 3, dn => $ldapUsername, password => $ldapPassword );
988
        
989
        	my $dn = 'uid=' . $query->param('uid') . ',' . $dnBase;
990
        	debug("Inserting new entry for: $dn");
991

    
992
        	# Create a hashed version of the password
993
        	my $shapass = createSeededPassHash($query->param('userPassword'));
994

    
995
        	# Do the insertion
996
        	my $additions = [ 
997
                'uid'   => $query->param('uid'),
998
                'o'   => $query->param('o'),
999
                'cn'   => join(" ", $query->param('givenName'), 
1000
                                    $query->param('sn')),
1001
                'sn'   => $query->param('sn'),
1002
                'givenName'   => $query->param('givenName'),
1003
                'mail' => $query->param('mail'),
1004
                'userPassword' => $shapass,
1005
                'objectclass' => ['top', 'person', 'organizationalPerson', 
1006
                                'inetOrgPerson', 'uidObject' ]
1007
            	];
1008
        	if (defined($query->param('telephoneNumber')) && 
1009
            	$query->param('telephoneNumber') &&
1010
            	! $query->param('telephoneNumber') =~ /^\s+$/) {
1011
            	$$additions[$#$additions + 1] = 'telephoneNumber';
1012
            	$$additions[$#$additions + 1] = $query->param('telephoneNumber');
1013
        	}
1014
        	if (defined($query->param('title')) && 
1015
            	$query->param('title') &&
1016
            	! $query->param('title') =~ /^\s+$/) {
1017
            	$$additions[$#$additions + 1] = 'title';
1018
            	$$additions[$#$additions + 1] = $query->param('title');
1019
        	}
1020
        	my $result = $ldap->add ( 'dn' => $dn, 'attr' => [ @$additions ]);
1021
    
1022
        	if ($result->code()) {
1023
            	fullTemplate( ['registerFailed', 'register'], { stage => "register",
1024
                                                            allParams => $allParams,
1025
                                                            errorMessage => $result->error });
1026
            	# TODO SCW was included as separate errors, test this
1027
           	 	#$templateVars    = setVars({ stage => "register",
1028
           	 	#                     allParams => $allParams });
1029
            	#$template->process( $templates->{'register'}, $templateVars);
1030
        	} else {
1031
            	fullTemplate( ['success'] );
1032
        	}
1033

    
1034
        	$ldap->unbind;   # take down session
1035
        }
1036
    }
1037
}
1038

    
1039
sub handleResponseMessage {
1040

    
1041
  print "Content-type: text/html\n\n";
1042
  my $errorMessage = "You provided invalid input to the script. " .
1043
                     "Try again please.";
1044
  fullTemplate( [], { stage => $templates->{'stage'},
1045
                      errorMessage => $errorMessage });
1046
  exit();
1047
}
1048

    
1049
#
1050
# perform a simple search against the LDAP database using 
1051
# a small subset of attributes of each dn and return it
1052
# as a table to the calling browser.
1053
#
1054
sub handleSimpleSearch {
1055

    
1056
    my $o = $query->param('o');
1057

    
1058
    my $ldapurl = $ldapConfig->{$o}{'url'};
1059
    my $searchBase = $ldapConfig->{$o}{'base'};
1060

    
1061
    print "Content-type: text/html\n\n";
1062

    
1063
    my $allParams = { 
1064
                      'cn' => $query->param('cn'),
1065
                      'sn' => $query->param('sn'),
1066
                      'gn' => $query->param('gn'),
1067
                      'o'  => $query->param('o'),
1068
                      'facsimiletelephonenumber' 
1069
                      => $query->param('facsimiletelephonenumber'),
1070
                      'mail' => $query->param('cmail'),
1071
                      'telephonenumber' => $query->param('telephonenumber'),
1072
                      'title' => $query->param('title'),
1073
                      'uid' => $query->param('uid'),
1074
                      'ou' => $query->param('ou'),
1075
                    };
1076

    
1077
    # Search LDAP for matching entries that already exist
1078
    my $filter = "(" . 
1079
                 $query->param('searchField') . "=" .
1080
                 "*" .
1081
                 $query->param('searchValue') .
1082
                 "*" .
1083
                 ")";
1084

    
1085
    my @attrs = [ 'sn', 
1086
                  'gn', 
1087
                  'cn', 
1088
                  'o', 
1089
                  'facsimiletelephonenumber', 
1090
                  'mail', 
1091
                  'telephoneNumber', 
1092
                  'title', 
1093
                  'uid', 
1094
                  'labeledURI', 
1095
                  'ou' ];
1096

    
1097
    my $found = searchDirectory($ldapurl, $searchBase, $filter, \@attrs);
1098

    
1099
    # Send back the search results
1100
    if ($found) {
1101
      fullTemplate( ('searchResults'), { stage => "searchresults",
1102
                                         allParams => $allParams,
1103
                                         foundAccounts => $found });
1104
    } else {
1105
      $found = "No entries matched your criteria.  Please try again\n";
1106

    
1107
      fullTemplate( ('searchResults'), { stage => "searchresults",
1108
                                         allParams => $allParams,
1109
                                         foundAccounts => $found });
1110
    }
1111

    
1112
    exit();
1113
}
1114

    
1115
#
1116
# search the LDAP directory to see if a similar account already exists
1117
#
1118
sub searchDirectory {
1119
    my $ldapurl = shift;
1120
    my $base = shift;
1121
    my $filter = shift;
1122
    my $attref = shift;
1123

    
1124
	my $mesg;
1125
    my $foundAccounts = 0;
1126
    
1127
    #if ldap server is down, a html file containing warning message will be returned
1128
    my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
1129
    
1130
    if ($ldap) {
1131
    	$ldap->start_tls( verify => 'none');
1132
    	$ldap->bind( version => 3, anonymous => 1);
1133
    	my $mesg = $ldap->search (
1134
        	base   => $base,
1135
        	filter => $filter,
1136
        	attrs => @$attref,
1137
    	);
1138

    
1139
    	if ($mesg->count() > 0) {
1140
        	$foundAccounts = "";
1141
        	my $entry;
1142
        	foreach $entry ($mesg->sorted(['sn'])) {
1143
          		$foundAccounts .= "<tr>\n<td class=\"main\">\n";
1144
          		$foundAccounts .= "<a href=\"" unless 
1145
                    (!$entry->get_value('labeledURI'));
1146
         		 $foundAccounts .= $entry->get_value('labeledURI') unless
1147
                    (!$entry->get_value('labeledURI'));
1148
          		$foundAccounts .= "\">\n" unless 
1149
                    (!$entry->get_value('labeledURI'));
1150
          		$foundAccounts .= $entry->get_value('givenName');
1151
          		$foundAccounts .= "</a>\n" unless 
1152
                    (!$entry->get_value('labeledURI'));
1153
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1154
          		$foundAccounts .= "<a href=\"" unless 
1155
                    (!$entry->get_value('labeledURI'));
1156
          		$foundAccounts .= $entry->get_value('labeledURI') unless
1157
                    (!$entry->get_value('labeledURI'));
1158
          		$foundAccounts .= "\">\n" unless 
1159
                    (!$entry->get_value('labeledURI'));
1160
          		$foundAccounts .= $entry->get_value('sn');
1161
          		$foundAccounts .= "</a>\n";
1162
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1163
          		$foundAccounts .= $entry->get_value('mail');
1164
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1165
          		$foundAccounts .= $entry->get_value('telephonenumber');
1166
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1167
          		$foundAccounts .= $entry->get_value('title');
1168
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1169
          		$foundAccounts .= $entry->get_value('ou');
1170
          		$foundAccounts .= "\n</td>\n";
1171
          		$foundAccounts .= "</tr>\n";
1172
        	}
1173
    	}
1174
    	$ldap->unbind;   # take down session
1175
    }
1176
    return $foundAccounts;
1177
}
1178

    
1179
sub debug {
1180
    my $msg = shift;
1181
    
1182
    if ($debug) {
1183
        print STDERR "LDAPweb: $msg\n";
1184
    }
1185
}
1186

    
1187
sub handleLDAPBindFailure {
1188
    my $ldapAttemptUrl = shift;
1189
    my $primaryLdap =  $properties->getProperty('auth.url');
1190

    
1191
    if ($ldapAttemptUrl eq  $primaryLdap) {
1192
        handleGeneralServerFailure("The main LDAP server $ldapurl is down!");
1193
    } else {
1194
        debug("attempted to bind to nonresponsive LDAP server $ldapAttemptUrl, skipped.");
1195
    }
1196
}
1197

    
1198
sub handleGeneralServerFailure {
1199
    my $errorMessage = shift;
1200
    fullTemplate( ['mainServerFailure'], { errorMessage => $errorMessage });
1201
    exit(0);   
1202
   }
1203
    
1204
sub setVars {
1205
    my $paramVars = shift;
1206
    # initialize default parameters 
1207
    my $templateVars = { cfg => $cfg,
1208
                         styleSkinsPath => $contextUrl . "/style/skins",
1209
                         styleCommonPath => $contextUrl . "/style/common",
1210
                         contextUrl => $contextUrl,
1211
                         cgiPrefix => $cgiPrefix,
1212
                         orgList => \@orgList,
1213
                         config  => $config,
1214
    };
1215
    
1216
    # append customized params
1217
    while (my ($k, $v) = each (%$paramVars)) {
1218
        $templateVars->{$k} = $v;
1219
    }
1220
    
1221
    return $templateVars;
1222
}