Project

General

Profile

1
#!/usr/bin/perl -w
2
#
3
#  '$RCSfile$'
4
#  Copyright: 2001 Regents of the University of California 
5
#
6
#   '$Author: walbridge $'
7
#     '$Date: 2010-11-16 18:10:17 -0800 (Tue, 16 Nov 2010) $'
8
# '$Revision: 5650 $' 
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 $contextUrl = 'http://' . $properties->getProperty('server.name');
66
if ($properties->getProperty('server.httpPort') ne '80') {
67
        $contextUrl = $contextUrl . ':' . $properties->getProperty('server.httpPort');
68
}
69
$contextUrl = $contextUrl . '/' .  $properties->getProperty('application.context');
70

    
71
my $metacatUrl = $contextUrl . "/metacat";
72
my $cgiPrefix = "/" . $properties->getProperty('application.context') . "/cgi-bin";
73
my $styleSkinsPath = $contextUrl . "/style/skins";
74
my $styleCommonPath = $contextUrl . "/style/common";
75

    
76
my @errorMessages;
77
my $error = 0;
78

    
79
# Import all of the HTML form fields as variables
80
import_names('FORM');
81

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

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

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

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

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

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

    
136
# XXX END HACK
137

    
138

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

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

    
149
# Get the CGI input variables
150
my $query = new CGI;
151
my $debug = 1;
152

    
153
#--------------------------------------------------------------------------80c->
154
# Set up the Template Toolkit to read html form templates
155

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

    
161
# set some configuration options for the template object
162
my $ttConfig = {
163
             INCLUDE_PATH => $templatesDir,
164
             INTERPOLATE  => 0,
165
             POST_CHOMP   => 1,
166
             DEBUG        => 1, 
167
             };
