Project

General

Profile

1 2341 sgarg
#!/usr/bin/perl -w
2 4865 walbridge
#
3
#  '$RCSfile$'
4
#  Copyright: 2001 Regents of the University of California
5
#
6
#   '$Author$'
7
#     '$Date$'
8
# '$Revision$'
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 2341 sgarg
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 4394 walbridge
30
use lib '../WEB-INF/lib';
31 4080 daigle
use strict;             # turn on strict syntax checking
32
use Template;           # load the template-toolkit module
33 4394 walbridge
use CGI qw/:standard :html3/; # load the CGI module
34 4080 daigle
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 4394 walbridge
use Cwd 'abs_path';
42 2341 sgarg
43 4080 daigle
# Global configuration paramters
44 4394 walbridge
# This entire block (including skin parsing) could be pushed out to a separate .pm file
45 4080 daigle
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 4394 walbridge
    print "Content-type: text/html\n\n";
51 4080 daigle
    print "Unable to locate Metacat properties. Working directory is set as " .
52
        $workingDirectory .", is this correct?";
53
    exit(0);
54
}
55 2341 sgarg
56 4080 daigle
$properties->load(*METACAT_PROPERTIES);
57 4010 tao
58 4394 walbridge
# 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 4864 walbridge
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 4394 walbridge
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 4747 walbridge
    debug("No configuration set.");
90 4394 walbridge
    print "Content-type: text/html\n\n";
91 4749 walbridge
    print 'LDAPweb Error: The registry requires a skin name to continue.';
92 4394 walbridge
    exit();
93
}
94
95
# Metacat isn't initialized, the registry will fail in strange ways.
96
if (!($metacatUrl)) {
97 4747 walbridge
    debug("No Metacat.");
98 4394 walbridge
    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
my $searchBase;
121
my $ldapUsername;
122
my $ldapPassword;
123 4728 walbridge
# TODO: when should we use surl instead? Is there a setting promoting one over the other?
124
# TODO: the default tree for accounts should be exposed somewhere, defaulting to unaffiliated
125
my $ldapurl = $properties->getProperty('auth.url');
126 4080 daigle
127
# Java uses miliseconds, Perl expects whole seconds
128 4728 walbridge
my $timeout = $properties->getProperty('ldap.connectTimeLimit') / 1000;
129 4080 daigle
130 2341 sgarg
# Get the CGI input variables
131
my $query = new CGI;
132 4747 walbridge
my $debug = 1;
133 2341 sgarg
134
#--------------------------------------------------------------------------80c->
135
# Set up the Template Toolkit to read html form templates
136
137 4080 daigle
# templates hash, imported from ldap.templates tree in metacat.properties
138
my $templates = $properties->splitToTree(qr/\./, 'ldap.templates');
139 4394 walbridge
$$templates{'header'} = $skinProperties->getProperty("registry.templates.header");
140
$$templates{'footer'} = $skinProperties->getProperty("registry.templates.footer");
141 2341 sgarg
142
# set some configuration options for the template object
143 4394 walbridge
my $ttConfig = {
144
             INCLUDE_PATH => $templatesDir,
145
             INTERPOLATE  => 0,
146
             POST_CHOMP   => 1,
147
             DEBUG        => 1,
148 2341 sgarg
             };
149
150
# create an instance of the template
151 4394 walbridge
my $template = Template->new($ttConfig) || handleGeneralServerFailure($Template::ERROR);
152 2341 sgarg
153 4080 daigle
# custom LDAP properties hash
154
my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');
155 2341 sgarg
156 4394 walbridge
my $orgProps = $properties->splitToTree(qr/\./, 'organization');
157
my $orgNames = $properties->splitToTree(qr/\./, 'organization.name');
158
# pull out properties available e.g. 'name', 'base'
159
my @orgData = keys(%$orgProps);
160
my @orgList;
161
while (my ($oKey, $oVal) = each(%$orgNames)) {
162
    push(@orgList, $oKey);
163
}
164
165 4080 daigle
my $ldapConfig;
166
foreach my $o (@orgList) {
167 4394 walbridge
    foreach my $d (@orgData) {
168
        $ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");
169 4080 daigle
    }
170 4394 walbridge
    # also include DN, which is just org + base
171
    if ($ldapConfig->{$o}{'org'}) {
172
        $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'org'} . "," . $ldapConfig->{$o}{'base'};
173
    } else {
174
        $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'base'};
175
    }
176 4865 walbridge
177
    # include filter information. By default, our filters are 'o=$name', e.g. 'o=NAPIER'
178
    # these can be overridden by specifying them in metacat.properties.
179
    if (!$ldapConfig->{$o}{'filter'}) {
180
        $ldapConfig->{$o}{'filter'} = "o=$o";
181
    }
