Project

General

Profile

1
#!/usr/bin/perl -w
2
#
3
#  '$RCSfile$'
4
#  Copyright: 2001 Regents of the University of California 
5
#
6
#   '$Author: leinfelder $'
7
#     '$Date: 2012-05-29 15:02:20 -0700 (Tue, 29 May 2012) $'
8
# '$Revision: 7199 $' 
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 Cwd 'abs_path';
42

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

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

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

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

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

    
80
my @errorMessages;
81
my $error = 0;
82

    
83
# Import all of the HTML form fields as variables
84
import_names('FORM');
85

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

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

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

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

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

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

    
140
# XXX END HACK
141

    
142

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

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

    
153
# Get the CGI input variables
154
my $query = new CGI;
155
my $debug = 1;
156

    
157
#--------------------------------------------------------------------------80c->
158
# Set up the Template Toolkit to read html form templates
159

    
160
# templates hash, imported from ldap.templates tree in metacat.properties
161
my $templates = $properties->splitToTree(qr/\./, 'ldap.templates');
162
$$templates{'header'} = $skinProperties->getProperty("registry.templates.header");
163
$$templates{'footer'} = $skinProperties->getProperty("registry.templates.footer");
164

    
165
# set some configuration options for the template object
166
my $ttConfig = {
167
             INCLUDE_PATH => $templatesDir,
168
             INTERPOLATE  => 0,
169
             POST_CHOMP   => 1,
170
             DEBUG        => 1, 
171
             };
172

    
173
# create an instance of the template
174
my $template = Template->new($ttConfig) || handleGeneralServerFailure($Template::ERROR);
175

    
176
# custom LDAP properties hash
177
my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');
178

    
179
my $orgProps = $properties->splitToTree(qr/\./, 'organization');
180
my $orgNames = $properties->splitToTree(qr/\./, 'organization.name');
181
# pull out properties available e.g. 'name', 'base'
182
my @orgData = keys(%$orgProps);
183

    
184
my @orgList;
185
while (my ($oKey, $oVal) = each(%$orgNames)) {
186
    push(@orgList, $oKey);
187
}
188

    
189
my $authBase = $properties->getProperty("auth.base");
190
my $ldapConfig;
191
foreach my $o (@orgList) {
192
    foreach my $d (@orgData) {
193
        $ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");
194
    }
195

    
196
    # XXX hack, remove after 1.9
197
    if ($o eq 'UCNRS') {
198
        $ldapConfig->{'UCNRS'}{'base'} = $nrsConfig->{'base'};
199
        $ldapConfig->{'UCNRS'}{'user'} = $nrsConfig->{'username'};
200
        $ldapConfig->{'UCNRS'}{'password'} = $nrsConfig->{'password'};
201
    }
202

    
203
    # set default base
204
    if (!$ldapConfig->{$o}{'base'}) {
205
        $ldapConfig->{$o}{'base'} = $authBase;
206
    }
207

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

    
237
    if (!$ldapConfig->{$o}{'password'}) {
238
        $ldapConfig->{$o}{'password'} = $ldapConfig->{'unaffiliated'}{'password'};
239
    }
240
}
241

    
242
#--------------------------------------------------------------------------80c->
243
# Define the main program logic that calls subroutines to do the work
244
#--------------------------------------------------------------------------80c->
245

    
246
# The processing step we are handling
247
my $stage = $query->param('stage') || $templates->{'stage'};
248

    
249
my $cfg = $query->param('cfg');
250
debug("started with stage $stage, cfg $cfg");
251

    
252
# define the possible stages
253
my %stages = (
254
              'initregister'      => \&handleInitRegister,
255
              'register'          => \&handleRegister,
256
              'registerconfirmed' => \&handleRegisterConfirmed,
257
              'simplesearch'      => \&handleSimpleSearch,
258
              'initaddentry'      => \&handleInitAddEntry,
259
              'addentry'          => \&handleAddEntry,
260
              'initmodifyentry'   => \&handleInitModifyEntry,
261
              'modifyentry'       => \&handleModifyEntry,
262
              'changepass'        => \&handleChangePassword,
263
              'initchangepass'    => \&handleInitialChangePassword,
264
              'resetpass'         => \&handleResetPassword,
265
              'initresetpass'     => \&handleInitialResetPassword,
266
             );
