File Coverage

blib/lib/CGI/AuthRegister.pm

Criterion	Covered	Total	%
statement	26	1263	2.0
branch	1	496	0.2
condition	0	123	0.0
subroutine	8	69	11.5
pod	5	50	10.0
total	40	2001	2.0

\n"; };

line stmt bran cond sub pod time code

1 # file: AuthRegister.pm

2 # CGI::AuthRegister - AuthRegister Module for Simple CGI Authentication and

3 # Registration in Perl

6 package CGI::AuthRegister;

7 1 1 6191 use strict;

1 2

1 27

8 1 1 4 use vars qw($NAME $ABSTRACT $VERSION);

1 1

1 77

9 $NAME = 'AuthRegister';

10 $ABSTRACT = 'AuthRegister Module for Simple CGI Authentication and '.

11 'Registration in Perl';

12 $VERSION = '1.404'; # Last update: 2022-09-19

14 1 1 2262 use CGI qw(:standard);

1 29761

1 4

15 # Useful diagnostics:

16 # use CGI qw(:standard :Carp -debug);

17 # use CGI::Carp 'fatalsToBrowser';

18 # use diagnostics; # verbose error messages

19 # use strict; # check for mistakes

20 1 1 3122 use Carp;

1 2

1 64

21 require Exporter;

22 1 1 13 use vars qw(@ISA @EXPORT);

1 2

1 94

23 @ISA = qw(Exporter);

24 @EXPORT = qw($AddAuthenticatedUser $DebugLevel $Error $SessionId

25 $SiteId $SiteName $User $UserEmail $UserId $SendLogs $LogReport

26 $LDAPuse $LDAPserver $LDAPdn $LDAPaddUsers $LinkForgotpwd

27 $GenCasPageCustom

28 analyze_cookie header_delete_cookie header_session_cookie

29 import_dir_and_config login logout

30 require_https require_login run_cas send_email_reminder

31 get_user get_user_by_userid send_email_to_admin

32 set_new_session store_log

33 );

35 1 3198 use vars qw( $AddAuthenticatedUser $AllowSignup

36 $DBdir $DBusers $DBpwd $DBsessions $DBusersCas $DBpwdCas

37 $DBsessionsCas $DBcasTokens $DebugLevel

38 $Email_admin $Email_from $Email_bcc $Error $ErrorInternal

39 $GenCasPageCustom $Header $LogReport

40 $LDAPuse $LDAPserver $LDAPdn $LDAPaddUsers $LinkForgotpwd

41 $Sendmail $Session $SessionId $SiteId $SiteName $Ticket

42 1 1 7 $User $UserEmail $UserId $SendLogs $SecretSalt);

1 1

43 $AddAuthenticatedUser = ''; # If user is authenticated and not in database,

44 # add user to the database. (it should replace $LDAPaddUsers)!!!

45 $AllowSignup = ''; # 1 to allow new user signup

46 $DBdir = 'db'; # directory for stored data (822 db, sessions)

47 $DBusers = 'users.db'; # Users db

48 $DBusersCas = 'users-cas.db'; # CAS users db

49 $DBpwd = 'passwords'; # Passwords file

50 $DBpwdCas = 'passwords-cas'; # CAS passwords

51 $DBsessions = 'sessions.d'; # Sessions

52 $DBsessionsCas = 'sessions-cas.d'; # CAS sessions

53 $DBcasTokens = 'cas-tokens.db'; # CAS Tokens

54 # $Error = ''; # Appended error messages, OK to be sent to user

55 # $ErrorInternal = ''; # Appended internal error messages, intended

56 # for administrator

57 # $Header # Keeps the latest prepared HTTP header, if not printed

58 # $LogReport = ''; # Collecting some important log events if needed

59 $SecretSalt = &random_name; # Secret salt for generating secrets (e.g. tokens)

60 # $Session = ''; # Session data structure

61 # $SessionId = ''; # Session identifier, generated

62 $SiteId = 'Site'; # Site identifier, used in cookies and emails

63 $SiteName = 'Site'; # Site name, can include spaces

64 # $Ticket = ''; # Session ticket for security, generated

65 # $User = ''; # User data structure

66 # $UserEmail = ''; # User email address

67 # $SendLogs = ''; # If true, send logs by email to admin ($Email_bcc)

69 $Email_from = ''; # Example: $SiteId.' ';

70 $Email_bcc = ''; # Example: $SiteId.' Bcc ';

72 $Sendmail = "/usr/lib/sendmail"; # Sendmail with full path

74 # Some function prototypes

75 sub putfile($@);

77 ########################################################################

78 # Section: Configuration

79 # sets site id as the base directory name; imports configuration.pl if exists

80 sub import_dir_and_config {

81 0 0 1 0 my $base = `pwd`; $base =~ /\/([^\/]*)$/; $base = $1; $base =~ s/\s+$//;

0 0

82 0 0 $SiteId = $SiteName = $base;

83 0 0 0 if (-r 'configuration.pl') { package main; require 'configuration.pl'; }

0 0

84 }

86 ########################################################################

87 # Section: HTTPS Connection and Cookies Management

89 # Check that the connection is HTTPS and if not, redirect to HTTPS.

90 # It must be done before script produces any output.

91 sub require_https {

92 0 0 0 1 0 if ($ENV{'HTTPS'} ne 'on') {

93 0 0 print "Status: 301 Moved Permanently\n".

94 "Location: https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}\n\n";

95 0 0 exit 0; }

96 }

98 # Used to run a CAS service. If not logged in, ask for userid and password.

99 # On success, offer to pass confirmation back to the site; on fail offer retry

100 # or go back to the site. If site not given, stay. If previously logged in

101 # offer to pass confirmation to the site. Handles ?logout requests.

102 # Allows parentheses in userid's for login, which are removed. This allows

103 # users to use auxiliary comments with userid, so that browser can distinguish

104 # passwords.

105 sub run_cas {

106 0 0 0 0 my %params = @_;

107 0 0 my $querystring = $ENV{QUERY_STRING};

108 0 0 $DBusers = $DBusersCas; $DBpwd = $DBpwdCas; $DBsessions = $DBsessionsCas;

0 0

109 0 0 &import_dir_and_config; &require_https;

0 0

110 0 0 0 0 if ($querystring eq '' && param('querystring')) {

111 0 0 $querystring=param('querystring') }

112 0 0 0 if ($querystring eq 'cas-all.css') { &deliver('cas-all.css') }

0 0

113 0 0 0 if ($querystring eq 'cas-mobile.css') { &deliver('cas-mobile.css') }

0 0

114

115 0 0 0 0 if (param('rt') ne '' && param('rt') eq 'verify') {

116 0 0 my $username = param('username'); my $stoken = param('stoken');

0 0

117 0 0 my $r = &_db8_find_first("$DBdir/$DBcasTokens", 'k=stoken', $stoken);

118 0 0 my $ans = 'fail';

119 0 0 0 0 if ($r ne '' and $r->{stoken} eq $stoken and $r->{userid} eq $username) {

120 0 0 $ans = 'ok';

121 0 0 0 if ($DebugLevel > 5) { $LogReport .= "CAS verification OK for ".

0 0

122 0 0 "username($username) stoken($stoken)"; &store_log; }

123 }

124 0 0 0 if ($ans ne 'ok') {

125 0 0 print header(), "answer:fail\n";

126 0 0 0 if ($DebugLevel > 5) { $LogReport .= "CAS verify failed for ".

0 0

127 "username($username) stoken($stoken)"; }

128 0 0 &store_log; exit(); }

0 0

129 0 0 &_db8_remove("$DBdir/$DBcasTokens", 'k=stoken', $stoken);

130 0 0 print header(), "answer:ok\n"; exit();

0 0

131 }

132

133 0 0 my $redirect_uri;

134 0 0 0 if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }

0 0 0

135 0 0 elsif (param('r') ne '') { $redirect_uri = param('r') }

136

137 ### Helper functions: finishGeneral, finishWithPageBack

138