182 2341 sgarg
}
183
184
#--------------------------------------------------------------------------80c->
185
# Define the main program logic that calls subroutines to do the work
186
#--------------------------------------------------------------------------80c->
187
188
# The processing step we are handling
189 4080 daigle
my $stage = $query->param('stage') || $templates->{'stage'};
190 2341 sgarg
191
my $cfg = $query->param('cfg');
192 4767 walbridge
debug("started with stage $stage, cfg $cfg");
193 2341 sgarg
194
# define the possible stages
195
my %stages = (
196
              'initregister'      => \&handleInitRegister,
197
              'register'          => \&handleRegister,
198
              'registerconfirmed' => \&handleRegisterConfirmed,
199
              'simplesearch'      => \&handleSimpleSearch,
200
              'initaddentry'      => \&handleInitAddEntry,
201
              'addentry'          => \&handleAddEntry,
202
              'initmodifyentry'   => \&handleInitModifyEntry,
203
              'modifyentry'       => \&handleModifyEntry,
204 2972 jones
              'changepass'        => \&handleChangePassword,
205
              'initchangepass'    => \&handleInitialChangePassword,
206 2341 sgarg
              'resetpass'         => \&handleResetPassword,
207 2414 sgarg
              'initresetpass'     => \&handleInitialResetPassword,
208 2341 sgarg
             );
209 4394 walbridge
210 2341 sgarg
# call the appropriate routine based on the stage
211
if ( $stages{$stage} ) {
212
  $stages{$stage}->();
213
} else {
214
  &handleResponseMessage();
215
}
216
217
#--------------------------------------------------------------------------80c->
218
# Define the subroutines to do the work
219
#--------------------------------------------------------------------------80c->
220
221 4728 walbridge
sub fullTemplate {
222
    my $templateList = shift;
223
    my $templateVars = setVars(shift);
224 2341 sgarg
225 4728 walbridge
    $template->process( $templates->{'header'}, $templateVars );
226
    foreach my $tmpl (@{$templateList}) {
227
        $template->process( $templates->{$tmpl}, $templateVars );
228
    }
229
    $template->process( $templates->{'footer'}, $templateVars );
230
}
231
232 2341 sgarg
#
233
# create the initial registration form
234
#
235
sub handleInitRegister {
236
  my $vars = shift;
237
238
  print "Content-type: text/html\n\n";
239
  # process the template files:
240 4080 daigle
  fullTemplate(['register'], {stage => "register"});
241 2341 sgarg
  exit();
242
}
243
244
#
245
# process input from the register stage, which occurs when
246
# a user submits form data to create a new account
247
#
248
sub handleRegister {
249
250
    print "Content-type: text/html\n\n";
251
252
    my $allParams = { 'givenName' => $query->param('givenName'),
253
                      'sn' => $query->param('sn'),
254
                      'o' => $query->param('o'),
255
                      'mail' => $query->param('mail'),
256
                      'uid' => $query->param('uid'),
257
                      'userPassword' => $query->param('userPassword'),
258
                      'userPassword2' => $query->param('userPassword2'),
259
                      'title' => $query->param('title'),
260
                      'telephoneNumber' => $query->param('telephoneNumber') };
261
    # Check that all required fields are provided and not null
262
    my @requiredParams = ( 'givenName', 'sn', 'o', 'mail',
263
                           'uid', 'userPassword', 'userPassword2');
264
    if (! paramsAreValid(@requiredParams)) {
265
        my $errorMessage = "Required information is missing. " .
266
            "Please fill in all required fields and resubmit the form.";
267 4080 daigle
        fullTemplate(['register'], { stage => "register",
268
                                     allParams => $allParams,
269
                                     errorMessage => $errorMessage });
270
        exit();
271 2341 sgarg
    } else {
272 2972 jones
        my $o = $query->param('o');
273 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
274 2341 sgarg
    }
275
276
    # Search LDAP for matching entries that already exist
277
    # Some forms use a single text search box, whereas others search per
278
    # attribute.
279
    my $filter;
280
    if ($query->param('searchField')) {
281
282
      $filter = "(|" .
283
                "(uid=" . $query->param('searchField') . ") " .
284
                "(mail=" . $query->param('searchField') . ")" .
285
                "(&(sn=" . $query->param('searchField') . ") " .
286
                "(givenName=" . $query->param('searchField') . "))" .
287
                ")";
288
    } else {
289
      $filter = "(|" .
290
                "(uid=" . $query->param('uid') . ") " .
291
                "(mail=" . $query->param('mail') . ")" .
292
                "(&(sn=" . $query->param('sn') . ") " .
293
                "(givenName=" . $query->param('givenName') . "))" .
294
                ")";
295
    }
296
297
    my @attrs = [ 'uid', 'o', 'cn', 'mail', 'telephoneNumber', 'title' ];
298
    my $found = findExistingAccounts($ldapurl, $searchBase, $filter, \@attrs);
299
300
    # If entries match, send back a request to confirm new-user creation
301
    if ($found) {
302 4080 daigle
      fullTemplate( ['registerMatch', 'register'], { stage => "registerconfirmed",
303
                                                     allParams => $allParams,
304
                                                     foundAccounts => $found });
305 2341 sgarg
    # Otherwise, create a new user in the LDAP directory
306
    } else {
307
        createAccount($allParams);
308
    }
309
310
    exit();
311
}
312
313
#
314
# process input from the registerconfirmed stage, which occurs when
315
# a user chooses to create an account despite similarities to other
316
# existing accounts
317
#
318
sub handleRegisterConfirmed {
319
320
    my $allParams = { 'givenName' => $query->param('givenName'),
321
                      'sn' => $query->param('sn'),
322 4080 daigle
                      'o' => 'unaffiliated', # only accept unaffiliated registration
323 2341 sgarg
                      'mail' => $query->param('mail'),
324
                      'uid' => $query->param('uid'),
325
                      'userPassword' => $query->param('userPassword'),
326
                      'userPassword2' => $query->param('userPassword2'),
327
                      'title' => $query->param('title'),
328
                      'telephoneNumber' => $query->param('telephoneNumber') };
329
    print "Content-type: text/html\n\n";
330
    createAccount($allParams);
331
    exit();
332
}
333
334
#
335
# change a user's password upon request
336
#
337
sub handleChangePassword {
338
339
    print "Content-type: text/html\n\n";
340
341
    my $allParams = { 'test' => "1", };
342
    if ($query->param('uid')) {
343
        $$allParams{'uid'} = $query->param('uid');
344
    }
345
    if ($query->param('o')) {
346
        $$allParams{'o'} = $query->param('o');
347 2972 jones
        my $o = $query->param('o');
348
349 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
350 2341 sgarg
    }
351
352
353
    # Check that all required fields are provided and not null
354
    my @requiredParams = ( 'uid', 'o', 'oldpass',
355
                           'userPassword', 'userPassword2');
356
    if (! paramsAreValid(@requiredParams)) {
357
        my $errorMessage = "Required information is missing. " .
358
            "Please fill in all required fields and submit the form.";
359 4080 daigle
        fullTemplate( ['changePass'], { stage => "changepass",
360
                                        allParams => $allParams,
361
                                        errorMessage => $errorMessage });
362
        exit();
363 2341 sgarg
    }
364
365
    # We have all of the info we need, so try to change the password
366
    if ($query->param('userPassword') =~ $query->param('userPassword2')) {
367
368 2972 jones
        my $o = $query->param('o');
369 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
370
        $ldapUsername = $ldapConfig->{$o}{'user'};
371
        $ldapPassword = $ldapConfig->{$o}{'password'};
372 2341 sgarg
373 4080 daigle
        my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};;
374 2341 sgarg
        if ($query->param('o') =~ "LTER") {
375 4080 daigle
            fullTemplate( ['registerLter'] );
376 2341 sgarg
        } else {
377
            my $errorMessage = changePassword(
378
                    $dn, $query->param('userPassword'),
379
                    $dn, $query->param('oldpass'), $query->param('o'));
380 2972 jones
            if ($errorMessage) {
381 4080 daigle
                fullTemplate( ['changePass'], { stage => "changepass",
382
                                                allParams => $allParams,
383
                                                errorMessage => $errorMessage });
384
                exit();
385 2341 sgarg
            } else {
386 4080 daigle
                fullTemplate( ['changePassSuccess'], { stage => "changepass",
387
                                                       allParams => $allParams });
388
                exit();
389 2341 sgarg
            }
390
        }
391
    } else {
392
        my $errorMessage = "The passwords do not match. Try again.";
393 4080 daigle
        fullTemplate( ['changePass'], { stage => "changepass",
394
                                        allParams => $allParams,
395
                                        errorMessage => $errorMessage });
396
        exit();
397 2341 sgarg
    }
