loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.163 and 1.193

version 1.163, 2003/11/17 09:32:17	version 1.193, 2004/06/08 22:09:44
Line 10	Line 10
#	#
# LON-CAPA is free software; you can redistribute it and/or modify	# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by	# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or	# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.	# (at your option) any later version.
#	#
# LON-CAPA is distributed in the hope that it will be useful,	# LON-CAPA is distributed in the hope that it will be useful,
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;

my $DEBUG = 0; # Non zero to enable debug log entries.	my $DEBUG = 0; # Non zero to enable debug log entries.

Line 162 sub ReadManagerTable {	Line 164 sub ReadManagerTable {

# Clean out the old table first..	# Clean out the old table first..

foreach my $key (keys %managers) {	foreach my $key (keys %managers) {
delete $managers{$key};	delete $managers{$key};
}	}

my $tablename = $perlvar{'lonTabDir'}."/managers.tab";	my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
if (!open (MANAGERS, $tablename)) {	if (!open (MANAGERS, $tablename)) {
logthis('<font color="red">No manager table. Nobody can manage!!</font>');	logthis('<font color="red">No manager table. Nobody can manage!!</font>');
return;	return;
}	}
while(my $host = <MANAGERS>) {	while(my $host = <MANAGERS>) {
chomp($host);	chomp($host);
if (!defined $hostip{$host}) { # This is a non cluster member	if ($host =~ "^#") { # Comment line.
	logthis('<font color="green"> Skipping line: '. "$host</font>\n");
	next;
	}
	if (!defined $hostip{$host}) { # This is a non cluster member
# The entry is of the form:	# The entry is of the form:
# cluname:hostname	# cluname:hostname
# cluname - A 'cluster hostname' is needed in order to negotiate	# cluname - A 'cluster hostname' is needed in order to negotiate
# the host key.	# the host key.
# hostname- The dns name of the host.	# hostname- The dns name of the host.
#	#
	my($cluname, $dnsname) = split(/:/, $host);
my($cluname, $dnsname) = split(/:/, $host);
open(MGRPIPE, "/usr/bin/host $dnsname \|") \|\| die "Can't make host pipeline";	my $ip = gethostbyname($dnsname);
my $dnsinfo = <MGRPIPE>;	if(defined($ip)) { # bad names don't deserve entry.
chomp $dnsinfo;	my $hostip = inet_ntoa($ip);
close MGRPIPE;	$managers{$hostip} = $cluname;
my($jname, $jhas, $jaddress, $hostip) = split(/ /, $dnsinfo);	logthis('<font color="green"> registering manager '.
$managers{$hostip} = $cluname;	"$dnsname as $cluname with $hostip </font>\n");
} else {	}
$managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber	} else {
}	logthis('<font color="green"> existing host'." $host</font>\n");
}	$managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber
	}
	}
}	}

#	#
Line 219 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 279 sub AdjustHostContents {	Line 286 sub AdjustHostContents {
my $adjusted;	my $adjusted;
my $me = $perlvar{'lonHostID'};	my $me = $perlvar{'lonHostID'};

foreach my $line (split(/\n/,$contents)) {	foreach my $line (split(/\n/,$contents)) {
if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {	if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {
chomp($line);	chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);	my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {	if ($id eq $me) {
open(PIPE, " /usr/bin/host $name \|") \|\| die "Cant' make host pipeline";	my $ip = gethostbyname($name);
my $hostinfo = <PIPE>;	my $ipnew = inet_ntoa($ip);
close PIPE;	$ip = $ipnew;

my ($hostname, $has, $address, $ipnew) = split(/ /,$hostinfo);
&logthis('<font color="green">'.
"hostname = $hostname me = $me, name = $name actual ip = $ipnew </font>");

if ($hostname eq $name) { # Lookup succeeded..
&logthis('<font color="green"> look up ok <font>');
$ip = $ipnew;
} else {
&logthis('<font color="green"> Lookup failed: '
.$hostname." ne $name </font>");
}
# Reconstruct the host line and append to adjusted:	# Reconstruct the host line and append to adjusted:

my $newline = "$id:$domain:$role:$name:$ip";	my $newline = "$id:$domain:$role:$name:$ip";
if($maxcon ne "") { # Not all hosts have loncnew tuning params	if($maxcon ne "") { # Not all hosts have loncnew tuning params
$newline .= ":$maxcon:$idleto:$mincon";	$newline .= ":$maxcon:$idleto:$mincon";
}	}
$adjusted .= $newline."\n";	$adjusted .= $newline."\n";

} else { # Not me, pass unmodified.	} else { # Not me, pass unmodified.
$adjusted .= $line."\n";	$adjusted .= $line."\n";
}	}
} else { # Blank or comment never re-written.	} else { # Blank or comment never re-written.
$adjusted .= $line."\n"; # Pass blanks and comments as is.	$adjusted .= $line."\n"; # Pass blanks and comments as is.
}	}
}	}
return $adjusted;	return $adjusted;
}	}
#	#
# InstallFile: Called to install an administrative file:	# InstallFile: Called to install an administrative file:
Line 332 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 356 sub InstallFile {	Line 351 sub InstallFile {

return 1;	return 1;
}	}
	#
	# ConfigFileFromSelector: converts a configuration file selector
	# (one of host or domain at this point) into a
	# configuration file pathname.
	#
	# Parameters:
	# selector - Configuration file selector.
	# Returns:
	# Full path to the file or undef if the selector is invalid.
	#
	sub ConfigFileFromSelector {
	my $selector = shift;
	my $tablefile;

	my $tabledir = $perlvar{'lonTabDir'}.'/';
	if ($selector eq "hosts") {
	$tablefile = $tabledir."hosts.tab";
	} elsif ($selector eq "domain") {
	$tablefile = $tabledir."domain.tab";
	} else {
	return undef;
	}
	return $tablefile;

	}