139 local *finishGeneral = sub {

140 0 0 0 my $page = &gen_cas_page;

141 0 0 0 if ($redirect_uri ne '') {

142 0 0 my $h = "

143 "value=\"$redirect_uri\">";

144 0 0 $page=~ s//$h\n$&/;

145 0 0 my $t = "CAS Authentication requested by the following site:
\n".

146 "".&htmlquote($redirect_uri)."";

147 0 0 $page =~ s/(.*?\n\n/\n/s;

161 0 0 $page =~ s/.*?\n\n/\n/s;

162 0 0 0 if ($redirect_uri ne '') {

163 0 0 my $stoken = &gen_secret; $userid=~s/["<>]//g;

0 0

164 0 0 my $f = "$DBdir/$DBcasTokens";

165 0 0 0 0 if (!-f $f && !&check_db_files) { $LogReport.=$Error; &store_log;

0 0

166 0 0 print "Error: $Error"; exit; }

0 0

167 0 0 0 if (!-f $f) { putfile $f, ''; chmod 0600, $f; }

0 0

168 0 0 &_db8_append($f, "userid:$userid\nstoken:$stoken" );

169 0 0 0 if ($Error ne '') { $LogReport.=$Error; &store_log;

0 0

170 0 0 print "Error: $Error"; exit; }

0 0

171 0 0 my $h = "";

172 0 0 $page=~ s//$h\n$&/;

173 0 0 $h = "";

174 0 0 $page=~ s//$h\n$&/;

175 0 0 $page =~ s/(

176 0 0 my $r = &encodeuri($redirect_uri);

177

$page =~ s/(

178 0 0 } else { $page =~ s///s; }

179 0 0 print $page;

180 # Log out user so that they have to login every time they use the service

181 0 0 logout();

182 0 0 exit;

183 0 0 };

184 ### End of helper functions

185

186 # Check redirect_uri

187 0 0 0 0 if ($redirect_uri ne '' &&

188 $redirect_uri !~ /^https:\/\/(\w|[-.~\/])+/i &&

189 $redirect_uri !~ /^http:\/\/(\w|[-.~\/:])+/i ## This is temporary for a student project

190 ## It is probably is too relaxed.

191 ) {

192 0 0 my $page = &gen_cas_page;

193 0 0 my $h = 'redirect_uri Error!';

194 0 0 my $t = "URI of the requesting site is not in an acceptable format:
\n".

195 "".&htmlquote($redirect_uri)."
\n".

196 "Please check with the CAS maintainer if you think that this URI ".

197 "should be accepted. The rules include a requirement that the URI ".

198 "starts with 'https://' (including uppercase), and can have only some ".

199 "standard characters. It is possible that more characters should be ".

200 "allowed.";

201 0 0 $page =~ s/(.*?//s;

204 0 0 print header(), $page; exit;

0 0

205 }

206

207 0 0 0 0 if ($querystring eq 'forgotpwd' or param('rt') eq 'forgotpwd') {

208 0 0 0 if ($LinkForgotpwd) { print CGI::redirect(-uri=>$LinkForgotpwd); exit; }

0 0

209 0 0 my $page = &gen_cas_page; my $h = 'Send Password';

0 0

210 0 0 my $t = "Enter your UserID or Email to have password reset and sent to ".

211 "you by email.\nIf you do not receive email, it may mean that you are ".

212 "not registered in the system, and you should contanct the administrator.";

213 0 0 $page =~ s/(.*?\n\n/\n/s;

216 0 0 $page =~ s/(

217 0 0 print header(), $page; exit;

0 0

218 }

219

220 0 0 my $title = "Login Page for Site: $CGI::AuthRegister::SiteName";

221

my $HTMLstart = "$title

$title

\n";

222 0 0 my $Formstart = "";

223

my $LoginForm = "

Please login with your DalFCS Account userid and password:
\n".$Formstart.

224 hidden('querystring',$querystring).

225

"\n\n".

CS Userid:	".
226		textfield(-name=>"csuserid")."
".
227		"Password:	".password_field(-name=>"password")."
228		'
	'.
229		"

\n";

230

231

# $LoginForm.="

LogReport:\n$CGI::AuthRegister::LogReport\nError=$CGI::AuthRegister::Error\n";

232

233 0 0 &analyze_cookie;

234

235 # Logout from CAS

236 0 0 0 0 if ($CGI::AuthRegister::SessionId ne '' && param('keywords') eq 'logout') {

237 0 0 CGI::AuthRegister::logout(); print header(); &finishGeneral; }

0 0

238

239 0 0 0 if ($SessionId ne '') { print header(); &finishWithPageBack; }

0 0

240

241 0 0 my $Request_type = param('request_type');

242

243 0 0 0 if ($Request_type eq 'Login') {

244 0 0 my $username = param('username'); my $password = param('password');

0 0

245 0 0 $username =~ s/$.*$//g; $username =~ s/\s+$//; $username =~ s/^\s+//;

0 0

246 0 0 $username =~ s/[^a-zA-Z0-9_-]//g; $username = lc($username);

0 0

247

248 0 0 0 if (! &login($username, $password) ) {

249 0 0 my $page = &gen_cas_page;

250 0 0 my $t = "Unsuccessful login!
\n";

251 0 0 0 if ($redirect_uri ne '') {

252 0 0 my $h = "

253 "value=\"$redirect_uri\">";

254 0 0 $page=~ s//$h\n$&/;

255 0 0 $t.= "CAS Authentication requested by the following site:
\n".

256 "".&htmlquote($redirect_uri).""; }

257 0 0 $page =~ s/(.*?//s; # remove the form

272 0 0 print header(), $page;

273 0 0 $LogReport.=$Error; &store_log;

0 0

274 0 0 exit;

275 }

276 else { # should be: $Request_type eq ''

277 0 0 print header(); &finishGeneral; }

0 0

278 0 0 die; # Not supposed to be reached

279 }

280

281

282 # If not logged in, ask for userid/email and password. Catches ?logout

283 # request as well. Allows parentheses in userid/email for login, which are

284 # removed. This allows users to use auxiliary comments with userid, so that

285 # browser can distinguish passwords.

286 sub require_login {

287 0 0 0 1 0 my %args = @_; return &_require_login_using_cas(@_) if exists($args{-cas});

0 0

288 0 0 my $title = "Login Page for Site: $SiteId";

289

my $HTMLstart = "$title

$title

\n";

290

my $Formstart = "

291 0 0 my $Back = "Click here for the main page.\n";

292 0 0 0 0 local *tr = sub { my($a,$b) = @_; return "

$a: ".

0 0

293 ($a=~/password/i?password_field(-name=>$b):textfield(-name=>$b)).

294 0 0 "

295

my $LoginForm = "

Please log in to access the site:
\n".$Formstart.

296

"\n".&tr('Userid or email','userid').

297		&tr('Password','password').
298		'
	'.
299		"

\n";

300

my $SendResetForm = "

If you forgot your password, it may be possible to ".

301 "retrieve it by email:
\n".$Formstart."Email: ".

302 textfield(-name=>"email_pw_send")."\n".

303 ''.

304 "\n".

305 "Or, you can reqest password to be reset and sent to you:
\n".

306 $Formstart."Email: ".textfield(-name=>"email_reset")."\n".

307 ''.

308 "\n".

309 ($AllowSignup?("".

310 "Register new user\n"):'');

311 0 0 my $RegistrationForm = $Formstart.

312

"\n".&tr('Userid','reg_userid').&tr('Email','reg_email').

313		&tr('Password','reg_password').&tr('Confirm password','reg_password2').
314		'
	'.
315		"

\n";

316

317 0 0 &analyze_cookie;

318 0 0 0 0 if ($SessionId ne '' && param('keywords') eq 'logout') {

319 0 0 logout(); print header_delete_cookie(),$HTMLstart,

0 0

320

You are logged out.\n", $LoginForm, $SendResetForm; exit; }

321

322 0 0 0 if ($SessionId ne '') { print header(); return 1; }

0 0

323

324 0 0 0 0 if (param('keywords') eq 'signup' && $AllowSignup) {

325

print header(), $HTMLstart, "

New Registration

\n",

326 0 0 $RegistrationForm; exit; }

327 elsif (param('confirmation_code')) {

328

print header(), $HTMLstart, "

Email Confirmation

\n";

329 0 0 &email_confirmation(param('confirmation_code')); exit;

0 0

330 }

331

332 0 0 my $Request_type = param('request_type');

333

334 0 0 0 0 if ($Request_type eq 'Login') {

335 0 0 my $email = param('userid'); my $password = param('password');

0 0

336 0 0 $email =~ s/$.*$//g; $email =~ s/\s+$//; $email =~ s/^\s+//;

0 0

337

338 0 0 0 if (! &login($email, $password) ) { # checks for userid and email

339 0 0 print header(), $HTMLstart, "Unsuccessful login!\n";

340 0 0 print $LoginForm, $SendResetForm; exit;

0 0

341 }

342 0 0 else { print header_session_cookie(); return 1; }

0 0

343 }

344 elsif ($Request_type eq 'Send_Password') {

345 0 0 &send_email_reminder(param('email_pw_send'), 'raw');

346 0 0 print header(), $HTMLstart, "You should receive password reminder if ".

347 "your email is registered at this site.\n".

348 "If you do not receive remider, you can contact the administrator.\n",

349 $LoginForm, $SendResetForm;

350 0 0 $LogReport.=$Error; &store_log;

0 0

351 0 0 exit;

352 }

353 elsif ($Request_type eq 'Reset_Password') {

354 0 0 &reset_and_send_email_reminder(param('email_reset'), 'raw');

355 0 0 print header(), $HTMLstart, "You should receive new password if ".

356 "your email is registered at this site.\n".

357 "If you do not receive remider, you can contact the administrator.\n",

358 0 0 $LoginForm, $SendResetForm; exit;

359 }

360 elsif ($Request_type eq 'Register' && $AllowSignup) {

361 0 0 $|=1; print header(), $HTMLstart;

0 0

362 0 0 ®ister_new_user;

363 0 0 exit;

364 }

365 else { # should be: $Request_type eq ''

366 0 0 print header(), $HTMLstart, $LoginForm, $SendResetForm; exit; }

0 0

367

368 0 0 die; # Not supposed to be reached

369 }

370

371 # parameters:

372 # -return_status=>1 rather than exiting on failure, return status

373 # return status values: 'logged out', 1, 'not logged in' 'login failed'

374 # If we want that user gets a suggestion to use CAS to login, then

375 # this option should not be used.

376 #

377 # -header_no_print=> do not print header on success, but keep in $Header

378 sub _require_login_using_cas {

379 0 0 0 my %args = @_; my $casurl = $args{-cas};

0 0

380 0 0 my $header_no_print = $args{-header_no_print};

381 0 0 my $retStatus;

382 0 0 0 $retStatus = $args{-return_status} if exists($args{-return_status});

383 0 0 my $title = "Login Page for Site: $SiteId";

384

my $HTMLstart = "$title

$title

\n";

385 0 0 my $casurl_r = "$casurl?r=".url();

386

my $LoginMsg = "

Please use CAS ".

387 "to login.\n";

388

389 0 0 &analyze_cookie;

390 0 0 0 0 if ($SessionId ne '' && param('keywords') eq 'logout') {

391 0 0 logout(); print header_delete_cookie();

0 0

392 0 0 0 if ($retStatus) { return 'logged out' }

0 0

393 0 0 print "";

394 0 0 my $redirect;

395 0 0 0 if ($args{-logout_redirect}) {

396 0 0 $redirect = encodeuri($args{-logout_redirect});

397 0 0 print " 398 "$redirect\">\n"; }

399 0 0 0 my $t = $title; $t = $args{-logout_title} if $args{-logout_title};

0 0

400

print "$t\n

$t

\n";

401

print "

You are logged out.\n";

402 0 0 0 if ($redirect) {

403

print "

You are redirected to $redirect.\n";

404 0 0 } else { print $LoginMsg; }

405 0 0 exit; }

406

407 0 0 0 if ($SessionId ne '') {

408 0 0 my $header = header();

409 0 0 0 if ($header_no_print) { $Header=$header; return 1; }

0 0

410 0 0 print $header; return 1; }

0 0

411

412 0 0 my $request_type = param('request_type');

413 0 0 0 if ($request_type ne 'Proceed') {

414 0 0 0 if ($retStatus) { print header(); return 'not logged in' }

0 0

415 0 0 print CGI::redirect(-uri=>$casurl_r);

416 0 0 exit; }

417 0 0 my $username = param('username'); my $stoken = param('stoken');

0 0

418 0 0 0 0 if ($username eq '' or $stoken eq '') {

419 0 0 0 print header(); if ($retStatus) { return 'not logged in' }

0 0

420 0 0 print $HTMLstart, $LoginMsg; exit; }

0 0

421

422 0 0 0 if ($casurl !~ /^https:\/\//i) {

423 0 0 my $u = CGI::url(); $u=~ s/\/[^\/]+$//; $casurl = "$u/$casurl"; }

0 0

424

425 0 0 require LWP::UserAgent; require HTTP::Request; require Mozilla::CA;

0 0

426 0 0 my $ua = LWP::UserAgent->new();

427 1 1 508 use HTTP::Request::Common qw(POST);

1 22509

1 9564

428 0 0 my $req = POST $casurl, [ rt=>'verify', username=>$username, stoken=>$stoken ];

429 0 0 my $resp = $ua->request($req);

430 0 0 my $result = 'fail';

431 0 0 0 if ($resp->is_success) {

432 0 0 my $message = $resp->decoded_content; $message =~ s/\s//g;

0 0

433 0 0 0 if ($message eq 'answer:ok') { $result = 'ok'; &_dbg383; }

0 0

434 0 0 else { $Error.=" message=($message);" }

435 } else {

436 0 0 $Error.= "HTTP POST error code: ". $resp->code. "\n".

437 "HTTP POST error message: ".$resp->message."\n";

438 }

439 0 0 0 if ($result ne 'ok') {

440 0 0 $Error.="ERR-401:verify failed, result=($result) casurl=($casurl)\n";

441 0 0 print header(); $LogReport.=$Error; &store_log;

0 0

442 0 0 0 if ($retStatus) { return 'login failed'; }

0 0

443 0 0 print $HTMLstart, "Unsuccessful login!\n"; exit; }

0 0

444 0 0 0 my $u = ($AddAuthenticatedUser ? &get_user_by_userid_or_add($username) :

445 &get_user_unique('userid', $username));

446 0 0 0 if ($u eq '') {

447 0 0 $Error.="411-ERR: no userid ($username) in users.db\n";

448 0 0 $LogReport.=$Error; &store_log;

0 0

449 0 0 0 print header(); if ($retStatus) { return 'login failed'; }

0 0

450 0 0 print $HTMLstart,

451 "Unsuccessful login! (username not in users.db, ERR-414)\n";

452 0 0 &store_log; exit; }

0 0

453 0 0 $User = $u; &set_new_session($User);

0 0

454 0 0 $LogReport.="User $UserEmail logged in.\n"; &store_log;

0 0

455 0 0 print header_session_cookie(); return 1;

0 0

456 }

457

458 # Requires session (i.e., to be logged in). Otherwise, makes redirection.

459 sub require_session {

460 0 0 1 0 my %args=@_; my $defaultcgi = 'index.cgi';

0 0

461 0 0 0 0 if (exists($args{-redirect}) && $args{-redirect} ne '' &&

462 $args{-redirect} ne $ENV{SCRIPT_NAME})

463 0 0 { $defaultcgi = $args{-redirect} }

464 0 0 0 0 if (exists($args{-back}) && $args{-back}) {

465 0 0 $defaultcgi.="?goto=$args{-back}";

466 }

467 0 0 &analyze_cookie;

468 0 0 0 if ($SessionId eq '') {

469 0 0 0 if ($ENV{SCRIPT_NAME} eq $defaultcgi) {

470 0 0 print CGI::header(), CGI::start_html, CGI::h1("159-ERR:Login required");

471 0 0 exit; }

472 0 0 print CGI::redirect(-uri=>$defaultcgi); exit;

0 0

473 }

474 }

475

476 # Prepare HTTP header. If SessionId is not empty, generate cookie with

477 # the sessionid and ticket.

478 sub header_session_cookie {

479 0 0 0 0 my %args=@_; my $redirect=$args{-redirect};

0 0

480 0 0 0 if ($redirect ne '') {

481 0 0 0 if ($SessionId eq '') { return redirect(-uri=>$redirect) }

0 0

482 else {

483 0 0 return redirect(-uri=>$redirect,-cookie=>

484 cookie(-name=>$SiteId,

485 -value=>"$SessionId $Ticket"));

486 }

487 } else {

488 0 0 0 if ($SessionId eq '') { return header } else

0 0

489 0 0 { return header(-cookie=>cookie(-name=>$SiteId,

490 -value=>"$SessionId $Ticket")) }

491 }

492 }

493

494 # Delete cookie after logging out. Return string.

495 sub header_delete_cookie {

496 0 0 0 0 return header(-cookie=>cookie(-name=>$SiteId, -value=>'', -expires=>"now")) }

497

498 # Analyze cookie to detect session, and check the ticket as well. It

499 # should be called at the beginning of a script. $SessionId and

500 # $Ticket are set to empty string if not successful. The information

501 # about the session is stored in $DBdir/$DBsessions/$SessionId/session.info

502 # file. The structures $Session and $User are set if successful.

503 sub analyze_cookie {

504 0 0 1 0 my $c = cookie(-name=>$SiteId); # sessionid and ticket

505 0 0 0 if ($DebugLevel > 5) { $LogReport.="cookie:$SiteId:$c\n"; &store_log; }

0 0

506 0 0 0 if ($c eq '') { $SessionId = $Ticket = ''; return; }

0 0

507 0 0 ($SessionId, $Ticket) = split(/\s+/, $c);

508 0 0 0 0 if ($SessionId !~ /^[\w.:-]+$/ or $Ticket !~ /^\w+$/)

509 0 0 { $User = $SessionId = $Ticket = ''; return; }

0 0

510

511 # check validity of session and set user variables

512 0 0 my $sessioninfofile = "$DBdir/$DBsessions/$SessionId/session.info";

513 0 0 0 if (!-f $sessioninfofile) { $SessionId = $Ticket = ''; return; }

0 0

514 0 0 my $se = &read_db_record("file=$sessioninfofile");

515 0 0 0 0 if (!ref($se) or $Ticket ne $se->{'Ticket'})

516 0 0 { $User = $SessionId = $Ticket = ''; return; }

0 0

517 0 0 $Session = $se;

518 0 0 $UserEmail = $se->{email}; $UserId = $se->{userid};

0 0

519 0 0 0 if ($UserEmail =~ /@/) { $User = &get_user_unique('email', $UserEmail) }

0 0 0

520 0 0 elsif ($UserId ne '') { $User = &get_user_unique('userid', $UserId) }

521 0 0 else { $Error.="435-ERR: Could not identify the user.\n"; goto E; }

0 0

522 0 0 0 0 if ($UserId ne '' && $User->{userid} ne $UserId) {

523 0 0 $Error.="437-ERR: Non-matching userid.\n"; goto E; }

0 0

524 0 0 0 if ($Error ne '') { goto E }

0 0

525 0 0 return 1;

526 E:

527 0 0 0 if ($Error ne '') { $LogReport.=$Error; &store_log; }

0 0

528 0 0 $User = $SessionId = $Ticket = ''; return;

0 0

529 }

530

531 ########################################################################

532 # Section: User Management

533

534 sub register_new_user {

535 0 0 0 0 my $reg_userid = param('reg_userid'); my $reg_email = param('reg_email');

0 0

536 0 0 my $reg_password = param('reg_password');

537 0 0 my $reg_password2 = param('reg_password2');

538 0 0 0 if ($reg_userid !~ /^(\w|[.-])+$/) {

539 0 0 $Error = "Userid must consist of \w . or - characters.";

540 0 0 print $Error; exit; }

0 0

541 0 0 0 if (!&emailcheckok($reg_email)) { print "Invalid email."; exit; }

0 0

542 0 0 0 if ($reg_password eq '') { print "Empty password."; exit; }

0 0

543 0 0 0 if ($reg_password ne $reg_password2) {

544 0 0 print "Passwords do not match."; exit; }

0 0

545 0 0 my $confirmation_code = &random_string(12,'0'..'9','A'..'Z','a'..'z');

546 0 0 my $dbf = "$DBdir/$DBusers";

547 0 0 0 0 if (!-f $dbf && !&check_db_files) { print "No db file."; exit; }

0 0

548 0 0 0 if (!&lock_mkdir($dbf)) { print "DB lock fail."; exit; }

0 0

549 0 0 my $dbfc = getfile($dbf); my $db_ref = &read_db($dbfc);

0 0

550 0 0 0 if (ref($db_ref) ne 'ARRAY') {

551 0 0 print "ERR-540: Cound not read db file."; &unlock_mkdir($dbf); exit; }

0 0

552 0 0 my @db = @{ $db_ref };

0 0

553 0 0 0 local *fin = sub { my $url="https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";

554 0 0 print "\nUser browser back button to edit data, or click ".

555 0 0 "Home.\n"; &unlock_mkdir($dbf); exit; };

0 0

556 0 0 for my $u (@db) {

557 0 0 0 if ($u->{userid} eq $reg_userid) { print "Userid already exists."; &fin; }

0 0

558 0 0 0 if ($u->{email} eq $reg_email) { print "Email already exists."; &fin; }

0 0

559 }

560 0 0 $dbfc =~ s/\n+$/\n/s;

561 0 0 $dbfc.="\nuserid:$reg_userid\nemail:$reg_email\n".

562 "status:disabled, waiting for confirmation code $confirmation_code\n";

563 0 0 putfile($dbf,$dbfc);

564 0 0 &unlock_mkdir($dbf);

565 0 0 &password_set($reg_email,$reg_password,'md5');

566 0 0 0 if ($Error) { print "Error: $Error"; exit; }

0 0

567 0 0 print "New user registered.\n";

568 0 0 print "
An email is being sent to confirm your email ".

569 "address...\n";

570 0 0 my $httpsconfirm = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}?".

571 "confirmation_code=$confirmation_code";

572 0 0 my $msg = "Hi,\n\nPlease click or visit the following link to confirm ".

573 "your registration at the site $SiteId:\n\n".

574 "$httpsconfirm\n\nBest regards,\n$SiteId Admin\n";

575 0 0 &send_email_to($reg_email, "Subject: $SiteId Email Confirmation", $msg);

576 0 0 print "
Email sent. Use the sent link to confirm your email.\n";

577 }

578

579 sub email_confirmation {

580 0 0 0 0 my $confirmation_code = shift;

581 0 0 my $dbf = "$DBdir/$DBusers";

582 0 0 0 0 if (!-f $dbf && !&check_db_files) { print "No db file."; exit; }

0 0

583 0 0 0 if (!&lock_mkdir($dbf)) { print "DB lock fail."; exit; }

0 0

584 0 0 my $dbfc = getfile($dbf); my $db_ref = &read_db($dbfc);

0 0

585 0 0 0 if (ref($db_ref) ne 'ARRAY') {

586 0 0 print "ERR-540: Cound not read db file."; &unlock_mkdir($dbf); exit; }

0 0

587 0 0 my @db = @{ $db_ref }; my $flag = '';

0 0

588 0 0 for my $u (@db) {

589 0 0 0 0 if (defined($u->{status}) and

590 $u->{status} =~ /^disabled, waiting for confirmation code (\S+)/ and

591 $1 eq $confirmation_code) {

592 $u->{status} =~

593 0 0 s/^disabled, waiting for confirmation code (\S+)/email confirmed/;

594 0 0 $flag = 1; last; } }

0 0

595 0 0 0 if (!$flag) { print "Invalid confirmation code.\n"; &unlock_mkdir($dbf);

0 0

596 0 0 return; }

597 0 0 _db8_update("file=$dbf", \@db);

598 0 0 &unlock_mkdir($dbf);

599 0 0 print "Email confirmed.\n

600 "$ENV{SCRIPT_NAME}\">Login page\n";

601 }

602

603 ########################################################################

604 # Section: Session Management

605

606 # params: $email, opt: pwstore type: md5 raw

607 sub reset_password {

608 0 0 0 0 0 my $email = shift; my $pwstore = shift; $pwstore = 'md5' if $pwstore eq '';

0 0

609 0 0 my $password = &random_password(6); my $pwdf = "$DBdir/$DBpwd";

0 0

610 0 0 0 if (!-f $pwdf) { putfile $pwdf, ''; chmod 0600, $pwdf }

0 0

611 0 0 0 if (!&lock_mkdir($pwdf)) { $Error.="378-ERR:\n"; return ''; }

0 0

612 0 0 0 local *PH; open(PH, $pwdf) or croak($!);

0 0

613 0 0 my $content = '';

614 0 0 while () {

615 0 0 my ($e,$p) = split;

616 0 0 0 $content .= $_ if $e ne $email;

617 }

618 0 0 close(PH);

619 0 0 $content .= "$email ";

620 0 0 0 if ($pwstore eq 'raw') { $content.="raw:$password" }

0 0 0

621 0 0 elsif($pwstore eq 'md5') { $content.="md5:".md5_base64($password) }

622 0 0 else { $content.="raw:$password" }

623 0 0 $content .= "\n";

624 0 0 putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);

0 0

625 0 0 return $password;

626 }

627

628 # $pwstoretype:md5,raw

629 sub password_set {

630 0 0 0 0 my $email = shift; my $pwd = shift; my $pwstoretype = shift;

0 0

631 0 0 0 $pwstoretype = 'md5' if $pwstoretype eq '';

632 0 0 my $pwdf = "$DBdir/$DBpwd";

633 0 0 0 if (!&check_db_files) { $Error.="AuthERR-587:\n"; return '' }

0 0

634 0 0 0 if (!&lock_mkdir($pwdf)) { $Error.="AuthErr-588:\n"; return ''; }

0 0

635 0 0 0 local *PH; open(PH, $pwdf) or croak($!);

0 0

636 0 0 my $newrow = "$email ";

637 0 0 0 if ($pwstoretype eq 'md5') { $newrow.="md5:".md5_base64($pwd)."\n" }

0 0

638 0 0 else { $newrow.="raw:$pwd\n" }

639 0 0 my $content = '';

640 0 0 while () {

641 0 0 my ($e,$p) = split;

642 0 0 0 if ($e eq $email) { $content.=$newrow; $newrow=''; }

0 0

643 0 0 else { $content.=$_ }

644 }

645 0 0 $content.=$newrow; $newrow=''; close(PH);

0 0

646 0 0 putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);

0 0

647 0 0 return 1;

648 }

649

650 sub md5_base64 {

651 0 0 0 0 my $arg=shift; require Digest::MD5; return Digest::MD5::md5_base64($arg); }

0 0

652

653 sub random_password {

654 0 0 0 0 0 my $n = shift; $n = 8 unless $n > 0;

0 0

655 0 0 my @chars = (2..9, 'a'..'k', 'm'..'z', 'A'..'N', 'P'..'Z',

656 qw(, . / ? ; : - = + ! @ $ % *) );

657 0 0 return join('', map { $chars[rand($#chars+1)] } (1..$n));

0 0

658 }

659

660 # removes session file and return the appropriate HTTP header

661 sub logout {

662 0 0 0 0 0 if ($Session eq '') { $Error.= "481-ERR: No session to log out\n"; return; }

0 0

663 0 0 0 if (!-d "$DBdir/$DBsessions/$SessionId") { $Error.="482-ERR: No session dir\n" }

0 0

664 else {

665 0 0 unlink(<$DBdir/$DBsessions/$SessionId/*>);

666 0 0 rmdir("$DBdir/$DBsessions/$SessionId"); }

667 0 0 $LogReport.=$Error."User UserId:$UserId UserEmail:$UserEmail logged out.\n";

668 0 0 &store_log; $Session = $SessionId = $Ticket = '';

0 0

669 0 0 return 1;

670 }

671

672 # The first parameter can be an userid and email. (diff by @)

673 sub login {

674 0 0 0 0 my $email = shift; my $password = shift;

0 0

675 0 0 $email = lc $email; my $userid;

0 0

676 0 0 0 if ($email !~ /@/) { $userid=$email; $email=''; }

0 0

677 0 0 0 if ($email ne '') {

678 0 0 0 if (!&emailcheckok($email)) {

679 0 0 $Error.="402-ERR:Incorrect email address format"; return; }

0 0

680 #my $u = &get_user_by_email($email);

681 0 0 my $u = &get_user_unique('email', $email);

682 0 0 0 if ($u eq '') { $Error.='405-ERR:Email not registered'; return; }

0 0

683 0 0 $userid = $u->{userid};

684 0 0 $User = $u;

685 } else {

686 0 0 0 if ($userid eq '') { $Error.="409-ERR:Empty userid"; return; }

0 0

687 0 0 0 0 if ($LDAPuse and $LDAPaddUsers) {

688 0 0 return _login_ldap_add($userid, $password); }

689 0 0 my $u = &get_user_unique('userid', $userid);

690 0 0 0 if ($u eq '') { $Error.='531-ERR:Not exist-unique'; &store_log; return; }

0 0

691 0 0 $email = $u->{email};

692 0 0 $User = $u;

693 }

694 # Randomize more salt

695 0 0 $SecretSalt = md5_base64("$SecretSalt $password");

696

697 0 0 0 if (!password_check($User, $password)) {

698 0 0 $Error.="418:Invalid password\n"; return ''; }

0 0

699

700 0 0 &set_new_session($User);

701 0 0 $LogReport.="User $UserEmail logged in.\n"; &store_log;

0 0

702 0 0 return 1;

703 }

704

705 sub _login_ldap_add {

706 0 0 0 my $userid = shift; my $password = shift;

0 0

707 0 0 0 if (!&password_check_ldap($userid, $password)) {

708 0 0 $Error.="570-ERR:Invalid password for LDAP\n"; return ''; }

0 0

709 0 0 my $u = &get_user_by_userid_or_add($userid);

710 0 0 0 if ($u eq '') { $Error.="572-ERR:\n"; &store_log; return; }

0 0

711 0 0 $User = $u;

712 # Randomize more salt

713 0 0 $SecretSalt = md5_base64("$SecretSalt $password");

714 0 0 &set_new_session($User);

715 0 0 $LogReport.="User userid:$userid logged in.\n"; &store_log;

0 0

716 0 0 return 1;

717 }

718

719 sub set_new_session {

720 0 0 0 0 my $u = shift;

721 0 0 my $email = $u->{email};

722 0 0 my $userid = $u->{userid};

723 0 0 0 0 if ($email !~ /@/ && $userid !~ /\w/) {

724 0 0 $Error .= "586-ERR: No email nor userid\n"; return ''; }

0 0

725 0 0 my $sDir = "$DBdir/$DBsessions";

726 0 0 0 0 if (!-d $sDir && !&check_db_files) { return ''; }

0 0

727

728 0 0 $^T =~ /\d{6}$/; my $sessionid = 't'.$&.'_';

0 0

729 0 0 my $a = $userid.'_'.$email,'______';

730 0 0 $a =~ /.*?(\w).*?(\w).*?(\w).*?(\w).*?(\w).*?(\w)/;

731 0 0 $sessionid.= $1.$2.$3.$4.$5;

732 0 0 0 if (! mkdir("$sDir/$sessionid", 0700)) {

733 0 0 0 my $cnt=1; for(;$cnt<100 and !mkdir("$sDir/${sessionid}_$cnt", 0700); ++$cnt) {}

0 0

734 0 0 0 croak "Cannot create sessions!" if $cnt == 100;

735 0 0 $sessionid = "${sessionid}_$cnt";

736 }

737 0 0 $SessionId = $sessionid; $Ticket = &gen_secret;

0 0

738 0 0 my $sessionrecord = "SessionId:$SessionId\nTicket:$Ticket\n";

739 0 0 0 $sessionrecord.="email:$email\n" if $email ne '';

740 0 0 0 $sessionrecord.="userid:$userid\n" if $userid ne '';

741 0 0 my $sessioninfofile = "$sDir/$SessionId/session.info";

742 0 0 putfile($sessioninfofile, $sessionrecord);

743 0 0 $UserEmail = $email; $UserId = $userid; $User = $u;

0 0

744 0 0 $Session = &read_db_record("file=$sessioninfofile");

745 0 0 0 die unless ref($Session);

746 0 0 return $SessionId;

747 }

748

749 # Return 1 if OK, '' otherwise

750 sub password_check {

751 0 0 0 0 my $u = shift; my $password = shift;

0 0

752 0 0 0 0 if (defined($u->{status}) and $u->{status}=~/^\s*disabled\b/)

753 0 0 { return '' }

754 0 0 0 if ($LDAPuse) { return &password_check_ldap($u->{userid}, $password); }

0 0

755 0 0 my $pwstored = &find_password($u->{email});

756 0 0 0 if ($pwstored =~ /^raw:/) {

757 0 0 0 $pwstored=$'; return ( ($pwstored eq $password) ? 1 : '' ); }

0 0

758 0 0 0 if ($pwstored =~ /^md5:/) {

759 0 0 0 $pwstored=$'; return ( ($pwstored eq md5_base64($password)) ? 1 : ''); }

0 0

760 0 0 $Error.="316-ERR:PWCheck error($pwstored)\n"; $ErrorInternal="AuthRegister:$Error"; return '';

0 0

761 }

762

763 # Modifying for LDAP; Return 1 if OK, '' otherwise

764 sub password_check_ldap {

765 0 0 0 0 my $username = shift; my $password = shift;

0 0

766 0 0 $username =~ s/[^a-zA-Z0-9._+=-]//g;

767 0 0 0 0 if ($username eq '' or $LDAPserver eq '' or $LDAPdn eq '') { return '' }

0 0 0

768 #use Net::LDAP;

769 0 0 eval "require Net::LDAP;";

770 0 0 0 if ($@) { $Error.="643-ERR: Net::LDAP module required for LDAP ".

0 0

771 0 0 "functionality\n"; return ''; }

772 0 0 my $dn = "uid=$username,$LDAPdn";

773 0 0 0 my $ldap = Net::LDAP->new("ldaps://$LDAPserver") or die "$@";

774 0 0 my $mesg = $ldap->bind($dn, password => $password);

775 0 0 0 if ($mesg->code == 0) {

776 # Password correct

777 0 0 $ldap->unbind; $ldap->disconnect;

0 0

778 0 0 return 1;

779 }

780 # else invalid password

781 0 0 $ldap->unbind;

782 0 0 $ldap->disconnect;

783 0 0 return '';

784 }

785

786 sub find_password {

787 0 0 0 0 my $email = shift; my $pwfile = "$DBdir/$DBpwd";

0 0

788 0 0 $email = lc $email;

789 0 0 0 0 if (!-f $pwfile && !&check_db_files) { return '' }

0 0

790 0 0 0 if (!&lock_mkdir($pwfile)) { $Error.="431-ERR:\n"; return ''; }

0 0

791 0 0 0 local *PH; if (!open(PH,$pwfile)) { &unlock_mkdir($pwfile);

0 0

792 0 0 $Error.="433-ERR: Cannot open ($pwfile):$!\n"; return ''; }

0 0

793 0 0 while () {

794 0 0 my ($e,$p) = split; $e = lc $e;

0 0

795 0 0 0 if ($e eq $email) { close(PH); &unlock_mkdir($pwfile); return $p; }

0 0

796 }

797 0 0 $Error.="NOTFOUND($email)";

798 0 0 close(PH); &unlock_mkdir($pwfile); return '';

0 0

799 }

800

801 # Try to generate a secure random secret

802 # The best option is to use Math::Random::Secure if available

803 # This implementation uses its own additional randomization

804 sub gen_secret {

805 0 0 0 0 0 my $n = shift; $n = 10 unless $n > 0; my $ret;

0 0

806 0 0 while (length($ret) < $n) {

807 0 0 $SecretSalt.= md5_base64($SecretSalt.rand);

808 0 0 my $a=md5_base64($SecretSalt.rand); $a=~ s/[+\/]//g; $ret.=$a;

0 0

809 }

810 0 0 return substr($ret, 0, $n);

811 }

812

813 sub random_name {

814 1 50 1 0 2 my $n = shift; $n = 8 unless $n > 0;

1 5

815 1 7 my @chars = (0..9, 'a'..'z', 'A'..'Z');

816 1 3 return join('', map { $chars[rand($#chars+1)] } (1..$n));

8 53

817 }

818

819 sub store_log {

820 0 0 0 0 if($#_>=-1) { $LogReport.=$_[0] }

821 0 0 return if $LogReport eq '';

822 0 0 if ($SendLogs) { &send_email_to_admin('Log entry', $LogReport); }

823 0 $LogReport = '';

824 }

825

826 ########################################################################

827 # Section: Email communication

828

829 # params: $email, opt: 'raw' or 'md5' to generate passord

830 sub reset_and_send_email_reminder {

831 0 0 0 my $email = shift; my $pwstore = shift;

832 0 $email=lc $email; $email =~ s/\s/ /g;

833 0 0 if ($email eq '') {

834 0 $Error.="328-ERR:No e-mail provided to send password\n"; return; }

835 0 0 if (!emailcheckok($email)) {

836 0 $Error.="330-ERR:Invalid e-mail address provided($email)\n"; return; }

837 0 my $user = get_user_unique('email',$email);

838 0 0 if ($user eq '') {

839 0 $Error.="333-ERR: No user with email ($email)\n"; return; }

840 0 my $pw = &reset_password($email, $pwstore);

841 0 &send_email_reminder1($email, $pw);

842 0 return 1;

843 }

844

845 # params: $email, opt: 'raw' or 'md5' to generate new password if not found

846 sub send_email_reminder {

847 0 0 0 my $email = shift; my $pwstore = shift;

848 0 $email=lc $email; $email =~ s/\s/ /g;

849 0 0 if ($email eq '') {

850 0 $Error.="505-ERR:No e-mail provided to send password\n"; return; }

851 0 my $user;

852 0 0 if ($email =~ /@/) { $user = &get_user_unique('email', $email) }

853 0 else { $user = &get_user_unique('userid', $email) }

854 0 0 if ($user eq '') {

855 0 $Error.="510-ERR: No user with userid/email ($email)\n"; return; }

856 0 $email = $user->{email};

857 0 0 if (!emailcheckok($email)) {

858 0 $Error.="513-ERR:Invalid e-mail address ($email)\n"; return; }

859 0 my $pw = find_password($email);

860 0 0 if ($pw =~ /^raw:/) { $pw = $' }

861 0 elsif ($pw ne '') { $Error.="516-ERR:Cannot retrieve password\n"; return; }

862 0 else { $pw = &reset_password($email, $pwstore) }

863

864 0 &send_email_reminder1($email, $pw);

865 0 return 1;

866 }

867

868 sub send_email_reminder1 {

869 0 0 0 my $email = shift; my $pw = shift;

870 0 my $httpslogin = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";

871

872 0 my $msg = "Hi,\n\nYour email and password for the $SiteId site is:\n\n".

873 "Email: $email\nPassword: $pw\n\n".

874 "You can log in at:\n\n$httpslogin\n\n\n".

875 # "$HttpsBaseLink/login.cgi\n\n\n".

876 "Best regards,\n$SiteId Admin\n";

877 0 &send_email_to($email, "Subject: $SiteId Password Reminder", $msg);

878 }

879

880 sub send_email_to_admin {

881 0 0 0 my $subject = shift; my $msg1 = shift;

882 0 $subject =~ s/\s+/ /g;

883 0 $subject = "Subject: [$SiteId System Report] $subject";

884 0 0 return if $Email_bcc eq '';

885 0 my $msg = '';

886 0 0 $msg.="From: $Email_from\n" unless $Email_from eq '';

887 0 $msg.="To: $Email_bcc\n";

888 0 $msg.="$subject\n\n$msg1";

889 0 &_send_email($msg);

890 }

891

892 sub send_email_to {

893 0 0 0 0 my $email = shift; croak unless &emailcheckok($email);

894 0 my $subject = shift; $subject =~ s/[\n\r]/ /g;

895 0 0 if ($subject !~ /^Subject: /) { $subject = "Subject: $subject" }

896 0 my $msg1 = shift;

897

898 0 my $msg = '';

899 0 0 $msg.="From: $Email_from\n" unless $Email_from eq '';

900 0 $msg.="To: $email\n";

901 0 0 $msg.="Bcc: $Email_bcc\n" unless $Email_bcc eq '';

902 0 $msg.="$subject\n\n$msg1";

903 0 &_send_email($msg);

904 }

905

906 sub _send_email {

907 0 0 my $fullmessage = shift;

908 0 0 if (! -x $Sendmail) {

909 0 $Error.="390-ERR:No sendmail ($Sendmail)\n"; return ''; }

910 0 local *S;

911 0 0 if (!open(S,"|$Sendmail -ti")) {

912 0 $Error.="393-ERR:Cannot run sendmail:$!\n"; return ''; }

913 0 print S $fullmessage; close(S);

914 }

915

916 ########################################################################

917 # Section: Data checks and transformations

918

919 # encode string into a \w* sequence

920 sub encode_w {

921 0 0 0 local $_ = shift;

922 0 s/[\Wx]/'x'.uc unpack("H2",$&)/ge;

923 0 return $_;

924 }

925

926 sub decode_w {

927 0 0 0 local $_ = shift;

928 0 s/x([0-9A-Fa-f][0-9A-Fa-f])/pack("c",hex($1))/ge;

929 0 return $_;

930 }

931

932 sub encodeuri($) {

933 0 0 0 local $_ = shift;

934 0 s/[^-A-Za-z0-9_.~:\/?=]/"%".uc unpack("H2",$1)/ge;

935 0 return $_;

936 }

937

938 # Prepare for HTML display by quoting meta characters.

939 0 0 0 sub htmlquote($) { local $_ = shift; s/&/&/g; s/

940

941 sub emailcheckok {

942 0 0 0 my $email = shift;

943 0 0 if ($email =~ /^[a-zA-Z][\w\.+-]*[a-zA-Z0-9+-]@

944 [a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$/x)

945 0 { return 1 }

946 0 return '';

947 }

948

949 sub useridcheckok {

950 0 0 0 0 my $userid = shift; return 1 if $userid=~/^[a-zA-Z0-9-]+$/; return ''; }

951

952 # DB related functions

953

954 sub read_users_db {

955 0 0 0 my $f = "$DBdir/$DBusers";

956 0 0 if (!-f $f) { $Error.= "636-ERR: no file $f\n"; return; }

957 0 return &read_db("file=$f") }

958

959 sub _db8_find_first {

960 0 0 my $dbf = shift; my $k = shift; my $v = shift;

961 0 0 die unless $k =~ /^k=/; $k = $';

962 0 my $db_ref = &read_db("file=$dbf");

963 0 0 if (ref($db_ref) ne 'ARRAY') {

964 0 $Error.="745-ERR: Could not read db file ($dbf)"; return ''; }

965 0 my @db = @{ $db_ref };

966 0 for my $r (@db) {

967 0 0 0 if (exists($r->{$k}) && $v eq $r->{$k}) { $Error.="FOUND\n"; return $r } }

968 0 return '';

969 }

970

971 sub get_user {

972 0 0 0 my $k = shift; my $v = shift;

973 0 my $db_ref = &read_users_db;

974 0 0 if (ref($db_ref) ne 'ARRAY') {

975 0 $Error.="AuthERR-836: Could not get users data (file system problem?)\n";

976 0 return $User='';

977 }

978 0 my @db = @{ $db_ref };

979 0 for my $r (@db)

980 0 0 0 { if (exists($r->{$k}) && $v eq $r->{$k}) { return $User=$r } }

981 0 $Error.="AuthERR-842: no user with key=($k) v=($v)\n"; return $User='';

982 }

983

984 sub get_user_by_email {

985 0 0 0 my $email = shift;

986 0 my $db_ref = &read_users_db;

987 0 0 if (ref($db_ref) ne 'ARRAY') {

988 0 $Error.="657-ERR: Could not get users data (file system problem?)";

989 0 return $User=''; }

990 0 my @db = @{ $db_ref };

991 0 0 for my $r (@db) { if (lc($email) eq lc($r->{email})) { return $User=$r } }

992 0 $Error.="661-ERR: no user with email ($email)\n"; return $User='';

993 }

994

995 0 0 0 sub get_user_by_userid { return &get_user('userid', $_[0]) }

996

997 # Get user by userid, or add userid if does not exist

998 sub get_user_by_userid_or_add {

999 0 0 0 my $userid = shift; my $f = "$DBdir/$DBusers";

1000 0 0 0 if (!-f $f && !&check_db_files) { return '' }

1001 0 my @db = @{ &read_db("file=$f") };

1002 0 my $u = '';

1003 0 for my $r (@db) {

1004 0 0 next unless exists($r->{userid}); my $v1 = $r->{userid};

1005 0 $v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;

1006 0 0 next unless $v1 eq $userid;

1007 0 0 if ($u eq '') { $u = $r; next; }

1008 0 $Error.= "819-ERR: double userid ($userid)\n"; return '';

1009 }

1010 0 0 return $User=$u unless $u eq '';

1011 0 $userid =~ s/\s//g; &_db8_append($f, "userid:$userid");

1012 0 return get_user_by_userid($userid);

1013 }

1014

1015 # Get user by a key,value, but make sure there is exactly one such user

1016 # Normalizes whitespace and case insensitive

1017 sub get_user_unique {

1018 0 0 0 my $k = shift; my $v = shift; my $f = "$DBdir/$DBusers";

1019 0 0 0 if (!-f $f && !&check_db_files) { return '' }

1020 0 my @db = @{ &read_db("file=$f") };

1021 0 $v=~s/^\s+//; $v=~s/\s+$//; $v=~s/\s+/ /g; $v = lc $v;

1022 0 0 0 if ($k eq '' or $v eq '')

1023 0 { $Error.="669-ERR:Empty k or v ($k:$v)\n"; return ''; }

1024 0 my $u = '';

1025 0 for my $r (@db) {

1026 0 0 next unless exists($r->{$k}); my $v1 = $r->{$k};

1027 0 $v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;

1028 0 0 next unless $v eq $v1;

1029 0 0 if ($u eq '') { $u = $r; next; }

1030 0 $Error.= "676-ERR: double user key ($k:$v)\n"; return '';

1031 }

1032 0 0 return $User=$u unless $u eq '';

1033 0 $Error.="894-ERR: no user with key ($k:$v)\n"; return '';

1034 }

1035

1036 sub check_db_files {

1037 0 0 0 my $ret; my $pwfile = "$DBdir/$DBpwd";

1038 0 0 if (!-d $DBdir) { $ret = mkdir($DBdir, 0700);

1039 0 0 if (!$ret) { $Error.="687-ERR: Could not create dir '$DBdir'"; return ''; }}

1040 0 0 if (!-f $pwfile) { putfile $pwfile, ''; chmod 0600, $pwfile; }

1041 0 0 if (!-f $pwfile) { $Error.="689-ERR: Could not create $pwfile file";

1042 0 return ''; }

1043 0 my $f = "$DBdir/$DBusers";

1044 0 0 if (!-f $f) { putfile $f, "#userid:someid\n#email:email\@domain.com\n";

1045 0 chmod 0600, $f; }

1046 0 0 if (!-f $f) { $Error.="694-ERR: Could not create $f file"; return ''; }

1047 0 $f = "$DBdir/$DBsessions";

1048 0 0 if (!-d $f) { $ret = mkdir($f, 0700);

1049 0 0 if (!$ret) { $Error.="708-ERR: Could not create dir '$f'"; return ''; }}

1050

1051 0 return 1;

1052 }

1053

1054 # _db8_update - updates given db with minimal changes

1055 # Usage: db8_update($strOrFile, $db)

1056 # 2013-2017 Vlado Keselj, version 1.4; documentation in DB822.txt

1057 # Example: &db8_update("file=$filename", $db);

1058 sub _db8_update {

1059 0 0 my $arg = shift; my $db=shift; my $file='';

1060 0 0 if ($arg =~ /^file=/) {

1061 0 0 $file = $'; die "file=''!?" if $file eq '';

1062 0 0 local *F; open(F, $file) or die "cannot open $file:$!";

1063 0 $arg = join('', );

1064 0 close(F);

1065 }

1066

1067 0 my $arg_save = $arg; my $dbi = 0; my $argcopy = '';

1068 0 while ($arg) {

1069 # allow comments and space betwen records

1070 0 0 if ($arg =~ /^(\s*\n|[ \t]*#.*\n)*/) { $argcopy.=$&; $arg = $'; }

1071 0 my $record;

1072 0 0 if ($arg =~ /\n(\n+)/) { $record = "$`\n"; $arg = $1.$'; }

1073 0 else { $record = $arg; $arg = ''; }

1074 0 0 if ($dbi > $#{$db}) { last }

1075 0 my $r = {}; my %savedkeys = ();

1076 0 while ($record) {

1077 0 my $avpair = '';

1078 0 0 if ($record =~ /^.*/) { $avpair = $& }

1079 0 while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)

1080 0 { $record = "$1 $3$'"; $avpair.= $2.$3; }

1081 0 0 $record =~ /^([^\n:]*):(.*)\n/ or die;

1082 0 my $k = $1; my $v = $2; $record = $';

1083 0 $avpair .= "\n";

1084 0 0 if (exists($r->{$k})) {

1085 0 my $c = 0;

1086 0 while (exists($r->{"$k-$c"})) { ++$c }

1087 0 $k = "$k-$c";

1088 }

1089 0 $r->{$k} = $v;

1090 0 0 0 if (exists($db->[$dbi]->{$k}) && $db->[$dbi]->{$k} eq $v)

1091 0 { $argcopy .= $avpair }

1092 elsif (exists($db->[$dbi]->{$k})) {

1093 0 my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved

1094 0 $argcopy .= "$k:$newv\n";

1095 } # else skip it

1096 0 $savedkeys{$k} = 1;

1097 }

1098 0 for my $k (keys %{ $db->[$dbi] }) {

1099 0 0 if (!exists($savedkeys{$k})) {

1100 0 my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved

1101 0 $argcopy .= "$k:$newv\n";

1102 }

1103 }

1104 0 ++$dbi;

1105 }

1106

1107 0 while ($dbi <= $#{$db}) {

1108 0 $argcopy .= "\n";

1109 0 for my $k (sort(keys(%{ $db->[$dbi] }))) {

1110 0 my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved

1111 0 $argcopy .= "$k:$newv\n";

1112 }

1113 0 ++$dbi;

1114 }

1115

1116 0 0 if ($file ne '') {

1117 0 0 if ($argcopy ne $arg_save) {

1118 #rename($file, "$file.bak");

1119 0 local *F; open(F,">$file"); print F $argcopy; close(F);

1120 }

1121 0 return;

1122 0 } else { return $argcopy }

1123 } # end of _db8_update

1124

1125 sub _db8_remove {

1126 0 0 my $dbf = shift; my $kdel = shift; my $vdel = shift;

1127 0 0 die unless $kdel =~ /^k=/; $kdel = $';

1128 0 0 if (!&lock_mkdir($dbf)) { $Error.="793-ERR"; return '' }

1129 0 0 local *F; if (!open(F, $dbf)) { &unlock_mkdir($dbf);

1130 0 $Error.="795-ERR: opening file $dbf: $!"; return ''; }

1131 0 my $arg = join('',); close(F);

1132

1133 0 my $arg_save = $arg; my $dbi = 0; my $argcopy = '';

1134 0 while ($arg) {

1135 0 my $prologue;

1136 0 0 if ($arg =~ /^([ \t\r]*(#.*)?\n)+/) { $prologue = $&; $arg = $'; }

1137 0 $argcopy.=$prologue;

1138 0 0 last if $arg eq ''; my $record; my $record_save;

1139 0 0 if ($arg =~ /([ \t\r]*\n){2,}/) {

1140 0 $record = "$`\n"; $arg = $'; $record_save = "$`$&"; }

1141 0 else { $record_save = $record = $arg; $arg = ''; }

1142 0 my $r = {};

1143 0 while ($record) {

1144 0 0 $record =~ /^[ \t]*([^\n:]*?)[ \t]*:/ or die "db8: no attribute";

1145 0 my $k = $1; $record = $';

1146 0 while ($record =~ /^(.*)(\\\r?\n|\r?\n[ \t]+)(\S.*)/)

1147 0 { $record = "$1 $3$'" }

1148 0 0 $record =~ /^[ \t]*(.*?)[ \t\r]*\n/ or die;

1149 0 my $v = $1; $record = $';

1150 0 0 if (exists($r->{$k})) {

1151 0 my $c = 0;

1152 0 while (exists($r->{"$k-$c"})) { ++$c }

1153 0 $k = "$k-$c";

1154 }

1155 0 $r->{$k} = $v;

1156 }

1157 0 0 0 if (exists($r->{$kdel}) && $r->{$kdel} eq $vdel) {}

1158 0 else { $argcopy .= $record_save }

1159 }

1160

1161 0 0 if ($argcopy ne $arg_save) {

1162 0 0 if (!open(F, ">$dbf.lock/new")) { &unlock_mkdir($dbf);

1163 0 $Error.="828-ERR: opening file $dbf.lock/new: $!"; return ''; }

1164 0 print F $argcopy; close(F); chmod 0600, "$dbf.lock/new"; unlink($dbf);

1165 0 rename("$dbf.lock/new", $dbf); }

1166 0 &unlock_mkdir($dbf);

1167 } # end of _db8_remove

1168

1169 # Read DB records in the RFC822-like style (to add reference).

1170 sub read_db {

1171 0 0 0 my $arg = shift;

1172 0 0 if ($arg =~ /^file=/) {

1173 0 0 my $f = $'; if (!&lock_mkdir($f)) { return '' }

1174 0 local *F;

1175 0 0 if (!open(F, $f)) {

1176 0 $Error.="ERR-945: $f: $!"; &unlock_mkdir($f); return ''; }

1177 0 $arg = join('', ); close(F); &unlock_mkdir($f);

1178 }

1179

1180 0 my $db = [];

1181 0 while ($arg) {

1182 0 $arg =~ s/^\s*(#.*\s*)*//; # allow comments betwen records

1183 0 my $record;

1184 0 0 if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }

1185 0 else { $record = $arg; $arg = ''; }

1186 0 my $r = {};

1187 0 while ($record) {

1188 0 0 if ($record =~ /^#.*\n?/) { $record=$'; next; }

1189 0 while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)

1190 0 { $record = "$1 $3$'" }

1191 0 0 $record =~ /^([^\n:]*):(.*)\n/ or die;

1192 0 my $k = $1; my $v = $2; $record = $';

1193 0 0 if (exists($r->{$k})) {

1194 0 my $c = 0;

1195 0 while (exists($r->{"$k-$c"})) { ++$c }

1196 0 $k = "$k-$c";

1197 }

1198 0 $r->{$k} = $v;

1199 }

1200 0 push @{ $db }, $r;

1201 }

1202 0 return $db;

1203 }

1204

1205 # Append a record or records to db8

1206 # Assumes that the file is in a good format

1207 sub _db8_append {

1208 0 0 my $fdb=shift;

1209 0 0 if (!&lock_mkdir($fdb)) { $Error.="ERR-975: $!"; return '' }

1210 0 0 local *F; if (!open(F, ">>$fdb")) { &unlock_mkdir($fdb);

1211 0 $Error.="ERR-977: write file $fdb: $!"; return ''; }

1212 0 while (@_) { my $r=shift; $r =~ s/\s*$/\n/s; print F "\n$r"; }

1213 0 &unlock_mkdir($fdb);

1214 }

1215

1216 # Read one DB record in the RFC822-like style (to add reference).

1217 sub read_db_record {

1218 0 0 0 my $arg = shift;

1219 0 0 if ($arg =~ /^file=/) {

1220 0 0 my $f = $'; local *F; open(F, $f) or die "cannot open $f:$!";

1221 0 $arg = join('', ); close(F);

1222 }

1223

1224 0 while ($arg =~ s/^(\s*|\s*#.*)\n//) {} # allow comments before record

1225 0 my $record;

1226 0 0 if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }

1227 0 else { $record = $arg; $arg = ''; }

1228 0 my $r = {};

1229 0 while ($record) {

1230 0 while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)

1231 0 { $record = "$1 $3$'" }

1232 0 0 $record =~ /^([^\n:]*):(.*)\n/ or die;

1233 0 my $k = $1; my $v = $2; $record = $';

1234 0 0 if (exists($r->{$k})) {

1235 0 my $c = 0;

1236 0 while (exists($r->{"$k-$c"})) { ++$c }

1237 0 $k = "$k-$c";

1238 }

1239 0 $r->{$k} = $v;

1240 }

1241 0 return $r;

1242 }

1243

1244 # parameters: $n - sequence length; @_ domain elements

1245 sub random_string {

1246 0 0 0 my $n = shift;

1247 0 0 return '' if $n < 1;

1248 0 my @r = map { $_[rand($#_+1)] } (1..$n);

1249 0 return join('',@r);

1250 }

1251

1252 sub putfile($@) {

1253 0 0 0 my $f = shift; local *F;

1254 0 0 if (!open(F, ">$f")) { $Error.="325-ERR:Cannot write ($f):$!\n"; return; }

1255 0 for (@_) { print F } close(F);

1256 }

1257

1258 sub getfile($) {

1259 0 0 0 my $f = shift; local *F;

1260 0 0 if (!open(F, "<$f")) {

1261 0 $Error.="ERR-1099:getfile:cannot open $f:$!"; return; }

1262 0 my @r = ; close(F);

1263 0 0 return wantarray ? @r : join ('', @r);

1264 }

1265

1266 ########################################################################

1267 # Section: Simple file locking using mkdir

1268

1269 # Exlusive locking using mkdir

1270 # lock_mkdir($fname); # return 1=success ''=fail

1271 sub lock_mkdir {

1272 0 0 0 my $fname = shift; my $lockd = "$fname.lock"; my $locked;

1273 # First, hopefully most usual case

1274 0 0 0 if (!-e $lockd && ($locked = mkdir($lockd,0700))) { return $locked }

1275 0 my $tryfor=10; #sec

1276 0 $locked = ''; # flag

1277 0 for (my $i=0; $i<2*$tryfor; ++$i) {

1278 0 select(undef,undef,undef,0.5); # wait for 0.5 sec

1279 0 0 !-e $lockd && ($locked = mkdir($lockd,0700));

1280 0 0 if ($locked) { return $locked }

1281 }

1282 0 $Error.="393-ERR:Could not lock file ($fname)\n"; return $locked;

1283 }

1284

1285 # Unlock using mkdir

1286 # unlock_mkdir($fname); # return 1=success ''=fail or no lock

1287 sub unlock_mkdir {

1288 0 0 0 my $fname = shift; my $lockd = "$fname.lock";

1289 0 0 if (!-e $lockd) { $Error.="400-ERR:No lock on ($fname)\n"; return '' }

1290 0 0 if (-d $lockd) { return rmdir($lockd) }

1291 0 0 0 if (-f $lockd or -l $lockd) { unlink($lockd) }

1292 0 $Error.="AuthERR-1279:Unknown error"; return '';

1293 }

1294

1295 ########################################################################

1296 # Section: Prepackaged HTML and CSS files

1297

1298 sub gen_cas_page {

1299 0 0 0 my $ret;

1300 #

1301 # echo "\$ret=<<'EOT';\n${c}EOT"; !>#+

1302 0 $ret=<<'EOT';

1303

1304 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

1305

1306 CAS - Central Authentication Service

1307

1308

1309

1310

1311

1312 media="handheld, only screen and (max-device-width: 480px)" type="text/css">

1313

1314

1319

1320

1325

1326

1327

1328

1329

CAS – Central Authentication

1330 Service

1331

1332

1333

1334

1335

1336

1337
1338							Login Required
1339							CAS Authentication
1340
1341
1342

1343							UserID:
1344
1345
1346							size="20" autocomplete="off" type="text">
1347
1348
1349
1350

1351							Password:
1352
1353
1354							value="" size="20" autocomplete="off" type="password">
1355
1356
1357

1358
1359
1360
1361							name="request_type">
1362
1363

1364
1365							Please note
1366							Before entering your userid and password, verify that the URL
1367							for this page begins with:
1368							_THIS_URL_
1369
1370							To protect your privacy, quit your web browser when you
1371							are done accessing services that require authentication.
1372
1373
1374

1375

1376

1377

1378

1379

1380

1381

1382

1383

1384

1385

1386

1387

1388

1389

1390

1391

1392

1393

1394

1395

1396

1397 EOT#-

1398 #+

1399 $ret=<<'EOT';

1400

1401 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

1402

1403 CAS - Central Authentication Service

1404

1405

1406

1407

1408

1409 media="handheld, only screen and (max-device-width: 480px)" type="text/css">

1410

1411

1416

1417

1422

1423

1424

1425

1426

CAS – Central Authentication

1427 Service

1428

1429

1430

1431

1432

1433

1434
1435							Login Required
1436							CAS Authentication
1437
1438
1439

1440							UserID:
1441
1442
1443							size="20" autocomplete="off" type="text">
1444
1445
1446
1447

1448							Password:
1449
1450
1451							value="" size="20" autocomplete="off" type="password">
1452
1453
1454

1455
1456
1457
1458							name="request_type">
1459
1460

1461
1462							Please note
1463							Before entering your userid and password, verify that the URL
1464							for this page begins with:
1465							_THIS_URL_
1466
1467							To protect your privacy, quit your web browser when you
1468							are done accessing services that require authentication.
1469
1470
1471

1472

1473

1474

1475

1476

1477

1478

1479

1480

1481

1482

1483

1484

1485

1486

1487

1488

1489

1490

1491

1492

1493

1494 EOT

1495 #-

1496 0 0 if ($GenCasPageCustom ne '') { $ret = $GenCasPageCustom }

1497

1498 0 my $cssCasAll = $ENV{SCRIPT_NAME}.'?cas-all.css';

1499 0 my $cssCasMobile = $ENV{SCRIPT_NAME}.'?cas-mobile.css';

1500 0 $ret=~ s/href="cas-all.css"/href="$cssCasAll"/;

1501 0 $ret=~ s/href="cas-mobile.css"/href="$cssCasMobile"/;

1502

1503 0 my $redirect_uri;

1504 0 0 if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }

1505 0 elsif (param('r') ne '') { $redirect_uri = param('r') }

1506

1507 # Remove "Before entering" unless there is a URL to show (todo, for now,

1508 # just remove)

1509 0 $ret=~ s/.*?(<\/p>)/$1/s;

1510

1511 0 my $forgotpassword = 1; # include link, todo for exclusion

1512 0 my $removerighthandside = 1;

1513 0 0 if ($forgotpassword) {

1514 0 $removerighthandside=''; $ret=~s//$1/g; }

1515 0 0 if ($SessionId ne '') { $ret=~s//$1/g; }

1516

1517 0 $ret=~s///g;

1518

1519 # Remove righthand side

1520 0 0 if($removerighthandside) {

1521 0 $ret =~

1522

s/(

)(.*?)(<\/div>)/$1$3/s;

1523 }

1524 else { # remove "hideinMobile"

1525 0 $ret =~ s///; }

1526

1527 0 return $ret;

1528 }

1529

1530 sub deliver {

1531 0 0 0 my $par = shift;

1532 0 0 if ($par eq 'cas-all.css') {

1533 0 print "Content-Type: text/css; charset=UTF-8\n\n".

1534 #

1535 # echo "<<'EOT';\n${c}EOT\n;"; !>#+

1536 <<'EOT';

1537 body {

1538 background-color: #D1AF55; /*#76A9DC;*/

1539 color: #444;

1540 font-family: "Times New Roman", Times, serif;

1541 margin: 30px;

1542 padding: 5px;

1543 }

1544

1545 a:link { text-decoration: none; }

1546 a:visited { text-decoration: none; }

1547 a:active { text-decoration: none; }

1548 a:hover { text-decoration: underline; }

1549 .hide { display: none; }

1550

1551 .shadow {

1552 box-shadow: 5px 5px 5px #ccc;

1553 -moz-box-shadow: 5px 5px 5px #ccc;

1554 -webkit-box-shadow: 5px 5px 5px #ccc;

1555 }

1556

1557 #pagebox {

1558 background: #fff;

1559 border: 1px solid #000;

1560 box-shadow: 10px 10px 10px #444;

1561 -moz-box-shadow: 10px 10px 10px #444;

1562 -webkit-box-shadow: 10px 10px 20px #444;

1563 margin: 0px auto;

1564 width: 788px;

1565 height: 491px;

1566 }

1567

1568 #headerBox {

1569 background: #A17F25;

1570 border-bottom: 1px solid #916F15;

1571 border-left: 1px solid #916F15;

1572 border-right: 1px solid #916F15;

1573 border-top: 1px solid #916F15;

1574 clear: both;

1575 height: 82px;

1576 width: 786px;

1577 text-align:center;

1578 color: #ffffff;

1579 }

1580

1581 #content-left {

1582 background: #fff;

1583 border-right: 1px solid #0F4D92;

1584 clear: both;

1585 float: left;

1586 height: 377px;

1587 margin: 0px;

1588 padding: 15px;

1589 width: 530px;

1590 }

1591

1592 #content-right {

1593 background: #fafae8;

1594 border: 0px;

1595 float: right;

1596 height: 377px;

1597 margin: 0px;

1598 padding: 15px;

1599 width: 197px;

1600 }

1601

1602 #content-left h1 {

1603 font-family: "Times New Roman", Times, serif;

1604 font-size: 20px;

1605 font-weight: normal;

1606 margin: 0px 0px 5px 0px;

1607 }

1608

1609 #content-left h2 {

1610 font-family: "Times New Roman", Times, serif;

1611 font-size: 20px;

1612 font-weight: normal;

1613 margin: 5px 0px 5px 0px;

1614 }

1615

1616 #content-left p.formLabel {

1617 color: #5F5F5F;

1618 font-family: "Times New Roman", Times, serif;

1619 font-size: 16px;

1620 font-weight: normal;

1621 margin: 6px 0px 0px 0px;

1622 text-align: right;

1623 }

1624

1625 #content-left p.sans {

1626 color: #5F5F5F;

1627 font-family: Verdana, Arial, Helvetica, sans;

1628 font-size: 11px;

1629 font-weight: normal;

1630 line-height: 1.7em;

1631 margin: 5px 0px 5px 0px;

1632 }

1633

1634 #content-left p.sansURL {

1635 color: #4e6d98;

1636 font-family: Verdana, Arial, Helvetica, sans;

1637 font-size: 11px;

1638 font-weight: normal;

1639 line-height: 1em;

1640 margin: 15px 0px 5px 0px;

1641 }

1642

1643 #content ul.plain, ul.plain a {

1644 color: #1A3E6F;

1645 font-family: Verdana, Geneva, Arial, sans-serif;

1646 font-size: 14px;

1647 line-height: 1.5em;

1648 list-style: none;

1649 margin: .4em 0em .2em 0em;

1650 padding: 0em 0em 0em 0em;

1651 text-indent: 0em;

1652 }

1653

1654 #content ul.plain li, ul.plain li a {

1655 padding-bottom: 0.8em;

1656 }

1657

1658 #content ul.plain li.disabled {

1659 color: #bbb;

1660 }

1661

1662

1663 #content ul.plain-serif, ul.plain-serif a {

1664 color: #1A3E6F;

1665 font-family: "Times New Roman", Times, serif;

1666 font-size: 14px;

1667 line-height: 1.2em;

1668 list-style: none;

1669 margin: 30px 0px 0px 0px;

1670 padding: 0px 0px 0px 0px;

1671 text-indent: 0em;

1672 }

1673

1674 #content ul.plain-serif li, ul.plain-serif li a {

1675 padding-bottom: 0.8em;

1676 }

1677

1678 #content ol {

1679 font-family: Verdana, Arial, Helvetica, sans;

1680 font-size: 11px;

1681 font-weight: normal;

1682 line-height: 1.8em;

1683 margin: 0px 0px 0px 20px;

1684 padding: 0px 0px 0px 0px;

1685 text-indent: 0em;

1686 }

1687

1688 #content ol li, ol li a { padding-bottom: 0.8em; }

1689 EOT

1690 ;#-

1691 #+

1692 0 <<'EOT';

1693 body {

1694 background-color: #D1AF55; /*#76A9DC;*/

1695 color: #444;

1696 font-family: "Times New Roman", Times, serif;

1697 margin: 30px;

1698 padding: 5px;

1699 }

1700

1701 a:link { text-decoration: none; }

1702 a:visited { text-decoration: none; }

1703 a:active { text-decoration: none; }

1704 a:hover { text-decoration: underline; }

1705 .hide { display: none; }

1706

1707 .shadow {

1708 box-shadow: 5px 5px 5px #ccc;

1709 -moz-box-shadow: 5px 5px 5px #ccc;

1710 -webkit-box-shadow: 5px 5px 5px #ccc;

1711 }

1712

1713 #pagebox {

1714 background: #fff;

1715 border: 1px solid #000;

1716 box-shadow: 10px 10px 10px #444;

1717 -moz-box-shadow: 10px 10px 10px #444;

1718 -webkit-box-shadow: 10px 10px 20px #444;

1719 margin: 0px auto;

1720 width: 788px;

1721 height: 491px;

1722 }

1723

1724 #headerBox {

1725 background: #A17F25;

1726 border-bottom: 1px solid #916F15;

1727 border-left: 1px solid #916F15;

1728 border-right: 1px solid #916F15;

1729 border-top: 1px solid #916F15;

1730 clear: both;

1731 height: 82px;

1732 width: 786px;

1733 text-align:center;

1734 color: #ffffff;

1735 }

1736

1737 #content-left {

1738 background: #fff;

1739 border-right: 1px solid #0F4D92;

1740 clear: both;

1741 float: left;

1742 height: 377px;

1743 margin: 0px;

1744 padding: 15px;

1745 width: 530px;

1746 }

1747

1748 #content-right {

1749 background: #fafae8;

1750 border: 0px;

1751 float: right;

1752 height: 377px;

1753 margin: 0px;

1754 padding: 15px;

1755 width: 197px;

1756 }

1757

1758 #content-left h1 {

1759 font-family: "Times New Roman", Times, serif;

1760 font-size: 20px;

1761 font-weight: normal;

1762 margin: 0px 0px 5px 0px;

1763 }

1764

1765 #content-left h2 {

1766 font-family: "Times New Roman", Times, serif;

1767 font-size: 20px;

1768 font-weight: normal;

1769 margin: 5px 0px 5px 0px;

1770 }

1771

1772 #content-left p.formLabel {

1773 color: #5F5F5F;

1774 font-family: "Times New Roman", Times, serif;

1775 font-size: 16px;

1776 font-weight: normal;

1777 margin: 6px 0px 0px 0px;

1778 text-align: right;

1779 }

1780

1781 #content-left p.sans {

1782 color: #5F5F5F;

1783 font-family: Verdana, Arial, Helvetica, sans;

1784 font-size: 11px;

1785 font-weight: normal;

1786 line-height: 1.7em;

1787 margin: 5px 0px 5px 0px;

1788 }

1789

1790 #content-left p.sansURL {

1791 color: #4e6d98;

1792 font-family: Verdana, Arial, Helvetica, sans;

1793 font-size: 11px;

1794 font-weight: normal;

1795 line-height: 1em;

1796 margin: 15px 0px 5px 0px;

1797 }

1798

1799 #content ul.plain, ul.plain a {

1800 color: #1A3E6F;

1801 font-family: Verdana, Geneva, Arial, sans-serif;

1802 font-size: 14px;

1803 line-height: 1.5em;

1804 list-style: none;

1805 margin: .4em 0em .2em 0em;

1806 padding: 0em 0em 0em 0em;

1807 text-indent: 0em;

1808 }

1809

1810 #content ul.plain li, ul.plain li a {

1811 padding-bottom: 0.8em;

1812 }

1813

1814 #content ul.plain li.disabled {

1815 color: #bbb;

1816 }

