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 5214 walbridge
        ' MetacatUrl is set correctly in ' .  $skinName . '.properties';
101 4394 walbridge
    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 4870 walbridge
# 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 4394 walbridge
my $searchBase;
140
my $ldapUsername;
141
my $ldapPassword;
142 4728 walbridge
# 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 4080 daigle
146
# Java uses miliseconds, Perl expects whole seconds
147 4728 walbridge
my $timeout = $properties->getProperty('ldap.connectTimeLimit') / 1000;
148 4080 daigle
149 2341 sgarg
# Get the CGI input variables
150
my $query = new CGI;
151 4747 walbridge
my $debug = 1;
152 2341 sgarg
153
#--------------------------------------------------------------------------80c->
154
# Set up the Template Toolkit to read html form templates
155
156 4080 daigle
# templates hash, imported from ldap.templates tree in metacat.properties
157
my $templates = $properties->splitToTree(qr/\./, 'ldap.templates');
158 4394 walbridge
$$templates{'header'} = $skinProperties->getProperty("registry.templates.header");
159
$$templates{'footer'} = $skinProperties->getProperty("registry.templates.footer");
160 2341 sgarg
161
# set some configuration options for the template object
162 4394 walbridge
my $ttConfig = {
163
             INCLUDE_PATH => $templatesDir,
164
             INTERPOLATE  => 0,
165
             POST_CHOMP   => 1,
166
             DEBUG        => 1,
167 2341 sgarg
             };
168
169
# create an instance of the template
170 4394 walbridge
my $template = Template->new($ttConfig) || handleGeneralServerFailure($Template::ERROR);
171 2341 sgarg
172 4080 daigle
# custom LDAP properties hash
173
my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');
174 2341 sgarg
175 4394 walbridge
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 4870 walbridge
180 4394 walbridge
my @orgList;
181
while (my ($oKey, $oVal) = each(%$orgNames)) {
182
    push(@orgList, $oKey);
183
}
184
185 4866 walbridge
my $authBase = $properties->getProperty("auth.base");
186 4080 daigle
my $ldapConfig;
187
foreach my $o (@orgList) {
188 4394 walbridge
    foreach my $d (@orgData) {
189
        $ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");
190 4080 daigle
    }
191 4866 walbridge
192 4870 walbridge
    # 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 4866 walbridge
    # 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 4394 walbridge
    } else {
220
        $ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'base'};
221
    }
222 4868 walbridge
223
    # set LDAP administrator user account
224 4866 walbridge
    if (!$ldapConfig->{$o}{'user'}) {
225
        $ldapConfig->{$o}{'user'} = $ldapConfig->{'unaffiliated'}{'user'};
226 4865 walbridge
    }
227 4868 walbridge
    # 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 4866 walbridge
233
    if (!$ldapConfig->{$o}{'password'}) {
234
        $ldapConfig->{$o}{'password'} = $ldapConfig->{'unaffiliated'}{'password'};
235
    }
236 2341 sgarg
}
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 4080 daigle
my $stage = $query->param('stage') || $templates->{'stage'};
244 2341 sgarg
245
my $cfg = $query->param('cfg');
246 4767 walbridge
debug("started with stage $stage, cfg $cfg");
247 2341 sgarg
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 2972 jones
              'changepass'        => \&handleChangePassword,
259
              'initchangepass'    => \&handleInitialChangePassword,
260 2341 sgarg
              'resetpass'         => \&handleResetPassword,
261 2414 sgarg
              'initresetpass'     => \&handleInitialResetPassword,
262 2341 sgarg
             );
263 4394 walbridge
264 2341 sgarg
# 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 4728 walbridge
sub fullTemplate {
276
    my $templateList = shift;
277
    my $templateVars = setVars(shift);
278 2341 sgarg
279 4728 walbridge
    $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 2341 sgarg
#
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 4080 daigle
  fullTemplate(['register'], {stage => "register"});
295 2341 sgarg
  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 4080 daigle
        fullTemplate(['register'], { stage => "register",
322
                                     allParams => $allParams,
323
                                     errorMessage => $errorMessage });
324
        exit();
325 2341 sgarg
    } else {
326 2972 jones
        my $o = $query->param('o');
327 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
328 2341 sgarg
    }
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 4080 daigle
      fullTemplate( ['registerMatch', 'register'], { stage => "registerconfirmed",
357
                                                     allParams => $allParams,
358
                                                     foundAccounts => $found });
359 2341 sgarg
    # 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 4080 daigle
                      'o' => 'unaffiliated', # only accept unaffiliated registration
377 2341 sgarg
                      '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 2972 jones
        my $o = $query->param('o');
