CGI-AuthRegister
view release on metacpan or search on metacpan
AuthRegister.pm view on Meta::CPAN
my $querystring = $ENV{QUERY_STRING};
$DBusers = $DBusersCas; $DBpwd = $DBpwdCas; $DBsessions = $DBsessionsCas;
&import_dir_and_config; &require_https;
if ($querystring eq '' && param('querystring')) {
$querystring=param('querystring') }
if ($querystring eq 'cas-all.css') { &deliver('cas-all.css') }
if ($querystring eq 'cas-mobile.css') { &deliver('cas-mobile.css') }
if (param('rt') ne '' && param('rt') eq 'verify') {
my $username = param('username'); my $stoken = param('stoken');
my $r = &_db8_find_first("$DBdir/$DBcasTokens", 'k=stoken', $stoken);
my $ans = 'fail';
if ($r ne '' and $r->{stoken} eq $stoken and $r->{userid} eq $username) {
$ans = 'ok';
if ($DebugLevel > 5) { $LogReport .= "CAS verification OK for ".
"username($username) stoken($stoken)"; &store_log; }
}
if ($ans ne 'ok') {
print header(), "answer:fail\n";
if ($DebugLevel > 5) { $LogReport .= "CAS verify failed for ".
"username($username) stoken($stoken)"; }
&store_log; exit(); }
&_db8_remove("$DBdir/$DBcasTokens", 'k=stoken', $stoken);
print header(), "answer:ok\n"; exit();
}
my $redirect_uri;
if (param('redirect_uri') ne '') { $redirect_uri = param('redirect_uri') }
elsif (param('r') ne '') { $redirect_uri = param('r') }
### Helper functions: finishGeneral, finishWithPageBack
local *finishGeneral = sub {
my $page = &gen_cas_page;
if ($redirect_uri ne '') {
my $h = "<input type=\"hidden\" name=\"redirect_uri\" ".
"value=\"$redirect_uri\">";
$page=~ s/<!--!hiddenfields-->/$h\n$&/;
my $t = "CAS Authentication requested by the following site:<br>\n".
"<code>".&htmlquote($redirect_uri)."</code>";
$page =~ s/(<!--38--)>(.*)/$1>$t/;
}
print $page; exit; };
local *finishWithPageBack = sub {
my $page = &gen_cas_page; my $h = 'Successful Authentication!';
my $userid = $User->{userid};
my $t = "You are authenticated with the userid '$userid'.\n";
if ($redirect_uri ne '') { $t.="Click the button 'Proceed' to ".
"pass the userid and an authentication code to the site:\n<br>".
"<code>".&htmlquote($redirect_uri)."</code>"; }
$page =~ s/(<!--37--)>(.*)/$1>$h/;
$page =~ s/(<!--38--)>(.*)/$1>$t/;
$page =~ s/<!--!username-->.*?\n\n/\n/s;
$page =~ s/<!--!password-->.*?\n\n/\n/s;
if ($redirect_uri ne '') {
my $stoken = &gen_secret; $userid=~s/["<>]//g;
my $f = "$DBdir/$DBcasTokens";
if (!-f $f && !&check_db_files) { $LogReport.=$Error; &store_log;
print "<html><body>Error: $Error"; exit; }
if (!-f $f) { putfile $f, ''; chmod 0600, $f; }
&_db8_append($f, "userid:$userid\nstoken:$stoken" );
if ($Error ne '') { $LogReport.=$Error; &store_log;
print "<html><body>Error: $Error"; exit; }
my $h = "<input type=\"hidden\" name=\"username\" value=\"$userid\">";
$page=~ s/<!--!hiddenfields-->/$h\n$&/;
$h = "<input type=\"hidden\" name=\"stoken\" value=\"$stoken\">";
$page=~ s/<!--!hiddenfields-->/$h\n$&/;
$page =~ s/(<input class="inputButton" value=)"Login"/$1"Proceed"/;
my $r = &encodeuri($redirect_uri);
$page =~ s/(<form id="login_form" action=)"\?login"/$1"$r"/;
} else { $page =~ s/<input class="inputButton".*?>//s; }
print $page;
# Log out user so that they have to login every time they use the service
logout();
exit;
};
### End of helper functions
# Check redirect_uri
if ($redirect_uri ne '' &&
$redirect_uri !~ /^https:\/\/(\w|[-.~\/])+/i &&
$redirect_uri !~ /^http:\/\/(\w|[-.~\/:])+/i ## This is temporary for a student project
## It is probably is too relaxed.
) {
my $page = &gen_cas_page;
my $h = 'redirect_uri Error!';
my $t = "URI of the requesting site is not in an acceptable format:<br>\n".
"<code>".&htmlquote($redirect_uri)."</code><br>\n".
"Please check with the CAS maintainer if you think that this URI ".
"should be accepted. The rules include a requirement that the URI ".
"starts with 'https://' (including uppercase), and can have only some ".
"standard characters. It is possible that more characters should be ".
"allowed.";
$page =~ s/(<!--37--)>(.*)/$1>$h/;
$page =~ s/(<!--38--)>(.*)/$1>$t/;
$page =~ s/<!--username-->.*?<!--\/lastrow-->//s;
print header(), $page; exit;
}
if ($querystring eq 'forgotpwd' or param('rt') eq 'forgotpwd') {
if ($LinkForgotpwd) { print CGI::redirect(-uri=>$LinkForgotpwd); exit; }
my $page = &gen_cas_page; my $h = 'Send Password';
my $t = "Enter your UserID or Email to have password reset and sent to ".
"you by email.\nIf you do not receive email, it may mean that you are ".
"not registered in the system, and you should contanct the administrator.";
$page =~ s/(<!--37--)>(.*)/$1>$h/;
$page =~ s/(<!--38--)>(.*)/$1>$t/;
$page =~ s/<!--!password-->.*?\n\n/\n/s;
$page =~ s/(<input class="inputButton" value=)"Login"/$1"Send_Password"/;
print header(), $page; exit;
}
my $title = "Login Page for Site: $CGI::AuthRegister::SiteName";
my $HTMLstart = "<HTML><HEAD><TITLE>$title</TITLE><BODY><h1>$title</h1>\n";
my $Formstart = "<form action=\"$ENV{SCRIPT_NAME}\" method=\"post\">";
my $LoginForm = "<p>Please login with your DalFCS Account userid and password:<br>\n".$Formstart.
hidden('querystring',$querystring).
"<table><tr><td align=right>CS Userid:</td><td>".
textfield(-name=>"csuserid")."</td></tr>\n<tr><td align=right>".
"Password:</td><td>".password_field(-name=>"password")."</td></tr>\n".
AuthRegister.pm view on Meta::CPAN
if (ref($db_ref) ne 'ARRAY') {
print "ERR-540: Cound not read db file."; &unlock_mkdir($dbf); exit; }
my @db = @{ $db_ref };
local *fin = sub { my $url="https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";
print "\nUser browser back button to edit data, or click ".
"<a href=\"$url\">Home</a>.\n"; &unlock_mkdir($dbf); exit; };
for my $u (@db) {
if ($u->{userid} eq $reg_userid) { print "Userid already exists."; &fin; }
if ($u->{email} eq $reg_email) { print "Email already exists."; &fin; }
}
$dbfc =~ s/\n+$/\n/s;
$dbfc.="\nuserid:$reg_userid\nemail:$reg_email\n".
"status:disabled, waiting for confirmation code $confirmation_code\n";
putfile($dbf,$dbfc);
&unlock_mkdir($dbf);
&password_set($reg_email,$reg_password,'md5');
if ($Error) { print "Error: $Error"; exit; }
print "New user registered.\n";
print "<br>An email is being sent to confirm your email ".
"address...\n";
my $httpsconfirm = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}?".
"confirmation_code=$confirmation_code";
my $msg = "Hi,\n\nPlease click or visit the following link to confirm ".
"your registration at the site $SiteId:\n\n".
"$httpsconfirm\n\nBest regards,\n$SiteId Admin\n";
&send_email_to($reg_email, "Subject: $SiteId Email Confirmation", $msg);
print "<br>Email sent. Use the sent link to confirm your email.\n";
}
sub email_confirmation {
my $confirmation_code = shift;
my $dbf = "$DBdir/$DBusers";
if (!-f $dbf && !&check_db_files) { print "No db file."; exit; }
if (!&lock_mkdir($dbf)) { print "DB lock fail."; exit; }
my $dbfc = getfile($dbf); my $db_ref = &read_db($dbfc);
if (ref($db_ref) ne 'ARRAY') {
print "ERR-540: Cound not read db file."; &unlock_mkdir($dbf); exit; }
my @db = @{ $db_ref }; my $flag = '';
for my $u (@db) {
if (defined($u->{status}) and
$u->{status} =~ /^disabled, waiting for confirmation code (\S+)/ and
$1 eq $confirmation_code) {
$u->{status} =~
s/^disabled, waiting for confirmation code (\S+)/email confirmed/;
$flag = 1; last; } }
if (!$flag) { print "Invalid confirmation code.\n"; &unlock_mkdir($dbf);
return; }
_db8_update("file=$dbf", \@db);
&unlock_mkdir($dbf);
print "Email confirmed.\n<a href=\"https://$ENV{SERVER_NAME}".
"$ENV{SCRIPT_NAME}\">Login page</a>\n";
}
########################################################################
# Section: Session Management
# params: $email, opt: pwstore type: md5 raw
sub reset_password {
my $email = shift; my $pwstore = shift; $pwstore = 'md5' if $pwstore eq '';
my $password = &random_password(6); my $pwdf = "$DBdir/$DBpwd";
if (!-f $pwdf) { putfile $pwdf, ''; chmod 0600, $pwdf }
if (!&lock_mkdir($pwdf)) { $Error.="378-ERR:\n"; return ''; }
local *PH; open(PH, $pwdf) or croak($!);
my $content = '';
while (<PH>) {
my ($e,$p) = split;
$content .= $_ if $e ne $email;
}
close(PH);
$content .= "$email ";
if ($pwstore eq 'raw') { $content.="raw:$password" }
elsif($pwstore eq 'md5') { $content.="md5:".md5_base64($password) }
else { $content.="raw:$password" }
$content .= "\n";
putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);
return $password;
}
# $pwstoretype:md5,raw
sub password_set {
my $email = shift; my $pwd = shift; my $pwstoretype = shift;
$pwstoretype = 'md5' if $pwstoretype eq '';
my $pwdf = "$DBdir/$DBpwd";
if (!&check_db_files) { $Error.="AuthERR-587:\n"; return '' }
if (!&lock_mkdir($pwdf)) { $Error.="AuthErr-588:\n"; return ''; }
local *PH; open(PH, $pwdf) or croak($!);
my $newrow = "$email ";
if ($pwstoretype eq 'md5') { $newrow.="md5:".md5_base64($pwd)."\n" }
else { $newrow.="raw:$pwd\n" }
my $content = '';
while (<PH>) {
my ($e,$p) = split;
if ($e eq $email) { $content.=$newrow; $newrow=''; }
else { $content.=$_ }
}
$content.=$newrow; $newrow=''; close(PH);
putfile $pwdf, $content; chmod 0600, $pwdf; &unlock_mkdir($pwdf);
return 1;
}
sub md5_base64 {
my $arg=shift; require Digest::MD5; return Digest::MD5::md5_base64($arg); }
sub random_password {
my $n = shift; $n = 8 unless $n > 0;
my @chars = (2..9, 'a'..'k', 'm'..'z', 'A'..'N', 'P'..'Z',
qw(, . / ? ; : - = + ! @ $ % *) );
return join('', map { $chars[rand($#chars+1)] } (1..$n));
}
# removes session file and return the appropriate HTTP header
sub logout {
if ($Session eq '') { $Error.= "481-ERR: No session to log out\n"; return; }
if (!-d "$DBdir/$DBsessions/$SessionId") { $Error.="482-ERR: No session dir\n" }
else {
unlink(<$DBdir/$DBsessions/$SessionId/*>);
rmdir("$DBdir/$DBsessions/$SessionId"); }
$LogReport.=$Error."User UserId:$UserId UserEmail:$UserEmail logged out.\n";
&store_log; $Session = $SessionId = $Ticket = '';
return 1;
}
# The first parameter can be an userid and email. (diff by @)
sub login {
my $email = shift; my $password = shift;
$email = lc $email; my $userid;
if ($email !~ /@/) { $userid=$email; $email=''; }
if ($email ne '') {
if (!&emailcheckok($email)) {
$Error.="402-ERR:Incorrect email address format"; return; }
#my $u = &get_user_by_email($email);
my $u = &get_user_unique('email', $email);
if ($u eq '') { $Error.='405-ERR:Email not registered'; return; }
$userid = $u->{userid};
$User = $u;
} else {
if ($userid eq '') { $Error.="409-ERR:Empty userid"; return; }
if ($LDAPuse and $LDAPaddUsers) {
return _login_ldap_add($userid, $password); }
my $u = &get_user_unique('userid', $userid);
if ($u eq '') { $Error.='531-ERR:Not exist-unique'; &store_log; return; }
$email = $u->{email};
$User = $u;
}
# Randomize more salt
$SecretSalt = md5_base64("$SecretSalt $password");
if (!password_check($User, $password)) {
$Error.="418:Invalid password\n"; return ''; }
&set_new_session($User);
$LogReport.="User $UserEmail logged in.\n"; &store_log;
return 1;
}
sub _login_ldap_add {
my $userid = shift; my $password = shift;
AuthRegister.pm view on Meta::CPAN
{ if (exists($r->{$k}) && $v eq $r->{$k}) { return $User=$r } }
$Error.="AuthERR-842: no user with key=($k) v=($v)\n"; return $User='';
}
sub get_user_by_email {
my $email = shift;
my $db_ref = &read_users_db;
if (ref($db_ref) ne 'ARRAY') {
$Error.="657-ERR: Could not get users data (file system problem?)";
return $User=''; }
my @db = @{ $db_ref };
for my $r (@db) { if (lc($email) eq lc($r->{email})) { return $User=$r } }
$Error.="661-ERR: no user with email ($email)\n"; return $User='';
}
sub get_user_by_userid { return &get_user('userid', $_[0]) }
# Get user by userid, or add userid if does not exist
sub get_user_by_userid_or_add {
my $userid = shift; my $f = "$DBdir/$DBusers";
if (!-f $f && !&check_db_files) { return '' }
my @db = @{ &read_db("file=$f") };
my $u = '';
for my $r (@db) {
next unless exists($r->{userid}); my $v1 = $r->{userid};
$v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;
next unless $v1 eq $userid;
if ($u eq '') { $u = $r; next; }
$Error.= "819-ERR: double userid ($userid)\n"; return '';
}
return $User=$u unless $u eq '';
$userid =~ s/\s//g; &_db8_append($f, "userid:$userid");
return get_user_by_userid($userid);
}
# Get user by a key,value, but make sure there is exactly one such user
# Normalizes whitespace and case insensitive
sub get_user_unique {
my $k = shift; my $v = shift; my $f = "$DBdir/$DBusers";
if (!-f $f && !&check_db_files) { return '' }
my @db = @{ &read_db("file=$f") };
$v=~s/^\s+//; $v=~s/\s+$//; $v=~s/\s+/ /g; $v = lc $v;
if ($k eq '' or $v eq '')
{ $Error.="669-ERR:Empty k or v ($k:$v)\n"; return ''; }
my $u = '';
for my $r (@db) {
next unless exists($r->{$k}); my $v1 = $r->{$k};
$v1=~s/^\s+//; $v1=~s/\s+$//; $v1=~s/\s+/ /g; $v1 = lc $v1;
next unless $v eq $v1;
if ($u eq '') { $u = $r; next; }
$Error.= "676-ERR: double user key ($k:$v)\n"; return '';
}
return $User=$u unless $u eq '';
$Error.="894-ERR: no user with key ($k:$v)\n"; return '';
}
sub check_db_files {
my $ret; my $pwfile = "$DBdir/$DBpwd";
if (!-d $DBdir) { $ret = mkdir($DBdir, 0700);
if (!$ret) { $Error.="687-ERR: Could not create dir '$DBdir'"; return ''; }}
if (!-f $pwfile) { putfile $pwfile, ''; chmod 0600, $pwfile; }
if (!-f $pwfile) { $Error.="689-ERR: Could not create $pwfile file";
return ''; }
my $f = "$DBdir/$DBusers";
if (!-f $f) { putfile $f, "#userid:someid\n#email:email\@domain.com\n";
chmod 0600, $f; }
if (!-f $f) { $Error.="694-ERR: Could not create $f file"; return ''; }
$f = "$DBdir/$DBsessions";
if (!-d $f) { $ret = mkdir($f, 0700);
if (!$ret) { $Error.="708-ERR: Could not create dir '$f'"; return ''; }}
return 1;
}
# _db8_update - updates given db with minimal changes
# Usage: db8_update($strOrFile, $db)
# 2013-2017 Vlado Keselj, version 1.4; documentation in DB822.txt
# Example: &db8_update("file=$filename", $db);
sub _db8_update {
my $arg = shift; my $db=shift; my $file='';
if ($arg =~ /^file=/) {
$file = $'; die "file=''!?" if $file eq '';
local *F; open(F, $file) or die "cannot open $file:$!";
$arg = join('', <F>);
close(F);
}
my $arg_save = $arg; my $dbi = 0; my $argcopy = '';
while ($arg) {
# allow comments and space betwen records
if ($arg =~ /^(\s*\n|[ \t]*#.*\n)*/) { $argcopy.=$&; $arg = $'; }
my $record;
if ($arg =~ /\n(\n+)/) { $record = "$`\n"; $arg = $1.$'; }
else { $record = $arg; $arg = ''; }
if ($dbi > $#{$db}) { last }
my $r = {}; my %savedkeys = ();
while ($record) {
my $avpair = '';
if ($record =~ /^.*/) { $avpair = $& }
while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)
{ $record = "$1 $3$'"; $avpair.= $2.$3; }
$record =~ /^([^\n:]*):(.*)\n/ or die;
my $k = $1; my $v = $2; $record = $';
$avpair .= "\n";
if (exists($r->{$k})) {
my $c = 0;
while (exists($r->{"$k-$c"})) { ++$c }
$k = "$k-$c";
}
$r->{$k} = $v;
if (exists($db->[$dbi]->{$k}) && $db->[$dbi]->{$k} eq $v)
{ $argcopy .= $avpair }
elsif (exists($db->[$dbi]->{$k})) {
my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved
$argcopy .= "$k:$newv\n";
} # else skip it
$savedkeys{$k} = 1;
}
for my $k (keys %{ $db->[$dbi] }) {
if (!exists($savedkeys{$k})) {
my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved
$argcopy .= "$k:$newv\n";
}
}
++$dbi;
}
while ($dbi <= $#{$db}) {
$argcopy .= "\n";
for my $k (sort(keys(%{ $db->[$dbi] }))) {
my $newv = $db->[$dbi]->{$k}; $newv =~ s/\s/ /g; #to be improved
$argcopy .= "$k:$newv\n";
}
++$dbi;
}
if ($file ne '') {
if ($argcopy ne $arg_save) {
#rename($file, "$file.bak");
local *F; open(F,">$file"); print F $argcopy; close(F);
}
return;
} else { return $argcopy }
} # end of _db8_update
sub _db8_remove {
my $dbf = shift; my $kdel = shift; my $vdel = shift;
die unless $kdel =~ /^k=/; $kdel = $';
if (!&lock_mkdir($dbf)) { $Error.="793-ERR"; return '' }
local *F; if (!open(F, $dbf)) { &unlock_mkdir($dbf);
$Error.="795-ERR: opening file $dbf: $!"; return ''; }
my $arg = join('',<F>); close(F);
my $arg_save = $arg; my $dbi = 0; my $argcopy = '';
while ($arg) {
my $prologue;
if ($arg =~ /^([ \t\r]*(#.*)?\n)+/) { $prologue = $&; $arg = $'; }
$argcopy.=$prologue;
last if $arg eq ''; my $record; my $record_save;
if ($arg =~ /([ \t\r]*\n){2,}/) {
$record = "$`\n"; $arg = $'; $record_save = "$`$&"; }
else { $record_save = $record = $arg; $arg = ''; }
my $r = {};
while ($record) {
$record =~ /^[ \t]*([^\n:]*?)[ \t]*:/ or die "db8: no attribute";
my $k = $1; $record = $';
while ($record =~ /^(.*)(\\\r?\n|\r?\n[ \t]+)(\S.*)/)
{ $record = "$1 $3$'" }
$record =~ /^[ \t]*(.*?)[ \t\r]*\n/ or die;
my $v = $1; $record = $';
if (exists($r->{$k})) {
my $c = 0;
while (exists($r->{"$k-$c"})) { ++$c }
$k = "$k-$c";
}
$r->{$k} = $v;
}
if (exists($r->{$kdel}) && $r->{$kdel} eq $vdel) {}
else { $argcopy .= $record_save }
}
if ($argcopy ne $arg_save) {
if (!open(F, ">$dbf.lock/new")) { &unlock_mkdir($dbf);
$Error.="828-ERR: opening file $dbf.lock/new: $!"; return ''; }
print F $argcopy; close(F); chmod 0600, "$dbf.lock/new"; unlink($dbf);
rename("$dbf.lock/new", $dbf); }
&unlock_mkdir($dbf);
} # end of _db8_remove
# Read DB records in the RFC822-like style (to add reference).
sub read_db {
my $arg = shift;
if ($arg =~ /^file=/) {
my $f = $'; if (!&lock_mkdir($f)) { return '' }
local *F;
if (!open(F, $f)) {
$Error.="ERR-945: $f: $!"; &unlock_mkdir($f); return ''; }
$arg = join('', <F>); close(F); &unlock_mkdir($f);
}
my $db = [];
while ($arg) {
$arg =~ s/^\s*(#.*\s*)*//; # allow comments betwen records
my $record;
if ($arg =~ /\n\n+/) { $record = "$`\n"; $arg = $'; }
else { $record = $arg; $arg = ''; }
my $r = {};
while ($record) {
if ($record =~ /^#.*\n?/) { $record=$'; next; }
while ($record =~ /^(.*)(\\\n|\n[ \t]+)(.*)/)
{ $record = "$1 $3$'" }
$record =~ /^([^\n:]*):(.*)\n/ or die;
my $k = $1; my $v = $2; $record = $';
if (exists($r->{$k})) {
my $c = 0;
while (exists($r->{"$k-$c"})) { ++$c }
$k = "$k-$c";
}
$r->{$k} = $v;
}
push @{ $db }, $r;
}
return $db;
}
# Append a record or records to db8
# Assumes that the file is in a good format
sub _db8_append {
my $fdb=shift;
if (!&lock_mkdir($fdb)) { $Error.="ERR-975: $!"; return '' }
local *F; if (!open(F, ">>$fdb")) { &unlock_mkdir($fdb);
$Error.="ERR-977: write file $fdb: $!"; return ''; }
while (@_) { my $r=shift; $r =~ s/\s*$/\n/s; print F "\n$r"; }
&unlock_mkdir($fdb);
}
# Read one DB record in the RFC822-like style (to add reference).
sub read_db_record {
my $arg = shift;
if ($arg =~ /^file=/) {
my $f = $'; local *F; open(F, $f) or die "cannot open $f:$!";
$arg = join('', <F>); close(F);
}
while ($arg =~ s/^(\s*|\s*#.*)\n//) {} # allow comments before record
( run in 1.252 second using v1.01-cache-2.11-cpan-39bf76dae61 )