#	#
# PushFile: Called to do an administrative push of a file.	# PushFile: Called to do an administrative push of a file.
# - Ensure the file being pushed is one we support.	# - Ensure the file being pushed is one we support.
Line 386 sub PushFile {	Line 405 sub PushFile {
# part of some elaborate spoof that managed somehow to authenticate.	# part of some elaborate spoof that managed somehow to authenticate.
#	#

my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.
if ($filename eq "host") {	my $tablefile = ConfigFileFromSelector($filename);
$tablefile .= "hosts.tab";	if(! (defined $tablefile)) {
} elsif ($filename eq "domain") {
$tablefile .= "domain.tab";
} else {
return "refused";	return "refused";
}	}
#	#
Line 483 sub ReinitProcess {	Line 499 sub ReinitProcess {
}	}
return 'ok';	return 'ok';
}	}
	# Validate a line in a configuration file edit script:
	# Validation includes:
	# - Ensuring the command is valid.
	# - Ensuring the command has sufficient parameters
	# Parameters:
	# scriptline - A line to validate (\n has been stripped for what it's worth).
	#
	# Return:
	# 0 - Invalid scriptline.
	# 1 - Valid scriptline
	# NOTE:
	# Only the command syntax is checked, not the executability of the
	# command.
	#
	sub isValidEditCommand {
	my $scriptline = shift;

	# Line elements are pipe separated:

	my ($command, $key, $newline) = split(/\\|/, $scriptline);
	&logthis('<font color="green"> isValideditCommand checking: '.
	"Command = '$command', Key = '$key', Newline = '$newline' </font>\n");

	if ($command eq "delete") {
	#
	# key with no newline.
	#
	if( ($key eq "") \|\| ($newline ne "")) {
	return 0; # Must have key but no newline.
	} else {
	return 1; # Valid syntax.
	}
	} elsif ($command eq "replace") {
	#
	# key and newline:
	#
	if (($key eq "") \|\| ($newline eq "")) {
	return 0;
	} else {
	return 1;
	}
	} elsif ($command eq "append") {
	if (($key ne "") && ($newline eq "")) {
	return 1;
	} else {
	return 0;
	}
	} else {
	return 0; # Invalid command.
	}
	return 0; # Should not get here!!!
	}
	#
	# ApplyEdit - Applies an edit command to a line in a configuration
	# file. It is the caller's responsiblity to validate the
	# edit line.
	# Parameters:
	# $directive - A single edit directive to apply.
	# Edit directives are of the form:
	# append\|newline - Appends a new line to the file.
	# replace\|key\|newline - Replaces the line with key value 'key'
	# delete\|key - Deletes the line with key value 'key'.
	# $editor - A config file editor object that contains the
	# file being edited.
	#
	sub ApplyEdit {

	my ($directive, $editor) = @_;

	# Break the directive down into its command and its parameters
	# (at most two at this point. The meaning of the parameters, if in fact
	# they exist depends on the command).

	my ($command, $p1, $p2) = split(/\\|/, $directive);

	if($command eq "append") {
	$editor->Append($p1); # p1 - key p2 null.
	} elsif ($command eq "replace") {
	$editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline.
	} elsif ($command eq "delete") {
	$editor->DeleteLine($p1); # p1 - key p2 null.
	} else { # Should not get here!!!
	die "Invalid command given to ApplyEdit $command"
	}
	}
	#
	# AdjustOurHost:
	# Adjusts a host file stored in a configuration file editor object
	# for the true IP address of this host. This is necessary for hosts
	# that live behind a firewall.
	# Those hosts have a publicly distributed IP of the firewall, but
	# internally must use their actual IP. We assume that a given
	# host only has a single IP interface for now.
	# Formal Parameters:
	# editor - The configuration file editor to adjust. This
	# editor is assumed to contain a hosts.tab file.
	# Strategy:
	# - Figure out our hostname.
	# - Lookup the entry for this host.
	# - Modify the line to contain our IP
	# - Do a replace for this host.
	sub AdjustOurHost {
	my $editor = shift;

	# figure out who I am.

	my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname.

	# Get my host file entry.

	my $ConfigLine = $editor->Find($myHostName);
	if(! (defined $ConfigLine)) {
	die "AdjustOurHost - no entry for me in hosts file $myHostName";
	}
	# figure out my IP:
	# Use the config line to get my hostname.
	# Use gethostbyname to translate that into an IP address.
	#
	my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
	my $BinaryIp = gethostbyname($name);
	my $ip = inet_ntoa($ip);
	#
	# Reassemble the config line from the elements in the list.
	# Note that if the loncnew items were not present before, they will
	# be now even if they would be empty
	#
	my $newConfigLine = $id;
	foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
	$newConfigLine .= ":".$item;
	}
	# Replace the line:

	$editor->ReplaceLine($id, $newConfigLine);

	}
	#
	# ReplaceConfigFile:
	# Replaces a configuration file with the contents of a
	# configuration file editor object.
	# This is done by:
	# - Copying the target file to <filename>.old
	# - Writing the new file to <filename>.tmp
	# - Moving <filename.tmp> -> <filename>
	# This laborious process ensures that the system is never without
	# a configuration file that's at least valid (even if the contents
	# may be dated).
	# Parameters:
	# filename - Name of the file to modify... this is a full path.
	# editor - Editor containing the file.
	#
	sub ReplaceConfigFile {

	my ($filename, $editor) = @_;

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

	my $contents = $editor->Get(); # Get the contents of the file.

	InstallFile($filename, $contents);
	}
	#
	#
	# Called to edit a configuration table file
	# Parameters:
	# request - The entire command/request sent by lonc or lonManage
	# Return:
	# The reply to send to the client.
	#
	sub EditFile {
	my $request = shift;

	# Split the command into it's pieces: edit:filetype:script

	my ($request, $filetype, $script) = split(/:/, $request,3); # : in script

	# Check the pre-coditions for success:

	if($request != "edit") { # Something is amiss afoot alack.
	return "error:edit request detected, but request != 'edit'\n";
	}
	if( ($filetype ne "hosts") &&
	($filetype ne "domain")) {
	return "error:edit requested with invalid file specifier: $filetype \n";
	}

	# Split the edit script and check it's validity.

	my @scriptlines = split(/\n/, $script); # one line per element.
	my $linecount = scalar(@scriptlines);
	for(my $i = 0; $i < $linecount; $i++) {
	chomp($scriptlines[$i]);
	if(!isValidEditCommand($scriptlines[$i])) {
	return "error:edit with bad script line: '$scriptlines[$i]' \n";
	}
	}

	# Execute the edit operation.
	# - Create a config file editor for the appropriate file and
	# - execute each command in the script:
	#
	my $configfile = ConfigFileFromSelector($filetype);
	if (!(defined $configfile)) {
	return "refused\n";
	}
	my $editor = ConfigFileEdit->new($configfile);

	for (my $i = 0; $i < $linecount; $i++) {
	ApplyEdit($scriptlines[$i], $editor);
	}
	# If the file is the host file, ensure that our host is
	# adjusted to have our ip:
	#
	if($filetype eq "host") {
	AdjustOurHost($editor);
	}
	# Finally replace the current file with our file.
	#
	ReplaceConfigFile($configfile, $editor);

	return "ok\n";
	}
