loncom/lond - diff - 1.178.2.22

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.178.2.9 and 1.178.2.22

version 1.178.2.9, 2004/03/22 09:05:11	version 1.178.2.22, 2004/05/04 10:09:38
Line 182 sub TieDomainHash {	Line 182 sub TieDomainHash {
my $domain = shift;	my $domain = shift;
my $namespace = shift;	my $namespace = shift;
my $how = shift;	my $how = shift;

# Filter out any whitespace in the domain name:	# Filter out any whitespace in the domain name:

$domain =~ s/\W//g;	$domain =~ s/\W//g;

# We have enough to go on to tie the hash:	# We have enough to go on to tie the hash:

my $UserTopDir = $perlvar('lonUsersDir');	my $UserTopDir = $perlvar{'lonUsersDir'};
my $DomainDir = $UserTopDir."/$domain";	my $DomainDir = $UserTopDir."/$domain";
my $ResourceFile = $DomainDir."/$namespace.db";	my $ResourceFile = $DomainDir."/$namespace.db";
my %hash;	my %hash;
if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) {	if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) {
if (scalar @_) { # Need to log the operation.	if (scalar @_) { # Need to log the operation.
my $logFh = IO::File->new(">>$DomainDir/$namespace.hist");	my $logFh = IO::File->new(">>$DomainDir/$namespace.hist");
if($logFH) {	if($logFh) {
my $TimeStamp = time;	my $TimeStamp = time;
my ($loghead, $logtail) = @_;	my ($loghead, $logtail) = @_;
print $logFH "$loghead:$TimeStamp:$logtail\n";	print $logFh "$loghead:$TimeStamp:$logtail\n";
}	}
}	}
return \%hash; # Return the tied hash.	return \%hash; # Return the tied hash.
Line 229 sub TieDomainHash {	Line 229 sub TieDomainHash {
# undef if the has could not be tied.	# undef if the has could not be tied.
#	#
sub TieUserHash {	sub TieUserHash {
my $domain = shift;	my $domain = shift;
my $user = shift;	my $user = shift;
my $namespace = shift;	my $namespace = shift;
my $how = shift;	my $how = shift;

$namespace=~s/\//\_/g; # / -> _	$namespace=~s/\//\_/g; # / -> _
$namespace=~s/\W//g; # whitespace eliminated.	$namespace=~s/\W//g; # whitespace eliminated.
my $proname = propath($domain, $user);	my $proname = propath($domain, $user);

# If this is a namespace for which a history is kept,	# If this is a namespace for which a history is kept,
# make the history log entry:	# make the history log entry:


unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) {	if (($namespace =~/^nohist\_/) && (scalar @_ > 0)) {
my $hfh = IO::File->new(">>$proname/$namespace.hist");	my $args = scalar @_;
if($hfh) {	Debug(" Opening history: $namespace $args");
my $now = time;	my $hfh = IO::File->new(">>$proname/$namespace.hist");
my $loghead = shift;	if($hfh) {
my $what = shift;	my $now = time;
print $hfh "$loghead:$now:$what\n";	my $loghead = shift;
}	my $what = shift;
}	print $hfh "$loghead:$now:$what\n";
# Tie the database.	}
	}
my %hash;	# Tie the database.
if(tie(%hash, 'GDBM_FILE', "$proname/$namespace.db",
$how, 0640)) {	my %hash;
return \%hash;	if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
}	$how, 0640)) {
else {	return \%hash;
return undef;	}
}	else {
	return undef;
	}

}	}

#	#
Line 725 sub AuthenticateHandler {	Line 727 sub AuthenticateHandler {
my $cmd = shift;	my $cmd = shift;
my $tail = shift;	my $tail = shift;
my $client = shift;	my $client = shift;

# Regenerate the full input line	# Regenerate the full input line

my $userinput = $cmd.":".$tail;	my $userinput = $cmd.":".$tail;

# udom - User's domain.	# udom - User's domain.
# uname - Username.	# uname - Username.
# upass - User's password.	# upass - User's password.

my ($udom,$uname,$upass)=split(/:/,$tail);	my ($udom,$uname,$upass)=split(/:/,$tail);
Debug(" Authenticate domain = $udom, user = $uname, password = $upass");	Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
chomp($upass);	chomp($upass);
$upass=unescape($upass);	$upass=unescape($upass);

# Fetch the user authentication information:	my $pwdcorrect = ValidateUser($udom, $uname, $upass);
	if($pwdcorrect) {
my $realpasswd = GetAuthType($udom, $uname);	Reply( $client, "authorized\n", $userinput);
if($realpasswd ne "nouser") { # nouser means no passwd file.
my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
my $pwdcorrect=0;
#	#
# Authenticate against password stored in the internal file.	# Bad credentials: Failed to authorize
#	#
Debug("Authenticating via $howpwd");
if ($howpwd eq 'internal') {
&Debug("Internal auth");
$pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);
#
# Authenticate against the unix password file.
#
} elsif ($howpwd eq 'unix') {
&Debug("Unix auth");
if((getpwnam($uname))[1] eq "") { #no such user!
$pwdcorrect = 0;
} else {
$contentpwd=(getpwnam($uname))[1];
my $pwauth_path="/usr/local/sbin/pwauth";
unless ($contentpwd eq 'x') { # Not in shadow file.
$pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);
} elsif (-e $pwauth_path) { # In shadow file so
open PWAUTH, "\|$pwauth_path" or # use external program
die "Cannot invoke authentication";
print PWAUTH "$uname\n$upass\n";
close PWAUTH;
$pwdcorrect=!$?;
}
}
#
# Authenticate against a Kerberos 4 server:
#
} elsif ($howpwd eq 'krb4') {
my $null=pack("C",0);
unless ($upass=~/$null/) {
my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname,
"",
$contentpwd,
'krbtgt',
$contentpwd,
1,
$upass);
if (!$krb4_error) {
$pwdcorrect = 1;
} else {
$pwdcorrect=0;
# log error if it is not a bad password
if ($krb4_error != 62) {
&logthis('krb4:'.$uname.','.$contentpwd.','.
&Authen::Krb4::get_err_txt($Authen::Krb4::error));
}
}
}
#
# Authenticate against a Kerberos 5 server:
#
} elsif ($howpwd eq 'krb5') {
my $null=pack("C",0);
unless ($upass=~/$null/) {
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
my $krbserver=&Authen::Krb5::parse_name($krbservice);
my $credentials=&Authen::Krb5::cc_default();
$credentials->initialize($krbclient);
my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,
$krbserver,
$upass,
$credentials);
$pwdcorrect = ($krbreturn == 1);
} else {
$pwdcorrect=0;
}
#
# Finally, the user may have written in an authentication module.
# in that case, if requested, authenticate against it.
#
} elsif ($howpwd eq 'localauth') {
$pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd);
}
#
# Successfully authorized.
#
if ($pwdcorrect) {
Reply( $client, "authorized\n", $userinput);
#
# Bad credentials: Failed to authorize
#
} else {
Failure( $client, "non_authorized\n", $userinput);
}
# Used to be unknown_user but that allows crackers to
# distinguish between bad username and bad password so...
#
} else {	} else {
Failure( $client, "non_authorized\n", $userinput);	Failure( $client, "non_authorized\n", $userinput);
}	}