402
403 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
404 2341 sgarg
    }
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 4080 daigle
        fullTemplate( ['changePass'], { stage => "changepass",
414
                                        allParams => $allParams,
415
                                        errorMessage => $errorMessage });
416
        exit();
417 2341 sgarg
    }
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 2972 jones
        my $o = $query->param('o');
423 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
424
        $ldapUsername = $ldapConfig->{$o}{'user'};
425
        $ldapPassword = $ldapConfig->{$o}{'password'};
426 2341 sgarg
427 4080 daigle
        my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};;
428 2341 sgarg
        if ($query->param('o') =~ "LTER") {
429 4080 daigle
            fullTemplate( ['registerLter'] );
430 2341 sgarg
        } else {
431
            my $errorMessage = changePassword(
432
                    $dn, $query->param('userPassword'),
433
                    $dn, $query->param('oldpass'), $query->param('o'));
434 2972 jones
            if ($errorMessage) {
435 4080 daigle
                fullTemplate( ['changePass'], { stage => "changepass",
436
                                                allParams => $allParams,
437
                                                errorMessage => $errorMessage });
438
                exit();
439 2341 sgarg
            } else {
440 4080 daigle
                fullTemplate( ['changePassSuccess'], { stage => "changepass",
441
                                                       allParams => $allParams });
442
                exit();
443 2341 sgarg
            }
444
        }
445
    } else {
446
        my $errorMessage = "The passwords do not match. Try again.";
447 4080 daigle
        fullTemplate( ['changePass'], { stage => "changepass",
448
                                        allParams => $allParams,
449
                                        errorMessage => $errorMessage });
450
        exit();
451 2341 sgarg
    }
452
}
453
454
#
455 2414 sgarg
# 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 4080 daigle
    fullTemplate( ['changePass'], { stage => "changepass",
464
                                    errorMessage => $errorMessage });
465
    exit();
466 2414 sgarg
}
467
468
#
469 2341 sgarg
# 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 2972 jones
        my $o = $query->param('o');
482
483 4080 daigle
        $searchBase = $ldapConfig->{$o}{'base'};
484 4868 walbridge
        $ldapUsername = $ldapConfig->{$o}{'user'};
485 4080 daigle
        $ldapPassword = $ldapConfig->{$o}{'password'};
486 2341 sgarg
    }
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 4080 daigle
        fullTemplate( ['resetPass'],  { stage => "resetpass",
494
                                        allParams => $allParams,
495
                                        errorMessage => $errorMessage });
496
        exit();
497 2341 sgarg
    }
498
499
    # We have all of the info we need, so try to change the password
500
    my $o = $query->param('o');
501 4080 daigle
    my $dn = "uid=" . $query->param('uid') . "," . $ldapConfig->{$o}{'dn'};
502 4866 walbridge
    debug("handleResetPassword: dn: $dn");
503 2341 sgarg
    if ($query->param('o') =~ "LTER") {
504 4080 daigle
        fullTemplate( ['registerLter'] );
505
        exit();
506 2341 sgarg
    } 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 4080 daigle
            $errorMessage = changePassword($dn, $userPass, $ldapUsername, $ldapPassword, $query->param('o'));
517 2341 sgarg
        } else {
518
            $errorMessage = "User not found in database.  Please try again.";
519
        }
520
521
        if ($errorMessage) {
522 4080 daigle
            fullTemplate( ['resetPass'], { stage => "resetpass",
523
                                           allParams => $allParams,
524
                                           errorMessage => $errorMessage });
525
            exit();
526 2341 sgarg
        } else {
527
            my $errorMessage = sendPasswordNotification($query->param('uid'),
528 2972 jones
                    $query->param('o'), $userPass, $recipient, $cfg);
529 4080 daigle
            fullTemplate( ['resetPassSuccess'], { stage => "resetpass",
530
                                                  allParams => $allParams,
531
                                                  errorMessage => $errorMessage });
532
            exit();
533 2341 sgarg
        }
534
    }
535
}
536
537
#
538 2414 sgarg
# 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 4080 daigle
    fullTemplate( ['resetPass'], { stage => "resetpass",
545
                                   errorMessage => $errorMessage });
546
    exit();
547 2414 sgarg
}
548
549
#
550 2341 sgarg
# 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 4080 daigle
    my $searchBase = $ldapConfig->{$o}{'base'};
575 4868 walbridge
576 2341 sgarg
    my $errorMessage = 0;
577 3177 tao
    my $ldap;
578 4868 walbridge
579 4771 walbridge
    #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 4394 walbridge