267

    
268
# call the appropriate routine based on the stage
269
if ( $stages{$stage} ) {
270
  $stages{$stage}->();
271
} else {
272
  &handleResponseMessage();
273
}
274

    
275
#--------------------------------------------------------------------------80c->
276
# Define the subroutines to do the work
277
#--------------------------------------------------------------------------80c->
278

    
279
sub fullTemplate {
280
    my $templateList = shift;
281
    my $templateVars = setVars(shift);
282

    
283
    $template->process( $templates->{'header'}, $templateVars );
284
    foreach my $tmpl (@{$templateList}) {
285
        $template->process( $templates->{$tmpl}, $templateVars );
286
    }
287
    $template->process( $templates->{'footer'}, $templateVars );
288
}
289

    
290
#
291
# create the initial registration form 
292
#
293
sub handleInitRegister {
294
  my $vars = shift;
295

    
296
  print "Content-type: text/html\n\n";
297
  # process the template files:
298
  fullTemplate(['register'], {stage => "register"}); 
299
  exit();
300
}
301

    
302
#
303
# process input from the register stage, which occurs when
304
# a user submits form data to create a new account
305
#
306
sub handleRegister {
307
    
308
    print "Content-type: text/html\n\n";
309

    
310
    my $allParams = { 'givenName' => $query->param('givenName'), 
311
                      'sn' => $query->param('sn'),
312
                      'o' => $query->param('o'), 
313
                      'mail' => $query->param('mail'), 
314
                      'uid' => $query->param('uid'), 
315
                      'userPassword' => $query->param('userPassword'), 
316
                      'userPassword2' => $query->param('userPassword2'), 
317
                      'title' => $query->param('title'), 
318
                      'telephoneNumber' => $query->param('telephoneNumber') };
319
    # Check that all required fields are provided and not null
320
    my @requiredParams = ( 'givenName', 'sn', 'o', 'mail', 
321
                           'uid', 'userPassword', 'userPassword2');
322
    if (! paramsAreValid(@requiredParams)) {
323
        my $errorMessage = "Required information is missing. " .
324
            "Please fill in all required fields and resubmit the form.";
325
        fullTemplate(['register'], { stage => "register",
326
                                     allParams => $allParams,
327
                                     errorMessage => $errorMessage });
328
        exit();
329
    } else {
330
        my $o = $query->param('o');    
331
        $searchBase = $ldapConfig->{$o}{'base'};  
332
    }
333

    
334
    # Search LDAP for matching entries that already exist
335
    # Some forms use a single text search box, whereas others search per
336
    # attribute.
337
    my $filter;
338
    if ($query->param('searchField')) {
339

    
340
      $filter = "(|" . 
341
                "(uid=" . $query->param('searchField') . ") " .
342
                "(mail=" . $query->param('searchField') . ")" .
343
                "(&(sn=" . $query->param('searchField') . ") " . 
344
                "(givenName=" . $query->param('searchField') . "))" . 
345
                ")";
346
    } else {
347
      $filter = "(|" . 
348
                "(uid=" . $query->param('uid') . ") " .
349
                "(mail=" . $query->param('mail') . ")" .
350
                "(&(sn=" . $query->param('sn') . ") " . 
351
                "(givenName=" . $query->param('givenName') . "))" . 
352
                ")";
353
    }
354

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

    
358
    # If entries match, send back a request to confirm new-user creation
359
    if ($found) {
360
      fullTemplate( ['registerMatch', 'register'], { stage => "registerconfirmed",
361
                                                     allParams => $allParams,
362
                                                     foundAccounts => $found });
363
    # Otherwise, create a new user in the LDAP directory
364
    } else {
365
        createAccount($allParams);
366
    }
367

    
368
    exit();
369
}
370

    
371
#
372
# process input from the registerconfirmed stage, which occurs when
373
# a user chooses to create an account despite similarities to other
374
# existing accounts
375
#
376
sub handleRegisterConfirmed {
377
  
378
    my $allParams = { 'givenName' => $query->param('givenName'), 
379
                      'sn' => $query->param('sn'),
380
                      'o' => 'unaffiliated', # only accept unaffiliated registration
381
                      'mail' => $query->param('mail'), 
382
                      'uid' => $query->param('uid'), 
383
                      'userPassword' => $query->param('userPassword'), 
384
                      'userPassword2' => $query->param('userPassword2'), 
385
                      'title' => $query->param('title'), 
386
                      'telephoneNumber' => $query->param('telephoneNumber') };
387
    print "Content-type: text/html\n\n";
388
    createAccount($allParams);
389
    exit();
390
}
391

    
392
#
393
# change a user's password upon request
394
#
395
sub handleChangePassword {
396

    
397
    print "Content-type: text/html\n\n";
398

    
399
    my $allParams = { 'test' => "1", };
400
    if ($query->param('uid')) {
401
        $$allParams{'uid'} = $query->param('uid');
402
    }
403
    if ($query->param('o')) {
404
        $$allParams{'o'} = $query->param('o');
405
        my $o = $query->param('o');
406
        
407
        $searchBase = $ldapConfig->{$o}{'base'};
408
    }
409

    
410

    
411
    # Check that all required fields are provided and not null
412
    my @requiredParams = ( 'uid', 'o', 'oldpass', 
413
                           'userPassword', 'userPassword2');
414
    if (! paramsAreValid(@requiredParams)) {
415
        my $errorMessage = "Required information is missing. " .
416
            "Please fill in all required fields and submit the form.";
417
        fullTemplate( ['changePass'], { stage => "changepass",
418
                                        allParams => $allParams,
419
                                        errorMessage => $errorMessage });
420
        exit();
421
    }
422

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

    
426
        my $o = $query->param('o');
427
        $searchBase = $ldapConfig->{$o}{'base'};
428
        $ldapUsername = $ldapConfig->{$o}{'user'};
429
        $ldapPassword = $ldapConfig->{$o}{'password'};
430

    
431
        my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};;