398
}
399
400
#
401 2414 sgarg
# change a user's password upon request - no input params
402
# only display chagepass template without any error
403
#
404
sub handleInitialChangePassword {
405
    print "Content-type: text/html\n\n";
406
407
    my $allParams = { 'test' => "1", };
408
    my $errorMessage = "";
409 4080 daigle
    fullTemplate( ['changePass'], { stage => "changepass",
410
                                    errorMessage => $errorMessage });
411
    exit();
412 2414 sgarg
}
413
414
#
415 2341 sgarg
# reset a user's password upon request
416
#
417
sub handleResetPassword {
418
419
    print "Content-type: text/html\n\n";
420
421
    my $allParams = { 'test' => "1", };
422
    if ($query->param('uid')) {
423
        $$allParams{'uid'} = $query->param('uid');
424
    }
425
    if ($query->param('o')) {
426
        $$allParams{'o'} = $query->param('o');
427 2972 jones
        my $o = $query->param('o');
428
429 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
430 4774 daigle
        $ldapUsername = $ldapConfig->{$o}{'user'} . ',' . $searchBase;
431 4080 daigle
        $ldapPassword = $ldapConfig->{$o}{'password'};
432 2341 sgarg
    }
433
434
    # Check that all required fields are provided and not null
435
    my @requiredParams = ( 'uid', 'o' );
436
    if (! paramsAreValid(@requiredParams)) {
437
        my $errorMessage = "Required information is missing. " .
438
            "Please fill in all required fields and submit the form.";
439 4080 daigle
        fullTemplate( ['resetPass'],  { stage => "resetpass",
440
                                        allParams => $allParams,
441
                                        errorMessage => $errorMessage });
442
        exit();
443 2341 sgarg
    }
444
445
    # We have all of the info we need, so try to change the password
446
    my $o = $query->param('o');
447 4080 daigle
    my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};