582 4849 daigle
    if ($ldap) {
583 4868 walbridge
        #$ldap->start_tls( verify => 'require',
584 2972 jones
                      #cafile => '/usr/share/ssl/ldapcerts/cacert.pem');
585 4868 walbridge
        $ldap->start_tls( verify => 'none');
586
        debug("changePassword: attempting to bind to $bindDN");
587
        my $bindresult = $ldap->bind( version => 3, dn => $bindDN,
588 2341 sgarg
                                  password => $bindPass );
589 4868 walbridge
        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 2341 sgarg
595 4849 daigle
    	# Find the user here and change their entry
596
    	my $newpass = createSeededPassHash($userPass);
597
    	my $modifications = { userPassword => $newpass };
598 4868 walbridge
      debug("changePass: setting password for $userDN to $newpass");
599 4849 daigle
    	my $result = $ldap->modify( $userDN, replace => { %$modifications });
600 2341 sgarg
601 4849 daigle
    	if ($result->code()) {
602 4866 walbridge
            debug("changePass: error changing password: " . $result->error);
603
        	$errorMessage = "There was an error changing the password:" .
604 2341 sgarg
                           "<br />\n" . $result->error;
605 4849 daigle
    	}
606
    	$ldap->unbind;   # take down session
607
    }
608 2341 sgarg
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 3177 tao
    my $ldap;
643 4749 walbridge
    debug("ldap server: $ldapurl");
644 4394 walbridge
645
    #if main ldap server is down, a html file containing warning message will be returned
646 4771 walbridge
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
647 4849 daigle
648
    if ($ldap) {
649
    	$ldap->start_tls( verify => 'none');
650
    	my $bindresult = $ldap->bind;
651
    	if ($bindresult->code) {
652
        	return $entry;
653
    	}
654 2341 sgarg
655 4849 daigle
    	if($ldapConfig->{$org}{'filter'}){
656 4865 walbridge
            debug("getLdapEntry: filter set, searching for base=$base, " .
657
                  "(&(uid=$username)($ldapConfig->{$org}{'filter'})");
658 4849 daigle
        	$mesg = $ldap->search ( base   => $base,
659 4080 daigle
                filter => "(&(uid=$username)($ldapConfig->{$org}{'filter'}))");
660 4849 daigle
    	} else {
661 4865 walbridge
            debug("getLdapEntry: no filter, searching for $base, (uid=$username)");
662 4849 daigle
        	$mesg = $ldap->search ( base   => $base, filter => "(uid=$username)");
663
    	}
664 3177 tao
665 4849 daigle
    	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 4865 walbridge
                    debug("getLdapEntry: recursion found $host, $path, $username, $org");
680 4849 daigle
                	return $entry;
681
            	}
682
        	}
683
    	}
684 2341 sgarg
    }
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 2972 jones
    my $cfg = shift;
697 2341 sgarg
698
    my $errorMessage = "";
699
    if ($recipient) {
700 4771 walbridge
        my $mailhost = $properties->getProperty('email.mailhost');
701
        my $sender =  $properties->getProperty('email.sender');
702 2341 sgarg
        # 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 4864 walbridge
        $contextUrl/cgi-bin/ldapweb.cgi?stage=changepass&cfg=$cfg
717 2341 sgarg
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 3175 tao
    my $ldap;
746 4847 daigle
    my $mesg;
747 2341 sgarg
748
    my $foundAccounts = 0;
749 4749 walbridge
750 4394 walbridge
    #if main ldap server is down, a html file containing warning message will be returned
751 4868 walbridge
    debug("findExistingAccounts: connecting to $ldapurl, $timeout");
752 4771 walbridge
    $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
753 4845 daigle
    if ($ldap) {
754
    	$ldap->start_tls( verify => 'none');
755
    	$ldap->bind( version => 3, anonymous => 1);
756 4848 daigle
		$mesg = $ldap->search (
757 4845 daigle
			base   => $base,
758
			filter => $filter,
759
			attrs => @$attref,
760
		);
761 2341 sgarg
762 4845 daigle
	    if ($mesg->count() > 0) {
763
			$foundAccounts = "";
764
			my $entry;
765
			foreach $entry ($mesg->all_entries) {
766 5650 walbridge
                # 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 4845 daigle
			}
781 2341 sgarg
        }
782 4845 daigle
    	$ldap->unbind;   # take down session
783 2341 sgarg
784 4848 daigle
    	# 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 2341 sgarg
    }
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 4080 daigle
        fullTemplate( ['registerLter'] );
835 2341 sgarg
    } 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 4080 daigle
            fullTemplate( ['registerFailed', 'register'], { stage => "register",
841
                                                            allParams => $allParams,
842
                                                            errorMessage => $errorMessage });
843
            exit();
844 2341 sgarg
        }
845
846 2972 jones
        my $o = $query->param('o');
847 2341 sgarg
848 4080 daigle
        my $searchBase = $ldapConfig->{$o}{'base'};
849
        my $dnBase = $ldapConfig->{$o}{'dn'};