1817

1818

1819 #content ul.plain-serif, ul.plain-serif a {

1820 color: #1A3E6F;

1821 font-family: "Times New Roman", Times, serif;

1822 font-size: 14px;

1823 line-height: 1.2em;

1824 list-style: none;

1825 margin: 30px 0px 0px 0px;

1826 padding: 0px 0px 0px 0px;

1827 text-indent: 0em;

1828 }

1829

1830 #content ul.plain-serif li, ul.plain-serif li a {

1831 padding-bottom: 0.8em;

1832 }

1833

1834 #content ol {

1835 font-family: Verdana, Arial, Helvetica, sans;

1836 font-size: 11px;

1837 font-weight: normal;

1838 line-height: 1.8em;

1839 margin: 0px 0px 0px 20px;

1840 padding: 0px 0px 0px 0px;

1841 text-indent: 0em;

1842 }

1843

1844 #content ol li, ol li a { padding-bottom: 0.8em; }

1845 EOT

1846 ;

1847 #-

1848 }

1849 elsif ($par eq 'cas-mobile.css') {

1850 0 print "Content-Type: text/css; charset=UTF-8\n\n".

1851 #

1852 # echo "<<'EOT';\n${c}EOT\n;"; !>#+

1853 <<'EOT';

1854 body {

1855 background-color: #fff;

1856 color: #444;

1857 font-family: "Times New Roman", Times, serif;

1858 margin: 0px;

1859 padding: 0px;

1860 }

1861

1862 a:link { text-decoration: none; }

1863 a:visited { text-decoration: none; }

1864 a:active { text-decoration: none; }

1865 a:hover { text-decoration: underline; }

1866 .hide { display: none; }

1867 .hideInMobile { display: none; }

1868

1869 #pagebox {

1870 border: 0px;

1871 background: #fff;

1872 margin: 0px;

1873 width: auto;

1874 height: auto;

1875 box-shadow: none;

1876 -moz-box-shadow: none;

1877 -webkit-box-shadow: none;

1878 }