168

    
169
# create an instance of the template
170
my $template = Template->new($ttConfig) || handleGeneralServerFailure($Template::ERROR);
171

    
172
# custom LDAP properties hash
173
my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');
174

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

    
180
my @orgList;
181
while (my ($oKey, $oVal) = each(%$orgNames)) {
182
    push(@orgList, $oKey);
183
}
184

    
185
my $authBase = $properties->getProperty("auth.base");
186
my $ldapConfig;
187
foreach my $o (@orgList) {
188
    foreach my $d (@orgData) {
189
        $ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");
190
    }
191

    
192
    # XXX hack, remove after 1.9
193
    if ($o eq 'UCNRS') {
194
        $ldapConfig->{'UCNRS'}{'base'} = $nrsConfig->{'base'};
195
        $ldapConfig->{'UCNRS'}{'user'} = $nrsConfig->{'username'};
196
        $ldapConfig->{'UCNRS'}{'password'} = $nrsConfig->{'password'};
197
    }
198

    
199
    # set default base
200
    if (!$ldapConfig->{$o}{'base'}) {
201
        $ldapConfig->{$o}{'base'} = $authBase;
202
    }
203

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

    
233
    if (!$ldapConfig->{$o}{'password'}) {
234
        $ldapConfig->{$o}{'password'} = $ldapConfig->{'unaffiliated'}{'password'};
235
    }
236
}
237

    
238
#--------------------------------------------------------------------------80c->
239
# Define the main program logic that calls subroutines to do the work
240
#--------------------------------------------------------------------------80c->
241

    
242
# The processing step we are handling
243
my $stage = $query->param('stage') || $templates->{'stage'};
244

    
245
my $cfg = $query->param('cfg');
246
debug("started with stage $stage, cfg $cfg");
247

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

    
264
# call the appropriate routine based on the stage
265
if ( $stages{$stage} ) {
266
  $stages{$stage}->();
267
} else {
268
  &handleResponseMessage();
269
}
270

    
271
#--------------------------------------------------------------------------80c->
272
# Define the subroutines to do the work
273
#--------------------------------------------------------------------------80c->
274

    
275
sub fullTemplate {
276
    my $templateList = shift;
277
    my $templateVars = setVars(shift);
278

    
279
    $template->process( $templates->{'header'}, $templateVars );
280
    foreach my $tmpl (@{$templateList}) {
281
        $template->process( $templates->{$tmpl}, $templateVars );
282
    }
283
    $template->process( $templates->{'footer'}, $templateVars );
284
}
285

    
286
#
287
# create the initial registration form 
288
#
289
sub handleInitRegister {
290
  my $vars = shift;
291

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

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

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

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

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

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

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

    
364
    exit();
365
}
366

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

    
388
#
389
# change a user's password upon request
390
#
391
sub handleChangePassword {
392

    
393
    print "Content-type: text/html\n\n";
394

    
395
    my $allParams = { 'test' => "1", };
396
    if ($query->param('uid')) {
397
        $$allParams{'uid'} = $query->param('uid');
398
    }
399
    if ($query->param('o')) {
400
        $$allParams{'o'} = $query->param('o');
401
        my $o = $query->param('o');
402
        
403
        $searchBase = $ldapConfig->{$o}{'base'};
404
    }
405

    
406

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

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

    
422
        my $o = $query->param('o');
423
        $searchBase = $ldapConfig->{$o}{'base'};
424
        $ldapUsername = $ldapConfig->{$o}{'user'};
425
        $ldapPassword = $ldapConfig->{$o}{'password'};
426

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

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

    
461
    my $allParams = { 'test' => "1", };
462
    my $errorMessage = "";
463
    fullTemplate( ['changePass'], { stage => "changepass",
464
                                    errorMessage => $errorMessage });
465
    exit();
466
}
467

    
468
#
469
# reset a user's password upon request
470
#
471
sub handleResetPassword {
472

    
473
    print "Content-type: text/html\n\n";
474

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

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

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

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

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

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

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

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

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

    
574
    my $searchBase = $ldapConfig->{$o}{'base'};
575

    
576
    my $errorMessage = 0;
577
    my $ldap;
578

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

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

    
609
    return $errorMessage;
610
}
611

    
612
#
613
# generate a Seeded SHA1 hash of a plaintext password
614
#
615
sub createSeededPassHash {
616
    my $secret = shift;
617

    
618
    my $salt = "";
619
    for (my $i=0; $i < 4; $i++) {
620
        $salt .= int(rand(10));
621
    }
622

    
623
    my $ctx = Digest::SHA1->new;
624
    $ctx->add($secret);
625
    $ctx->add($salt);
626
    my $hashedPasswd = '{SSHA}' . encode_base64($ctx->digest . $salt ,'');
627

    
628
    return $hashedPasswd;
629
}
630

    
631
#
632
# Look up an ldap entry for a user
633
#
634
sub getLdapEntry {
635
    my $ldapurl = shift;
636
    my $base = shift;
637
    my $username = shift;
638
    my $org = shift;
639

    
640
    my $entry = "";
641
    my $mesg;
642
    my $ldap;
643
    debug("ldap server: $ldapurl");
644

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

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

    
688
# 
689
# send an email message notifying the user of the pw change
690
#
691
sub sendPasswordNotification {
692
    my $username = shift;
693
    my $org = shift;
694
    my $newPass = shift;
695
    my $recipient = shift;
696
    my $cfg = shift;
697

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

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

    
716
        $contextUrl/cgi-bin/ldapweb.cgi?stage=changepass&cfg=$cfg
717

    
718
            Username: $username
719
        Organization: $org
720
        New Password: $newPass
721

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

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

    
748
    my $foundAccounts = 0;
749

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

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

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

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

    
805
    return $foundAccounts;
806
}
807

    
808
#
809
# Validate that we have the proper set of input parameters
810
#
811
sub paramsAreValid {
812
    my @pnames = @_;
813

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

    
823
    return $allValid;
824
}
825

    
826
#
827
# Bind to LDAP and create a new account using the information provided
828
# by the user
829
#
830
sub createAccount {
831
    my $allParams = shift;
832

    
833
    if ($query->param('o') =~ "LTER") {
834
        fullTemplate( ['registerLter'] );
835
    } else {
836

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

    
846
        my $o = $query->param('o');
847

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

    
864
        	# Create a hashed version of the password
865
        	my $shapass = createSeededPassHash($query->param('userPassword'));
866

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

    
906
        	$ldap->unbind;   # take down session
907
        }
908
    }
909
}
910

    
911
sub handleResponseMessage {
912

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

    
921
#
922
# perform a simple search against the LDAP database using 
923
# a small subset of attributes of each dn and return it
924
# as a table to the calling browser.
925
#
926
sub handleSimpleSearch {
927

    
928
    my $o = $query->param('o');
929

    
930
    my $ldapurl = $ldapConfig->{$o}{'url'};
931
    my $searchBase = $ldapConfig->{$o}{'base'};
932

    
933
    print "Content-type: text/html\n\n";
934

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

    
949
    # Search LDAP for matching entries that already exist
950
    my $filter = "(" . 
951
                 $query->param('searchField') . "=" .
952
                 "*" .
953
                 $query->param('searchValue') .
954
                 "*" .
955
                 ")";
956

    
957
    my @attrs = [ 'sn', 
958
                  'gn', 
959
                  'cn', 
960
                  'o', 
961
                  'facsimiletelephonenumber', 
962
                  'mail', 
963
                  'telephoneNumber', 
964
                  'title', 
965
                  'uid', 
966
                  'labeledURI', 
967
                  'ou' ];
968

    
969
    my $found = searchDirectory($ldapurl, $searchBase, $filter, \@attrs);
970

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

    
979
      fullTemplate( ('searchResults'), { stage => "searchresults",
980
                                         allParams => $allParams,
981
                                         foundAccounts => $found });
982
    }
983

    
984
    exit();
985
}
986

    
987
#
988
# search the LDAP directory to see if a similar account already exists
989
#
990
sub searchDirectory {
991
    my $ldapurl = shift;
992
    my $base = shift;
993
    my $filter = shift;
994
    my $attref = shift;
995

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

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

    
1051
sub debug {
1052
    my $msg = shift;
1053
    
1054
    if ($debug) {
1055
        print STDERR "LDAPweb: $msg\n";
1056
    }
1057
}
1058

    
1059
sub handleLDAPBindFailure {
1060
    my $ldapAttemptUrl = shift;
1061
    my $primaryLdap =  $properties->getProperty('auth.url');
1062

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

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