850 4868 walbridge
        my $ldapUsername = $ldapConfig->{$o}{'user'};
851 4749 walbridge
        my $ldapPassword = $ldapConfig->{$o}{'password'};
852 4771 walbridge
        debug("LDAP connection to $ldapurl...");
853 3177 tao
        #if main ldap server is down, a html file containing warning message will be returned
854 4771 walbridge
        my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
855 3177 tao
856 4849 daigle
        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 3177 tao
861 4849 daigle
        	my $dn = 'uid=' . $query->param('uid') . ',' . $dnBase;
862
        	debug("Inserting new entry for: $dn");
863 2341 sgarg
864 4849 daigle
        	# Create a hashed version of the password
865
        	my $shapass = createSeededPassHash($query->param('userPassword'));
866 2341 sgarg
867 4849 daigle
        	# Do the insertion
868
        	my $additions = [
869 2341 sgarg
                '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 4849 daigle
            	];
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 2341 sgarg
894 4849 daigle
        	if ($result->code()) {
895
            	fullTemplate( ['registerFailed', 'register'], { stage => "register",
896 4080 daigle
                                                            allParams => $allParams,
897
                                                            errorMessage => $result->error });
898 4849 daigle
            	# 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 2341 sgarg
        }
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 4080 daigle
  fullTemplate( [], { stage => $templates->{'stage'},
917
                      errorMessage => $errorMessage });
918
  exit();
919 2341 sgarg
}
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 4080 daigle
    my $ldapurl = $ldapConfig->{$o}{'url'};
931
    my $searchBase = $ldapConfig->{$o}{'base'};
932 2341 sgarg
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 4080 daigle
      fullTemplate( ('searchResults'), { stage => "searchresults",
974
                                         allParams => $allParams,
975
                                         foundAccounts => $found });
976 2341 sgarg
    } else {
977
      $found = "No entries matched your criteria.  Please try again\n";
978
979 4080 daigle
      fullTemplate( ('searchResults'), { stage => "searchresults",
980
                                         allParams => $allParams,
981
                                         foundAccounts => $found });
982 2341 sgarg
    }
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 4849 daigle
	my $mesg;
997 2341 sgarg
    my $foundAccounts = 0;
998 3177 tao
999
    #if ldap server is down, a html file containing warning message will be returned
1000 4771 walbridge
    my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleLDAPBindFailure($ldapurl);
1001 3177 tao
1002 4849 daigle
    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 2341 sgarg
1011 4849 daigle
    	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 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1018 4849 daigle
         		 $foundAccounts .= $entry->get_value('labeledURI') unless
1019 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1020 4849 daigle
          		$foundAccounts .= "\">\n" unless
1021 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1022 4849 daigle
          		$foundAccounts .= $entry->get_value('givenName');
1023
          		$foundAccounts .= "</a>\n" unless
1024 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1025 4849 daigle
          		$foundAccounts .= "\n</td>\n<td class=\"main\">\n";
1026
          		$foundAccounts .= "<a href=\"" unless
1027 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1028 4849 daigle
          		$foundAccounts .= $entry->get_value('labeledURI') unless
1029 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1030 4849 daigle
          		$foundAccounts .= "\">\n" unless
1031 2341 sgarg
                    (!$entry->get_value('labeledURI'));
1032 4849 daigle
          		$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 2341 sgarg
    }
1048
    return $foundAccounts;
1049
}
1050
1051
sub debug {
1052
    my $msg = shift;
1053
1054
    if ($debug) {
1055 4747 walbridge
        print STDERR "LDAPweb: $msg\n";
1056 2341 sgarg
    }
1057
}
1058 3175 tao
1059 4771 walbridge
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 3177 tao
sub handleGeneralServerFailure {
1071
    my $errorMessage = shift;
1072 4728 walbridge
    fullTemplate( ['mainServerFailure'], { errorMessage => $errorMessage });
1073 3175 tao
    exit(0);
1074
   }
1075
1076 4080 daigle
sub setVars {
1077
    my $paramVars = shift;
1078
    # initialize default parameters
1079
    my $templateVars = { cfg => $cfg,
1080 4394 walbridge
                         styleSkinsPath => $contextUrl . "/style/skins",
1081
                         styleCommonPath => $contextUrl . "/style/common",
1082
                         contextUrl => $contextUrl,
1083 4770 daigle
                         cgiPrefix => $cgiPrefix,
1084 4080 daigle
                         orgList => \@orgList,
1085 4394 walbridge
                         config  => $config,
1086 4080 daigle
    };
1087
1088
    # append customized params
1089
    while (my ($k, $v) = each (%$paramVars)) {
1090
        $templateVars->{$k} = $v;
1091
    }
1092
1093
    return $templateVars;
1094
}