1879

1880 #headerBox {

1881 border: 0px;

1882 background: #A17F25;

1883 overflow: hidden;

1884 width: auto;

1885 height: auto;

1886 }

1887

1888 #headerBox h1 { font-size: 14pt; }

1889

1890 #content-left {

1891 background: #fff;

1892 border: 0px;

1893 margin: 0px;

1894 padding: 15px;

1895 width: auto;

1896 height: auto;

1897 float: none;

1898 }

1899

1900 #content-right {

1901 background: #fff;

1902 border: 0px;

1903 width: auto;

1904 height: auto;

1905 float: none;

1906 margin-left: 85px;

1907 }

1908

1909 #form-layout { width: auto; }

1910

1911 #login_form input {

1912 background: #f8f8f8;

1913 border: 1px solid #aaa;

1914 color: #555;

1915 font-family: Verdana, Arial, Helvetica, sans;

1916 font-weight: normal;

1917 margin: 0px 0px 0px 0px;

1918 font-size: 16px;

1919 padding: 5px;

1920 }

1921

1922 #login_form input.inputButton {

1923 background: #F5F091;

1924 border: 1px solid #aaa;

1925 color: #555;

1926 font-family: Georgia, "Times New Roman", Times, serif;

1927 font-weight: normal;

1928 margin: 10px 0px 10px 0px;