432
        if ($query->param('o') =~ "LTER") {
433
            fullTemplate( ['registerLter'] );
434
        } else {
435
            my $errorMessage = changePassword(
436
                    $dn, $query->param('userPassword'), 
437
                    $dn, $query->param('oldpass'), $query->param('o'));
438
            if ($errorMessage) {
439
                fullTemplate( ['changePass'], { stage => "changepass",
440
                                                allParams => $allParams,
441
                                                errorMessage => $errorMessage });
442
                exit();
443
            } else {
444
                fullTemplate( ['changePassSuccess'], { stage => "changepass",
445
                                                       allParams => $allParams });
446
                exit();
447
            }
448
        }
449
    } else {
450
        my $errorMessage = "The passwords do not match. Try again.";
451
        fullTemplate( ['changePass'], { stage => "changepass",
452
                                        allParams => $allParams,
453
                                        errorMessage => $errorMessage });
454
        exit();
455
    }
456
}
457

    
458
#
459
# change a user's password upon request - no input params
460
# only display chagepass template without any error
461
#
462
sub handleInitialChangePassword {
463
    print "Content-type: text/html\n\n";
464

    
465
    my $allParams = { 'test' => "1", };
466
    my $errorMessage = "";
467
    fullTemplate( ['changePass'], { stage => "changepass",
468
                                    errorMessage => $errorMessage });
469
    exit();
470
}
471

    
472
#
473
# reset a user's password upon request
474
#
475
sub handleResetPassword {
476

    
477
    print "Content-type: text/html\n\n";
478

    
479
    my $allParams = { 'test' => "1", };
480
    if ($query->param('uid')) {
481
        $$allParams{'uid'} = $query->param('uid');
482
    }
483
    if ($query->param('o')) {
484
        $$allParams{'o'} = $query->param('o');
485
        my $o = $query->param('o');
486
        
487
        $searchBase = $ldapConfig->{$o}{'base'};
488
        $ldapUsername = $ldapConfig->{$o}{'user'};
489
        $ldapPassword = $ldapConfig->{$o}{'password'};
490
    }
491

    
492
    # Check that all required fields are provided and not null
493
    my @requiredParams = ( 'uid', 'o' );
494
    if (! paramsAreValid(@requiredParams)) {
495
        my $errorMessage = "Required information is missing. " .
496
            "Please fill in all required fields and submit the form.";
497
        fullTemplate( ['resetPass'],  { stage => "resetpass",
498
                                        allParams => $allParams,
499
                                        errorMessage => $errorMessage });
500
        exit();
501
    }
502

    
503
    # We have all of the info we need, so try to change the password
504
    my $o = $query->param('o');
505
    my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};
506
    debug("handleResetPassword: dn: $dn");
