Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.260 and 1.292

version 1.260, 2004/10/11 10:58:28	version 1.292, 2005/08/26 19:40:38
Line 46 use Authen::Krb5;	Line 46 use Authen::Krb5;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
use localenroll;	use localenroll;
	use localstudentphoto;
use File::Copy;	use File::Copy;
	use File::Find;
use LONCAPA::ConfigFileEdit;	use LONCAPA::ConfigFileEdit;
use LONCAPA::lonlocal;	use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
Line 64 my $currentdomainid;	Line 66 my $currentdomainid;

my $client;	my $client;
my $clientip; # IP address of client.	my $clientip; # IP address of client.
my $clientdns; # DNS name of client.
my $clientname; # LonCAPA name of client.	my $clientname; # LonCAPA name of client.

my $server;	my $server;
Line 112 my %Dispatcher;	Line 113 my %Dispatcher;
#	#
my $lastpwderror = 13; # Largest error number from lcpasswd.	my $lastpwderror = 13; # Largest error number from lcpasswd.
my @passwderrors = ("ok",	my @passwderrors = ("ok",
"lcpasswd must be run as user 'www'",	"pwchange_failure - lcpasswd must be run as user 'www'",
"lcpasswd got incorrect number of arguments",	"pwchange_failure - lcpasswd got incorrect number of arguments",
"lcpasswd did not get the right nubmer of input text lines",	"pwchange_failure - lcpasswd did not get the right nubmer of input text lines",
"lcpasswd too many simultaneous pwd changes in progress",	"pwchange_failure - lcpasswd too many simultaneous pwd changes in progress",
"lcpasswd User does not exist.",	"pwchange_failure - lcpasswd User does not exist.",
"lcpasswd Incorrect current passwd",	"pwchange_failure - lcpasswd Incorrect current passwd",
"lcpasswd Unable to su to root.",	"pwchange_failure - lcpasswd Unable to su to root.",
"lcpasswd Cannot set new passwd.",	"pwchange_failure - lcpasswd Cannot set new passwd.",
"lcpasswd Username has invalid characters",	"pwchange_failure - lcpasswd Username has invalid characters",
"lcpasswd Invalid characters in password",	"pwchange_failure - lcpasswd Invalid characters in password",
"lcpasswd User already exists",	"pwchange_failure - lcpasswd User already exists",
"lcpasswd Something went wrong with user addition.",	"pwchange_failure - lcpasswd Something went wrong with user addition.",
"lcpasswd Password mismatch",	"pwchange_failure - lcpasswd Password mismatch",
"lcpasswd Error filename is invalid");	"pwchange_failure - lcpasswd Error filename is invalid");