1929 font-size: 18px;

1930 }

1931

1932 #login_form input.formInput {

1933 width: 170px;

1934 float: none;

1935 }

1936

1937 h1.mobileTitle { display: none; }

1938

1939 #content-left h1 {

1940 color: #883F0A;

1941 font-family: Georgia, "Times New Roman", Times, serif;

1942 font-weight: bold;

1943 margin: 0px 0px 5px 0px;

1944 font-size: 19px;

1945 }

1946

1947 #content-left h2 { display: none; }

1948 #content-left p.sans { display: none; }

1949 #content-left p.sansURL { display: none; }

1950 #content-left p.mobile-tight { margin: 0; }

1951

1952 #content ul.plain, ul.plain a {

1953 color: #1A3E6F;

1954 font-family: Verdana, Geneva, Arial, sans-serif;

1955 line-height: 1.3em;

1956 list-style: none;

1957 margin: .4em 0em .2em 0em;

1958 padding: 0em 0em 0em 0em;

1959 text-indent: 0em;

1960 font-size: 14px;

1961 }

1962

1963 #content ul.plain li, ul.plain li a {

1964 padding-bottom: 0.8em;

1965 }

1966

1967 #content ul.plain li.disabled {

1968 color: #bbb;

1969 }

1970

1971 #content ul.plain-serif, ul.plain-serif a {