507
    if ($query->param('o') =~ "LTER") {
508
        fullTemplate( ['registerLter'] );
509
        exit();
510
    } else {
511
        my $errorMessage = "";
512
        my $recipient;
513
        my $userPass;
514
        my $entry = getLdapEntry($ldapurl, $searchBase, 
515
                $query->param('uid'), $query->param('o'));
516

    
517
        if ($entry) {
518
            $recipient = $entry->get_value('mail');
519
            $userPass = getRandomPassword();
520
            $errorMessage = changePassword($dn, $userPass, $ldapUsername, $ldapPassword, $query->param('o'));
521
        } else {
522
            $errorMessage = "User not found in database.  Please try again.";
523
        }
524

    
525
        if ($errorMessage) {
526
            fullTemplate( ['resetPass'], { stage => "resetpass",
527
                                           allParams => $allParams,
528
                                           errorMessage => $errorMessage });
529
            exit();
530
        } else {
531
            my $errorMessage = sendPasswordNotification($query->param('uid'),
532
                    $query->param('o'), $userPass, $recipient, $cfg);
533
            fullTemplate( ['resetPassSuccess'], { stage => "resetpass",
534
                                                  allParams => $allParams,
535
                                                  errorMessage => $errorMessage });
536
            exit();
537
        }
538
    }
539
}
540

    
541
#
542
# reset a user's password upon request- no initial params
543
# only display resetpass template without any error
544
#
545
sub handleInitialResetPassword {
546
    print "Content-type: text/html\n\n";
547
    my $errorMessage = "";
548
    fullTemplate( ['resetPass'], { stage => "resetpass",
549
                                   errorMessage => $errorMessage });
550
    exit();
551
}
552

    
553
#
554
# Construct a random string to use for a newly reset password
555
#
556
sub getRandomPassword {
557
    my $length = shift;
558
    if (!$length) {
559
        $length = 8;
560
    }
561
    my $newPass = "";
562

    
563
    my @chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(! @ $ ^) );
564
    $newPass = join("", @chars[ map { rand @chars } ( 1 .. $length ) ]);
565
    return $newPass;