448 2341 sgarg
    if ($query->param('o') =~ "LTER") {
449 4080 daigle
        fullTemplate( ['registerLter'] );
450
        exit();
451 2341 sgarg
    } else {
452
        my $errorMessage = "";
453
        my $recipient;
454
        my $userPass;
455
        my $entry = getLdapEntry($ldapurl, $searchBase,
456
                $query->param('uid'), $query->param('o'));
457
458
        if ($entry) {
459
            $recipient = $entry->get_value('mail');
460
            $userPass = getRandomPassword();
461 4080 daigle
            $errorMessage = changePassword($dn, $userPass, $ldapUsername, $ldapPassword, $query->param('o'));
462 2341 sgarg
        } else {
463
            $errorMessage = "User not found in database.  Please try again.";
464
        }
465
466
        if ($errorMessage) {
467 4080 daigle
            fullTemplate( ['resetPass'], { stage => "resetpass",
468
                                           allParams => $allParams,
469
                                           errorMessage => $errorMessage });
470
            exit();
471 2341 sgarg
        } else {
472
            my $errorMessage = sendPasswordNotification($query->param('uid'),
473 2972 jones
                    $query->param('o'), $userPass, $recipient, $cfg);
474 4080 daigle
            fullTemplate( ['resetPassSuccess'], { stage => "resetpass",
475
                                                  allParams => $allParams,
476
                                                  errorMessage => $errorMessage });
477
            exit();
478 2341 sgarg
        }
479
    }