1972 display: none;

1973 }

1974

1975 #content ul.plain-serif li, ul.plain-serif li a {

1976 padding-bottom: 0.8em;

1977 }

1978

1979 #content ol {

1980 color: #5F5F5F;

1981 font-family: Verdana, Arial, Helvetica, sans;

1982 font-size: 11px;

1983 font-weight: normal;

1984 line-height: 1.8em;

1985 margin: 0px 0px 0px 20px;

1986 padding: 0px 0px 0px 0px;

1987 text-indent: 0em;

1988 }

1989

1990 #content ol li, ol li a {

1991 padding-bottom: 0.8em;

1992 }

1993 EOT

1994 ;#-

1995 #+

1996 0 <<'EOT';

1997 body {

1998 background-color: #fff;

1999 color: #444;

2000 font-family: "Times New Roman", Times, serif;

2001 margin: 0px;

2002 padding: 0px;

2003 }

2004

2005 a:link { text-decoration: none; }

2006 a:visited { text-decoration: none; }

2007 a:active { text-decoration: none; }

2008 a:hover { text-decoration: underline; }

2009 .hide { display: none; }

2010 .hideInMobile { display: none; }

2011

2012 #pagebox {

2013 border: 0px;

2014 background: #fff;

2015 margin: 0px;

2016 width: auto;