#	#
# Convert an error return code from lcpasswd to a string value.	# Convert an error return code from lcpasswd to a string value.
#	#
Line 513 sub catchexception {	Line 749 sub catchexception {
my ($error)=@_;	my ($error)=@_;
$SIG{'QUIT'}='DEFAULT';	$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&logthis("<font color=red>CRITICAL: "	&status("Catching exception");
	&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 523 sub catchexception {	Line 760 sub catchexception {
}	}

sub timeout {	sub timeout {
&logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");	&status("Handling Timeout");
	&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 575 $server = IO::Socket::INET->new(LocalPor	Line 813 $server = IO::Socket::INET->new(LocalPor
# global variables	# global variables

my %children = (); # keys are current child process IDs	my %children = (); # keys are current child process IDs
my $children = 0; # current number of children

sub REAPER { # takes care of dead children	sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;	$SIG{CHLD} = \&REAPER;
my $pid = wait;	&status("Handling child death");
if (defined($children{$pid})) {	my $pid;
&logthis("Child $pid died");	do {
$children --;	$pid = waitpid(-1,&WNOHANG());
delete $children{$pid};	if (defined($children{$pid})) {
} else {	&logthis("Child $pid died");
&logthis("Unknown Child $pid died");	delete($children{$pid});
	} elsif ($pid > 0) {
	&logthis("Unknown Child $pid died");
	}
	} while ( $pid > 0 );
	foreach my $child (keys(%children)) {
	$pid = waitpid($child,&WNOHANG());
	if ($pid > 0) {
	&logthis("Child $child - $pid looks like we missed it's death");
	delete($children{$pid});
	}
}	}
	&status("Finished Handling child death");
}	}

sub HUNTSMAN { # signal handler for SIGINT	sub HUNTSMAN { # signal handler for SIGINT
	&status("Killing children (INT)");
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children	local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
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
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");
exit; # clean up with dignity	exit; # clean up with dignity
}	}

sub HUPSMAN { # signal handler for SIGHUP	sub HUPSMAN { # signal handler for SIGHUP
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children	local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
	&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)");
exec("$execdir/lond"); # here we go again	exec("$execdir/lond"); # here we go again
}	}

Line 636 sub ReadHostTable {	Line 888 sub ReadHostTable {
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";	open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";

while (my $configline=<CONFIG>) {	while (my $configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	if (!($configline =~ /^\s*\#/)) {
chomp($ip); $ip=~s/\D+$//;	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
$hostid{$ip}=$id;	chomp($ip); $ip=~s/\D+$//;
$hostdom{$id}=$domain;	$hostid{$ip}=$id;
$hostip{$id}=$ip;	$hostdom{$id}=$domain;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }	$hostip{$id}=$ip;
	if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
	}
}	}
close(CONFIG);	close(CONFIG);
}	}
Line 667 sub ReloadApache {	Line 921 sub ReloadApache {
# now be honored.	# now be honored.
#	#
sub UpdateHosts {	sub UpdateHosts {
	&status("Reload hosts.tab");
logthis('<font color="blue"> Updating connections </font>');	logthis('<font color="blue"> Updating connections </font>');
#	#
# The %children hash has the set of IP's we currently have children	# The %children hash has the set of IP's we currently have children
Line 691 sub UpdateHosts {	Line 946 sub UpdateHosts {
}	}
}	}
ReloadApache;	ReloadApache;
	&status("Finished reloading hosts.tab");
}	}


sub checkchildren {	sub checkchildren {
	&status("Checking on the children (sending signals)");
&initnewstatus();	&initnewstatus();
&logstatus();	&logstatus();
&logthis('Going to check on the children');	&logthis('Going to check on the children');
Line 709 sub checkchildren {	Line 966 sub checkchildren {
sleep 5;	sleep 5;
$SIG{ALRM} = sub { die "timeout" };	$SIG{ALRM} = sub { die "timeout" };
$SIG{__DIE__} = 'DEFAULT';	$SIG{__DIE__} = 'DEFAULT';
	&status("Checking on the children (waiting for reports)");
foreach (sort keys %children) {	foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {	unless (-e "$docdir/lon-status/londchld/$_.txt") {
eval {	eval {
Line 726 sub checkchildren {	Line 984 sub checkchildren {
}	}
$SIG{ALRM} = 'DEFAULT';	$SIG{ALRM} = 'DEFAULT';
$SIG{__DIE__} = \&catchexception;	$SIG{__DIE__} = \&catchexception;
	&status("Finished checking children");
}	}

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
Line 757 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 768 sub Reply {	Line 1026 sub Reply {
# ------------------------------------------------------------------ Log status	# ------------------------------------------------------------------ Log status

sub logstatus {	sub logstatus {
	&status("Doing logging");
my $docdir=$perlvar{'lonDocRoot'};	my $docdir=$perlvar{'lonDocRoot'};
{	{
my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");	my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";	print $fh $$."\t".$clientname."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
$fh->close();	$fh->close();
}	}
	&status("Finished londstatus.txt");
{	{
my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");	my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
print $fh $status."\n".$lastlog."\n".time;	print $fh $status."\n".$lastlog."\n".time;
$fh->close();	$fh->close();
}	}
	&status("Finished logging");
}	}

sub initnewstatus {	sub initnewstatus {
Line 834 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 942 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 966 ReadHostTable;	Line 1227 ReadHostTable;
# along the connection.	# along the connection.

while (1) {	while (1) {
	&status('Starting accept');
$client = $server->accept() or next;	$client = $server->accept() or next;
	&status('Accepted '.$client.' off to spawn');
make_new_child($client);	make_new_child($client);
	&status('Finished spawning');
}	}

sub make_new_child {	sub make_new_child {
Line 976 sub make_new_child {	Line 1240 sub make_new_child {
my $sigset;	my $sigset;

$client = shift;	$client = shift;
	&status('Starting new child '.$client);
&logthis('<font color="green"> Attempting to start child ('.$client.	&logthis('<font color="green"> Attempting to start child ('.$client.
")</font>");	")</font>");
# block signal for fork	# block signal for fork
Line 993 sub make_new_child {	Line 1258 sub make_new_child {
# the pid hash.	# the pid hash.
#	#
my $caller = getpeername($client);	my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);	my ($port,$iaddr);
$clientip=inet_ntoa($iaddr);	if (defined($caller) && length($caller) > 0) {
	($port,$iaddr)=unpack_sockaddr_in($caller);
	} else {
	&logthis("Unable to determine who caller was, getpeername returned nothing");
	}
	if (defined($iaddr)) {
	$clientip=inet_ntoa($iaddr);
	} else {
	&logthis("Unable to determine clinetip");
	$clientip='Unavailable';
	}

if ($pid) {	if ($pid) {
# Parent records the child's birth and returns.	# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)	sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;	$children{$pid} = $clientip;
$children++;
&status('Started child '.$pid);	&status('Started child '.$pid);
return;	return;
} else {	} else {
Line 1066 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 1091 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 1204 sub make_new_child {	Line 1478 sub make_new_child {
}	}
#--------------------------------------------------------------------- reinit	#--------------------------------------------------------------------- reinit
} elsif($userinput =~ /^reinit/) { # Encoded and manager	} elsif($userinput =~ /^reinit/) { # Encoded and manager
if (($wasenc == 1) && isManager) {	if (($wasenc == 1) && isManager) {
my $cert = GetCertificate($userinput);	my $cert = GetCertificate($userinput);
if(ValidManager($cert)) {	if(ValidManager($cert)) {
chomp($userinput);	chomp($userinput);
my $reply = ReinitProcess($userinput);	my $reply = ReinitProcess($userinput);
print $client "$reply\n";	print $client "$reply\n";
	} else {
	print $client "refused\n";
	}
} else {	} else {
print $client "refused\n";	Reply($client, "refused\n", $userinput);
}	}
} else {	#------------------------------------------------------------------------- edit
Reply($client, "refused\n", $userinput);	} elsif ($userinput =~ /^edit/) { # encoded and manager:
	if(($wasenc ==1) && (isManager)) {
	my $cert = GetCertificate($userinput);
}	if(ValidManager($cert)) {
	my($command, $filetype, $script) = split(/:/, $userinput);
	if (($filetype eq "hosts") \|\| ($filetype eq "domain")) {
	if($script ne "") {
	Reply($client, EditFile($userinput));
	} else {
	Reply($client,"refused\n",$userinput);
	}
	} else {
	Reply($client,"refused\n",$userinput);
	}
	} else {
	Reply($client,"refused\n",$userinput);
	}
	} else {
	Reply($client,"refused\n",$userinput);
	}
# ------------------------------------------------------------------------ auth	# ------------------------------------------------------------------------ auth
} elsif ($userinput =~ /^auth/) { # Encoded and client only.	} elsif ($userinput =~ /^auth/) { # Encoded and client only.
if (($wasenc==1) && isClient) {	if (($wasenc==1) && isClient) {
my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);	my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
chomp($upass);	chomp($upass);
Line 1269 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 1419 sub make_new_child {	Line 1712 sub make_new_child {
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)	$fperror="error: ".($!+0)
." mkdir failed while attempting "	." mkdir failed while attempting "
."makeuser\n";	."makeuser";
}	}
}	}
}	}
Line 1535 sub make_new_child {	Line 1828 sub make_new_child {
} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.	} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
if(isClient) {	if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
my ($udom,$uname,$ufile)=split(/\//,$fname);	my ($udom,$uname,$ufile) = ($fname =~ m\|^([^/]+)/([^/]+)/(.+)$\|);
my $udir=propath($udom,$uname).'/userfiles';	my $udir=propath($udom,$uname).'/userfiles';
unless (-e $udir) { mkdir($udir,0770); }	unless (-e $udir) { mkdir($udir,0770); }
if (-e $udir) {	if (-e $udir) {
$ufile=~s/^[\.\~]+//;	$ufile=~s/^[\.\~]+//;
$ufile=~s/\///g;	my $path = $udir;
	if ($ufile =~m\|(.+)/([^/]+)$\|) {
	my @parts=split('/',$1);
	foreach my $part (@parts) {
	$path .= '/'.$part;
	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 1569 sub make_new_child {	Line 1871 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
Line 1580 sub make_new_child {	Line 1912 sub make_new_child {
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {	$session.'.id')) {
while (my $line=<ENVIN>) {	while (my $line=<ENVIN>) {
if ($line=~/userfile\.$fname\=/) { $reply='ok'; }	if ($line=~ m\|userfile\.\Q$fname\E\=\|) { $reply='ok'; }
}	}
close(ENVIN);	close(ENVIN);
print $client $reply."\n";	print $client $reply."\n";
Line 1596 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 1723 sub make_new_child {	Line 2055 sub make_new_child {
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) failed ".	." untie(GDBM) failed ".
"while attempting put\n";	"while attempting inc\n";
}	}
} else {	} else {
print $client "error: ".($!)	print $client "error: ".($!)
." tie(GDBM) Failed ".	." tie(GDBM) Failed ".
"while attempting put\n";	"while attempting inc\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 2054 sub make_new_child {	Line 2386 sub make_new_child {
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);
while (my ($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
Line 2202 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 2292 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 2450 sub make_new_child {	Line 2781 sub make_new_child {
# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
if(isClient) {	if(isClient) {
	my $obs;
	my $rights;
my ($cmd,$ulsdir)=split(/:/,$userinput);	my ($cmd,$ulsdir)=split(/:/,$userinput);
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
Line 2457 sub make_new_child {	Line 2790 sub make_new_child {
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;
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
$ulsout.=$ulsfn.'&'.	#We do some obsolete checking here
join('&',@ulsstats).':';	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; }
	}
	}
	$ulsout.=$ulsfn.'&'.join('&',@ulsstats);
	if($obs eq '1') { $ulsout.="&1"; }
	else { $ulsout.="&0"; }
	if($rights eq '1') { $ulsout.="&1:"; }
	else { $ulsout.="&0:"; }
}	}
closedir(LSDIR);	closedir(LSDIR);
}	}
Line 2500 sub make_new_child {	Line 2846 sub make_new_child {
&logthis(	&logthis(
"Client $clientip ($clientname) hanging up: $userinput");	"Client $clientip ($clientname) hanging up: $userinput");
print $client "bye\n";	print $client "bye\n";
	$client->shutdown(2); # shutdown the socket forcibly.
$client->close();	$client->close();
last;	last;

Line 2517 sub make_new_child {	Line 2864 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 2531 sub make_new_child {	Line 2950 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 2563 sub make_new_child {	Line 2982 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
&logthis("ruequest 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 2584 sub ManagePermissions	Line 3000 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 2694 sub chatadd {	Line 3110 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 2826 sub make_passwd_file {	Line 3261 sub make_passwd_file {
}	}
} elsif ($umode eq 'unix') {	} elsif ($umode eq 'unix') {
{	{
	#
	# Don't allow the creation of privileged accounts!!! that would
	# be real bad!!!
	#
	my $uid = getpwnam($uname);
	if((defined $uid) && ($uid == 0)) {
	&logthis(">>>Attempted to create privilged account blocked");
	return "no_priv_account_error\n";
	}

my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";	my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
{	{
&Debug("Executing external: ".$execpath);	&Debug("Executing external: ".$execpath);

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

Removed from v.1.163
changed lines
	Added in v.1.193