566
}
567

    
568
#
569
# Change a password to a new value, binding as the provided user
570
#
571
sub changePassword {
572
    my $userDN = shift;
573
    my $userPass = shift;
574
    my $bindDN = shift;
575
    my $bindPass = shift;
576
    my $o = shift;
577

    
578
    my $searchBase = $ldapConfig->{$o}{'base'};
579

    
580
    my $errorMessage = 0;
581
    my $ldap;
582

    
583
    #if main ldap server is down, a html file containing warning message will be returned
584
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
585
    
586
    if ($ldap) {
587
        #$ldap->start_tls( verify => 'require',
588
                      #cafile => '/usr/share/ssl/ldapcerts/cacert.pem');
589
        $ldap->start_tls( verify => 'none');
590
        debug("changePassword: attempting to bind to $bindDN");
591
        my $bindresult = $ldap->bind( version => 3, dn => $bindDN, 
592
                                  password => $bindPass );
593
        if ($bindresult->code) {
594
            $errorMessage = "Failed to log in. Are you sure your connection credentails are " .
595
                            "correct? Please correct and try again...";
596
            return $errorMessage;
597
        }
598

    
599
    	# Find the user here and change their entry
600
    	my $newpass = createSeededPassHash($userPass);
601
    	my $modifications = { userPassword => $newpass };
602
      debug("changePass: setting password for $userDN to $newpass");
603
    	my $result = $ldap->modify( $userDN, replace => { %$modifications });
604
    
605
    	if ($result->code()) {
606
            debug("changePass: error changing password: " . $result->error);
607
        	$errorMessage = "There was an error changing the password:" .
608
                           "<br />\n" . $result->error;
609
    	} 
610
    	$ldap->unbind;   # take down session
611
    }
612

    
613
    return $errorMessage;
614
}
615

    
616
#
617
# generate a Seeded SHA1 hash of a plaintext password
618
#
619
sub createSeededPassHash {
620
    my $secret = shift;
621

    
622
    my $salt = "";
623
    for (my $i=0; $i < 4; $i++) {
624
        $salt .= int(rand(10));
625
    }
626

    
627
    my $ctx = Digest::SHA1->new;
628
    $ctx->add($secret);
629
    $ctx->add($salt);
630
    my $hashedPasswd = '{SSHA}' . encode_base64($ctx->digest . $salt ,'');
631

    
632
    return $hashedPasswd;
633
}
634

    
635
#
636
# Look up an ldap entry for a user
637
#
638
sub getLdapEntry {
639
    my $ldapurl = shift;
640
    my $base = shift;
641
    my $username = shift;
642
    my $org = shift;
643

    
644
    my $entry = "";
645
    my $mesg;
646
    my $ldap;
647
    debug("ldap server: $ldapurl");
648

    
649
    #if main ldap server is down, a html file containing warning message will be returned
650
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
651
    
652
    if ($ldap) {
653
    	$ldap->start_tls( verify => 'none');
654
    	my $bindresult = $ldap->bind;
655
    	if ($bindresult->code) {
656
        	return $entry;
657
    	}
658

    
659
    	if($ldapConfig->{$org}{'filter'}){
660
            debug("getLdapEntry: filter set, searching for base=$base, " .
661
                  "(&(uid=$username)($ldapConfig->{$org}{'filter'})");
662
        	$mesg = $ldap->search ( base   => $base,
663
                filter => "(&(uid=$username)($ldapConfig->{$org}{'filter'}))");
664
    	} else {
665
            debug("getLdapEntry: no filter, searching for $base, (uid=$username)");
666
        	$mesg = $ldap->search ( base   => $base, filter => "(uid=$username)");
667
    	}
668
    
669
    	if ($mesg->count > 0) {
670
        	$entry = $mesg->pop_entry;
671
        	$ldap->unbind;   # take down session
672
    	} else {
673
        	$ldap->unbind;   # take down session
674
        	# Follow references by recursive call to self
675
        	my @references = $mesg->references();
676
        	for (my $i = 0; $i <= $#references; $i++) {
677
            	my $uri = URI->new($references[$i]);
678
            	my $host = $uri->host();
679
            	my $path = $uri->path();
680
            	$path =~ s/^\///;
681
            	$entry = &getLdapEntry($host, $path, $username, $org);
682
            	if ($entry) {
683
                    debug("getLdapEntry: recursion found $host, $path, $username, $org");
684
                	return $entry;
685
            	}
686
        	}
687
    	}
688
    }
689
    return $entry;
690
}
691

    
692
# 
693
# send an email message notifying the user of the pw change
694
#
695
sub sendPasswordNotification {
696
    my $username = shift;
697
    my $org = shift;
698
    my $newPass = shift;
699
    my $recipient = shift;
700
    my $cfg = shift;
701

    
702
    my $errorMessage = "";
703
    if ($recipient) {
704
        my $mailhost = $properties->getProperty('email.mailhost');
705
        my $sender =  $properties->getProperty('email.sender');
706
        # Send the email message to them
707
        my $smtp = Net::SMTP->new($mailhost);
708
        $smtp->mail($sender);
709
        $smtp->to($recipient);
710

    
711
        my $message = <<"        ENDOFMESSAGE";
712
        To: $recipient
713
        From: $sender
714
        Subject: KNB Password Reset
715
        
716
        Somebody (hopefully you) requested that your KNB password be reset.  
717
        This is generally done when somebody forgets their password.  Your 
718
        password can be changed by visiting the following URL:
719

    
720
        $contextUrl/cgi-bin/ldapweb.cgi?stage=changepass&cfg=$cfg
721

    
722
            Username: $username
723
        Organization: $org
724
        New Password: $newPass
725

    
726
        Thanks,
727
            The KNB Development Team
728
    
729
        ENDOFMESSAGE
730
        $message =~ s/^[ \t\r\f]+//gm;
731
    
732
        $smtp->data($message);
733
        $smtp->quit;
734
    } else {
735
        $errorMessage = "Failed to send password because I " .
736
                        "couldn't find a valid email address.";
737
    }
738
    return $errorMessage;
739
}
740

    
741
#
742
# search the LDAP directory to see if a similar account already exists
743
#
744
sub findExistingAccounts {
745
    my $ldapurl = shift;
746
    my $base = shift;
747
    my $filter = shift;
748
    my $attref = shift;
749
    my $ldap;
750
    my $mesg;
751

    
752
    my $foundAccounts = 0;
753

    
754
    #if main ldap server is down, a html file containing warning message will be returned
755
    debug("findExistingAccounts: connecting to $ldapurl, $timeout");
756
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
757
    if ($ldap) {
758
    	$ldap->start_tls( verify => 'none');
759
    	$ldap->bind( version => 3, anonymous => 1);
760
		$mesg = $ldap->search (
761
			base   => $base,
762
			filter => $filter,
763
			attrs => @$attref,
764
		);
765

    
766
	    if ($mesg->count() > 0) {
767
			$foundAccounts = "";
768
			my $entry;
769
			foreach $entry ($mesg->all_entries) { 
770
                # a fix to ignore 'ou=Account' properties which are not usable accounts within Metacat.
771
                # this could be done directly with filters on the LDAP connection, instead.
772
                if ($entry->dn !~ /ou=Account/) {
773
                    $foundAccounts .= "<p>\n<b><u>Account:</u> ";
774
                    $foundAccounts .= $entry->dn();
775
                    $foundAccounts .= "</b><br />\n";
776
                    foreach my $attribute ($entry->attributes()) {
777
                        my $value = $entry->get_value($attribute);
778
                        $foundAccounts .= "$attribute: ";
779
                        $foundAccounts .= $value;
780
                        $foundAccounts .= "<br />\n";
781
                    }
782
                    $foundAccounts .= "</p>\n";
783
                }
784
			}
785
        }
786
    	$ldap->unbind;   # take down session
787

    
788
    	# Follow references
789
    	my @references = $mesg->references();
790
    	for (my $i = 0; $i <= $#references; $i++) {
791
        	my $uri = URI->new($references[$i]);
792
        	my $host = $uri->host();
793
        	my $path = $uri->path();
794
        	$path =~ s/^\///;
795
        	my $refFound = &findExistingAccounts($host, $path, $filter, $attref);
796
        	if ($refFound) {
797
            	$foundAccounts .= $refFound;
798
        	}
799
    	}
800
    }
801

    
802
    #print "<p>Checking referrals...</p>\n";
803
    #my @referrals = $mesg->referrals();
804
    #print "<p>Referrals count: ", scalar(@referrals), "</p>\n";
805
    #for (my $i = 0; $i <= $#referrals; $i++) {
806
        #print "<p>Referral: ", $referrals[$i], "</p>\n";
807
    #}
808

    
809
    return $foundAccounts;
810
}
811

    
812
#
813
# Validate that we have the proper set of input parameters
814
#
815
sub paramsAreValid {
816
    my @pnames = @_;
817

    
818
    my $allValid = 1;
819
    foreach my $parameter (@pnames) {
820
        if (!defined($query->param($parameter)) || 
821
            ! $query->param($parameter) ||
822
            $query->param($parameter) =~ /^\s+$/) {
823
            $allValid = 0;
824
        }
825
    }
826

    
827
    return $allValid;
828
}
829

    
830
#
831
# Bind to LDAP and create a new account using the information provided
832
# by the user
833
#
834
sub createAccount {
835
    my $allParams = shift;
836

    
837
    if ($query->param('o') =~ "LTER") {
838
        fullTemplate( ['registerLter'] );
839
    } else {
840

    
841
        # Be sure the passwords match
842
        if ($query->param('userPassword') !~ $query->param('userPassword2')) {
843
            my $errorMessage = "The passwords do not match. Try again.";
844
            fullTemplate( ['registerFailed', 'register'], { stage => "register",
845
                                                            allParams => $allParams,
846
                                                            errorMessage => $errorMessage });
847
            exit();
848
        }
849

    
850
        my $o = $query->param('o');
851

    
852
        my $searchBase = $ldapConfig->{$o}{'base'};
853
        my $dnBase = $ldapConfig->{$o}{'dn'};
854
        my $ldapUsername = $ldapConfig->{$o}{'user'};
855
        my $ldapPassword = $ldapConfig->{$o}{'password'};
856
        debug("LDAP connection to $ldapurl...");    
857
        #if main ldap server is down, a html file containing warning message will be returned
858
        my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
859
        
860
        if ($ldap) {
861
        	$ldap->start_tls( verify => 'none');
862
        	debug("Attempting to bind to LDAP server with dn = $ldapUsername, pwd = $ldapPassword");
863
        	$ldap->bind( version => 3, dn => $ldapUsername, password => $ldapPassword );
864
        
865
        	my $dn = 'uid=' . $query->param('uid') . ',' . $dnBase;
866
        	debug("Inserting new entry for: $dn");
867

    
868
        	# Create a hashed version of the password
869
        	my $shapass = createSeededPassHash($query->param('userPassword'));
870

    
871
        	# Do the insertion
872
        	my $additions = [ 
873
                'uid'   => $query->param('uid'),
874
                'o'   => $query->param('o'),
875
                'cn'   => join(" ", $query->param('givenName'), 
876
                                    $query->param('sn')),
877
                'sn'   => $query->param('sn'),
878
                'givenName'   => $query->param('givenName'),
879
                'mail' => $query->param('mail'),
880
                'userPassword' => $shapass,
881
                'objectclass' => ['top', 'person', 'organizationalPerson', 
882
                                'inetOrgPerson', 'uidObject' ]
883
            	];
884
        	if (defined($query->param('telephoneNumber')) && 
885
            	$query->param('telephoneNumber') &&
886
            	! $query->param('telephoneNumber') =~ /^\s+$/) {
887
            	$$additions[$#$additions + 1] = 'telephoneNumber';
888
            	$$additions[$#$additions + 1] = $query->param('telephoneNumber');
889
        	}
890
        	if (defined($query->param('title')) && 
891
            	$query->param('title') &&
892
            	! $query->param('title') =~ /^\s+$/) {
893
            	$$additions[$#$additions + 1] = 'title';
894
            	$$additions[$#$additions + 1] = $query->param('title');
895
        	}
896
        	my $result = $ldap->add ( 'dn' => $dn, 'attr' => [ @$additions ]);
897
    
898
        	if ($result->code()) {
899
            	fullTemplate( ['registerFailed', 'register'], { stage => "register",
900
                                                            allParams => $allParams,
901
                                                            errorMessage => $result->error });
902
            	# TODO SCW was included as separate errors, test this
903
           	 	#$templateVars    = setVars({ stage => "register",
904
           	 	#                     allParams => $allParams });
905
            	#$template->process( $templates->{'register'}, $templateVars);
906
        	} else {
907
            	fullTemplate( ['success'] );
908
        	}
909

    
910
        	$ldap->unbind;   # take down session
911
        }
912
    }
913
}
914

    
915
sub handleResponseMessage {
916

    
917
  print "Content-type: text/html\n\n";
918
  my $errorMessage = "You provided invalid input to the script. " .
919
                     "Try again please.";
920
  fullTemplate( [], { stage => $templates->{'stage'},
921
                      errorMessage => $errorMessage });
922
  exit();
923
}
924

    
925
#
926
# perform a simple search against the LDAP database using 
927
# a small subset of attributes of each dn and return it
928
# as a table to the calling browser.
929
#
930
sub handleSimpleSearch {
931

    
932
    my $o = $query->param('o');
933

    
934
    my $ldapurl = $ldapConfig->{$o}{'url'};
935
    my $searchBase = $ldapConfig->{$o}{'base'};
936

    
937
    print "Content-type: text/html\n\n";
938

    
939
    my $allParams = { 
940
                      'cn' => $query->param('cn'),
941
                      'sn' => $query->param('sn'),
942
                      'gn' => $query->param('gn'),
943
                      'o'  => $query->param('o'),
944
                      'facsimiletelephonenumber' 
945
                      => $query->param('facsimiletelephonenumber'),
946
                      'mail' => $query->param('cmail'),
947
                      'telephonenumber' => $query->param('telephonenumber'),
948
                      'title' => $query->param('title'),
949
                      'uid' => $query->param('uid'),
950
                      'ou' => $query->param('ou'),
951
                    };
952

    
953
    # Search LDAP for matching entries that already exist
954
    my $filter = "(" . 
955
                 $query->param('searchField') . "=" .
956
                 "*" .
957
                 $query->param('searchValue') .
958
                 "*" .
959
                 ")";
960

    
961
    my @attrs = [ 'sn', 
962
                  'gn', 
963
                  'cn', 
964
                  'o', 
965
                  'facsimiletelephonenumber', 
966
                  'mail', 
967
                  'telephoneNumber', 
968
                  'title', 
969
                  'uid', 
970
                  'labeledURI', 
971
                  'ou' ];
972

    
973
    my $found = searchDirectory($ldapurl, $searchBase, $filter, \@attrs);
974

    
975
    # Send back the search results
976
    if ($found) {
977
      fullTemplate( ('searchResults'), { stage => "searchresults",
978
                                         allParams => $allParams,
979
                                         foundAccounts => $found });
980
    } else {
981
      $found = "No entries matched your criteria.  Please try again\n";
982

    
983
      fullTemplate( ('searchResults'), { stage => "searchresults",
984
                                         allParams => $allParams,
985
                                         foundAccounts => $found });
986
    }
987

    
988
    exit();
989
}
990

    
991
#
992
# search the LDAP directory to see if a similar account already exists
993
#
994
sub searchDirectory {
995
    my $ldapurl = shift;
996
    my $base = shift;
997
    my $filter = shift;
998
    my $attref = shift;
999

    
1000
	my $mesg;
1001
    my $foundAccounts = 0;
1002
    
1003
    #if ldap server is down, a html file containing warning message will be returned
1004
    my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
1005
    
1006
    if ($ldap) {
1007
    	$ldap->start_tls( verify => 'none');
1008
    	$ldap->bind( version => 3, anonymous => 1);
1009
    	my $mesg = $ldap->search (
1010
        	base   => $base,
1011
        	filter => $filter,
1012
        	attrs => @$attref,
1013
    	);
1014

    
1015
    	if ($mesg->count() > 0) {
1016
        	$foundAccounts = "";
1017
        	my $entry;
1018
        	foreach $entry ($mesg->sorted(['sn'])) {
1019
          		$foundAccounts .= "<tr>\n<td class=\"main\">\n";
1020
          		$foundAccounts .= "<a href=\"" unless 
1021
                    (!$entry->get_value('labeledURI'));
1022
         		 $foundAccounts .= $entry->get_value('labeledURI') unless
1023
                    (!$entry->get_value('labeledURI'));
1024
          		$foundAccounts .= "\">\n" unless 
1025
                    (!$entry->get_value('labeledURI'));
1026
          		$foundAccounts .= $entry->get_value('givenName');
1027
          		$foundAccounts .= "</a>\n" unless 
1028
                    (!$entry->get_value('labeledURI'));
1029
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1030
          		$foundAccounts .= "<a href=\"" unless 
1031
                    (!$entry->get_value('labeledURI'));
1032
          		$foundAccounts .= $entry->get_value('labeledURI') unless
1033
                    (!$entry->get_value('labeledURI'));
1034
          		$foundAccounts .= "\">\n" unless 
1035
                    (!$entry->get_value('labeledURI'));
1036
          		$foundAccounts .= $entry->get_value('sn');
1037
          		$foundAccounts .= "</a>\n";
1038
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1039
          		$foundAccounts .= $entry->get_value('mail');
1040
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1041
          		$foundAccounts .= $entry->get_value('telephonenumber');
1042
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1043
          		$foundAccounts .= $entry->get_value('title');
1044
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1045
          		$foundAccounts .= $entry->get_value('ou');
1046
          		$foundAccounts .= "\n</td>\n";
1047
          		$foundAccounts .= "</tr>\n";
1048
        	}
1049
    	}
1050
    	$ldap->unbind;   # take down session
1051
    }
1052
    return $foundAccounts;
1053
}
1054

    
1055
sub debug {
1056
    my $msg = shift;
1057
    
1058
    if ($debug) {
1059
        print STDERR "LDAPweb: $msg\n";
1060
    }
1061
}
1062

    
1063
sub handleLDAPBindFailure {
1064
    my $ldapAttemptUrl = shift;
1065
    my $primaryLdap =  $properties->getProperty('auth.url');
1066

    
1067
    if ($ldapAttemptUrl eq  $primaryLdap) {
1068
        handleGeneralServerFailure("The main LDAP server $ldapurl is down!");
1069
    } else {
1070
        debug("attempted to bind to nonresponsive LDAP server $ldapAttemptUrl, skipped.");
1071
    }
1072
}
1073

    
1074
sub handleGeneralServerFailure {
1075
    my $errorMessage = shift;
1076
    fullTemplate( ['mainServerFailure'], { errorMessage => $errorMessage });
1077
    exit(0);   
1078
   }
1079
    
1080
sub setVars {
1081
    my $paramVars = shift;
1082
    # initialize default parameters 
1083
    my $templateVars = { cfg => $cfg,
1084
                         styleSkinsPath => $contextUrl . "/style/skins",
1085
                         styleCommonPath => $contextUrl . "/style/common",
1086
                         contextUrl => $contextUrl,
1087
                         cgiPrefix => $cgiPrefix,
1088
                         orgList => \@orgList,
1089
                         config  => $config,
1090
    };
1091
    
1092
    # append customized params
1093
    while (my ($k, $v) = each (%$paramVars)) {
1094
        $templateVars->{$k} = $v;
1095
    }
1096
    
1097
    return $templateVars;
1098
} 
(10-10/14)