2017 height: auto;

2018 box-shadow: none;

2019 -moz-box-shadow: none;

2020 -webkit-box-shadow: none;

2021 }

2022

2023 #headerBox {

2024 border: 0px;

2025 background: #A17F25;

2026 overflow: hidden;

2027 width: auto;

2028 height: auto;

2029 }

2030

2031 #headerBox h1 { font-size: 14pt; }

2032

2033 #content-left {

2034 background: #fff;

2035 border: 0px;

2036 margin: 0px;

2037 padding: 15px;

2038 width: auto;

2039 height: auto;

2040 float: none;

2041 }

2042

2043 #content-right {

2044 background: #fff;

2045 border: 0px;

2046 width: auto;

2047 height: auto;

2048 float: none;

2049 margin-left: 85px;

2050 }

2051

2052 #form-layout { width: auto; }

2053

2054 #login_form input {

2055 background: #f8f8f8;

2056 border: 1px solid #aaa;

2057 color: #555;

2058 font-family: Verdana, Arial, Helvetica, sans;

2059 font-weight: normal;

2060 margin: 0px 0px 0px 0px;

2061 font-size: 16px;

2062 padding: 5px;

2063 }

2064

2065 #login_form input.inputButton {

2066 background: #F5F091;

2067 border: 1px solid #aaa;

