loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.186 and 1.199

version 1.186, 2004/04/07 10:02:11	version 1.199, 2004/06/18 23:57:17
Line 45 use Authen::Krb4;	Line 45 use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
	use localenroll;
use File::Copy;	use File::Copy;
use LONCAPA::ConfigFileEdit;	use LONCAPA::ConfigFileEdit;

Line 225 sub ValidManager {	Line 226 sub ValidManager {
# 1 - Success.	# 1 - Success.
#	#
sub CopyFile {	sub CopyFile {
my $oldfile = shift;
my $newfile = shift;	my ($oldfile, $newfile) = @_;

# The file must exist:	# The file must exist:

Line 326 sub AdjustHostContents {	Line 327 sub AdjustHostContents {
# 0 - failure and $! has an errno.	# 0 - failure and $! has an errno.
#	#
sub InstallFile {	sub InstallFile {
my $Filename = shift;
my $Contents = shift;	my ($Filename, $Contents) = @_;
my $TempFile = $Filename.".tmp";	my $TempFile = $Filename.".tmp";

# Open the file for write:	# Open the file for write:
Line 564 sub isValidEditCommand {	Line 565 sub isValidEditCommand {
# file being edited.	# file being edited.
#	#
sub ApplyEdit {	sub ApplyEdit {
my $directive = shift;
my $editor = shift;	my ($directive, $editor) = @_;

# Break the directive down into its command and its parameters	# Break the directive down into its command and its parameters
# (at most two at this point. The meaning of the parameters, if in fact	# (at most two at this point. The meaning of the parameters, if in fact
Line 649 sub AdjustOurHost {	Line 650 sub AdjustOurHost {
# editor - Editor containing the file.	# editor - Editor containing the file.
#	#
sub ReplaceConfigFile {	sub ReplaceConfigFile {
my $filename = shift;
my $editor = shift;	my ($filename, $editor) = @_;

CopyFile ($filename, $filename.".old");	CopyFile ($filename, $filename.".old");

Line 749 sub catchexception {	Line 750 sub catchexception {
$SIG{'QUIT'}='DEFAULT';	$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&status("Catching exception");	&status("Catching exception");
&logthis("<font color=red>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $thisserver died through "	."ABNORMAL EXIT. Child $$ for server $thisserver died through "
."a crash with this error msg->[$error]</font>");	."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);	&logthis('Famous last words: '.$status.' - '.$lastlog);
Line 760 sub catchexception {	Line 761 sub catchexception {

sub timeout {	sub timeout {
&status("Handling Timeout");	&status("Handling Timeout");
&logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");	&logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
&catchexception('Timeout');	&catchexception('Timeout');
}	}
# -------------------------------- Set signal handlers to record abnormal exits	# -------------------------------- Set signal handlers to record abnormal exits
Line 843 sub HUNTSMAN { # si	Line 844 sub HUNTSMAN { # si
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&logthis("<font color=red>CRITICAL: Shutting down</font>");	&logthis("<font color='red'>CRITICAL: Shutting down</font>");
&status("Done killing children");	&status("Done killing children");
exit; # clean up with dignity	exit; # clean up with dignity
}	}
Line 853 sub HUPSMAN { # sig	Line 854 sub HUPSMAN { # sig
&status("Killing children for restart (HUP)");	&status("Killing children for restart (HUP)");
kill 'INT' => keys %children;	kill 'INT' => keys %children;
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");	&logthis("<font color='red'>CRITICAL: Restarting</font>");
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&status("Restarting self (HUP)");	&status("Restarting self (HUP)");
Line 1015 sub Debug {	Line 1016 sub Debug {
# request - Original request from client.	# request - Original request from client.
#	#
sub Reply {	sub Reply {
my $fd = shift;
my $reply = shift;	my ($fd, $reply, $request) = @_;
my $request = shift;

print $fd $reply;	print $fd $reply;
Debug("Request was $request Reply was $reply");	Debug("Request was $request Reply was $reply");
Line 1095 sub reconlonc {	Line 1095 sub reconlonc {
kill USR1 => $loncpid;	kill USR1 => $loncpid;
} else {	} else {
&logthis(	&logthis(
"<font color=red>CRITICAL: "	"<font color='red'>CRITICAL: "
."lonc at pid $loncpid not responding, giving up</font>");	."lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');	&logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
}	}
}	}

Line 1203 my $execdir=$perlvar{'lonDaemons'};	Line 1203 my $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");	open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";	print PIDSAVE "$$\n";
close(PIDSAVE);	close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");	&logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');	&status('Starting');


Line 1340 sub make_new_child {	Line 1340 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: $clientip did not reply challenge</font>");	"<font color='blue'>WARNING: $clientip did not reply challenge</font>");
&status('No challenge reply '.$clientip);	&status('No challenge reply '.$clientip);
}	}
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: "	"<font color='blue'>WARNING: "
."$clientip failed to initialize: >$remotereq< </font>");	."$clientip failed to initialize: >$remotereq< </font>");
&status('No init '.$clientip);	&status('No init '.$clientip);
}	}
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: Unknown client $clientip</font>");	"<font color='blue'>WARNING: Unknown client $clientip</font>");
&status('Hung up on '.$clientip);	&status('Hung up on '.$clientip);
}	}
if ($clientok) {	if ($clientok) {
Line 1365 sub make_new_child {	Line 1365 sub make_new_child {
}	}
&reconlonc("$perlvar{'lonSockDir'}/$id");	&reconlonc("$perlvar{'lonSockDir'}/$id");
}	}
&logthis("<font color=green>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {	while (my $userinput=<$client>) {
Line 1562 sub make_new_child {	Line 1562 sub make_new_child {
$pwdcorrect=0;	$pwdcorrect=0;
# log error if it is not a bad password	# log error if it is not a bad password
if ($krb4_error != 62) {	if ($krb4_error != 62) {
&logthis('krb4:'.$uname.','.$contentpwd.','.	&logthis('krb4:'.$uname.','.
&Authen::Krb4::get_err_txt($Authen::Krb4::error));	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
}	}
}	}
Line 1872 sub make_new_child {	Line 1872 sub make_new_child {
} else {	} else {
Reply($client, "refused\n", $userinput);	Reply($client, "refused\n", $userinput);
}	}
	# --------------------------------------------------------- remove a user file
	} elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
	if(isClient) {
	my ($cmd,$fname)=split(/:/,$userinput);
	my ($udom,$uname,$ufile) = ($fname =~ m\|^([^/]+)/([^/]+)/(.+)$\|);
	&logthis("$udom - $uname - $ufile");
	if ($ufile =~m\|/\.\./\|) {
	# any files paths with /../ in them refuse
	# to deal with
	print $client "refused\n";
	} else {
	my $udir=propath($udom,$uname);
	if (-e $udir) {
	my $file=$udir.'/userfiles/'.$ufile;
	if (-e $file) {
	unlink($file);
	if (-e $file) {
	print $client "failed\n";
	} else {
	print $client "ok\n";
	}
	} else {
	print $client "not_found\n";
	}
	} else {
	print $client "not_home\n";
	}
	}
	} else {
	Reply($client, "refused\n", $userinput);
	}
# ------------------------------------------ authenticate access to a user file	# ------------------------------------------ authenticate access to a user file
} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only	} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
if(isClient) {	if(isClient) {
Line 1897 sub make_new_child {	Line 1928 sub make_new_child {
if(isClient) {	if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
if (-e $fname) {	if (-e $fname) {
print $client &unsub($client,$fname,$clientip);	print $client &unsub($fname,$clientip);
} else {	} else {
print $client "not_found\n";	print $client "not_found\n";
}	}
Line 2502 sub make_new_child {	Line 2533 sub make_new_child {
}	}
# ------------------------------------------------------------------- querysend	# ------------------------------------------------------------------- querysend
} elsif ($userinput =~ /^querysend/) {	} elsif ($userinput =~ /^querysend/) {
if(isClient) {	if (isClient) {
my ($cmd,$query,	my ($cmd,$query,
$arg1,$arg2,$arg3)=split(/\:/,$userinput);	$arg1,$arg2,$arg3)=split(/\:/,$userinput);
$query=~s/\n*$//g;	$query=~s/\n*$//g;
Line 2592 sub make_new_child {	Line 2623 sub make_new_child {
$qresult.=$key.'='.$descr.'&';	$qresult.=$key.'='.$descr.'&';
} else {	} else {
my $unescapeVal = &unescape($descr);	my $unescapeVal = &unescape($descr);
if (eval('$unescapeVal=~/$description/i')) {	if (eval('$unescapeVal=~/\Q$description\E/i')) {
$qresult.="$key=$descr&";	$qresult.="$key=$descr&";
}	}
}	}
Line 2747 sub make_new_child {	Line 2778 sub make_new_child {
Reply($client, "refused\n", $userinput);	Reply($client, "refused\n", $userinput);

}	}
	# ----------------------------------------------------------portfolio directory list (portls)
	} elsif ($userinput =~ /^portls/) {
	if(isClient) {
	my ($cmd,$uname,$udom)=split(/:/,$userinput);
	my $udir=propath($udom,$uname).'/userfiles/portfolio';
	my $dirLine='';
	my $dirContents='';
	if (opendir(LSDIR,$udir.'/')){
	while ($dirLine = readdir(LSDIR)){
	$dirContents = $dirContents.$dirLine.'<br />';
	}
	}else{
	$dirContents = "No directory found\n";
	}
	print $client $dirContents."\n";
	} else {
	Reply($client, "refused\n", $userinput);
	}

# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
if(isClient) {	if(isClient) {
Line 2833 sub make_new_child {	Line 2883 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
}	}
	#------------------------------- is auto-enrollment enabled?
	} elsif ($userinput =~/^autorun/) {
	if (isClient) {
	my $outcome = &localenroll::run();
	print $client "$outcome\n";
	} else {
	print $client "0\n";
	}
	#------------------------------- get official sections (for auto-enrollment).
	} elsif ($userinput =~/^autogetsections/) {
	if (isClient) {
	my ($cmd,$coursecode)=split(/:/,$userinput);
	my @secs = &localenroll::get_sections($coursecode);
	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,$course_id,$owner)=split(/:/,$userinput);
	my $outcome = &localenroll::new_course($course_id,$owner);
	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,$course_id)=split(/:/,$userinput);
	my $outcome=&localenroll::validate_courseID($course_id);
	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)=split(/:/,$userinput);
	my ($create_passwd,$authchk) = @_;
	($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam);
	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";
	}
# ------------------------------------------------------------- unknown command	# ------------------------------------------------------------- unknown command

} else {	} else {
Line 2847 sub make_new_child {	Line 2969 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
$client->close();	$client->close();
&logthis("<font color=blue>WARNING: "	&logthis("<font color='blue'>WARNING: "
."Rejected client $clientip, closing connection</font>");	."Rejected client $clientip, closing connection</font>");
}	}
}	}

# =============================================================================	# =============================================================================

&logthis("<font color=red>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."Disconnect from $clientip ($clientname)</font>");	."Disconnect from $clientip ($clientname)</font>");


Line 2879 sub make_new_child {	Line 3001 sub make_new_child {
#	#
sub ManagePermissions	sub ManagePermissions
{	{
my $request = shift;
my $domain = shift;	my ($request, $domain, $user, $authtype) = @_;
my $user = shift;
my $authtype= shift;

# 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 =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
Line 2899 sub ManagePermissions	Line 3019 sub ManagePermissions
#	#
sub GetAuthType	sub GetAuthType
{	{
my $domain = shift;
my $user = shift;	my ($domain, $user) = @_;

Debug("GetAuthType( $domain, $user ) \n");	Debug("GetAuthType( $domain, $user ) \n");
my $proname = &propath($domain, $user);	my $proname = &propath($domain, $user);
Line 3009 sub chatadd {	Line 3129 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;
}	}

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

Removed from v.1.186
changed lines
	Added in v.1.199