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: 2009-03-26 14:04:46 -0700 (Thu, 26 Mar 2009) $'
8
# '$Revision: 4870 $' 
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 . '.cfg';
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
				$foundAccounts .= "<p>\n<b><u>Account:</u> ";
767
				$foundAccounts .= $entry->dn();
768
				$foundAccounts .= "</b><br />\n";
769
				foreach my $attribute ($entry->attributes()) {
770
					$foundAccounts .= "$attribute: ";
771
					$foundAccounts .= $entry->get_value($attribute);
772
					$foundAccounts .= "<br />\n";
773
				}
774
				$foundAccounts .= "</p>\n";
775
			}
776
        }
777
    	$ldap->unbind;   # take down session
778

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

    
793
    #print "<p>Checking referrals...</p>\n";
794
    #my @referrals = $mesg->referrals();
795
    #print "<p>Referrals count: ", scalar(@referrals), "</p>\n";
796
    #for (my $i = 0; $i <= $#referrals; $i++) {
797
        #print "<p>Referral: ", $referrals[$i], "</p>\n";
798
    #}
799

    
800
    return $foundAccounts;
801
}
802

    
803
#
804
# Validate that we have the proper set of input parameters
805
#
806
sub paramsAreValid {
807
    my @pnames = @_;
808

    
809
    my $allValid = 1;
810
    foreach my $parameter (@pnames) {
811
        if (!defined($query->param($parameter)) || 
812
            ! $query->param($parameter) ||
813
            $query->param($parameter) =~ /^\s+$/) {
814
            $allValid = 0;
815
        }
816
    }
817

    
818
    return $allValid;
819
}
820

    
821
#
822
# Bind to LDAP and create a new account using the information provided
823
# by the user
824
#
825
sub createAccount {
826
    my $allParams = shift;
827

    
828
    if ($query->param('o') =~ "LTER") {
829
        fullTemplate( ['registerLter'] );
830
    } else {
831

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

    
841
        my $o = $query->param('o');
842

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

    
859
        	# Create a hashed version of the password
860
        	my $shapass = createSeededPassHash($query->param('userPassword'));
861

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

    
901
        	$ldap->unbind;   # take down session
902
        }
903
    }
904
}
905

    
906
sub handleResponseMessage {
907

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

    
916
#
917
# perform a simple search against the LDAP database using 
918
# a small subset of attributes of each dn and return it
919
# as a table to the calling browser.
920
#
921
sub handleSimpleSearch {
922

    
923
    my $o = $query->param('o');
924

    
925
    my $ldapurl = $ldapConfig->{$o}{'url'};
926
    my $searchBase = $ldapConfig->{$o}{'base'};
927

    
928
    print "Content-type: text/html\n\n";
929

    
930
    my $allParams = { 
931
                      'cn' => $query->param('cn'),
932
                      'sn' => $query->param('sn'),
933
                      'gn' => $query->param('gn'),
934
                      'o'  => $query->param('o'),
935
                      'facsimiletelephonenumber' 
936
                      => $query->param('facsimiletelephonenumber'),
937
                      'mail' => $query->param('cmail'),
938
                      'telephonenumber' => $query->param('telephonenumber'),
939
                      'title' => $query->param('title'),
940
                      'uid' => $query->param('uid'),
941
                      'ou' => $query->param('ou'),
942
                    };
943

    
944
    # Search LDAP for matching entries that already exist
945
    my $filter = "(" . 
946
                 $query->param('searchField') . "=" .
947
                 "*" .
948
                 $query->param('searchValue') .
949
                 "*" .
950
                 ")";
951

    
952
    my @attrs = [ 'sn', 
953
                  'gn', 
954
                  'cn', 
955
                  'o', 
956
                  'facsimiletelephonenumber', 
957
                  'mail', 
958
                  'telephoneNumber', 
959
                  'title', 
960
                  'uid', 
961
                  'labeledURI', 
962
                  'ou' ];
963

    
964
    my $found = searchDirectory($ldapurl, $searchBase, $filter, \@attrs);
965

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

    
974
      fullTemplate( ('searchResults'), { stage => "searchresults",
975
                                         allParams => $allParams,
976
                                         foundAccounts => $found });
977
    }
978

    
979
    exit();
980
}
981

    
982
#
983
# search the LDAP directory to see if a similar account already exists
984
#
985
sub searchDirectory {
986
    my $ldapurl = shift;
987
    my $base = shift;
988
    my $filter = shift;
989
    my $attref = shift;
990

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

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

    
1046
sub debug {
1047
    my $msg = shift;
1048
    
1049
    if ($debug) {
1050
        print STDERR "LDAPweb: $msg\n";
1051
    }
1052
}
1053

    
1054
sub handleLDAPBindFailure {
1055
    my $ldapAttemptUrl = shift;
1056
    my $primaryLdap =  $properties->getProperty('auth.url');
1057

    
1058
    if ($ldapAttemptUrl eq  $primaryLdap) {
1059
        handleGeneralServerFailure("The main LDAP server $ldapurl is down!");
1060
    } else {
1061
        debug("attempted to bind to nonresponsive LDAP server $ldapAttemptUrl, skipped.");
1062
    }
1063
}
1064

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