| 26 |
26 |
# This is a web-based application for allowing users to register a new
|
| 27 |
27 |
# account for Metacat access. We currently only support LDAP even
|
| 28 |
28 |
# though metacat could potentially support other types of directories.
|
| 29 |
|
#
|
|
29 |
|
|
30 |
use lib '../WEB-INF/lib';
|
| 30 |
31 |
use strict; # turn on strict syntax checking
|
| 31 |
32 |
use Template; # load the template-toolkit module
|
| 32 |
|
use CGI; # load the CGI module
|
|
33 |
use CGI qw/:standard :html3/; # load the CGI module
|
| 33 |
34 |
use Net::LDAP; # load the LDAP net libraries
|
| 34 |
35 |
use Net::SMTP; # load the SMTP net libraries
|
| 35 |
36 |
use Digest::SHA1; # for creating the password hash
|
| ... | ... | |
| 37 |
38 |
use URI; # for parsing URL syntax
|
| 38 |
39 |
use Config::Properties; # for parsing Java .properties files
|
| 39 |
40 |
use File::Basename; # for path name parsing
|
|
41 |
use Cwd 'abs_path';
|
| 40 |
42 |
|
| 41 |
43 |
# Global configuration paramters
|
|
44 |
# This entire block (including skin parsing) could be pushed out to a separate .pm file
|
| 42 |
45 |
my $cgiUrl = $ENV{'SCRIPT_FILENAME'};
|
| 43 |
46 |
my $workingDirectory = dirname($cgiUrl);
|
| 44 |
47 |
my $metacatProps = "${workingDirectory}/../WEB-INF/metacat.properties";
|
| 45 |
48 |
my $properties = new Config::Properties();
|
| 46 |
49 |
unless (open (METACAT_PROPERTIES, $metacatProps)) {
|
| 47 |
|
#print "Content-type: text/html\n\n";
|
|
50 |
print "Content-type: text/html\n\n";
|
| 48 |
51 |
print "Unable to locate Metacat properties. Working directory is set as " .
|
| 49 |
52 |
$workingDirectory .", is this correct?";
|
| 50 |
53 |
exit(0);
|
| ... | ... | |
| 54 |
57 |
|
| 55 |
58 |
## Set up our default configuration
|
| 56 |
59 |
my $ldapProps = $properties->splitToTree(qr/\./, 'ldap');
|
|
60 |
# local directory configuration
|
|
61 |
my $skinsDir = "${workingDirectory}/../style/skins";
|
|
62 |
my $templatesDir = abs_path("${workingDirectory}/../style/common/templates");
|
|
63 |
my $tempDir = $properties->getProperty('application.tempDir');
|
|
64 |
|
|
65 |
# url configuration
|
|
66 |
my $server = $properties->splitToTree(qr/\./, 'server');
|
|
67 |
my $contextUrl = 'http://' . $properties->getProperty('server.name') . ':' .
|
|
68 |
$properties->getProperty('server.httpPort') . '/' .
|
|
69 |
$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("Registry: No configuration set.");
|
|
90 |
print "Content-type: text/html\n\n";
|
|
91 |
print 'Registry 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("Registry: 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 |
my $searchBase;
|
|
121 |
my $ldapUsername;
|
|
122 |
my $ldapPassword;
|
| 57 |
123 |
my $ldapurl = $ldapProps->{'url'};
|
| 58 |
|
my $mainldapurl = $ldapProps->{'mainurl'};
|
| 59 |
|
my $ldapUsername = $ldapProps->{'user'};
|
| 60 |
|
my $ldapPassword = $ldapProps->{'password'};
|
| 61 |
|
my $searchBase = $ldapProps->{'searchbase'};
|
| 62 |
|
my $mailhost = $properties->getProperty('email.mailhost');
|
| 63 |
|
my $sender = $properties->getProperty('email.sender');
|
| 64 |
124 |
|
| 65 |
125 |
# Java uses miliseconds, Perl expects whole seconds
|
| 66 |
|
my $TIMEOUT = $ldapProps->{'connectTimeLimit'} / 1000;
|
| 67 |
|
my $mainldapdownmessage = "The main ldap server $mainldapurl is down!";
|
|
126 |
my $timeout = $ldapProps->{'connectTimeLimit'} / 1000;
|
|
127 |
my $ldapdownmessage = "The main ldap server $ldapProps->{'url'} is down!";
|
| 68 |
128 |
|
| 69 |
129 |
# Get the CGI input variables
|
| 70 |
130 |
my $query = new CGI;
|
| 71 |
|
|
| 72 |
131 |
my $debug = 0;
|
| 73 |
132 |
|
| 74 |
133 |
#--------------------------------------------------------------------------80c->
|
| ... | ... | |
| 76 |
135 |
|
| 77 |
136 |
# templates hash, imported from ldap.templates tree in metacat.properties
|
| 78 |
137 |
my $templates = $properties->splitToTree(qr/\./, 'ldap.templates');
|
|
138 |
$$templates{'header'} = $skinProperties->getProperty("registry.templates.header");
|
|
139 |
$$templates{'footer'} = $skinProperties->getProperty("registry.templates.footer");
|
| 79 |
140 |
|
| 80 |
141 |
# set some configuration options for the template object
|
| 81 |
|
my $config_templates = {
|
| 82 |
|
INCLUDE_PATH => $properties->getProperty('templates-dir'),
|
| 83 |
|
INTERPOLATE => 0,
|
| 84 |
|
POST_CHOMP => 1,
|
|
142 |
my $ttConfig = {
|
|
143 |
INCLUDE_PATH => $templatesDir,
|
|
144 |
INTERPOLATE => 0,
|
|
145 |
POST_CHOMP => 1,
|
|
146 |
DEBUG => 1,
|
| 85 |
147 |
};
|
| 86 |
148 |
|
| 87 |
149 |
# create an instance of the template
|
| 88 |
|
my $template = Template->new($config_templates) || handleGeneralServerFailure($Template::ERROR);
|
|
150 |
my $template = Template->new($ttConfig) || handleGeneralServerFailure($Template::ERROR);
|
| 89 |
151 |
|
| 90 |
152 |
# custom LDAP properties hash
|
| 91 |
153 |
my $ldapCustom = $properties->splitToTree(qr/\./, 'ldap');
|
| 92 |
154 |
|
| 93 |
|
my @orgList = split(/,/, $properties->getProperty('ldap.organizations'));
|
|
155 |
my $orgProps = $properties->splitToTree(qr/\./, 'organization');
|
|
156 |
my $orgNames = $properties->splitToTree(qr/\./, 'organization.name');
|
|
157 |
# pull out properties available e.g. 'name', 'base'
|
|
158 |
my @orgData = keys(%$orgProps);
|
|
159 |
my @orgList;
|
|
160 |
while (my ($oKey, $oVal) = each(%$orgNames)) {
|
|
161 |
push(@orgList, $oKey);
|
|
162 |
}
|
|
163 |
|
| 94 |
164 |
my $ldapConfig;
|
| 95 |
|
|
| 96 |
165 |
foreach my $o (@orgList) {
|
| 97 |
|
debug($o);
|
| 98 |
|
# pull the raw tree in to prevent Perl pass-by-value shenanigans
|
| 99 |
|
$ldapConfig->{$o} = $properties->splitToTree(qr/\./, 'ldap');
|
| 100 |
|
|
| 101 |
|
# override the defaults set in ldap with the custom values
|
| 102 |
|
if (defined $ldapCustom->{$o}) {
|
| 103 |
|
my $custom = $ldapCustom->{$o};
|
| 104 |
|
while (my ($key, $value) = each(%$custom)) {
|
| 105 |
|
$ldapConfig->{$o}{$key} = $value;
|
| 106 |
|
}
|
|
166 |
foreach my $d (@orgData) {
|
|
167 |
$ldapConfig->{$o}{$d} = $properties->getProperty("organization.$d.$o");
|
| 107 |
168 |
}
|
|
169 |
# also include DN, which is just org + base
|
|
170 |
if ($ldapConfig->{$o}{'org'}) {
|
|
171 |
$ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'org'} . "," . $ldapConfig->{$o}{'base'};
|
|
172 |
} else {
|
|
173 |
$ldapConfig->{$o}{'dn'} = $ldapConfig->{$o}{'base'};
|
|
174 |
}
|
| 108 |
175 |
}
|
| 109 |
176 |
|
| 110 |
177 |
#--------------------------------------------------------------------------80c->
|
| ... | ... | |
| 132 |
199 |
'resetpass' => \&handleResetPassword,
|
| 133 |
200 |
'initresetpass' => \&handleInitialResetPassword,
|
| 134 |
201 |
);
|
|
202 |
|
| 135 |
203 |
# call the appropriate routine based on the stage
|
| 136 |
204 |
if ( $stages{$stage} ) {
|
| 137 |
205 |
$stages{$stage}->();
|
| ... | ... | |
| 185 |
253 |
exit();
|
| 186 |
254 |
} else {
|
| 187 |
255 |
my $o = $query->param('o');
|
| 188 |
|
$ldapurl = $ldapConfig->{$o}{'url'};
|
| 189 |
256 |
$searchBase = $ldapConfig->{$o}{'base'};
|
| 190 |
257 |
}
|
| 191 |
258 |
|
| ... | ... | |
| 263 |
330 |
$$allParams{'o'} = $query->param('o');
|
| 264 |
331 |
my $o = $query->param('o');
|
| 265 |
332 |
|
| 266 |
|
$ldapurl = $ldapConfig->{$o}{'url'};
|
| 267 |
333 |
$searchBase = $ldapConfig->{$o}{'base'};
|
| 268 |
334 |
}
|
| 269 |
335 |
|
| ... | ... | |
| 284 |
350 |
if ($query->param('userPassword') =~ $query->param('userPassword2')) {
|
| 285 |
351 |
|
| 286 |
352 |
my $o = $query->param('o');
|
| 287 |
|
$ldapurl = $ldapConfig->{$o}{'url'};
|
| 288 |
353 |
$searchBase = $ldapConfig->{$o}{'base'};
|
| 289 |
354 |
$ldapUsername = $ldapConfig->{$o}{'user'};
|
| 290 |
355 |
$ldapPassword = $ldapConfig->{$o}{'password'};
|
| ... | ... | |
| 345 |
410 |
$$allParams{'o'} = $query->param('o');
|
| 346 |
411 |
my $o = $query->param('o');
|
| 347 |
412 |
|
| 348 |
|
$ldapurl = $ldapConfig->{$o}{'url'};
|
| 349 |
413 |
$searchBase = $ldapConfig->{$o}{'base'};
|
| 350 |
414 |
$ldapUsername = $ldapConfig->{$o}{'user'};
|
| 351 |
415 |
$ldapPassword = $ldapConfig->{$o}{'password'};
|
| ... | ... | |
| 436 |
500 |
my $bindPass = shift;
|
| 437 |
501 |
my $o = shift;
|
| 438 |
502 |
|
| 439 |
|
my $ldapurl = $ldapConfig->{$o}{'url'};
|
| 440 |
503 |
my $searchBase = $ldapConfig->{$o}{'base'};
|
| 441 |
504 |
|
| 442 |
505 |
my $errorMessage = 0;
|
| 443 |
506 |
my $ldap;
|
| 444 |
|
if ($ldapurl =~ $mainldapurl){
|
| 445 |
|
#if main ldap server is down, a html file containing warning message will be returned
|
| 446 |
|
$ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or handleGeneralServerFailure($mainldapdownmessage);
|
| 447 |
|
}
|
| 448 |
|
else{
|
| 449 |
|
#if a referral ldap server is down, we will ignore it silently
|
| 450 |
|
$ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or return;
|
| 451 |
|
}
|
| 452 |
|
#$ldap->start_tls( verify => 'require',
|
|
507 |
|
|
508 |
#if main ldap server is down, a html file containing warning message will be returned
|
|
509 |
$ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleGeneralServerFailure($ldapdownmessage);
|
|
510 |
|
|
511 |
#$ldap->start_tls( verify => 'require',
|
| 453 |
512 |
#cafile => '/usr/share/ssl/ldapcerts/cacert.pem');
|
| 454 |
513 |
$ldap->start_tls( verify => 'none');
|
| 455 |
514 |
my $bindresult = $ldap->bind( version => 3, dn => $bindDN,
|
| ... | ... | |
| 506 |
565 |
my $mesg;
|
| 507 |
566 |
my $ldap;
|
| 508 |
567 |
print("ldap server ", $ldapurl, "\n");
|
| 509 |
|
if ($ldapurl =~ $mainldapurl){
|
| 510 |
|
#if main ldap server is down, a html file containing warning message will be returned
|
| 511 |
|
$ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or handleGeneralServerFailure($mainldapdownmessage);
|
| 512 |
|
}
|
| 513 |
|
else{
|
| 514 |
|
#if a referral ldap server is down, we will ignore it silently
|
| 515 |
|
$ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or return;
|
| 516 |
|
}
|
|
568 |
|
|
569 |
#if main ldap server is down, a html file containing warning message will be returned
|
|
570 |
$ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleGeneralServerFailure($ldapdownmessage);
|
| 517 |
571 |
$ldap->start_tls( verify => 'none');
|
| 518 |
572 |
my $bindresult = $ldap->bind;
|
| 519 |
573 |
if ($bindresult->code) {
|
| ... | ... | |
| 560 |
614 |
|
| 561 |
615 |
my $errorMessage = "";
|
| 562 |
616 |
if ($recipient) {
|
|
617 |
my $mailhost = $properties->getProperty('email.mailhost');
|
|
618 |
my $sender = $properties->getProperty('email.sender');
|
| 563 |
619 |
# Send the email message to them
|
| 564 |
620 |
my $smtp = Net::SMTP->new($mailhost);
|
| 565 |
621 |
$smtp->mail($sender);
|
| ... | ... | |
| 607 |
663 |
|
| 608 |
664 |
my $foundAccounts = 0;
|
| 609 |
665 |
#print("the ldapurl in findExstingAccounts is ", $ldapurl, "\n");
|
| 610 |
|
if ($ldapurl =~ $mainldapurl){
|
| 611 |
|
#if main ldap server is down, a html file containing warning message will be returned
|
| 612 |
|
$ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or handleGeneralServerFailure($mainldapdownmessage);
|
| 613 |
|
}
|
| 614 |
|
else{
|
| 615 |
|
#if a referral ldap server is down, we will ignore it silently
|
| 616 |
|
$ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or return;
|
| 617 |
|
}
|
|
666 |
#if main ldap server is down, a html file containing warning message will be returned
|
|
667 |
$ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleGeneralServerFailure($ldapdownmessage);
|
| 618 |
668 |
$ldap->start_tls( verify => 'none');
|
| 619 |
669 |
$ldap->bind( version => 3, anonymous => 1);
|
| 620 |
670 |
my $mesg = $ldap->search (
|
| ... | ... | |
| 703 |
753 |
|
| 704 |
754 |
my $o = $query->param('o');
|
| 705 |
755 |
|
| 706 |
|
my $ldapurl = $ldapConfig->{$o}{'url'};
|
| 707 |
756 |
my $ldapUsername = $ldapConfig->{$o}{'user'};
|
| 708 |
757 |
my $ldapPassword = $ldapConfig->{$o}{'password'};
|
| 709 |
758 |
my $searchBase = $ldapConfig->{$o}{'base'};
|
| 710 |
759 |
my $dnBase = $ldapConfig->{$o}{'dn'};
|
| 711 |
|
|
| 712 |
760 |
|
| 713 |
761 |
#if main ldap server is down, a html file containing warning message will be returned
|
| 714 |
|
my $ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or handleGeneralServerFailure("The ldap server " . $ldapurl . " is down!");
|
|
762 |
my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleGeneralServerFailure("The ldap server " . $ldapurl . " is down!");
|
| 715 |
763 |
|
| 716 |
764 |
|
| 717 |
765 |
$ldap->start_tls( verify => 'none');
|
| ... | ... | |
| 851 |
899 |
my $attref = shift;
|
| 852 |
900 |
|
| 853 |
901 |
my $foundAccounts = 0;
|
| 854 |
|
|
| 855 |
902 |
|
| 856 |
|
|
| 857 |
903 |
#if ldap server is down, a html file containing warning message will be returned
|
| 858 |
|
my $ldap = Net::LDAP->new($ldapurl, timeout => $TIMEOUT) or handleGeneralServerFailure("The ldap server " . $ldapurl . " is down!");
|
|
904 |
my $ldap = Net::LDAP->new($ldapurl, timeout => $timeout) or handleGeneralServerFailure("The ldap server " . $ldapurl . " is down!");
|
| 859 |
905 |
|
| 860 |
906 |
$ldap->start_tls( verify => 'none');
|
| 861 |
907 |
$ldap->bind( version => 3, anonymous => 1);
|
| ... | ... | |
| 922 |
968 |
my $paramVars = shift;
|
| 923 |
969 |
# initialize default parameters
|
| 924 |
970 |
my $templateVars = { cfg => $cfg,
|
| 925 |
|
styleSkinsPath => $properties->getProperty('style-skins-path'),
|
| 926 |
|
styleCommonPath => $properties->getProperty('style-common-path'),
|
| 927 |
|
baseUrl => $properties->getProperty('baseUrl'),
|
|
971 |
styleSkinsPath => $contextUrl . "/style/skins",
|
|
972 |
styleCommonPath => $contextUrl . "/style/common",
|
|
973 |
contextUrl => $contextUrl,
|
| 928 |
974 |
orgList => \@orgList,
|
|
975 |
config => $config,
|
| 929 |
976 |
};
|
| 930 |
977 |
|
| 931 |
978 |
# append customized params
|
| ... | ... | |
| 939 |
986 |
sub fullTemplate {
|
| 940 |
987 |
my $templateList = shift;
|
| 941 |
988 |
my $templateVars = setVars(shift);
|
| 942 |
|
|
|
989 |
|
| 943 |
990 |
$template->process( $templates->{'header'}, $templateVars );
|
| 944 |
|
|
| 945 |
991 |
foreach my $tmpl (@{$templateList}) {
|
| 946 |
992 |
$template->process( $templates->{$tmpl}, $templateVars );
|
| 947 |
|
}
|
|
993 |
}
|
| 948 |
994 |
$template->process( $templates->{'footer'}, $templateVars );
|
| 949 |
995 |
}
|
Further rework on ldapweb.cgi for 1.9 compatibility. Finished changes needed to have skinnable presentation for ldapweb.cgi, and reworked the organization logic to be compatible with our current method of storing the data (organization.* within metacat.properties).