480
}
481
482
#
483 2414 sgarg
# reset a user's password upon request- no initial params
484
# only display resetpass template without any error
485
#
486
sub handleInitialResetPassword {
487
    print "Content-type: text/html\n\n";
488
    my $errorMessage = "";
489 4080 daigle
    fullTemplate( ['resetPass'], { stage => "resetpass",
490
                                   errorMessage => $errorMessage });
491
    exit();
492 2414 sgarg
}
493
494
#
495 2341 sgarg
# Construct a random string to use for a newly reset password
496
#
497
sub getRandomPassword {
498
    my $length = shift;
499
    if (!$length) {
500
        $length = 8;
501
    }
502
    my $newPass = "";
503
504
    my @chars = ( "A" .. "Z", "a" .. "z", 0 .. 9, qw(! @ $ ^) );
505
    $newPass = join("", @chars[ map { rand @chars } ( 1 .. $length ) ]);
506
    return $newPass;
507
}
508
509
#
510
# Change a password to a new value, binding as the provided user
511
#
512
sub changePassword {
513
    my $userDN = shift;
514
    my $userPass = shift;
515
    my $bindDN = shift;
516
    my $bindPass = shift;
517
    my $o = shift;
518
519 4080 daigle
    my $searchBase = $ldapConfig->{$o}{'base'};
520 2341 sgarg
521
    my $errorMessage = 0;
522 3177 tao
    my $ldap;
523 4394 walbridge
524 4771 walbridge
    #if main ldap server is down, a html file containing warning message will be returned
525
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
526 4394 walbridge
527 4849 daigle
    if ($ldap) {
528
    	#$ldap->start_tls( verify => 'require',
529 2972 jones
                      #cafile => '/usr/share/ssl/ldapcerts/cacert.pem');
530 4849 daigle
    	$ldap->start_tls( verify => 'none');
531
    	my $bindresult = $ldap->bind( version => 3, dn => $bindDN,
532 2341 sgarg
                                  password => $bindPass );
533 4849 daigle
    	if ($bindresult->code) {
534
        	$errorMessage = "Failed to log in. Are you sure your connection credentails are " .
535 4774 daigle
                        "correct? Please correct and try again...";
536 4849 daigle
       	 	return $errorMessage;
537
    	}
538 2341 sgarg
539 4849 daigle
    	# Find the user here and change their entry
540
    	my $newpass = createSeededPassHash($userPass);
541
    	my $modifications = { userPassword => $newpass };
542
    	my $result = $ldap->modify( $userDN, replace => { %$modifications });
543 2341 sgarg
544 4849 daigle
    	if ($result->code()) {
545
        	my $errorMessage = "There was an error changing the password." .
546 2341 sgarg
                           "<br />\n" . $result->error;
547 4849 daigle
    	}
548
    	$ldap->unbind;   # take down session
549
    }
550 2341 sgarg
551
    return $errorMessage;
552
}
553
554
#
555
# generate a Seeded SHA1 hash of a plaintext password
556
#
557
sub createSeededPassHash {
558
    my $secret = shift;
559
560
    my $salt = "";
561
    for (my $i=0; $i < 4; $i++) {
562
        $salt .= int(rand(10));
563
    }
564
565
    my $ctx = Digest::SHA1->new;
566
    $ctx->add($secret);
567
    $ctx->add($salt);
568
    my $hashedPasswd = '{SSHA}' . encode_base64($ctx->digest . $salt ,'');
569
570
    return $hashedPasswd;
571
}
572
573
#
574
# Look up an ldap entry for a user
575
#
576
sub getLdapEntry {
577
    my $ldapurl = shift;
578
    my $base = shift;
579
    my $username = shift;
580
    my $org = shift;
581
582
    my $entry = "";
583
    my $mesg;
584 3177 tao
    my $ldap;
585 4749 walbridge
    debug("ldap server: $ldapurl");
586 4394 walbridge
587
    #if main ldap server is down, a html file containing warning message will be returned
588 4771 walbridge
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
589 4849 daigle
590
    if ($ldap) {
591
    	$ldap->start_tls( verify => 'none');
592
    	my $bindresult = $ldap->bind;
593
    	if ($bindresult->code) {
594
        	return $entry;
595
    	}
596 2341 sgarg
597 4849 daigle
    	if($ldapConfig->{$org}{'filter'}){
598 4865 walbridge
            debug("getLdapEntry: filter set, searching for base=$base, " .
599
                  "(&(uid=$username)($ldapConfig->{$org}{'filter'})");
600 4849 daigle
        	$mesg = $ldap->search ( base   => $base,
601 4080 daigle
                filter => "(&(uid=$username)($ldapConfig->{$org}{'filter'}))");
602 4849 daigle
    	} else {
603 4865 walbridge
            debug("getLdapEntry: no filter, searching for $base, (uid=$username)");
604 4849 daigle
        	$mesg = $ldap->search ( base   => $base, filter => "(uid=$username)");
605
    	}
606 3177 tao
607 4849 daigle
    	if ($mesg->count > 0) {
608
        	$entry = $mesg->pop_entry;
609
        	$ldap->unbind;   # take down session
610
    	} else {
611
        	$ldap->unbind;   # take down session
612
        	# Follow references by recursive call to self
613
        	my @references = $mesg->references();
614
        	for (my $i = 0; $i <= $#references; $i++) {
615
            	my $uri = URI->new($references[$i]);
616
            	my $host = $uri->host();
617
            	my $path = $uri->path();
618
            	$path =~ s/^\///;
619
            	$entry = &getLdapEntry($host, $path, $username, $org);
620
            	if ($entry) {
621 4865 walbridge
                    debug("getLdapEntry: recursion found $host, $path, $username, $org");
622 4849 daigle
                	return $entry;
623
            	}
624
        	}
625
    	}
626 2341 sgarg
    }
627
    return $entry;
628
}
629
630
#
631
# send an email message notifying the user of the pw change
632
#
633
sub sendPasswordNotification {
634
    my $username = shift;
635
    my $org = shift;
636
    my $newPass = shift;
637
    my $recipient = shift;
638 2972 jones
    my $cfg = shift;
639 2341 sgarg
640
    my $errorMessage = "";
641
    if ($recipient) {
642 4771 walbridge
        my $mailhost = $properties->getProperty('email.mailhost');
643
        my $sender =  $properties->getProperty('email.sender');
644 2341 sgarg
        # Send the email message to them
645
        my $smtp = Net::SMTP->new($mailhost);
646
        $smtp->mail($sender);
647
        $smtp->to($recipient);
648
649
        my $message = <<"        ENDOFMESSAGE";
650
        To: $recipient
651
        From: $sender
652
        Subject: KNB Password Reset
653
654
        Somebody (hopefully you) requested that your KNB password be reset.
655
        This is generally done when somebody forgets their password.  Your
656
        password can be changed by visiting the following URL:
657
658 4864 walbridge
        $contextUrl/cgi-bin/ldapweb.cgi?stage=changepass&cfg=$cfg
659 2341 sgarg
660
            Username: $username
661
        Organization: $org
662
        New Password: $newPass
663
664
        Thanks,
665
            The KNB Development Team
666
667
        ENDOFMESSAGE
668
        $message =~ s/^[ \t\r\f]+//gm;
669
670
        $smtp->data($message);
671
        $smtp->quit;
672
    } else {
673
        $errorMessage = "Failed to send password because I " .
674
                        "couldn't find a valid email address.";
675
    }
676
    return $errorMessage;
677
}
678
679
#
680
# search the LDAP directory to see if a similar account already exists
681
#
682
sub findExistingAccounts {
683
    my $ldapurl = shift;
684
    my $base = shift;
685
    my $filter = shift;
686
    my $attref = shift;
687 3175 tao
    my $ldap;
688 4847 daigle
    my $mesg;
689 2341 sgarg
690
    my $foundAccounts = 0;
691 4749 walbridge
692 4394 walbridge
    #if main ldap server is down, a html file containing warning message will be returned
693 4767 walbridge
    debug("connecting to LDAP in findExistingAccounts with settings $ldapurl, $timeout");
694 4771 walbridge
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
695 4845 daigle
    if ($ldap) {
696
    	$ldap->start_tls( verify => 'none');
697
    	$ldap->bind( version => 3, anonymous => 1);
698 4848 daigle
		$mesg = $ldap->search (
699 4845 daigle
			base   => $base,
700
			filter => $filter,
701
			attrs => @$attref,
702
		);
703 2341 sgarg
704 4845 daigle
	    if ($mesg->count() > 0) {
705
			$foundAccounts = "";
706
			my $entry;
707
			foreach $entry ($mesg->all_entries) {
708 4846 daigle
				$foundAccounts .= "<p>\n<b><u>Account:</u> ";
709 4845 daigle
				$foundAccounts .= $entry->dn();
710
				$foundAccounts .= "</b><br />\n";
711
				foreach my $attribute ($entry->attributes()) {
712
					$foundAccounts .= "$attribute: ";
713
					$foundAccounts .= $entry->get_value($attribute);
714
					$foundAccounts .= "<br />\n";
715
				}
716
				$foundAccounts .= "</p>\n";
717
			}
718 2341 sgarg
        }
719 4845 daigle
    	$ldap->unbind;   # take down session
720 2341 sgarg
721 4848 daigle
    	# Follow references
722
    	my @references = $mesg->references();
723
    	for (my $i = 0; $i <= $#references; $i++) {
724
        	my $uri = URI->new($references[$i]);
725
        	my $host = $uri->host();
726
        	my $path = $uri->path();
727
        	$path =~ s/^\///;
728
        	my $refFound = &findExistingAccounts($host, $path, $filter, $attref);
729
        	if ($refFound) {
730
            	$foundAccounts .= $refFound;
731
        	}
732
    	}
733 2341 sgarg
    }
734
735
    #print "<p>Checking referrals...</p>\n";
736
    #my @referrals = $mesg->referrals();
737
    #print "<p>Referrals count: ", scalar(@referrals), "</p>\n";
738
    #for (my $i = 0; $i <= $#referrals; $i++) {
739
        #print "<p>Referral: ", $referrals[$i], "</p>\n";
740
    #}
741
742
    return $foundAccounts;
743
}
744
745
#
746
# Validate that we have the proper set of input parameters
747
#
748
sub paramsAreValid {
749
    my @pnames = @_;
750
751
    my $allValid = 1;
752
    foreach my $parameter (@pnames) {
753
        if (!defined($query->param($parameter)) ||
754
            ! $query->param($parameter) ||
755
            $query->param($parameter) =~ /^\s+$/) {
756
            $allValid = 0;
757
        }
758
    }
759
760
    return $allValid;
761
}
762
763
#
764
# Bind to LDAP and create a new account using the information provided
765
# by the user
766
#
767
sub createAccount {
768
    my $allParams = shift;
769
770
    if ($query->param('o') =~ "LTER") {
771 4080 daigle
        fullTemplate( ['registerLter'] );
772 2341 sgarg
    } else {
773
774
        # Be sure the passwords match
775
        if ($query->param('userPassword') !~ $query->param('userPassword2')) {
776
            my $errorMessage = "The passwords do not match. Try again.";
777 4080 daigle
            fullTemplate( ['registerFailed', 'register'], { stage => "register",
778
                                                            allParams => $allParams,
779
                                                            errorMessage => $errorMessage });
780
            exit();
781 2341 sgarg
        }
782
783 2972 jones
        my $o = $query->param('o');
784 2341 sgarg
785 4080 daigle
        my $searchBase = $ldapConfig->{$o}{'base'};
786
        my $dnBase = $ldapConfig->{$o}{'dn'};
787 4749 walbridge
        my $ldapUsername = $ldapConfig->{$o}{'user'} . ',' . $searchBase;
788
        my $ldapPassword = $ldapConfig->{$o}{'password'};
789 4771 walbridge
        debug("LDAP connection to $ldapurl...");
790 3177 tao
        #if main ldap server is down, a html file containing warning message will be returned
791 4771 walbridge
        my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
792 3177 tao
793 4849 daigle
        if ($ldap) {
794
        	$ldap->start_tls( verify => 'none');
795
        	debug("Attempting to bind to LDAP server with dn = $ldapUsername, pwd = $ldapPassword");
796
        	$ldap->bind( version => 3, dn => $ldapUsername, password => $ldapPassword );
797 3177 tao
798 4849 daigle
        	my $dn = 'uid=' . $query->param('uid') . ',' . $dnBase;
799
        	debug("Inserting new entry for: $dn");
800 2341 sgarg
801 4849 daigle
        	# Create a hashed version of the password
802
        	my $shapass = createSeededPassHash($query->param('userPassword'));
803 2341 sgarg
804 4849 daigle
        	# Do the insertion
805
        	my $additions = [
806 2341 sgarg
                'uid'   => $query->param('uid'),
807
                'o'   => $query->param('o'),
808
                'cn'   => join(" ", $query->param('givenName'),
809
                                    $query->param('sn')),
810
                'sn'   => $query->param('sn'),
811
                'givenName'   => $query->param('givenName'),
812
                'mail' => $query->param('mail'),
813
                'userPassword' => $shapass,
814
                'objectclass' => ['top', 'person', 'organizationalPerson',
815
                                'inetOrgPerson', 'uidObject' ]
816 4849 daigle
            	];
817
        	if (defined($query->param('telephoneNumber')) &&
818
            	$query->param('telephoneNumber') &&
819
            	! $query->param('telephoneNumber') =~ /^\s+$/) {
820
            	$$additions[$#$additions + 1] = 'telephoneNumber';
821
            	$$additions[$#$additions + 1] = $query->param('telephoneNumber');
822
        	}
823
        	if (defined($query->param('title')) &&
824
            	$query->param('title') &&
825
            	! $query->param('title') =~ /^\s+$/) {
826
            	$$additions[$#$additions + 1] = 'title';
827
            	$$additions[$#$additions + 1] = $query->param('title');
828
        	}
829
        	my $result = $ldap->add ( 'dn' => $dn, 'attr' => [ @$additions ]);
830 2341 sgarg
831 4849 daigle
        	if ($result->code()) {
832
            	fullTemplate( ['registerFailed', 'register'], { stage => "register",
833 4080 daigle
                                                            allParams => $allParams,
834
                                                            errorMessage => $result->error });
835 4849 daigle
            	# TODO SCW was included as separate errors, test this
836
           	 	#$templateVars    = setVars({ stage => "register",
837
           	 	#                     allParams => $allParams });
838
            	#$template->process( $templates->{'register'}, $templateVars);
839
        	} else {
840
            	fullTemplate( ['success'] );
841
        	}
842
843
        	$ldap->unbind;   # take down session
844 2341 sgarg
        }
845
    }
846
}
847
848
sub handleResponseMessage {
849
850
  print "Content-type: text/html\n\n";
851
  my $errorMessage = "You provided invalid input to the script. " .
852
                     "Try again please.";
853 4080 daigle
  fullTemplate( [], { stage => $templates->{'stage'},
854
                      errorMessage => $errorMessage });
855
  exit();
856 2341 sgarg
}
857
858
#
859
# perform a simple search against the LDAP database using
860
# a small subset of attributes of each dn and return it
861
# as a table to the calling browser.
862
#
863
sub handleSimpleSearch {
864
865
    my $o = $query->param('o');
866
867 4080 daigle
    my $ldapurl = $ldapConfig->{$o}{'url'};
868
    my $searchBase = $ldapConfig->{$o}{'base'};
869 2341 sgarg
870
    print "Content-type: text/html\n\n";
871
872
    my $allParams = {
873
                      'cn' => $query->param('cn'),
874
                      'sn' => $query->param('sn'),
875
                      'gn' => $query->param('gn'),
876
                      'o'  => $query->param('o'),
877
                      'facsimiletelephonenumber'
878
                      => $query->param('facsimiletelephonenumber'),
879
                      'mail' => $query->param('cmail'),
880
                      'telephonenumber' => $query->param('telephonenumber'),
881
                      'title' => $query->param('title'),
882
                      'uid' => $query->param('uid'),
883
                      'ou' => $query->param('ou'),
884
                    };
885
886
    # Search LDAP for matching entries that already exist
887
    my $filter = "(" .
888
                 $query->param('searchField') . "=" .
889
                 "*" .
890
                 $query->param('searchValue') .
891
                 "*" .
892
                 ")";
893
894
    my @attrs = [ 'sn',
895
                  'gn',
896
                  'cn',
897
                  'o',
898
                  'facsimiletelephonenumber',
899
                  'mail',
900
                  'telephoneNumber',
901
                  'title',
902
                  'uid',
903
                  'labeledURI',
904
                  'ou' ];
905
906
    my $found = searchDirectory($ldapurl, $searchBase, $filter, \@attrs);
907
908
    # Send back the search results
909
    if ($found) {
910 4080 daigle
      fullTemplate( ('searchResults'), { stage => "searchresults",
911
                                         allParams => $allParams,
912
                                         foundAccounts => $found });
913 2341 sgarg
    } else {
914
      $found = "No entries matched your criteria.  Please try again\n";
915
916 4080 daigle
      fullTemplate( ('searchResults'), { stage => "searchresults",
917
                                         allParams => $allParams,
918
                                         foundAccounts => $found });
919 2341 sgarg
    }
920
921
    exit();
922
}
923
924
#
925
# search the LDAP directory to see if a similar account already exists
926
#
927
sub searchDirectory {
928
    my $ldapurl = shift;
929
    my $base = shift;
930
    my $filter = shift;
931
    my $attref = shift;
932
933 4849 daigle
	my $mesg;
934 2341 sgarg
    my $foundAccounts = 0;
935 3177 tao
936
    #if ldap server is down, a html file containing warning message will be returned
937 4771 walbridge
    my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
938 3177 tao
939 4849 daigle
    if ($ldap) {
940
    	$ldap->start_tls( verify => 'none');
941
    	$ldap->bind( version => 3, anonymous => 1);
942
    	my $mesg = $ldap->search (
943
        	base   => $base,
944
        	filter => $filter,
945
        	attrs => @$attref,
946
    	);
947 2341 sgarg
948 4849 daigle
    	if ($mesg->count() > 0) {
949
        	$foundAccounts = "";
950
        	my $entry;
951
        	foreach $entry ($mesg->sorted(['sn'])) {
952
          		$foundAccounts .= "<tr>\n<td class=\"main\">\n";
953
          		$foundAccounts .= "<a href=\"" unless
954 2341 sgarg
                    (!$entry->get_value('labeledURI'));
955 4849 daigle
         		 $foundAccounts .= $entry->get_value('labeledURI') unless
956 2341 sgarg
                    (!$entry->get_value('labeledURI'));
957 4849 daigle
          		$foundAccounts .= "\">\n" unless
958 2341 sgarg
                    (!$entry->get_value('labeledURI'));
959 4849 daigle
          		$foundAccounts .= $entry->get_value('givenName');
960
          		$foundAccounts .= "</a>\n" unless
961 2341 sgarg
                    (!$entry->get_value('labeledURI'));
962 4849 daigle
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
963
          		$foundAccounts .= "<a href=\"" unless
964 2341 sgarg
                    (!$entry->get_value('labeledURI'));
965 4849 daigle
          		$foundAccounts .= $entry->get_value('labeledURI') unless
966 2341 sgarg
                    (!$entry->get_value('labeledURI'));
967 4849 daigle
          		$foundAccounts .= "\">\n" unless
968 2341 sgarg
                    (!$entry->get_value('labeledURI'));
969 4849 daigle
          		$foundAccounts .= $entry->get_value('sn');
970
          		$foundAccounts .= "</a>\n";
971
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
972
          		$foundAccounts .= $entry->get_value('mail');
973
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
974
          		$foundAccounts .= $entry->get_value('telephonenumber');
975
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
976
          		$foundAccounts .= $entry->get_value('title');
977
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
978
          		$foundAccounts .= $entry->get_value('ou');
979
          		$foundAccounts .= "\n</td>\n";
980
          		$foundAccounts .= "</tr>\n";
981
        	}
982
    	}
983
    	$ldap->unbind;   # take down session
984 2341 sgarg
    }
985
    return $foundAccounts;
986
}
987
988
sub debug {
989
    my $msg = shift;
990
991
    if ($debug) {
992 4747 walbridge
        print STDERR "LDAPweb: $msg\n";
993 2341 sgarg
    }
994
}
995 3175 tao
996 4771 walbridge
sub handleLDAPBindFailure {
997
    my $ldapAttemptUrl = shift;
998
    my $primaryLdap =  $properties->getProperty('auth.url');
999
1000
    if ($ldapAttemptUrl eq  $primaryLdap) {
1001
        handleGeneralServerFailure("The main LDAP server $ldapurl is down!");
1002
    } else {
1003
        debug("attempted to bind to nonresponsive LDAP server $ldapAttemptUrl, skipped.");
1004
    }
1005
}
1006
1007 3177 tao
sub handleGeneralServerFailure {
1008
    my $errorMessage = shift;
1009 4728 walbridge
    fullTemplate( ['mainServerFailure'], { errorMessage => $errorMessage });
1010 3175 tao
    exit(0);
1011
   }
1012
1013 4080 daigle
sub setVars {
1014
    my $paramVars = shift;
1015
    # initialize default parameters
1016
    my $templateVars = { cfg => $cfg,
1017 4394 walbridge
                         styleSkinsPath => $contextUrl . "/style/skins",
1018
                         styleCommonPath => $contextUrl . "/style/common",
1019
                         contextUrl => $contextUrl,
1020 4770 daigle
                         cgiPrefix => $cgiPrefix,
1021 4080 daigle
                         orgList => \@orgList,
1022 4394 walbridge
                         config  => $config,
1023 4080 daigle
    };
1024
1025
    # append customized params
1026
    while (my ($k, $v) = each (%$paramVars)) {
1027
        $templateVars->{$k} = $v;
1028
    }
1029
1030
    return $templateVars;
1031
}