2068 color: #555;

2069 font-family: Georgia, "Times New Roman", Times, serif;

2070 font-weight: normal;

2071 margin: 10px 0px 10px 0px;

2072 font-size: 18px;

2073 }

2074

2075 #login_form input.formInput {

2076 width: 170px;

2077 float: none;

2078 }

2079

2080 h1.mobileTitle { display: none; }

2081

2082 #content-left h1 {

2083 color: #883F0A;

2084 font-family: Georgia, "Times New Roman", Times, serif;

2085 font-weight: bold;

2086 margin: 0px 0px 5px 0px;

2087 font-size: 19px;

2088 }

2089

2090 #content-left h2 { display: none; }

2091 #content-left p.sans { display: none; }

2092 #content-left p.sansURL { display: none; }

2093 #content-left p.mobile-tight { margin: 0; }

2094

2095 #content ul.plain, ul.plain a {

2096 color: #1A3E6F;

2097 font-family: Verdana, Geneva, Arial, sans-serif;

2098 line-height: 1.3em;

2099 list-style: none;

2100 margin: .4em 0em .2em 0em;

2101 padding: 0em 0em 0em 0em;

2102 text-indent: 0em;

2103 font-size: 14px;

2104 }

2105

2106 #content ul.plain li, ul.plain li a {

2107 padding-bottom: 0.8em;

2108 }

2109

2110 #content ul.plain li.disabled {

2111 color: #bbb;

2112 }

2113

2114 #content ul.plain-serif, ul.plain-serif a {

2115 display: none;

2116 }

2117

2118 #content ul.plain-serif li, ul.plain-serif li a {

2119 padding-bottom: 0.8em;

2120 }

2121

2122 #content ol {

2123 color: #5F5F5F;

2124 font-family: Verdana, Arial, Helvetica, sans;

2125 font-size: 11px;

2126 font-weight: normal;

2127 line-height: 1.8em;

2128 margin: 0px 0px 0px 20px;

2129 padding: 0px 0px 0px 0px;

2130 text-indent: 0em;

2131 }

2132

2133 #content ol li, ol li a {

2134 padding-bottom: 0.8em;

2135 }

2136 EOT

2137 ;

2138 #-

2139

2140 }

2141 0 exit;

2142 } # end of sub deliver

2143

2144 ########################################################################

2145 # Section: Debug Functions

2146

2147 0 0 0 sub _dbg383 { return unless $DebugLevel > 5;

2148 0 $LogReport.="CAS client: Verification successful.\n"; &store_log; }

2149

2150 ########################################################################

2151 # Section: End of code; Documentation

2152

2153 1;

2154

2155 __END__

File Coverage

$title

$title

New Registration

Email Confirmation

$title

$t

CAS – Central Authentication

Login Required

Please note

CAS – Central Authentication

Login Required

Please note