loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.166 and 1.192

version 1.166, 2003/12/22 11:03:37	version 1.192, 2004/06/01 09:58:30
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 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 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 224 sub ValidManager {	Line 225 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 325 sub AdjustHostContents {	Line 326 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 349 sub InstallFile {	Line 350 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 379 sub PushFile {	Line 404 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 476 sub ReinitProcess {	Line 498 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 507 sub catchexception {	Line 749 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 518 sub catchexception {	Line 760 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 570 $server = IO::Socket::INET->new(LocalPor	Line 812 $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;
&status("Handling child death");	&status("Handling child death");
my $pid = wait;	my $pid;
if (defined($children{$pid})) {	do {
&logthis("Child $pid died");	$pid = waitpid(-1,&WNOHANG());
$children --;	if (defined($children{$pid})) {
delete $children{$pid};	&logthis("Child $pid died");
} else {	delete($children{$pid});
&logthis("Unknown Child $pid died");	} 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");	&status("Finished Handling child death");
}	}
Line 593 sub HUNTSMAN { # si	Line 843 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 603 sub HUPSMAN { # sig	Line 853 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 637 sub ReadHostTable {	Line 887 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 763 sub Debug {	Line 1015 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 778 sub logstatus {	Line 1029 sub logstatus {
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");	&status("Finished londstatus.txt");
Line 843 sub reconlonc {	Line 1094 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 951 my $execdir=$perlvar{'lonDaemons'};	Line 1202 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 1006 sub make_new_child {	Line 1257 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 1079 sub make_new_child {	Line 1339 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 1104 sub make_new_child {	Line 1364 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 1237 sub make_new_child {	Line 1497 sub make_new_child {
my($command, $filetype, $script) = split(/:/, $userinput);	my($command, $filetype, $script) = split(/:/, $userinput);
if (($filetype eq "hosts") \|\| ($filetype eq "domain")) {	if (($filetype eq "hosts") \|\| ($filetype eq "domain")) {
if($script ne "") {	if($script ne "") {
Reply($client,"ok\n",$userinput); # DEBUG: Call EditFile here.	Reply($client, EditFile($userinput));
} else {	} else {
Reply($client,"refused\n",$userinput);	Reply($client,"refused\n",$userinput);
}	}
Line 1301 sub make_new_child {	Line 1561 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 1451 sub make_new_child {	Line 1711 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 1567 sub make_new_child {	Line 1827 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 1601 sub make_new_child {	Line 1870 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 1612 sub make_new_child {	Line 1911 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 1628 sub make_new_child {	Line 1927 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 1755 sub make_new_child {	Line 2054 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 2086 sub make_new_child {	Line 2385 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 2324 sub make_new_child {	Line 2622 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 2482 sub make_new_child {	Line 2780 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 2489 sub make_new_child {	Line 2789 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 2564 sub make_new_child {	Line 2877 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 2596 sub make_new_child {	Line 2909 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 2617 sub ManagePermissions	Line 2927 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 2727 sub chatadd {	Line 3037 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 2859 sub make_passwd_file {	Line 3188 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.166
changed lines
	Added in v.1.192