return 1;	return 1;
}	}
RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);	RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);
Line 878 sub ChangePasswordHandler {	Line 790 sub ChangePasswordHandler {
# npass - New password.	# npass - New password.

my ($udom,$uname,$upass,$npass)=split(/:/,$tail);	my ($udom,$uname,$upass,$npass)=split(/:/,$tail);
chomp($npass);
$upass=&unescape($upass);	$upass=&unescape($upass);
$npass=&unescape($npass);	$npass=&unescape($npass);
&Debug("Trying to change password for $uname");	&Debug("Trying to change password for $uname");
my $realpasswd = GetAuthType($udom, $uname);
if ($realpasswd ne "nouser") {	# First require that the user can be authenticated with their
	# old password:

	my $validated = ValidateUser($udom, $uname, $upass);
	if($validated) {
	my $realpasswd = GetAuthType($udom, $uname); # Defined since authd.

my ($howpwd,$contentpwd)=split(/:/,$realpasswd);	my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
if ($howpwd eq 'internal') {	if ($howpwd eq 'internal') {
&Debug("internal auth");	&Debug("internal auth");
if (crypt($upass,$contentpwd) eq $contentpwd) {	my $salt=time;
my $salt=time;	$salt=substr($salt,6,2);
$salt=substr($salt,6,2);	my $ncpass=crypt($npass,$salt);
my $ncpass=crypt($npass,$salt);	if(RewritePwFile($udom, $uname, "internal:$ncpass")) {
if(RewritePwFile($udom, $uname, "internal:$ncpass")) {	&logthis("Result of password change for "
&logthis("Result of password change for "	."$uname: pwchange_success");
."$uname: pwchange_success");	Reply($client, "ok\n", $userinput);
Reply($client, "ok\n", $userinput);
} else {
&logthis("Unable to open $uname passwd "
."to change password");
Failure( $client, "non_authorized\n",$userinput);
}
} else {	} else {
Failure($client, "non_authorized\n", $userinput);	&logthis("Unable to open $uname passwd "
	."to change password");
	Failure( $client, "non_authorized\n",$userinput);
}	}
} elsif ($howpwd eq 'unix') {	} elsif ($howpwd eq 'unix') {
# Unix means we have to access /etc/password	# Unix means we have to access /etc/password
# one way or another.
# First: Make sure the current password is
# correct
&Debug("auth is unix");	&Debug("auth is unix");
$contentpwd=(getpwnam($uname))[1];	my $execdir=$perlvar{'lonDaemons'};
my $pwdcorrect = "0";	&Debug("Opening lcpasswd pipeline");
my $pwauth_path="/usr/local/sbin/pwauth";	my $pf = IO::File->new("\|$execdir/lcpasswd > "
unless ($contentpwd eq 'x') {	."$perlvar{'lonDaemons'}"
$pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);	."/logs/lcpasswd.log");
} elsif (-e $pwauth_path) {	print $pf "$uname\n$npass\n$npass\n";
open PWAUTH, "\|$pwauth_path" or	close $pf;
die "Cannot invoke authentication";	my $err = $?;
print PWAUTH "$uname\n$upass\n";	my $result = ($err>0 ? 'pwchange_failure' : 'ok');
close PWAUTH;	&logthis("Result of password change for $uname: ".
&Debug("exited pwauth with $? ($uname,$upass) ");	&lcpasswdstrerror($?));
$pwdcorrect=($? == 0);	Reply($client, "$result\n", $userinput);
}
if ($pwdcorrect) {
my $execdir=$perlvar{'lonDaemons'};
&Debug("Opening lcpasswd pipeline");
my $pf = IO::File->new("\|$execdir/lcpasswd > "
."$perlvar{'lonDaemons'}"
."/logs/lcpasswd.log");
print $pf "$uname\n$npass\n$npass\n";
close $pf;
my $err = $?;
my $result = ($err>0 ? 'pwchange_failure' : 'ok');
&logthis("Result of password change for $uname: ".
&lcpasswdstrerror($?));
Reply($client, "$result\n", $userinput);
} else {
Reply($client, "non_authorized\n", $userinput);
}
} else {	} else {
# this just means that the current password mode is not	# this just means that the current password mode is not
# one we know how to change (e.g the kerberos auth modes or	# one we know how to change (e.g the kerberos auth modes or
Line 945 sub ChangePasswordHandler {	Line 839 sub ChangePasswordHandler {
#	#
Reply( $client, "auth_mode_error\n", $userinput);	Reply( $client, "auth_mode_error\n", $userinput);
}	}
} else {
# used to be unknonw user but that gives out too much info..	}
# so make it the same as if the initial passwd was bad.	else {
#
Reply( $client, "non_authorized\n", $userinput);	Reply( $client, "non_authorized\n", $userinput);
}	}

return 1;	return 1;
}	}
RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);	RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);
Line 998 sub AddUserHandler {	Line 892 sub AddUserHandler {
for (my $i=3;$i<= ($#fpparts-1);$i++) {	for (my $i=3;$i<= ($#fpparts-1);$i++) {
$fpnow.='/'.$fpparts[$i];	$fpnow.='/'.$fpparts[$i];
unless (-e $fpnow) {	unless (-e $fpnow) {
	&logthis("mkdir $fpnow");
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)." mkdir failed while attempting "	$fperror="error: ".($!+0)." mkdir failed while attempting "
."makeuser";	."makeuser";
Line 1097 sub IsHomeHandler {	Line 992 sub IsHomeHandler {

my ($udom,$uname)=split(/:/,$tail);	my ($udom,$uname)=split(/:/,$tail);
chomp($uname);	chomp($uname);
my $passfile = PasswordPath($udom, $uname);	my $passfile = PasswordFilename($udom, $uname);
if($passfile) {	if($passfile) {
Reply( $client, "found\n", $userinput);	Reply( $client, "found\n", $userinput);
} else {	} else {
Line 1135 sub UpdateResourceHandler {	Line 1030 sub UpdateResourceHandler {

my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my $fname=$tail;	my $fname= $tail; # This allows interactive testing


my $ownership=ishome($fname);	my $ownership=ishome($fname);
if ($ownership eq 'not_owner') {	if ($ownership eq 'not_owner') {
if (-e $fname) {	if (-e $fname) {
Line 1245 sub FetchUserFileHandler {	Line 1142 sub FetchUserFileHandler {
}	}
RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);	RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);
#	#
# Authenticate access to a user file. Question? The token for athentication	# Authenticate access to a user file.
# is allowed to be sent as cleartext is this really what we want? This token
# represents the user's session id. Once it is forged does this allow too much
# access??
#	#
# Parameters:	# Parameters:
# $cmd - The command that got us here.	# $cmd - The command that got us here.
Line 1298 sub UnsubscribeHandler {	Line 1192 sub UnsubscribeHandler {
my $client = shift;	my $client = shift;
my $userinput= "$cmd:$tail";	my $userinput= "$cmd:$tail";

my $fname = $tail;	my ($fname) = $tail;

	Debug("Unsubscribing $fname");
if (-e $fname) {	if (-e $fname) {
Reply($client, &unsub($client,$fname,$clientip), $userinput);	Debug("Exists");
	Reply($client, &unsub($fname,$clientip), $userinput);
} else {	} else {
Failure($client, "not_found\n", $userinput);	Failure($client, "not_found\n", $userinput);
}	}
return 1;	return 1;
}	}
RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);	RegisterHandler("unsub", \&UnsubscribeHandler, 0, 1, 0);

# Subscribe to a resource.	# Subscribe to a resource
#	#
# Parameters:	# Parameters:
# $cmd - The command that got us here.	# $cmd - The command that got us here.
Line 1409 sub PutUserProfileEntry {	Line 1306 sub PutUserProfileEntry {
my $tail = shift;	my $tail = shift;
my $client = shift;	my $client = shift;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my ($udom,$uname,$namespace,$what) =split(/:/,$tail);	my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
if ($namespace ne 'roles') {	if ($namespace ne 'roles') {
chomp($what);	chomp($what);
my $hashref = TieUserHash($udom, $uname, $namespace,	my $hashref = TieUserHash($udom, $uname, $namespace,
&GDBM_WRCREAT(),"P",$what);	&GDBM_WRCREAT(),"P",$what);
if($hashref) {	if($hashref) {
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
}	}
if (untie(%$hashref)) {	if (untie(%$hashref)) {
Reply( $client, "ok\n", $userinput);	Reply( $client, "ok\n", $userinput);
} else {	} else {
Failure($client, "error: ".($!+0)." untie(GDBM) failed ".	Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
"while attempting put\n",	"while attempting put\n",
$userinput);	$userinput);
}	}
} else {	} else {
Failure( $client, "error: ".($!)." tie(GDBM) Failed ".	Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
"while attempting put\n", $userinput);	"while attempting put\n", $userinput);
}	}
} else {	} else {
Failure( $client, "refused\n", $userinput);	Failure( $client, "refused\n", $userinput);
}	}

return 1;	return 1;
}	}
RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);	RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);

Line 1465 sub IncrementUserValueHandler {	Line 1362 sub IncrementUserValueHandler {
if ($namespace ne 'roles') {	if ($namespace ne 'roles') {
chomp($what);	chomp($what);
my $hashref = TieUserHash($udom, $uname,	my $hashref = TieUserHash($udom, $uname,
$namespace, &GDBM_WRCREAT(),	$namespace, &GDBM_WRCREAT(),
"P",$what);	"P",$what);
if ($hashref) {	if ($hashref) {
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
# We could check that we have a number...	# We could check that we have a number...
if (! defined($value) \|\| $value eq '') {	if (! defined($value) \|\| $value eq '') {
$value = 1;	$value = 1;
}	}
$hashref->{$key}+=$value;	$hashref->{$key}+=$value;
}	}
if (untie(%$hashref)) {	if (untie(%$hashref)) {
Reply( $client, "ok\n", $userinput);	Reply( $client, "ok\n", $userinput);
} else {	} else {
Failure($client, "error: ".($!+0)." untie(GDBM) failed ".	Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
"while attempting inc\n", $userinput);	"while attempting inc\n", $userinput);
}	}
} else {	} else {
Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".	Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting inc\n", $userinput);	"while attempting inc\n", $userinput);
}	}
} else {	} else {
Failure($client, "refused\n", $userinput);	Failure($client, "refused\n", $userinput);
}	}

return 1;	return 1;
}	}
Line 1520 sub RolesPutHandler {	Line 1417 sub RolesPutHandler {
my $client = shift;	my $client = shift;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my ($exedom,$exeuser,$udom,$uname,$what) =split(/:/,$tail);	my ( $exedom, $exeuser, $udom, $uname, $what) = split(/:/,$tail);
&Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
"what = ".$what);
my $namespace='roles';	my $namespace='roles';
chomp($what);	chomp($what);
my $hashref = TieUserHash($udom, $uname, $namespace,	my $hashref = TieUserHash($udom, $uname, $namespace,
&GDBM_WRCREAT(), "P",	&GDBM_WRCREAT(), "P",
"$exedom:$exeuser:$what");	"$exedom:$exeuser:$what");
#	#
# Log the attempt to set a role. The {}'s here ensure that the file	# Log the attempt to set a role. The {}'s here ensure that the file
# handle is open for the minimal amount of time. Since the flush	# handle is open for the minimal amount of time. Since the flush
Line 1583 sub RolesDeleteHandler {	Line 1480 sub RolesDeleteHandler {
my $namespace='roles';	my $namespace='roles';
chomp($what);	chomp($what);
my $hashref = TieUserHash($udom, $uname, $namespace,	my $hashref = TieUserHash($udom, $uname, $namespace,
&GDBM_WRCREAT(), "D",	&GDBM_WRCREAT(), "D",
"$exedom:$exeuser:$what");	"$exedom:$exeuser:$what");

if ($hashref) {	if ($hashref) {
my @rolekeys=split(/\&/,$what);	my @rolekeys=split(/\&/,$what);

foreach my $key (@rolekeys) {	foreach my $key (@rolekeys) {
delete $hashref->{$key};	delete $hashref->{$key};
}	}
if (untie(%$hashref)) {	if (untie(%$hashref)) {
Reply($client, "ok\n", $userinput);	Reply($client, "ok\n", $userinput);
} else {	} else {
Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting rolesdel\n", $userinput);	"while attempting rolesdel\n", $userinput);
}	}
} else {	} else {
Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".	Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting rolesdel\n", $userinput);	"while attempting rolesdel\n", $userinput);
}	}

return 1;	return 1;
}	}
Line 1635 sub GetProfileEntry {	Line 1532 sub GetProfileEntry {
my ($udom,$uname,$namespace,$what) = split(/:/,$tail);	my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
chomp($what);	chomp($what);
my $hashref = TieUserHash($udom, $uname, $namespace,	my $hashref = TieUserHash($udom, $uname, $namespace,
&GDBM_READER());	&GDBM_READER());
if ($hashref) {	if ($hashref) {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $qresult='';	my $qresult='';

for (my $i=0;$i<=$#queries;$i++) {	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.	$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string.
}	}
Line 1704 sub GetProfileEntryEncrypted {	Line 1601 sub GetProfileEntryEncrypted {
$qresult.=" ";	$qresult.=" ";
my $encqresult='';	my $encqresult='';
for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {	for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
$encqresult.= unpack("H16", $cipher->encrypt(substr($qresult,	$encqresult.= unpack("H16",
$encidx,	$cipher->encrypt(substr($qresult,
8)));	$encidx,
	8)));
}	}
Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);	Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
} else {	} else {
Line 1723 sub GetProfileEntryEncrypted {	Line 1621 sub GetProfileEntryEncrypted {

return 1;	return 1;
}	}
RegisterHandler("eget", \&GetProfileEncrypted, 0, 1, 0);	RegisterHandler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);

#	#
# Deletes a key in a user profile database.	# Deletes a key in a user profile database.
Line 1851 sub DumpProfileDatabase {	Line 1749 sub DumpProfileDatabase {
# $data{$symb}->{'v.'.$parameter}=$version;	# $data{$symb}->{'v.'.$parameter}=$version;
# since $parameter will be unescaped, we do not	# since $parameter will be unescaped, we do not
# have to worry about silly parameter names...	# have to worry about silly parameter names...

my $qresult='';	my $qresult='';
my %data = (); # A hash of anonymous hashes..	my %data = (); # A hash of anonymous hashes..
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
Line 1954 sub DumpWithRegexp {	Line 1852 sub DumpWithRegexp {
}	}
RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);	RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);

# Store an aitem in any database but the roles database.	# Store a set of key=value pairs associated with a versioned name.
#	#
# Parameters:	# Parameters:
# $cmd - Request command keyword.	# $cmd - Request command keyword.
Line 2020 sub StoreHandler {	Line 1918 sub StoreHandler {
}	}
RegisterHandler("store", \&StoreHandler, 0, 1, 0);	RegisterHandler("store", \&StoreHandler, 0, 1, 0);
#	#
# Restore a prior version of a resource.	# Dump out all versions of a resource that has key=value pairs associated
	# with it for each version. These resources are built up via the store
	# command.
#	#
# Parameters:	# Parameters:
# $cmd - Command keyword.	# $cmd - Command keyword.
Line 2034 RegisterHandler("store", \&StoreHandler,	Line 1934 RegisterHandler("store", \&StoreHandler,
# 1 indicating the caller should not yet exit.	# 1 indicating the caller should not yet exit.
# Side-effects:	# Side-effects:
# Writes a reply to the client.	# Writes a reply to the client.
	# The reply is a string of the following shape:
	# version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2...
	# Where the 1 above represents version 1.
	# this continues for all pairs of keys in all versions.
	#
	#
	#
#	#
sub RestoreHandler {	sub RestoreHandler {
my $cmd = shift;	my $cmd = shift;
Line 2263 sub PutCourseIdHandler {	Line 2170 sub PutCourseIdHandler {

my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

	my ($udom, $what) = split(/:/, $tail);
chomp($what);	chomp($what);
my $now=time;	my $now=time;
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
Line 2328 sub DumpCourseIdHandler {	Line 2236 sub DumpCourseIdHandler {
}	}
unless (defined($since)) { $since=0; }	unless (defined($since)) { $since=0; }
my $qresult='';	my $qresult='';
	logthis(" Looking for $description since $since");
my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());	my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my ($descr,$lasttime)=split(/\:/,$value);	my ($descr,$lasttime)=split(/\:/,$value);
	logthis("Got: key = $key descr = $descr time: $lasttime");
if ($lasttime<$since) {	if ($lasttime<$since) {
	logthis("Skipping .. too early");
next;	next;
}	}
if ($description eq '.') {	if ($description eq '.') {
	logthis("Adding wildcard match");
$qresult.=$key.'='.$descr.'&';	$qresult.=$key.'='.$descr.'&';
} else {	} else {
my $unescapeVal = &unescape($descr);	my $unescapeVal = &unescape($descr);
	logthis("Matching with $unescapeVal");
if (eval('$unescapeVal=~/$description/i')) {	if (eval('$unescapeVal=~/$description/i')) {
	logthis("Adding on match");
$qresult.="$key=$descr&";	$qresult.="$key=$descr&";
}	}
}	}
Line 2432 sub GetIdHandler {	Line 2345 sub GetIdHandler {
my $cmd = shift;	my $cmd = shift;
my $tail = shift;	my $tail = shift;
my $client = shift;	my $client = shift;

my $userinput = "$client:$tail";	my $userinput = "$client:$tail";

my ($udom,$what)=split(/:/,$tail);	my ($udom,$what)=split(/:/,$tail);
chomp($what);	chomp($what);
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
Line 2455 sub GetIdHandler {	Line 2368 sub GetIdHandler {
Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".	Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting idget\n",$userinput);	"while attempting idget\n",$userinput);
}	}

return 1;	return 1;
}	}

Line 2523 sub TmpGetHandler {	Line 2436 sub TmpGetHandler {
my $id = shift;	my $id = shift;
my $client = shift;	my $client = shift;
my $userinput = "$cmd:$id";	my $userinput = "$cmd:$id";


chomp($id);
$id=~s/\W/\_/g;	$id=~s/\W/\_/g;
my $store;	my $store;
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
Line 2558 sub TmpDelHandler {	Line 2471 sub TmpDelHandler {
my $cmd = shift;	my $cmd = shift;
my $id = shift;	my $id = shift;
my $client = shift;	my $client = shift;

my $userinput= "$cmd:$id";	my $userinput= "$cmd:$id";

chomp($id);	chomp($id);
$id=~s/\W/\_/g;	$id=~s/\W/\_/g;
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
Line 2570 sub TmpDelHandler {	Line 2483 sub TmpDelHandler {
Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".	Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
"while attempting tmpdel\n", $userinput);	"while attempting tmpdel\n", $userinput);
}	}

return 1;	return 1;

}	}
Line 2598 sub LsHandler {	Line 2511 sub LsHandler {

my $userinput = "$cmd:$ulsdir";	my $userinput = "$cmd:$ulsdir";

	chomp($ulsdir);

my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
	logthis("ls for '$ulsdir'");
if (-e $ulsdir) {	if (-e $ulsdir) {
	logthis("ls - directory exists");
if(-d $ulsdir) {	if(-d $ulsdir) {
	logthis("ls $ulsdir is a file");
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
Line 2785 sub ProcessRequest {	Line 2703 sub ProcessRequest {
# Split off the request keyword from the rest of the stuff.	# Split off the request keyword from the rest of the stuff.

my ($command, $tail) = split(/:/, $userinput, 2);	my ($command, $tail) = split(/:/, $userinput, 2);
	chomp($command);
	chomp($tail);
	$tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.

Debug("Command received: $command, encoded = $wasenc");	Debug("Command received: $command, encoded = $wasenc");

Line 2826 sub ProcessRequest {	Line 2747 sub ProcessRequest {
$KeepGoing = &$Handler($command, $tail, $client);	$KeepGoing = &$Handler($command, $tail, $client);
} else {	} else {
Debug("Refusing to dispatch because ok is false");	Debug("Refusing to dispatch because ok is false");
Failure($client, "refused", $userinput);	Failure($client, "refused\n", $userinput);
}	}


Line 3898 sub subsqlreply {	Line 3819 sub subsqlreply {

sub propath {	sub propath {
my ($udom,$uname)=@_;	my ($udom,$uname)=@_;
	Debug("Propath:$udom:$uname");
$udom=~s/\W//g;	$udom=~s/\W//g;
$uname=~s/\W//g;	$uname=~s/\W//g;
	Debug("Propath2:$udom:$uname");
my $subdir=$uname.'__';	my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;	$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";	my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
	Debug("Propath returning $proname");
return $proname;	return $proname;
}	}

Line 3910 sub propath {	Line 3834 sub propath {

sub ishome {	sub ishome {
my $author=shift;	my $author=shift;
	Debug("ishome: $author");
$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;	$author=~s/\/home\/httpd\/html\/res\/([^\/])\/([^\/]).*/$1\/$2/;
	Debug(" after big regsub: $author");
my ($udom,$uname)=split(/\//,$author);	my ($udom,$uname)=split(/\//,$author);
	Debug(" domain: $udom user: $uname");
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
	Debug(" path = $proname");
if (-e $proname) {	if (-e $proname) {
return 'owner';	return 'owner';
} else {	} else {
Line 4138 sub ManagePermissions {	Line 4066 sub ManagePermissions {
my $authtype= shift;	my $authtype= shift;

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
&logthis("ruequest is $request");	&logthis("request is $request");
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};	my $execdir = $perlvar{'lonDaemons'};
my $userhome= "/home/$user" ;	my $userhome= "/home/$user" ;
Line 4160 sub PasswordPath {	Line 4088 sub PasswordPath {
my $user = shift;	my $user = shift;

my $path = &propath($domain, $user);	my $path = &propath($domain, $user);
my $path .= "/passwd";	$path .= "/passwd";

return $path;	return $path;
}	}
Line 4179 sub PasswordFilename {	Line 4107 sub PasswordFilename {
my $domain = shift;	my $domain = shift;
my $user = shift;	my $user = shift;

my $path = PasswordPath($domain, $user);	Debug ("PasswordFilename called: dom = $domain user = $user");

	my $path = PasswordPath($domain, $user);
	Debug("PasswordFilename got path: $path");
if(-e $path) {	if(-e $path) {
return $path;	return $path;
} else {	} else {
Line 4240 sub GetAuthType {	Line 4170 sub GetAuthType {
}	}
}	}

	#
	# Validate a user given their domain, name and password. This utility
	# function is used by both AuthenticateHandler and ChangePasswordHandler
	# to validate the login credentials of a user.
	# Parameters:
	# $domain - The domain being logged into (this is required due to
	# the capability for multihomed systems.
	# $user - The name of the user being validated.
	# $password - The user's propoposed password.
	#
	# Returns:
	# 1 - The domain,user,pasword triplet corresponds to a valid
	# user.
	# 0 - The domain,user,password triplet is not a valid user.
	#
	sub ValidateUser {
	my $domain = shift;
	my $user = shift;
	my $password= shift;

	# Why negative ~pi you may well ask? Well this function is about
	# authentication, and therefore very important to get right.
	# I've initialized the flag that determines whether or not I've
	# validated correctly to a value it's not supposed to get.
	# At the end of this function. I'll ensure that it's not still that
	# value so we don't just wind up returning some accidental value
	# as a result of executing an unforseen code path that
	# did not set $validated.

	my $validated = -3.14159;

	# How we authenticate is determined by the type of authentication
	# the user has been assigned. If the authentication type is
	# "nouser", the user does not exist so we will return 0.

	my $contents = GetAuthType($domain, $user);
	my ($howpwd, $contentpwd) = split(/:/, $contents);

	my $null = pack("C",0); # Used by kerberos auth types.

	if ($howpwd ne 'nouser') {

	if($howpwd eq "internal") { # Encrypted is in local password file.
	$validated = (crypt($password, $contentpwd) eq $contentpwd);
	}
	elsif ($howpwd eq "unix") { # User is a normal unix user.
	$contentpwd = (getpwnam($user))[1];
	if($contentpwd) {
	if($contentpwd eq 'x') { # Shadow password file...
	my $pwauth_path = "/usr/local/sbin/pwauth";
	open PWAUTH, "\|$pwauth_path" or
	die "Cannot invoke authentication";
	print PWAUTH "$user\n$password\n";
	close PWAUTH;
	$validated = ! $?;

	} else { # Passwords in /etc/passwd.
	$validated = (crypt($password,
	$contentpwd) eq $contentpwd);
	}
	} else {
	$validated = 0;
	}
	}
	elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
	if(! ($password =~ /$null/) ) {
	my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
	"",
	$contentpwd,,
	'krbtgt',
	$contentpwd,
	1,
	$password);
	if(!$k4error) {
	$validated = 1;
	}
	else {
	$validated = 0;
	&logthis('krb4: '.$user.', '.$contentpwd.', '.
	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
	}
	}
	else {
	$validated = 0; # Password has a match with null.
	}
	}
	elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
	if(!($password =~ /$null/)) { # Null password not allowed.
	my $krbclient = &Authen::Krb5::parse_name($user.'@'
	.$contentpwd);
	my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
	my $krbserver = &Authen::Krb5::parse_name($krbservice);
	my $credentials= &Authen::Krb5::cc_default();
	$credentials->initialize($krbclient);
	my $krbreturn = &Authen::KRb5::get_in_tkt_with_password($krbclient,
	$krbserver,
	$password,
	$credentials);
	$validated = ($krbreturn == 1);
	}
	else {
	$validated = 0;
	}
	}
	elsif ($howpwd eq "localauth") {
	# Authenticate via installation specific authentcation method:
	$validated = &localauth::localauth($user,
	$password,
	$contentpwd);
	}
	else { # Unrecognized auth is also bad.
	$validated = 0;
	}
	} else {
	$validated = 0;
	}
	#
	# $validated has the correct stat of the authentication:
	#

	unless ($validated != -3.14159) {
	die "ValidateUser - failed to set the value of validated";
	}
	return $validated;
	}

	#
	# Add a line to the subscription list?
	#
sub addline {	sub addline {
my ($fname,$hostid,$ip,$newline)=@_;	my ($fname,$hostid,$ip,$newline)=@_;
my $contents;	my $contents;
Line 4247 sub addline {	Line 4306 sub addline {
my $expr='^'.$hostid.':'.$ip.':';	my $expr='^'.$hostid.':'.$ip.':';
$expr =~ s/\./\\\./g;	$expr =~ s/\./\\\./g;
my $sh;	my $sh;
	Debug("Looking for $expr");
if ($sh=IO::File->new("$fname.subscription")) {	if ($sh=IO::File->new("$fname.subscription")) {
while (my $subline=<$sh>) {	while (my $subline=<$sh>) {
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}	Debug("addline: line: $subline");
	if ($subline !~ /$expr/) {
	$contents.= $subline;
	} else {
	Debug("Found $subline");
	$found=1;
	}
}	}
$sh->close();	$sh->close();
}	}
$sh=IO::File->new(">$fname.subscription");	$sh=IO::File->new(">$fname.subscription");
if ($contents) { print $sh $contents; }	if ($contents) { print $sh $contents; }
if ($newline) { print $sh $newline; }	if ($newline) {
	Debug("Appending $newline");
	print $sh $newline;
	}
$sh->close();	$sh->close();
return $found;	return $found;
}	}
	#
	# Get chat messages.
	#
sub getchat {	sub getchat {
my ($cdom,$cname,$udom,$uname)=@_;	my ($cdom,$cname,$udom,$uname)=@_;
my %hash;	my %hash;
Line 4284 sub getchat {	Line 4355 sub getchat {
}	}
return (@participants,@entries);	return (@participants,@entries);
}	}
	#
	# Add a chat message
	#
sub chatadd {	sub chatadd {
my ($cdom,$cname,$newchat)=@_;	my ($cdom,$cname,$newchat)=@_;
my %hash;	my %hash;
Line 4324 sub chatadd {	Line 4397 sub chatadd {
sub unsub {	sub unsub {
my ($fname,$clientip)=@_;	my ($fname,$clientip)=@_;
my $result;	my $result;
	my $unsubs = 0; # Number of successful unsubscribes:


	# An old way subscriptions were handled was to have a
	# subscription marker file:

	Debug("Attempting unlink of $fname.$clientname");
if (unlink("$fname.$clientname")) {	if (unlink("$fname.$clientname")) {
$result="ok\n";	$unsubs++; # Successful unsub via marker file.
} else {	}
$result="not_subscribed\n";
}	# The more modern way to do it is to have a subscription list
	# file:

if (-e "$fname.subscription") {	if (-e "$fname.subscription") {
my $found=&addline($fname,$clientname,$clientip,'');	my $found=&addline($fname,$clientname,$clientip,'');
if ($found) { $result="ok\n"; }	if ($found) {
	$unsubs++;
	}
	}

	# If either or both of these mechanisms succeeded in unsubscribing a
	# resource we can return ok:

	if($unsubs) {
	$result = "ok\n";
} else {	} else {
if ($result != "ok\n") { $result="not_subscribed\n"; }	$result = "not_subscribed\n";
}	}

return $result;	return $result;
}	}

Line 4386 sub thisversion {	Line 4478 sub thisversion {

sub subscribe {	sub subscribe {
my ($userinput,$clientip)=@_;	my ($userinput,$clientip)=@_;
	chomp($userinput);
my $result;	my $result;
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
my $ownership=&ishome($fname);	my $ownership=&ishome($fname);
	Debug("subscribe: Owner = $ownership file: '$fname'");
if ($ownership eq 'owner') {	if ($ownership eq 'owner') {
# explitly asking for the current version?	# explitly asking for the current version?
unless (-e $fname) {	unless (-e $fname) {
	Debug("subscribe - does not exist");
my $currentversion=&currentversion($fname);	my $currentversion=&currentversion($fname);
if (&thisversion($fname)==$currentversion) {	if (&thisversion($fname)==$currentversion) {
if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {	if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
Line 4407 sub subscribe {	Line 4502 sub subscribe {
}	}
}	}
if (-e $fname) {	if (-e $fname) {
	Debug("subscribe - exists");
if (-d $fname) {	if (-d $fname) {
$result="directory\n";	$result="directory\n";
} else {	} else {
Line 4455 sub make_passwd_file {	Line 4551 sub make_passwd_file {
print $pf "localauth:$npass\n";	print $pf "localauth:$npass\n";
}	}
} elsif ($umode eq 'unix') {	} elsif ($umode eq 'unix') {
{	#
my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";	# Don't allow the creation of privileged accounts!!! that would
{	# be real bad!!!
&Debug("Executing external: ".$execpath);	#
&Debug("user = ".$uname.", Password =". $npass);	my $uid = getpwnam($uname);
my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");	if((defined $uid) && ($uid == 0)) {
print $se "$uname\n";	&logthis(">>>Attempted add of privileged account blocked<<<");
print $se "$npass\n";	return "no_priv_account_error\n";
print $se "$npass\n";
}
my $useraddok = $?;
if($useraddok > 0) {
&logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
}
my $pf = IO::File->new(">$passfilename");
print $pf "unix:\n";
}	}

	#
	my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";

	&Debug("Executing external: ".$execpath);
	&Debug("user = ".$uname.", Password =". $npass);
	my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
	print $se "$uname\n";
	print $se "$npass\n";
	print $se "$npass\n";

	my $useraddok = $?;
	if($useraddok > 0) {
	my $lcstring = lcuseraddstrerror($useraddok);
	&logthis("Failed lcuseradd: $lcstring");
	return "error: lcuseradd failed: $lcstring\n";
	}
	my $pf = IO::File->new(">$passfilename");
	print $pf "unix:\n";

} elsif ($umode eq 'none') {	} elsif ($umode eq 'none') {
{	{
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
Line 4485 sub make_passwd_file {	Line 4593 sub make_passwd_file {

sub sethost {	sub sethost {
my ($remotereq) = @_;	my ($remotereq) = @_;
	Debug("sethost got $remotereq");
my (undef,$hostid)=split(/:/,$remotereq);	my (undef,$hostid)=split(/:/,$remotereq);
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
	Debug("sethost attempting to set host $hostid");
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {	if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
$currenthostid=$hostid;	$currenthostid=$hostid;
$currentdomainid=$hostdom{$hostid};	$currentdomainid=$hostdom{$hostid};

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.178.2.9
changed lines
	Added in v.1.178.2.22