# The array below are lcuseradd error strings.:	# The array below are lcuseradd error strings.:
Line 177 sub ResetStatistics {	Line 178 sub ResetStatistics {
# $initcmd - The full text of the init command.	# $initcmd - The full text of the init command.
#	#
# Implicit inputs:	# Implicit inputs:
# $clientdns - The DNS name of the remote client.
# $thisserver - Our DNS name.	# $thisserver - Our DNS name.
#	#
# Returns:	# Returns:
Line 186 sub ResetStatistics {	Line 186 sub ResetStatistics {
#	#
sub LocalConnection {	sub LocalConnection {
my ($Socket, $initcmd) = @_;	my ($Socket, $initcmd) = @_;
Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");	Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");
if($clientdns ne $thisserver) {	if($clientip ne "127.0.0.1") {
&logthis('<font color="red"> LocalConnection rejecting non local: '	&logthis('<font color="red"> LocalConnection rejecting non local: '
."$clientdns ne $thisserver </font>");	."$clientip ne $thisserver </font>");
close $Socket;	close $Socket;
return undef;	return undef;
} else {	} else {
Line 473 sub CopyFile {	Line 473 sub CopyFile {

my ($oldfile, $newfile) = @_;	my ($oldfile, $newfile) = @_;

# The file must exist:	if (! copy($oldfile,$newfile)) {
	return 0;
if(-e $oldfile) {

# Read the old file.

my $oldfh = IO::File->new("< $oldfile");
if(!$oldfh) {
return 0;
}
my @contents = <$oldfh>; # Suck in the entire file.

# write the backup file:

my $newfh = IO::File->new("> $newfile");
if(!(defined $newfh)){
return 0;
}
my $lines = scalar @contents;
for (my $i =0; $i < $lines; $i++) {
print $newfh ($contents[$i]);
}

$oldfh->close;
$newfh->close;

chmod(0660, $newfile);

return 1;

} else {
return 0;
}	}
	chmod(0660, $newfile);
	return 1;
}	}
#	#
# Host files are passed out with externally visible host IPs.	# Host files are passed out with externally visible host IPs.
Line 1130 sub read_profile {	Line 1102 sub read_profile {
# 0 - Program should exit.	# 0 - Program should exit.
# Side effects:	# Side effects:
# Reply information is sent to the client.	# Reply information is sent to the client.

sub ping_handler {	sub ping_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
Debug("$cmd $tail $client .. $currenthostid:");	Debug("$cmd $tail $client .. $currenthostid:");
Line 1158 sub ping_handler {	Line 1129 sub ping_handler {
# 0 - Program should exit.	# 0 - Program should exit.
# Side effects:	# Side effects:
# Reply information is sent to the client.	# Reply information is sent to the client.

sub pong_handler {	sub pong_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;

Line 1213 sub establish_key_handler {	Line 1183 sub establish_key_handler {
}	}
&register_handler("ekey", \&establish_key_handler, 0, 1,1);	&register_handler("ekey", \&establish_key_handler, 0, 1,1);


# Handler for the load command. Returns the current system load average	# Handler for the load command. Returns the current system load average
# to the requestor.	# to the requestor.
#	#
Line 1248 sub load_handler {	Line 1217 sub load_handler {

return 1;	return 1;
}	}
register_handler("load", \&load_handler, 0, 1, 0);	&register_handler("load", \&load_handler, 0, 1, 0);

#	#
# Process the userload request. This sub returns to the client the current	# Process the userload request. This sub returns to the client the current
Line 1278 sub user_load_handler {	Line 1247 sub user_load_handler {

return 1;	return 1;
}	}
register_handler("userload", \&user_load_handler, 0, 1, 0);	&register_handler("userload", \&user_load_handler, 0, 1, 0);

# Process a request for the authorization type of a user:	# Process a request for the authorization type of a user:
# (userauth).	# (userauth).
Line 1314 sub user_authorization_type {	Line 1283 sub user_authorization_type {
my ($type,$otherinfo) = split(/:/,$result);	my ($type,$otherinfo) = split(/:/,$result);
if($type =~ /^krb/) {	if($type =~ /^krb/) {
$type = $result;	$type = $result;
}	} else {
&Reply( $replyfd, "$type:\n", $userinput);	$type .= ':';
	}
	&Reply( $replyfd, "$type\n", $userinput);
}	}

return 1;	return 1;
Line 1335 sub user_authorization_type {	Line 1306 sub user_authorization_type {
# 0 - Program should exit	# 0 - Program should exit
# Implicit Output:	# Implicit Output:
# a reply is written to the client.	# a reply is written to the client.

sub push_file_handler {	sub push_file_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

Line 1378 sub push_file_handler {	Line 1348 sub push_file_handler {
# Side Effects:	# Side Effects:
# The reply is written to $client.	# The reply is written to $client.
#	#

sub du_handler {	sub du_handler {
my ($cmd, $ududir, $client) = @_;	my ($cmd, $ududir, $client) = @_;
my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.	my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
Line 1395 sub du_handler {	Line 1364 sub du_handler {
# etc.	# etc.
#	#
if (-d $ududir) {	if (-d $ududir) {
# And as Shakespeare would say to make	my $total_size=0;
# assurance double sure,	my $code=sub {
# use execute_command to ensure that the command is not executed in	if ($_=~/\.\d+\./) { return;}
# a shell that can screw us up.	if ($_=~/\.meta$/) { return;}
	$total_size+=(stat($_))[7];
my $duout = execute_command("du -ks $ududir");	};
$duout=~s/[^\d]//g; #preserve only the numbers	find($code,$ududir);
&Reply($client,"$duout\n","$cmd:$ududir");	$total_size=int($total_size/1024);
	&Reply($client,"$total_size\n","$cmd:$ududir");
} else {	} else {

&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");	&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");

}	}
return 1;	return 1;
}	}
&register_handler("du", \&du_handler, 0, 1, 0);	&register_handler("du", \&du_handler, 0, 1, 0);

	#
	# The ls_handler routine should be considered obosolete and is retained
	# for communication with legacy servers. Please see the ls2_handler.
#	#
# ls - list the contents of a directory. For each file in the	# ls - list the contents of a directory. For each file in the
# selected directory the filename followed by the full output of	# selected directory the filename followed by the full output of
Line 1430 sub du_handler {	Line 1400 sub du_handler {
# The reply is written to $client.	# The reply is written to $client.
#	#
sub ls_handler {	sub ls_handler {
	# obsoleted by ls2_handler
my ($cmd, $ulsdir, $client) = @_;	my ($cmd, $ulsdir, $client) = @_;

my $userinput = "$cmd:$ulsdir";	my $userinput = "$cmd:$ulsdir";
Line 1442 sub ls_handler {	Line 1413 sub ls_handler {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
undef $obs, $rights;	undef($obs);
	undef($rights);
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
#We do some obsolete checking here	#We do some obsolete checking here
if(-e $ulsdir.'/'.$ulsfn.".meta") {	if(-e $ulsdir.'/'.$ulsfn.".meta") {
Line 1476 sub ls_handler {	Line 1448 sub ls_handler {
}	}
&register_handler("ls", \&ls_handler, 0, 1, 0);	&register_handler("ls", \&ls_handler, 0, 1, 0);

	#
	# Please also see the ls_handler, which this routine obosolets.
	# ls2_handler differs from ls_handler in that it escapes its return
	# values before concatenating them together with ':'s.
	#
	# ls2 - list the contents of a directory. For each file in the
	# selected directory the filename followed by the full output of
	# the stat function is returned. The returned info for each
	# file are separated by ':'. The stat fields are separated by &'s.
	# Parameters:
	# $cmd - The command that dispatched us (ls).
	# $ulsdir - The directory path to list... I'm not sure what this
	# is relative as things like ls:. return e.g.
	# no_such_dir.
	# $client - Socket open on the client.
	# Returns:
	# 1 - indicating that the daemon should not disconnect.
	# Side Effects:
	# The reply is written to $client.
	#
	sub ls2_handler {
	my ($cmd, $ulsdir, $client) = @_;

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

	my $obs;
	my $rights;
	my $ulsout='';
	my $ulsfn;
	if (-e $ulsdir) {
	if(-d $ulsdir) {
	if (opendir(LSDIR,$ulsdir)) {
	while ($ulsfn=readdir(LSDIR)) {
	undef($obs);
	undef($rights);
	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
	#We do some obsolete checking here
	if(-e $ulsdir.'/'.$ulsfn.".meta") {
	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
	my @obsolete=<FILE>;
	foreach my $obsolete (@obsolete) {
	if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }
	if($obsolete =~ m\|(<copyright>)(default)\|) {
	$rights = 1;
	}
	}
	}
	my $tmp = $ulsfn.'&'.join('&',@ulsstats);
	if ($obs eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
	if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
	$ulsout.= &escape($tmp).':';
	}
	closedir(LSDIR);
	}
	} else {
	my @ulsstats=stat($ulsdir);
	$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
	}
	} else {
	$ulsout='no_such_dir';
	}
	if ($ulsout eq '') { $ulsout='empty'; }
	&Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
	return 1;
	}
	&register_handler("ls2", \&ls2_handler, 0, 1, 0);

# Process a reinit request. Reinit requests that either	# Process a reinit request. Reinit requests that either
# lonc or lond be reinitialized so that an updated	# lonc or lond be reinitialized so that an updated
Line 1508 sub reinit_process_handler {	Line 1544 sub reinit_process_handler {
}	}
return 1;	return 1;
}	}

&register_handler("reinit", \&reinit_process_handler, 1, 0, 1);	&register_handler("reinit", \&reinit_process_handler, 1, 0, 1);

# Process the editing script for a table edit operation.	# Process the editing script for a table edit operation.
Line 1550 sub edit_table_handler {	Line 1585 sub edit_table_handler {
}	}
return 1;	return 1;
}	}
register_handler("edit", \&edit_table_handler, 1, 0, 1);	&register_handler("edit", \&edit_table_handler, 1, 0, 1);


#	#
# Authenticate a user against the LonCAPA authentication	# Authenticate a user against the LonCAPA authentication
Line 1606 sub authenticate_handler {	Line 1640 sub authenticate_handler {

return 1;	return 1;
}	}
	&register_handler("auth", \&authenticate_handler, 1, 1, 0);
register_handler("auth", \&authenticate_handler, 1, 1, 0);

#	#
# Change a user's password. Note that this function is complicated by	# Change a user's password. Note that this function is complicated by
Line 1670 sub change_password_handler {	Line 1703 sub change_password_handler {
&Failure( $client, "non_authorized\n",$userinput);	&Failure( $client, "non_authorized\n",$userinput);
}	}
} elsif ($howpwd eq 'unix') {	} elsif ($howpwd eq 'unix') {
# Unix means we have to access /etc/password	my $result = &change_unix_password($uname, $npass);
&Debug("auth is unix");
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: ".	&logthis("Result of password change for $uname: ".
&lcpasswdstrerror($?));	$result);
&Reply($client, "$result\n", $userinput);	&Reply($client, "$result\n", $userinput);
} else {	} else {
# this just means that the current password mode is not	# this just means that the current password mode is not
Line 1698 sub change_password_handler {	Line 1721 sub change_password_handler {

return 1;	return 1;
}	}
register_handler("passwd", \&change_password_handler, 1, 1, 0);	&register_handler("passwd", \&change_password_handler, 1, 1, 0);


#	#
# Create a new user. User in this case means a lon-capa user.	# Create a new user. User in this case means a lon-capa user.
Line 1738 sub add_user_handler {	Line 1760 sub add_user_handler {
if (-e $passfilename) {	if (-e $passfilename) {
&Failure( $client, "already_exists\n", $userinput);	&Failure( $client, "already_exists\n", $userinput);
} else {	} else {
my @fpparts=split(/\//,$passfilename);
my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
my $fperror='';	my $fperror='';
for (my $i=3;$i<= ($#fpparts-1);$i++) {	if (!&mkpath($passfilename)) {
$fpnow.='/'.$fpparts[$i];	$fperror="error: ".($!+0)." mkdir failed while attempting "
unless (-e $fpnow) {	."makeuser";
&logthis("mkdir $fpnow");
unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)." mkdir failed while attempting "
."makeuser";
}
}
}	}
unless ($fperror) {	unless ($fperror) {
my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);	my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
Line 1790 sub add_user_handler {	Line 1804 sub add_user_handler {
# Implicit inputs:	# Implicit inputs:
# The authentication systems describe above have their own forms of implicit	# The authentication systems describe above have their own forms of implicit
# input into the authentication process that are described above.	# input into the authentication process that are described above.
	# NOTE:
	# This is also used to change the authentication credential values (e.g. passwd).
	#
#	#
sub change_authentication_handler {	sub change_authentication_handler {

Line 1806 sub change_authentication_handler {	Line 1823 sub change_authentication_handler {
chomp($npass);	chomp($npass);

$npass=&unescape($npass);	$npass=&unescape($npass);
	my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
my $passfilename = &password_path($udom, $uname);	my $passfilename = &password_path($udom, $uname);
if ($passfilename) { # Not allowed to create a new user!!	if ($passfilename) { # Not allowed to create a new user!!
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);	# If just changing the unix passwd. need to arrange to run
&Reply($client, $result, $userinput);	# passwd since otherwise make_passwd_file will run
	# lcuseradd which fails if an account already exists
	# (to prevent an unscrupulous LONCAPA admin from stealing
	# an existing account by overwriting it as a LonCAPA account).

	if(($oldauth =~/^unix/) && ($umode eq "unix")) {
	my $result = &change_unix_password($uname, $npass);
	&logthis("Result of password change for $uname: ".$result);
	if ($result eq "ok") {
	&Reply($client, "$result\n")
	} else {
	&Failure($client, "$result\n");
	}
	} else {
	my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
	#
	# If the current auth mode is internal, and the old auth mode was
	# unix, or krb*, and the user is an author for this domain,
	# re-run manage_permissions for that role in order to be able
	# to take ownership of the construction space back to www:www
	#


	if( (($oldauth =~ /^unix/) && ($umode eq "internal")) \|\|
	(($oldauth =~ /^internal/) && ($umode eq "unix")) ) {
	if(&is_author($udom, $uname)) {
	&Debug(" Need to manage author permissions...");
	&manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
	}
	}
	&Reply($client, $result, $userinput);
	}


} else {	} else {
&Failure($client, "non_authorized\n", $userinput); # Fail the user now.	&Failure($client, "non_authorized\n", $userinput); # Fail the user now.
}	}
Line 1964 sub fetch_user_file_handler {	Line 2015 sub fetch_user_file_handler {
# Note that any regular files in the way of this path are	# Note that any regular files in the way of this path are
# wiped out to deal with some earlier folly of mine.	# wiped out to deal with some earlier folly of mine.

my $path = $udir;	if (!&mkpath($udir.'/'.$ufile)) {
if ($ufile =~m\|(.+)/([^/]+)$\|) {	&Failure($client, "unable_to_create\n", $userinput);
my @parts=split('/',$1);
foreach my $part (@parts) {
$path .= '/'.$part;
if( -f $path) {
unlink($path);
}
if ((-e $path)!=1) {
mkdir($path,0770);
}
}
}	}


my $destname=$udir.'/'.$ufile;	my $destname=$udir.'/'.$ufile;
my $transname=$udir.'/'.$ufile.'.in.transit';	my $transname=$udir.'/'.$ufile.'.in.transit';
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 2022 sub fetch_user_file_handler {	Line 2062 sub fetch_user_file_handler {
#	#
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.

sub remove_user_file_handler {	sub remove_user_file_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

Line 2075 sub remove_user_file_handler {	Line 2114 sub remove_user_file_handler {
#	#
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.

sub mkdir_user_file_handler {	sub mkdir_user_file_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

Line 2089 sub mkdir_user_file_handler {	Line 2127 sub mkdir_user_file_handler {
} else {	} else {
my $udir = &propath($udom,$uname);	my $udir = &propath($udom,$uname);
if (-e $udir) {	if (-e $udir) {
my $newdir=$udir.'/userfiles/'.$ufile;	my $newdir=$udir.'/userfiles/'.$ufile.'/';
if (!-e $newdir) {	if (!&mkpath($newdir)) {
my @parts=split('/',$newdir);	&Failure($client, "failed\n", "$cmd:$tail");
my $path;
foreach my $part (@parts) {
$path .= '/'.$part;
if (!-e $path) {
mkdir($path,0770);
}
}
if (!-e $newdir) {
&Failure($client, "failed\n", "$cmd:$tail");
} else {
&Reply($client, "ok\n", "$cmd:$tail");
}
} else {
&Failure($client, "not_found\n", "$cmd:$tail");
}	}
	&Reply($client, "ok\n", "$cmd:$tail");
} else {	} else {
&Failure($client, "not_home\n", "$cmd:$tail");	&Failure($client, "not_home\n", "$cmd:$tail");
}	}
Line 2124 sub mkdir_user_file_handler {	Line 2149 sub mkdir_user_file_handler {
#	#
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.

sub rename_user_file_handler {	sub rename_user_file_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

Line 2158 sub rename_user_file_handler {	Line 2182 sub rename_user_file_handler {
}	}
&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);	&register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);


#	#
# Authenticate access to a user file by checking the user's	# Authenticate access to a user file by checking that the token the user's
# session token(?)	# passed also exists in their session file
#	#
# Parameters:	# Parameters:
# cmd - The request keyword that dispatched to tus.	# cmd - The request keyword that dispatched to tus.
Line 2169 sub rename_user_file_handler {	Line 2192 sub rename_user_file_handler {
# client - Filehandle open on the client.	# client - Filehandle open on the client.
# Return:	# Return:
# 1.	# 1.

sub token_auth_user_file_handler {	sub token_auth_user_file_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

Line 2190 sub token_auth_user_file_handler {	Line 2212 sub token_auth_user_file_handler {
return 1;	return 1;

}	}

&register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);	&register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);


#	#
# Unsubscribe from a resource.	# Unsubscribe from a resource.
#	#
Line 2222 sub unsubscribe_handler {	Line 2242 sub unsubscribe_handler {
return 1;	return 1;
}	}
&register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);	&register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);

# Subscribe to a resource	# Subscribe to a resource
#	#
# Parameters:	# Parameters:
Line 2300 sub activity_log_handler {	Line 2321 sub activity_log_handler {

return 1;	return 1;
}	}
register_handler("log", \&activity_log_handler, 0, 1, 0);	&register_handler("log", \&activity_log_handler, 0, 1, 0);

#	#
# Put a namespace entry in a user profile hash.	# Put a namespace entry in a user profile hash.
Line 2351 sub put_user_profile_entry {	Line 2372 sub put_user_profile_entry {
}	}
&register_handler("put", \&put_user_profile_entry, 0, 1, 0);	&register_handler("put", \&put_user_profile_entry, 0, 1, 0);

	# Put a piece of new data in hash, returns error if entry already exists
	# Parameters:
	# $cmd - The command that got us here.
	# $tail - Tail of the command (remaining parameters).
	# $client - File descriptor connected to client.
	# Returns
	# 0 - Requested to exit, caller should shut down.
	# 1 - Continue processing.
	#
	sub newput_user_profile_entry {
	my ($cmd, $tail, $client) = @_;

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

	my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
	if ($namespace eq 'roles') {
	&Failure( $client, "refused\n", $userinput);
	return 1;
	}

	chomp($what);

	my $hashref = &tie_user_hash($udom, $uname, $namespace,
	&GDBM_WRCREAT(),"N",$what);
	if(!$hashref) {
	&Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
	"while attempting put\n", $userinput);
	return 1;
	}

	my @pairs=split(/\&/,$what);
	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
	if (exists($hashref->{$key})) {
	&Failure($client, "key_exists: ".$key."\n",$userinput);
	return 1;
	}
	}

	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
	$hashref->{$key}=$value;
	}

	if (untie(%$hashref)) {
	&Reply( $client, "ok\n", $userinput);
	} else {
	&Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
	"while attempting put\n",
	$userinput);
	}
	return 1;
	}
	&register_handler("newput", \&newput_user_profile_entry, 0, 1, 0);

#	#
# Increment a profile entry in the user history file.	# Increment a profile entry in the user history file.
# The history contains keyword value pairs. In this case,	# The history contains keyword value pairs. In this case,
Line 2381 sub increment_user_value_handler {	Line 2457 sub increment_user_value_handler {
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);
	$value = &unescape($value);
# 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 ($namespace eq 'nohist_resourcetracker') {
	if ($hashref->{$key} < 0) {
	$hashref->{$key} = 0;
	}
	}
}	}
if (untie(%$hashref)) {	if (untie(%$hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
Line 2405 sub increment_user_value_handler {	Line 2487 sub increment_user_value_handler {
}	}
&register_handler("inc", \&increment_user_value_handler, 0, 1, 0);	&register_handler("inc", \&increment_user_value_handler, 0, 1, 0);


#	#
# Put a new role for a user. Roles are LonCAPA's packaging of permissions.	# Put a new role for a user. Roles are LonCAPA's packaging of permissions.
# Each 'role' a user has implies a set of permissions. Adding a new role	# Each 'role' a user has implies a set of permissions. Adding a new role
Line 2445 sub roles_put_handler {	Line 2526 sub roles_put_handler {
# is done on close this improves the chances the log will be an un-	# is done on close this improves the chances the log will be an un-
# corrupted ordered thing.	# corrupted ordered thing.
if ($hashref) {	if ($hashref) {
	my $pass_entry = &get_auth_type($udom, $uname);
	my ($auth_type,$pwd) = split(/:/, $pass_entry);
	$auth_type = $auth_type.":";
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);
my $pass_entry = &get_auth_type($udom, $uname);
my ($auth_type,$pwd) = split(/:/, $pass_entry);
$auth_type = $auth_type.":";
&manage_permissions($key, $udom, $uname,	&manage_permissions($key, $udom, $uname,
$auth_type);	$auth_type);
$hashref->{$key}=$value;	$hashref->{$key}=$value;
Line 2613 sub get_profile_entry_encrypted {	Line 2694 sub get_profile_entry_encrypted {
return 1;	return 1;
}	}
&register_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);	&register_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);

#	#
# Deletes a key in a user profile database.	# Deletes a key in a user profile database.
#	#
Line 2631 sub get_profile_entry_encrypted {	Line 2713 sub get_profile_entry_encrypted {
# 0 - Exit server.	# 0 - Exit server.
#	#
#	#

sub delete_profile_entry {	sub delete_profile_entry {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

Line 2660 sub delete_profile_entry {	Line 2741 sub delete_profile_entry {
return 1;	return 1;
}	}
&register_handler("del", \&delete_profile_entry, 0, 1, 0);	&register_handler("del", \&delete_profile_entry, 0, 1, 0);

#	#
# List the set of keys that are defined in a profile database file.	# List the set of keys that are defined in a profile database file.
# A successful reply from this will contain an & separated list of	# A successful reply from this will contain an & separated list of
Line 2838 sub dump_with_regexp {	Line 2920 sub dump_with_regexp {

return 1;	return 1;
}	}

&register_handler("dump", \&dump_with_regexp, 0, 1, 0);	&register_handler("dump", \&dump_with_regexp, 0, 1, 0);

# Store a set of key=value pairs associated with a versioned name.	# Store a set of key=value pairs associated with a versioned name.
Line 2870 sub store_handler {	Line 2951 sub store_handler {
chomp($what);	chomp($what);
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_WRCREAT(), "P",	&GDBM_WRCREAT(), "S",
"$rid:$what");	"$rid:$what");
if ($hashref) {	if ($hashref) {
my $now = time;	my $now = time;
Line 2904 sub store_handler {	Line 2985 sub store_handler {
return 1;	return 1;
}	}
&register_handler("store", \&store_handler, 0, 1, 0);	&register_handler("store", \&store_handler, 0, 1, 0);

#	#
# Dump out all versions of a resource that has key=value pairs associated	# 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	# with it for each version. These resources are built up via the store
Line 3004 sub send_chat_handler {	Line 3086 sub send_chat_handler {
return 1;	return 1;
}	}
&register_handler("chatsend", \&send_chat_handler, 0, 1, 0);	&register_handler("chatsend", \&send_chat_handler, 0, 1, 0);

#	#
# Retrieve the set of chat messagss from a discussion board.	# Retrieve the set of chat messagss from a discussion board.
#	#
Line 3139 sub reply_query_handler {	Line 3222 sub reply_query_handler {
# $tail - Tail of the command. In this case consists of a colon	# $tail - Tail of the command. In this case consists of a colon
# separated list contaning the domain to apply this to and	# separated list contaning the domain to apply this to and
# an ampersand separated list of keyword=value pairs.	# an ampersand separated list of keyword=value pairs.
	# Each value is a colon separated list that includes:
	# description, institutional code and course owner.
	# For backward compatibility with versions included
	# in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
	# code and/or course owner are preserved from the existing
	# record when writing a new record in response to 1.1 or
	# 1.2 implementations of lonnet::flushcourselogs().
	#
# $client - Socket open on the client.	# $client - Socket open on the client.
# Returns:	# Returns:
# 1 - indicating that processing should continue	# 1 - indicating that processing should continue
Line 3152 sub put_course_id_handler {	Line 3243 sub put_course_id_handler {

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

my ($udom, $what) = split(/:/, $tail);	my ($udom, $what) = split(/:/, $tail,2);
chomp($what);	chomp($what);
my $now=time;	my $now=time;
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
Line 3160 sub put_course_id_handler {	Line 3251 sub put_course_id_handler {
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$descr,$inst_code)=split(/=/,$pair);	my ($key,$courseinfo) = split(/=/,$pair,2);
$hashref->{$key}=$descr.':'.$inst_code.':'.$now;	$courseinfo =~ s/=/:/g;

	my @current_items = split(/:/,$hashref->{$key});
	shift(@current_items); # remove description
	pop(@current_items); # remove last access
	my $numcurrent = scalar(@current_items);

	my @new_items = split(/:/,$courseinfo);
	my $numnew = scalar(@new_items);
	if ($numcurrent > 0) {
	if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier
	$courseinfo .= ':'.join(':',@current_items);
	} elsif ($numnew == 2) { # flushcourselogs() from 1.2.X
	$courseinfo .= ':'.$current_items[$numcurrent-1];
	}
	}
	$hashref->{$key}=$courseinfo.':'.$now;
}	}
if (untie(%$hashref)) {	if (untie(%$hashref)) {
&Reply( $client, "ok\n", $userinput);	&Reply( $client, "ok\n", $userinput);
Line 3199 sub put_course_id_handler {	Line 3306 sub put_course_id_handler {
# description - regular expression that is used to filter	# description - regular expression that is used to filter
# the dump. Only keywords matching this regexp	# the dump. Only keywords matching this regexp
# will be used.	# will be used.
	# institutional code - optional supplied code to filter
	# the dump. Only courses with an institutional code
	# that match the supplied code will be returned.
	# owner - optional supplied username of owner to filter
	# the dump. Only courses for which the course
	# owner matches the supplied username will be
	# returned. Implicit assumption that owner
	# is a user in the domain in which the
	# course database is defined.
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3209 sub dump_course_id_handler {	Line 3325 sub dump_course_id_handler {

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

my ($udom,$since,$description) =split(/:/,$tail);	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
if (defined($description)) {	if (defined($description)) {
$description=&unescape($description);	$description=&unescape($description);
} else {	} else {
$description='.';	$description='.';
}	}
	if (defined($instcodefilter)) {
	$instcodefilter=&unescape($instcodefilter);
	} else {
	$instcodefilter='.';
	}
	if (defined($ownerfilter)) {
	$ownerfilter=&unescape($ownerfilter);
	} else {
	$ownerfilter='.';
	}
	if (defined($coursefilter)) {
	$coursefilter=&unescape($coursefilter);
	} else {
	$coursefilter='.';
	}

unless (defined($since)) { $since=0; }	unless (defined($since)) { $since=0; }
my $qresult='';	my $qresult='';
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {	if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
my ($descr,$lasttime,$inst_code);	my ($descr,$lasttime,$inst_code,$owner);
if ($value =~ m/^([^\:]):([^\:]):(\d+)$/) {	my @courseitems = split(/:/,$value);
($descr,$inst_code,$lasttime)=($1,$2,$3);	$lasttime = pop(@courseitems);
} else {	($descr,$inst_code,$owner)=@courseitems;
($descr,$lasttime) = split(/\:/,$value);
}
if ($lasttime<$since) { next; }	if ($lasttime<$since) { next; }
if ($description eq '.') {	my $match = 1;
$qresult.=$key.'='.$descr.':'.$inst_code.'&';	unless ($description eq '.') {
} else {	my $unescapeDescr = &unescape($descr);
my $unescapeVal = &unescape($descr);	unless (eval('$unescapeDescr=~/\Q$description\E/i')) {
if (eval('$unescapeVal=~/\Q$description\E/i')) {	$match = 0;
$qresult.=$key.'='.$descr.':'.$inst_code.'&';
}	}
	}
	unless ($instcodefilter eq '.' \|\| !defined($instcodefilter)) {
	my $unescapeInstcode = &unescape($inst_code);
	unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
	$match = 0;
	}
}	}
	unless ($ownerfilter eq '.' \|\| !defined($ownerfilter)) {
	my $unescapeOwner = &unescape($owner);
	unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
	$match = 0;
	}
	}
	unless ($coursefilter eq '.' \|\| !defined($coursefilter)) {
	my $unescapeCourse = &unescape($key);
	unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {
	$match = 0;
	}
	}
	if ($match == 1) {
	$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
	}
}	}
if (untie(%$hashref)) {	if (untie(%$hashref)) {
chop($qresult);	chop($qresult);
Line 3298 sub put_id_handler {	Line 3448 sub put_id_handler {

return 1;	return 1;
}	}

&register_handler("idput", \&put_id_handler, 0, 1, 0);	&register_handler("idput", \&put_id_handler, 0, 1, 0);

#	#
# Retrieves a set of id values from the id database.	# Retrieves a set of id values from the id database.
# Returns an & separated list of results, one for each requested id to the	# Returns an & separated list of results, one for each requested id to the
Line 3348 sub get_id_handler {	Line 3498 sub get_id_handler {

return 1;	return 1;
}	}
	&register_handler("idget", \&get_id_handler, 0, 1, 0);
register_handler("idget", \&get_id_handler, 0, 1, 0);

#	#
# Process the tmpput command I'm not sure what this does.. Seems to	# Process the tmpput command I'm not sure what this does.. Seems to
Line 3392 sub tmp_put_handler {	Line 3541 sub tmp_put_handler {

}	}
&register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);	&register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);

# Processes the tmpget command. This command returns the contents	# Processes the tmpget command. This command returns the contents
# of a temporary resource file(?) created via tmpput.	# of a temporary resource file(?) created via tmpput.
#	#
Line 3404 sub tmp_put_handler {	Line 3554 sub tmp_put_handler {
# 1 - Inidcating processing can continue.	# 1 - Inidcating processing can continue.
# Side effects:	# Side effects:
# A reply is sent to the client.	# A reply is sent to the client.

#	#
sub tmp_get_handler {	sub tmp_get_handler {
my ($cmd, $id, $client) = @_;	my ($cmd, $id, $client) = @_;
Line 3427 sub tmp_get_handler {	Line 3576 sub tmp_get_handler {
return 1;	return 1;
}	}
&register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);	&register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);

#	#
# Process the tmpdel command. This command deletes a temp resource	# Process the tmpdel command. This command deletes a temp resource
# created by the tmpput command.	# created by the tmpput command.
Line 3460 sub tmp_del_handler {	Line 3610 sub tmp_del_handler {

}	}
&register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);	&register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);

#	#
# Processes the setannounce command. This command	# Processes the setannounce command. This command
# creates a file named announce.txt in the top directory of	# creates a file named announce.txt in the top directory of
Line 3498 sub set_announce_handler {	Line 3649 sub set_announce_handler {
return 1;	return 1;
}	}
&register_handler("setannounce", \&set_announce_handler, 0, 1, 0);	&register_handler("setannounce", \&set_announce_handler, 0, 1, 0);

#	#
# Return the version of the daemon. This can be used to determine	# Return the version of the daemon. This can be used to determine
# the compatibility of cross version installations or, alternatively to	# the compatibility of cross version installations or, alternatively to
Line 3522 sub get_version_handler {	Line 3674 sub get_version_handler {
return 1;	return 1;
}	}
&register_handler("version", \&get_version_handler, 0, 1, 0);	&register_handler("version", \&get_version_handler, 0, 1, 0);

# Set the current host and domain. This is used to support	# Set the current host and domain. This is used to support
# multihomed systems. Each IP of the system, or even separate daemons	# multihomed systems. Each IP of the system, or even separate daemons
# on the same IP can be treated as handling a separate lonCAPA virtual	# on the same IP can be treated as handling a separate lonCAPA virtual
Line 3658 sub validate_course_owner_handler {	Line 3811 sub validate_course_owner_handler {
return 1;	return 1;
}	}
&register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);	&register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);

#	#
# Validate a course section in the official schedule of classes	# Validate a course section in the official schedule of classes
# from the institutions point of view (part of autoenrollment).	# from the institutions point of view (part of autoenrollment).
Line 3738 sub create_auto_enroll_password_handler	Line 3892 sub create_auto_enroll_password_handler
#	#
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.

sub retrieve_auto_file_handler {	sub retrieve_auto_file_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my $userinput = "cmd:$tail";	my $userinput = "cmd:$tail";
Line 3823 sub get_institutional_code_format_handle	Line 3976 sub get_institutional_code_format_handle

return 1;	return 1;
}	}
	&register_handler("autoinstcodeformat",
	\&get_institutional_code_format_handler,0,1,0);

&register_handler("autoinstcodeformat", \&get_institutional_code_format_handler,
0,1,0);

#
#
#
#
#	#
	# Gets a student's photo to exist (in the correct image type) in the user's
	# directory.
	# Formal Parameters:
	# $cmd - The command request that got us dispatched.
	# $tail - A colon separated set of words that will be split into:
	# $domain - student's domain
	# $uname - student username
	# $type - image type desired
	# $client - The socket open on the client.
	# Returns:
	# 1 - continue processing.
	sub student_photo_handler {
	my ($cmd, $tail, $client) = @_;
	my ($domain,$uname,$type) = split(/:/, $tail);

	my $path=&propath($domain,$uname).
	'/userfiles/internal/studentphoto.'.$type;
	if (-e $path) {
	&Reply($client,"ok\n","$cmd:$tail");
	return 1;
	}
	&mkpath($path);
	my $file=&localstudentphoto::fetch($domain,$uname);
	if (!$file) {
	&Failure($client,"unavailable\n","$cmd:$tail");
	return 1;
	}
	if (!-e $path) { &convert_photo($file,$path); }
	if (-e $path) {
	&Reply($client,"ok\n","$cmd:$tail");
	return 1;
	}
	&Failure($client,"unable_to_convert\n","$cmd:$tail");
	return 1;
	}
	&register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);

	# mkpath makes all directories for a file, expects an absolute path with a
	# file or a trailing / if just a dir is passed
	# returns 1 on success 0 on failure
	sub mkpath {
	my ($file)=@_;
	my @parts=split(/\//,$file,-1);
	my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
	for (my $i=3;$i<= ($#parts-1);$i++) {
	$now.='/'.$parts[$i];
	if (!-e $now) {
	if (!mkdir($now,0770)) { return 0; }
	}
	}
	return 1;
	}

#---------------------------------------------------------------	#---------------------------------------------------------------
#	#
# Getting, decoding and dispatching requests:	# Getting, decoding and dispatching requests:
#	#

#	#
# Get a Request:	# Get a Request:
# Gets a Request message from the client. The transaction	# Gets a Request message from the client. The transaction
Line 3943 sub process_request {	Line 4143 sub process_request {

}	}

#------------------- Commands not yet in spearate handlers. --------------	print $client "unknown_cmd\n";

#------------------------------- is auto-enrollment enabled?
if ($userinput =~/^autorun/) {
if (isClient) {
my ($cmd,$cdom) = split(/:/,$userinput);
my $outcome = &localenroll::run($cdom);
print $client "$outcome\n";
} else {
print $client "0\n";
}
#------------------------------- get official sections (for auto-enrollment).
} elsif ($userinput =~/^autogetsections/) {
if (isClient) {
my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
my @secs = &localenroll::get_sections($coursecode,$cdom);
my $seclist = &escape(join(':',@secs));
print $client "$seclist\n";
} else {
print $client "refused\n";
}
#----------------------- validate owner of new course section (for auto-enrollment).
} elsif ($userinput =~/^autonewcourse/) {
if (isClient) {
my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
print $client "$outcome\n";
} else {
print $client "refused\n";
}
#-------------- validate course section in schedule of classes (for auto-enrollment).
} elsif ($userinput =~/^autovalidatecourse/) {
if (isClient) {
my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
print $client "$outcome\n";
} else {
print $client "refused\n";
}
#--------------------------- create password for new user (for auto-enrollment).
} elsif ($userinput =~/^autocreatepassword/) {
if (isClient) {
my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
my ($create_passwd,$authchk);
($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
} else {
print $client "refused\n";
}
#--------------------------- read and remove temporary files (for auto-enrollment).
} elsif ($userinput =~/^autoretrieve/) {
if (isClient) {
my ($cmd,$filename) = split(/:/,$userinput);
my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
if ( (-e $source) && ($filename ne '') ) {
my $reply = '';
if (open(my $fh,$source)) {
while (<$fh>) {
chomp($_);
$_ =~ s/^\s+//g;
$_ =~ s/\s+$//g;
$reply .= $_;
}
close($fh);
print $client &escape($reply)."\n";
# unlink($source);
} else {
print $client "error\n";
}
} else {
print $client "error\n";
}
} else {
print $client "refused\n";
}
#--------------------- read and retrieve institutional code format
# (for support form).
} elsif ($userinput =~/^autoinstcodeformat/) {
if (isClient) {
my $reply;
my($cmd,$cdom,$course) = split(/:/,$userinput);
my @pairs = split/\&/,$course;
my %instcodes = ();
my %codes = ();
my @codetitles = ();
my %cat_titles = ();
my %cat_order = ();
foreach (@pairs) {
my ($key,$value) = split/=/,$_;
$instcodes{&unescape($key)} = &unescape($value);
}
my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);
if ($formatreply eq 'ok') {
my $codes_str = &hash2str(%codes);
my $codetitles_str = &array2str(@codetitles);
my $cat_titles_str = &hash2str(%cat_titles);
my $cat_order_str = &hash2str(%cat_order);
print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";
}
} else {
print $client "refused\n";
}
# ------------------------------------------------------------- unknown command

} else {
# unknown command
print $client "unknown_cmd\n";
}
# -------------------------------------------------------------------- complete	# -------------------------------------------------------------------- complete
Debug("process_request - returning 1");	Debug("process_request - returning 1");
return 1;	return 1;
Line 4312 sub ReadHostTable {	Line 4405 sub ReadHostTable {
my $myloncapaname = $perlvar{'lonHostID'};	my $myloncapaname = $perlvar{'lonHostID'};
Debug("My loncapa name is : $myloncapaname");	Debug("My loncapa name is : $myloncapaname");
while (my $configline=<CONFIG>) {	while (my $configline=<CONFIG>) {
if (!($configline =~ /^\s*\#/)) {	if ($configline !~ /^\s\#/ && $configline !~ /^\s$/ ) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	my ($id,$domain,$role,$name)=split(/:/,$configline);
chomp($ip); $ip=~s/\D+$//;	$name=~s/\s//g;
	my $ip = gethostbyname($name);
	if (length($ip) ne 4) {
	&logthis("Skipping host $id name $name no IP $ip found\n");
	next;
	}
	$ip=inet_ntoa($ip);
$hostid{$ip}=$id; # LonCAPA name of host by IP.	$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostdom{$id}=$domain; # LonCAPA domain name of host.	$hostdom{$id}=$domain; # LonCAPA domain name of host.
$hostip{$id}=$ip; # IP address of host.	$hostip{$id}=$ip; # IP address of host.
$hostdns{$name} = $id; # LonCAPA name of host by DNS.	$hostdns{$name} = $id; # LonCAPA name of host by DNS.

if ($id eq $perlvar{'lonHostID'}) {	if ($id eq $perlvar{'lonHostID'}) {
Line 4454 sub Reply {	Line 4553 sub Reply {
Debug("Request was $request Reply was $reply");	Debug("Request was $request Reply was $reply");

$Transactions++;	$Transactions++;


}	}


Line 4498 sub logstatus {	Line 4595 sub logstatus {
flock(LOG,LOCK_EX);	flock(LOG,LOCK_EX);
print LOG $$."\t".$clientname."\t".$currenthostid."\t"	print LOG $$."\t".$clientname."\t".$currenthostid."\t"
.$status."\t".$lastlog."\t $keymode\n";	.$status."\t".$lastlog."\t $keymode\n";
flock(DB,LOCK_UN);	flock(LOG,LOCK_UN);
close(LOG);	close(LOG);
}	}
&status("Finished logging");	&status("Finished logging");
Line 4683 $SIG{USR2} = \&UpdateHosts;	Line 4780 $SIG{USR2} = \&UpdateHosts;

ReadHostTable;	ReadHostTable;

	my $dist=`$perlvar{'lonDaemons'}/distprobe`;

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
# and if good, a child process is created to process transactions	# and if good, a child process is created to process transactions
Line 4729 sub make_new_child {	Line 4828 sub make_new_child {
if (defined($iaddr)) {	if (defined($iaddr)) {
$clientip = inet_ntoa($iaddr);	$clientip = inet_ntoa($iaddr);
Debug("Connected with $clientip");	Debug("Connected with $clientip");
$clientdns = gethostbyaddr($iaddr, AF_INET);
Debug("Connected with $clientdns by name");
} else {	} else {
&logthis("Unable to determine clientip");	&logthis("Unable to determine clientip");
$clientip='Unavailable';	$clientip='Unavailable';
Line 4760 sub make_new_child {	Line 4857 sub make_new_child {
# my $tmpsnum=0; # Now global	# my $tmpsnum=0; # Now global
#---------------------------------------------------- kerberos 5 initialization	#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();	if ($dist ne 'fedora4') {
	&Authen::Krb5::init_ets();
	}

&status('Accepted connection');	&status('Accepted connection');
# =============================================================================	# =============================================================================
Line 4770 sub make_new_child {	Line 4869 sub make_new_child {

ReadManagerTable; # May also be a manager!!	ReadManagerTable; # May also be a manager!!

my $clientrec=($hostid{$clientip} ne undef);	my $outsideip=$clientip;
my $ismanager=($managers{$clientip} ne undef);	if ($clientip eq '127.0.0.1') {
	$outsideip=$hostip{$perlvar{'lonHostID'}};
	}

	my $clientrec=($hostid{$outsideip} ne undef);
	my $ismanager=($managers{$outsideip} ne undef);
$clientname = "[unknonwn]";	$clientname = "[unknonwn]";
if($clientrec) { # Establish client type.	if($clientrec) { # Establish client type.
$ConnectionType = "client";	$ConnectionType = "client";
$clientname = $hostid{$clientip};	$clientname = $hostid{$outsideip};
if($ismanager) {	if($ismanager) {
$ConnectionType = "both";	$ConnectionType = "both";
}	}
} else {	} else {
$ConnectionType = "manager";	$ConnectionType = "manager";
$clientname = $managers{$clientip};	$clientname = $managers{$outsideip};
}	}
my $clientok;	my $clientok;

Line 4925 sub make_new_child {	Line 5029 sub make_new_child {
exit;	exit;

}	}
	#
	# Determine if a user is an author for the indicated domain.
	#
	# Parameters:
	# domain - domain to check in .
	# user - Name of user to check.
	#
	# Return:
	# 1 - User is an author for domain.
	# 0 - User is not an author for domain.
	sub is_author {
	my ($domain, $user) = @_;

	&Debug("is_author: $user @ $domain");

	my $hashref = &tie_user_hash($domain, $user, "roles",
	&GDBM_READER());

	# Author role should show up as a key /domain/_au

	my $key = "/$domain/_au";
	my $value = $hashref->{$key};

	if(defined($value)) {
	&Debug("$user @ $domain is an author");
	}

	return defined($value);
	}
#	#
# Checks to see if the input roleput request was to set	# Checks to see if the input roleput request was to set
# an author role. If so, invokes the lchtmldir script to set	# an author role. If so, invokes the lchtmldir script to set
Line 4938 sub make_new_child {	Line 5069 sub make_new_child {
# user - Name of the user for which the role is being put.	# user - Name of the user for which the role is being put.
# authtype - The authentication type associated with the user.	# authtype - The authentication type associated with the user.
#	#
sub manage_permissions	sub manage_permissions {
{

my ($request, $domain, $user, $authtype) = @_;	my ($request, $domain, $user, $authtype) = @_;

	&Debug("manage_permissions: $request $domain $user $authtype");

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};	my $execdir = $perlvar{'lonDaemons'};
my $userhome= "/home/$user" ;	my $userhome= "/home/$user" ;
&logthis("system $execdir/lchtmldir $userhome $user $authtype");	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
	&Debug("Setting homedir permissions for $userhome");
system("$execdir/lchtmldir $userhome $user $authtype");	system("$execdir/lchtmldir $userhome $user $authtype");
}	}
}	}
Line 4963 sub manage_permissions	Line 5095 sub manage_permissions
#	#
sub password_path {	sub password_path {
my ($domain, $user) = @_;	my ($domain, $user) = @_;
	return &propath($domain, $user).'/passwd';

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

return $path;
}	}

# Password Filename	# Password Filename
Line 5141 sub validate_user {	Line 5268 sub validate_user {
my $krbserver = &Authen::Krb5::parse_name($krbservice);	my $krbserver = &Authen::Krb5::parse_name($krbservice);
my $credentials= &Authen::Krb5::cc_default();	my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize($krbclient);	$credentials->initialize($krbclient);
my $krbreturn = &Authen::KRb5::get_in_tkt_with_password($krbclient,	my $krbreturn = &Authen::Krb5::get_in_tkt_with_password($krbclient,
$krbserver,	$krbserver,
$password,	$password,
$credentials);	$credentials);
Line 5385 sub subscribe {	Line 5512 sub subscribe {
}	}
return $result;	return $result;
}	}
	# Change the passwd of a unix user. The caller must have
	# first verified that the user is a loncapa user.
	#
	# Parameters:
	# user - Unix user name to change.
	# pass - New password for the user.
	# Returns:
	# ok - if success
	# other - Some meaningfule error message string.
	# NOTE:
	# invokes a setuid script to change the passwd.
	sub change_unix_password {
	my ($user, $pass) = @_;

	&Debug("change_unix_password");
	my $execdir=$perlvar{'lonDaemons'};
	&Debug("Opening lcpasswd pipeline");
	my $pf = IO::File->new("\|$execdir/lcpasswd > "
	."$perlvar{'lonDaemons'}"
	."/logs/lcpasswd.log");
	print $pf "$user\n$pass\n$pass\n";
	close $pf;
	my $err = $?;
	return ($err < @passwderrors) ? $passwderrors[$err] :
	"pwchange_falure - unknown error";


	}


sub make_passwd_file {	sub make_passwd_file {
my ($uname, $umode,$npass,$passfilename)=@_;	my ($uname, $umode,$npass,$passfilename)=@_;
Line 5392 sub make_passwd_file {	Line 5548 sub make_passwd_file {
if ($umode eq 'krb4' or $umode eq 'krb5') {	if ($umode eq 'krb4' or $umode eq 'krb5') {
{	{
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
print $pf "$umode:$npass\n";	if ($pf) {
	print $pf "$umode:$npass\n";
	} else {
	$result = "pass_file_failed_error";
	}
}	}
} elsif ($umode eq 'internal') {	} elsif ($umode eq 'internal') {
my $salt=time;	my $salt=time;
Line 5401 sub make_passwd_file {	Line 5561 sub make_passwd_file {
{	{
&Debug("Creating internal auth");	&Debug("Creating internal auth");
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
print $pf "internal:$ncpass\n";	if($pf) {
	print $pf "internal:$ncpass\n";
	} else {
	$result = "pass_file_failed_error";
	}
}	}
} elsif ($umode eq 'localauth') {	} elsif ($umode eq 'localauth') {
{	{
my $pf = IO::File->new(">$passfilename");	my $pf = IO::File->new(">$passfilename");
print $pf "localauth:$npass\n";	if($pf) {
	print $pf "localauth:$npass\n";
	} else {
	$result = "pass_file_failed_error";
	}
}	}
} elsif ($umode eq 'unix') {	} elsif ($umode eq 'unix') {
{	{
Line 5432 sub make_passwd_file {	Line 5600 sub make_passwd_file {
print $se "$npass\n";	print $se "$npass\n";
print $se "$lc_error_file\n"; # Status -> unique file.	print $se "$lc_error_file\n"; # Status -> unique file.
}	}
my $error = IO::File->new("< $lc_error_file");	if (-r $lc_error_file) {
my $useraddok = <$error>;	&Debug("Opening error file: $lc_error_file");
$error->close;	my $error = IO::File->new("< $lc_error_file");
unlink($lc_error_file);	my $useraddok = <$error>;
	$error->close;
chomp $useraddok;	unlink($lc_error_file);

if($useraddok > 0) {	chomp $useraddok;
my $error_text = &lcuseraddstrerror($useraddok);
&logthis("Failed lcuseradd: $error_text");	if($useraddok > 0) {
$result = "lcuseradd_failed:$error_text\n";	my $error_text = &lcuseraddstrerror($useraddok);
	&logthis("Failed lcuseradd: $error_text");
	$result = "lcuseradd_failed:$error_text\n";
	} else {
	my $pf = IO::File->new(">$passfilename");
	if($pf) {
	print $pf "unix:\n";
	} else {
	$result = "pass_file_failed_error";
	}
	}
} else {	} else {
my $pf = IO::File->new(">$passfilename");	&Debug("Could not locate lcuseradd error: $lc_error_file");
print $pf "unix:\n";	$result="bug_lcuseradd_no_output_file";
}	}
}	}
} elsif ($umode eq 'none') {	} elsif ($umode eq 'none') {
{	{
my $pf = IO::File->new("> $passfilename");	my $pf = IO::File->new("> $passfilename");
print $pf "none:\n";	if($pf) {
	print $pf "none:\n";
	} else {
	$result = "pass_file_failed_error";
	}
}	}
} else {	} else {
$result="auth_mode_error\n";	$result="auth_mode_error\n";
Line 5459 sub make_passwd_file {	Line 5641 sub make_passwd_file {
return $result;	return $result;
}	}

	sub convert_photo {
	my ($start,$dest)=@_;
	system("convert $start $dest");
	}

sub sethost {	sub sethost {
my ($remotereq) = @_;	my ($remotereq) = @_;
my (undef,$hostid)=split(/:/,$remotereq);	my (undef,$hostid)=split(/:/,$remotereq);

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

500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.

Removed from v.1.260
changed lines
	Added in v.1.292