loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.131 and 1.142

version 1.131, 2003/06/16 14:23:56	version 1.142, 2003/09/09 20:47:46
Line 50	Line 50
# population). Since the time averaged connection rate is close to zero	# population). Since the time averaged connection rate is close to zero
# because lonc's purpose is to maintain near continuous connnections,	# because lonc's purpose is to maintain near continuous connnections,
# preforking is not really needed.	# preforking is not really needed.
###	# 08/xx/2003 Ron Fox: Add management requests. Management requests
	# will be validated via a call to ValidateManager. At present, this
	# is done by simple host verification. In the future we can modify
	# this function to do a certificate check.
	# Management functions supported include:
	# - pushing /home/httpd/lonTabs/hosts.tab
	# - pushing /home/httpd/lonTabs/domain.tab
	# 09/08/2003 Ron Fox: Told lond to take care of change logging so we
	# don't have to remember it:
	# $Log$
	# Revision 1.142 2003/09/09 20:47:46 www
	# Permanently store chatroom entries in chatroom.log
	#
	# Revision 1.141 2003/09/08 10:32:07 foxr
	# Added PushFile sub This sub oversees the push of a new configuration table file
	# Currently supported files are:
	# - hosts.tab (transaction pushfile:hosts:contents)
	# - domain.tab (transaction pushfile:domain:contents)
	#


	use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;	use LONCAPA::Configuration;

Line 77 my $VERSION='$Revision$'; #' stupid emac	Line 97 my $VERSION='$Revision$'; #' stupid emac
my $remoteVERSION;	my $remoteVERSION;
my $currenthostid;	my $currenthostid;
my $currentdomainid;	my $currentdomainid;

	my $client;
	my $clientip;

	my $server;
	my $thisserver;

	my %hostid;
	my %hostdom;
	my %hostip;
	my %perlvar; # Will have the apache conf defined perl vars.

#	#
# The array below are password error strings."	# The array below are password error strings."
#	#
Line 116 my @adderrors = ("ok",	Line 148 my @adderrors = ("ok",


#	#
	# GetCertificate: Given a transaction that requires a certificate,
	# this function will extract the certificate from the transaction
	# request. Note that at this point, the only concept of a certificate
	# is the hostname to which we are connected.
	#
	# Parameter:
	# request - The request sent by our client (this parameterization may
	# need to change when we really use a certificate granting
	# authority.
	#
	sub GetCertificate {
	my $request = shift;

	return $clientip;
	}


	#
	# ValidManager: Determines if a given certificate represents a valid manager.
	# in this primitive implementation, the 'certificate' is
	# just the connecting loncapa client name. This is checked
	# against a valid client list in the configuration.
	#
	#
	sub ValidManager {
	my $certificate = shift;

	my $hostentry = $hostid{$certificate};
	if ($hostentry ne undef) {
	&logthis('<font color="yellow">Authenticating manager'.
	" $hostentry</font>");
	return 1;
	} else {
	&logthis('<font color="red"> Failed manager authentication '.
	"$certificate </font>");
	}
	}
	#
	# PushFile: Called to do an administrative push of a file.
	# - Ensure the file being pushed is one we support.
	# - Backup the old file to <filename.saved>
	# - Separate the contents of the new file out from the
	# rest of the request.
	# - Write the new file.
	# Parameter:
	# Request - The entire user request. This consists of a : separated
	# string pushfile:tablename:contents.
	# NOTE: The contents may have :'s in it as well making things a bit
	# more interesting... but not much.
	# Returns:
	# String to send to client ("ok" or "refused" if bad file).
	#
	sub PushFile {
	my $request = shift;
	my ($command, $filename, $contents) = split(":", $request, 3);

	# At this point in time, pushes for only the following tables are
	# supported:
	# hosts.tab ($filename eq host).
	# domain.tab ($filename eq domain).
	# Construct the destination filename or reject the request.
	#
	# lonManage is supposed to ensure this, however this session could be
	# part of some elaborate spoof that managed somehow to authenticate.
	#

	my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.
	if ($filename eq "host") {
	$tablefile .= "hosts.tab";
	} elsif ($filename eq "domain") {
	$tablefile .= "domain.tab";
	} else {
	return "refused";
	}
	#
	# >copy< the old table to the backup table
	# don't rename in case system crashes/reboots etc. in the time
	# window between a rename and write.
	#
	my $backupfile = $tablefile;
	$backupfile =~ s/\.tab$/.old/;
	# CopyFile($tablefile, $backupfile);
	&logthis('<font color="green"> Pushfile: backed up '
	.$tablefile." to $backupfile</font>");

	# Install the new file:

	# InstallFile($tablefile, $contents);

	# Indicate success:

	return "ok";

	}
	#
# Convert an error return code from lcpasswd to a string value.	# Convert an error return code from lcpasswd to a string value.
#	#
sub lcpasswdstrerror {	sub lcpasswdstrerror {
Line 145 sub catchexception {	Line 272 sub catchexception {
$SIG{'QUIT'}='DEFAULT';	$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&logthis("<font color=red>CRITICAL: "	&logthis("<font color=red>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $wasserver 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);
if ($client) { print $client "error: $error\n"; }	if ($client) { print $client "error: $error\n"; }
Line 165 $SIG{__DIE__}=\&catchexception;	Line 292 $SIG{__DIE__}=\&catchexception;
# ---------------------------------- Read loncapa_apache.conf and loncapa.conf	# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
&status("Read loncapa.conf and loncapa_apache.conf");	&status("Read loncapa.conf and loncapa_apache.conf");
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');	my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
my %perlvar=%{$perlvarref};	%perlvar=%{$perlvarref};
undef $perlvarref;	undef $perlvarref;

# ----------------------------- Make sure this process is running from user=www	# ----------------------------- Make sure this process is running from user=www
my $wwwid=getpwnam('www');	my $wwwid=getpwnam('www');
if ($wwwid!=$<) {	if ($wwwid!=$<) {
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";	my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $currenthostid User ID mismatch";	my $subj="LON: $currenthostid User ID mismatch";
system("echo 'User ID mismatch. lond must be run as user www.' \|\	system("echo 'User ID mismatch. lond must be run as user www.' \|\
mailto $emailto -s '$subj' > /dev/null");	mailto $emailto -s '$subj' > /dev/null");
exit 1;	exit 1;
Line 189 if (-e $pidfile) {	Line 316 if (-e $pidfile) {
if (kill 0 => $pide) { die "already running"; }	if (kill 0 => $pide) { die "already running"; }
}	}

$PREFORK=4; # number of children to maintain, at least four spare

# ------------------------------------------------------------- Read hosts file	# ------------------------------------------------------------- Read hosts file

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 ($configline=<CONFIG>) {	while (my $configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
chomp($ip); $ip=~s/\D+$//;	chomp($ip); $ip=~s/\D+$//;
$hostid{$ip}=$id;	$hostid{$ip}=$id;
$hostdom{$id}=$domain;	$hostdom{$id}=$domain;
$hostip{$id}=$ip;	$hostip{$id}=$ip;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }	if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
$PREFORK++;
}	}
close(CONFIG);	close(CONFIG);

Line 218 $server = IO::Socket::INET->new(LocalPor	Line 342 $server = IO::Socket::INET->new(LocalPor

# global variables	# global variables

$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should	my %children = (); # keys are current child process IDs
# process	my $children = 0; # current number of children
%children = (); # keys are current child process IDs
$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;
Line 250 sub HUPSMAN { # sig	Line 372 sub HUPSMAN { # sig
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>");
unlink("$execdir/logs/lond.pid");
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
	unlink("$execdir/logs/lond.pid");
exec("$execdir/lond"); # here we go again	exec("$execdir/lond"); # here we go again
}	}

Line 259 sub checkchildren {	Line 381 sub checkchildren {
&initnewstatus();	&initnewstatus();
&logstatus();	&logstatus();
&logthis('Going to check on the children');	&logthis('Going to check on the children');
$docdir=$perlvar{'lonDocRoot'};	my $docdir=$perlvar{'lonDocRoot'};
foreach (sort keys %children) {	foreach (sort keys %children) {
sleep 1;	sleep 1;
unless (kill 'USR1' => $_) {	unless (kill 'USR1' => $_) {
Line 331 sub initnewstatus {	Line 453 sub initnewstatus {
my $local=localtime($now);	my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";	print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");	opendir(DIR,"$docdir/lon-status/londchld");
while ($filename=readdir(DIR)) {	while (my $filename=readdir(DIR)) {
unlink("$docdir/lon-status/londchld/$filename");	unlink("$docdir/lon-status/londchld/$filename");
}	}
closedir(DIR);	closedir(DIR);
Line 473 sub ishome {	Line 595 sub ishome {
# ======================================================= Continue main program	# ======================================================= Continue main program
# ---------------------------------------------------- Fork once and dissociate	# ---------------------------------------------------- Fork once and dissociate

$fpid=fork;	my $fpid=fork;
exit if $fpid;	exit if $fpid;
die "Couldn't fork: $!" unless defined ($fpid);	die "Couldn't fork: $!" unless defined ($fpid);

Line 481 POSIX::setsid() or die "Can't start new	Line 603 POSIX::setsid() or die "Can't start new

# ------------------------------------------------------- Write our PID on disk	# ------------------------------------------------------- Write our PID on disk

$execdir=$perlvar{'lonDaemons'};	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);
Line 511 while (1) {	Line 633 while (1) {
}	}

sub make_new_child {	sub make_new_child {
my $client;
my $pid;	my $pid;
my $cipher;	my $cipher;
my $sigset;	my $sigset;
Line 522 sub make_new_child {	Line 643 sub make_new_child {
$sigset = POSIX::SigSet->new(SIGINT);	$sigset = POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset)	sigprocmask(SIG_BLOCK, $sigset)
or die "Can't block SIGINT for fork: $!\n";	or die "Can't block SIGINT for fork: $!\n";

die "fork: $!" unless defined ($pid = fork);	die "fork: $!" unless defined ($pid = fork);

if ($pid) {	if ($pid) {
Line 547 sub make_new_child {	Line 668 sub make_new_child {
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";

$tmpsnum=0;	my $tmpsnum=0;
#---------------------------------------------------- kerberos 5 initialization	#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
Line 561 sub make_new_child {	Line 682 sub make_new_child {
# see if we know client and check for spoof IP by challenge	# see if we know client and check for spoof IP by challenge
my $caller = getpeername($client);	my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);	my ($port,$iaddr)=unpack_sockaddr_in($caller);
my $clientip=inet_ntoa($iaddr);	$clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);	my $clientrec=($hostid{$clientip} ne undef);
&logthis(	&logthis(
"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"	"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
Line 640 sub make_new_child {	Line 761 sub make_new_child {
if ($userinput =~ /^ping/) {	if ($userinput =~ /^ping/) {
print $client "$currenthostid\n";	print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong	# ------------------------------------------------------------------------ pong
} elsif ($userinput =~ /^pong/) {	}elsif ($userinput =~ /^pong/) {
$reply=reply("ping",$hostid{$clientip});	my $reply=&reply("ping",$hostid{$clientip});
print $client "$currenthostid:$reply\n";	print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey	# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {	} elsif ($userinput =~ /^ekey/) {
Line 671 sub make_new_child {	Line 792 sub make_new_child {
} elsif ($userinput =~ /^userload/) {	} elsif ($userinput =~ /^userload/) {
my $userloadpercent=&userload();	my $userloadpercent=&userload();
print $client "$userloadpercent\n";	print $client "$userloadpercent\n";

	#
	# Transactions requiring encryption:
	#
# ----------------------------------------------------------------- currentauth	# ----------------------------------------------------------------- currentauth
} elsif ($userinput =~ /^currentauth/) {	} elsif ($userinput =~ /^currentauth/) {
if ($wasenc==1) {	if ($wasenc==1) {
Line 685 sub make_new_child {	Line 810 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
}	}
	#--------------------------------------------------------------------- pushfile
	} elsif($userinput =~ /^pushfile/) {
	if($wasenc == 1) {
	my $cert = GetCertificate($userinput);
	if(ValidManager($cert)) {
	my $reply = PushFile($userinput);
	print $client "$reply\n";
	} else {
	print $client "refused\n";
	}
	} else {
	print $client "refused\n";
	}
	#--------------------------------------------------------------------- reinit
	} elsif($userinput =~ /^reinit/) {
	if ($wasenc == 1) {
	my $cert = GetCertificate($userinput);
	if(ValidManager($cert)) {
	print $client "ok\n";
	} else {
	print $client "refused\n";
	}
	} else {
	print $client "refused\n";
	}
# ------------------------------------------------------------------------ auth	# ------------------------------------------------------------------------ auth
} elsif ($userinput =~ /^auth/) {	} elsif ($userinput =~ /^auth/) {
if ($wasenc==1) {	if ($wasenc==1) {
Line 725 sub make_new_child {	Line 875 sub make_new_child {
}	}
}	}
} elsif ($howpwd eq 'krb4') {	} elsif ($howpwd eq 'krb4') {
$null=pack("C",0);	my $null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
my $krb4_error = &Authen::Krb4::get_pw_in_tkt	my $krb4_error = &Authen::Krb4::get_pw_in_tkt
($uname,"",$contentpwd,'krbtgt',	($uname,"",$contentpwd,'krbtgt',
Line 742 sub make_new_child {	Line 892 sub make_new_child {
}	}
}	}
} elsif ($howpwd eq 'krb5') {	} elsif ($howpwd eq 'krb5') {
$null=pack("C",0);	my $null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);	my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;	my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
Line 796 sub make_new_child {	Line 946 sub make_new_child {
my $salt=time;	my $salt=time;
$salt=substr($salt,6,2);	$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);	my $ncpass=crypt($npass,$salt);
{ my $pf = IO::File->new(">$passfilename");	{
print $pf "internal:$ncpass\n"; }	my $pf;
&logthis("Result of password change for $uname: pwchange_success");	if ($pf = IO::File->new(">$passfilename")) {
print $client "ok\n";	print $pf "internal:$ncpass\n";
	&logthis("Result of password change for $uname: pwchange_success");
	print $client "ok\n";
	} else {
	&logthis("Unable to open $uname passwd to change password");
	print $client "non_authorized\n";
	}
	}

} else {	} else {
print $client "non_authorized\n";	print $client "non_authorized\n";
}	}
Line 826 sub make_new_child {	Line 984 sub make_new_child {
if ($pwdcorrect) {	if ($pwdcorrect) {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
&Debug("Opening lcpasswd pipeline");	&Debug("Opening lcpasswd pipeline");
my $pf = IO::File->new("\|$execdir/lcpasswd > /home/www/lcpasswd.log");	my $pf = IO::File->new("\|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
print $pf "$uname\n$npass\n$npass\n";	print $pf "$uname\n$npass\n$npass\n";
close $pf;	close $pf;
my $err = $?;	my $err = $?;
Line 867 sub make_new_child {	Line 1025 sub make_new_child {
} elsif ($udom ne $currentdomainid) {	} elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";	print $client "not_right_domain\n";
} else {	} else {
@fpparts=split(/\//,$proname);	my @fpparts=split(/\//,$proname);
$fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];	my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
$fperror='';	my $fperror='';
for ($i=3;$i<=$#fpparts;$i++) {	for (my $i=3;$i<=$#fpparts;$i++) {
$fpnow.='/'.$fpparts[$i];	$fpnow.='/'.$fpparts[$i];
unless (-e $fpnow) {	unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
Line 934 sub make_new_child {	Line 1092 sub make_new_child {
$uid,$gid,$rdev,$size,	$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,	$atime,$mtime,$ctime,
$blksize,$blocks)=stat($fname);	$blksize,$blocks)=stat($fname);
$now=time;	my $now=time;
$since=$now-$atime;	my $since=$now-$atime;
if ($since>$perlvar{'lonExpire'}) {	if ($since>$perlvar{'lonExpire'}) {
$reply=	my $reply=
reply("unsub:$fname","$hostid{$clientip}");	&reply("unsub:$fname","$hostid{$clientip}");
unlink("$fname");	unlink("$fname");
} else {	} else {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
Line 1009 sub make_new_child {	Line 1167 sub make_new_child {
} elsif ($userinput =~ /^tokenauthuserfile/) {	} elsif ($userinput =~ /^tokenauthuserfile/) {
my ($cmd,$fname,$session)=split(/:/,$userinput);	my ($cmd,$fname,$session)=split(/:/,$userinput);
chomp($session);	chomp($session);
$reply='non_auth';	my $reply='non_auth';
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {	$session.'.id')) {
while ($line=<ENVIN>) {	while (my $line=<ENVIN>) {
if ($line=~/userfile\.$fname\=/) { $reply='ok'; }	if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
}	}
close(ENVIN);	close(ENVIN);
print $client $reply."\n";	print $client $reply."\n";
} else {	} else {
print $client "invalid_token\n";	print $client "invalid_token\n";
}	}
# ----------------------------------------------------------------- unsubscribe	# ----------------------------------------------------------------- unsubscribe
} elsif ($userinput =~ /^unsub/) {	} elsif ($userinput =~ /^unsub/) {
Line 1069 sub make_new_child {	Line 1227 sub make_new_child {
) { print $hfh "P:$now:$what\n"; }	) { print $hfh "P:$now:$what\n"; }
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1111 sub make_new_child {	Line 1270 sub make_new_child {
}	}
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,	&ManagePermissions($key, $udom, $uname,
&GetAuthType( $udom,	&GetAuthType( $udom,
$uname));	$uname));
$hash{$key}=$value;	$hash{$key}=$value;

}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
Line 1157 sub make_new_child {	Line 1316 sub make_new_child {
}	}
}	}
my @rolekeys=split(/\&/,$what);	my @rolekeys=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {	my %hash;
foreach $key (@rolekeys) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
	foreach my $key (@rolekeys) {
delete $hash{$key};	delete $hash{$key};

}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
Line 1187 sub make_new_child {	Line 1346 sub make_new_child {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	my %hash;
for ($i=0;$i<=$#queries;$i++) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1219 sub make_new_child {	Line 1379 sub make_new_child {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	my %hash;
for ($i=0;$i<=$#queries;$i++) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1265 sub make_new_child {	Line 1426 sub make_new_child {
) { print $hfh "D:$now:$what\n"; }	) { print $hfh "D:$now:$what\n"; }
}	}
my @keys=split(/\&/,$what);	my @keys=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {	my %hash;
foreach $key (@keys) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
	foreach my $key (@keys) {
delete($hash{$key});	delete($hash{$key});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1289 sub make_new_child {	Line 1451 sub make_new_child {
$namespace=~s/\W//g;	$namespace=~s/\W//g;
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	my %hash;
foreach $key (keys %hash) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
	foreach my $key (keys %hash) {
$qresult.="$key&";	$qresult.="$key&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1314 sub make_new_child {	Line 1477 sub make_new_child {
$namespace=~s/\W//g;	$namespace=~s/\W//g;
my $qresult='';	my $qresult='';
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
	my %hash;
if (tie(%hash,'GDBM_File',	if (tie(%hash,'GDBM_File',
"$proname/$namespace.db",	"$proname/$namespace.db",
&GDBM_READER(),0640)) {	&GDBM_READER(),0640)) {
Line 1364 sub make_new_child {	Line 1528 sub make_new_child {
}	}
my $qresult='';	my $qresult='';
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	my %hash;
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);	study($regexp);
while (($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
} else {	} else {
Line 1406 sub make_new_child {	Line 1571 sub make_new_child {
) { print $hfh "P:$now:$rid:$what\n"; }	) { print $hfh "P:$now:$rid:$what\n"; }
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
	my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
my @previouskeys=split(/&/,$hash{"keys:$rid"});	my @previouskeys=split(/&/,$hash{"keys:$rid"});
my $key;	my $key;
$hash{"version:$rid"}++;	$hash{"version:$rid"}++;
my $version=$hash{"version:$rid"};	my $version=$hash{"version:$rid"};
my $allkeys='';	my $allkeys='';
foreach $pair (@pairs) {	foreach my $pair (@pairs) {
($key,$value)=split(/=/,$pair);	my ($key,$value)=split(/=/,$pair);
$allkeys.=$key.':';	$allkeys.=$key.':';
$hash{"$version:$rid:$key"}=$value;	$hash{"$version:$rid:$key"}=$value;
}	}
Line 1445 sub make_new_child {	Line 1610 sub make_new_child {
chomp($rid);	chomp($rid);
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	my %hash;
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
my $version=$hash{"version:$rid"};	my $version=$hash{"version:$rid"};
$qresult.="version=$version&";	$qresult.="version=$version&";
my $scope;	my $scope;
Line 1522 sub make_new_child {	Line 1688 sub make_new_child {
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";	"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
my $now=time;	my $now=time;
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value.':'.$now;	$hash{$key}=$value.':'.$now;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1552 sub make_new_child {	Line 1719 sub make_new_child {
my $qresult='';	my $qresult='';
my $proname=	my $proname=
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";	"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {	my %hash;
while (($key,$value) = each(%hash)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
	while (my ($key,$value) = each(%hash)) {
my ($descr,$lasttime)=split(/\:/,$value);	my ($descr,$lasttime)=split(/\:/,$value);
if ($lasttime<$since) { next; }	if ($lasttime<$since) { next; }
if ($regexp eq '.') {	if ($description eq '.') {
$qresult.=$key.'='.$descr.'&';	$qresult.=$key.'='.$descr.'&';
} else {	} else {
my $unescapeVal = &unescape($descr);	my $unescapeVal = &unescape($descr);
Line 1592 sub make_new_child {	Line 1760 sub make_new_child {
) { print $hfh "P:$now:$what\n"; }	) { print $hfh "P:$now:$what\n"; }
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {	my %hash;
foreach $pair (@pairs) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
($key,$value)=split(/=/,$pair);	foreach my $pair (@pairs) {
	my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
Line 1617 sub make_new_child {	Line 1786 sub make_new_child {
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";	my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
my $qresult='';	my $qresult='';
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {	my %hash;
for ($i=0;$i<=$#queries;$i++) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
	for (my $i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
if (untie(%hash)) {	if (untie(%hash)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) Failed ".	." untie(GDBM) Failed ".
"while attempting idget\n";	"while attempting idget\n";
}	}
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
Line 1709 sub make_new_child {	Line 1879 sub make_new_child {
}	}
if ($ulsout eq '') { $ulsout='empty'; }	if ($ulsout eq '') { $ulsout='empty'; }
print $client "$ulsout\n";	print $client "$ulsout\n";
	# ----------------------------------------------------------------- setannounce
	} elsif ($userinput =~ /^setannounce/) {
	my ($cmd,$announcement)=split(/:/,$userinput);
	chomp($announcement);
	$announcement=&unescape($announcement);
	if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
	'/announcement.txt')) {
	print $store $announcement;
	close $store;
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)."\n";
	}
# ------------------------------------------------------------------ Hanging up	# ------------------------------------------------------------------ Hanging up
} elsif (($userinput =~ /^exit/) \|\|	} elsif (($userinput =~ /^exit/) \|\|
($userinput =~ /^init/)) {	($userinput =~ /^init/)) {
Line 1772 sub ManagePermissions	Line 1955 sub ManagePermissions
my $authtype= shift;	my $authtype= shift;

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
	&logthis("ruequest is $request");
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" ;
Debug("system $execdir/lchtmldir $userhome $system $authtype");	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
system("$execdir/lchtmldir $userhome $user $authtype");	system("$execdir/lchtmldir $userhome $user $authtype");
}	}
}	}
Line 1819 sub addline {	Line 2002 sub addline {
my $found=0;	my $found=0;
my $expr='^'.$hostid.':'.$ip.':';	my $expr='^'.$hostid.':'.$ip.':';
$expr =~ s/\./\\\./g;	$expr =~ s/\./\\\./g;
	my $sh;
if ($sh=IO::File->new("$fname.subscription")) {	if ($sh=IO::File->new("$fname.subscription")) {
while (my $subline=<$sh>) {	while (my $subline=<$sh>) {
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}	if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
Line 1843 sub getchat {	Line 2027 sub getchat {
untie %hash;	untie %hash;
}	}
my @participants=();	my @participants=();
$cutoff=time-60;	my $cutoff=time-60;
if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",	if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
$hash{$uname.':'.$udom}=time;	$hash{$uname.':'.$udom}=time;
Line 1862 sub chatadd {	Line 2046 sub chatadd {
my %hash;	my %hash;
my $proname=&propath($cdom,$cname);	my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
	my $time=time;
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",	if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
&GDBM_WRCREAT(),0640)) {	&GDBM_WRCREAT(),0640)) {
@entries=map { $_.':'.$hash{$_} } sort keys %hash;	@entries=map { $_.':'.$hash{$_} } sort keys %hash;
my $time=time;
my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);	my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
my ($thentime,$idnum)=split(/\_/,$lastid);	my ($thentime,$idnum)=split(/\_/,$lastid);
my $newid=$time.'_000000';	my $newid=$time.'_000000';
Line 1885 sub chatadd {	Line 2069 sub chatadd {
}	}
untie %hash;	untie %hash;
}	}
	{
	my $hfh;
	if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
	print $hfh "$time:".&unescape($newchat)."\n";
	}
	}
}	}

sub unsub {	sub unsub {
Line 1921 sub currentversion {	Line 2111 sub currentversion {
}	}
if (-e $fname) { $version=1; }	if (-e $fname) { $version=1; }
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
	my $ulsfn;
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
# see if this is a regular file (ignore links produced earlier)	# see if this is a regular file (ignore links produced earlier)
my $thisfile=$ulsdir.'/'.$ulsfn;	my $thisfile=$ulsdir.'/'.$ulsfn;
unless (-l $thisfile) {	unless (-l $thisfile) {
if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {	if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
if ($1>$version) { $version=$1; }	if ($1>$version) { $version=$1; }
}	}
}	}
}	}
closedir(LSDIR);	closedir(LSDIR);
$version++;	$version++;
}	}
}	}
}	}
return $version;	return $version;
}	}

sub thisversion {	sub thisversion {
Line 1977 sub subscribe {	Line 2167 sub subscribe {
$result="directory\n";	$result="directory\n";
} else {	} else {
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}	if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}
$now=time;	my $now=time;
my $found=&addline($fname,$hostid{$clientip},$clientip,	my $found=&addline($fname,$hostid{$clientip},$clientip,
"$hostid{$clientip}:$clientip:$now\n");	"$hostid{$clientip}:$clientip:$now\n");
if ($found) { $result="$fname\n"; }	if ($found) { $result="$fname\n"; }
Line 2026 sub make_passwd_file {	Line 2216 sub make_passwd_file {
{	{
&Debug("Executing external: ".$execpath);	&Debug("Executing external: ".$execpath);
&Debug("user = ".$uname.", Password =". $npass);	&Debug("user = ".$uname.", Password =". $npass);
my $se = IO::File->new("\|$execpath > /home/www/lcuseradd.log");	my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
print $se "$uname\n";	print $se "$uname\n";
print $se "$npass\n";	print $se "$npass\n";
print $se "$npass\n";	print $se "$npass\n";
Line 2080 sub userload {	Line 2270 sub userload {
my $curtime=time;	my $curtime=time;
while ($filename=readdir(LONIDS)) {	while ($filename=readdir(LONIDS)) {
if ($filename eq '.' \|\| $filename eq '..') {next;}	if ($filename eq '.' \|\| $filename eq '..') {next;}
my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];	my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$atime < 3600) { $numusers++; }	if ($curtime-$mtime < 3600) { $numusers++; }
}	}
closedir(LONIDS);	closedir(LONIDS);
}	}
Line 2363 Send along temporarily stored informatio	Line 2553 Send along temporarily stored informatio

List part of a user's directory.	List part of a user's directory.

	=item pushtable

	Pushes a file in /home/httpd/lonTab directory. Currently limited to:
	hosts.tab and domain.tab. The old file is copied to *.tab.backup but
	must be restored manually in case of a problem with the new table file.
	pushtable requires that the request be encrypted and validated via
	ValidateManager. The form of the command is:
	enc:pushtable tablename <tablecontents> \n
	where pushtable, tablename and <tablecontents> will be encrypted, but \n is a
	cleartext newline.

=item Hanging up (exit or init)	=item Hanging up (exit or init)

What to do when a client tells the server that they (the client)	What to do when a client tells the server that they (the client)
Line 2373 are leaving the network.	Line 2574 are leaving the network.
If B<lond> is sent an unknown command (not in the list above),	If B<lond> is sent an unknown command (not in the list above),
it replys to the client "unknown_cmd".	it replys to the client "unknown_cmd".


=item UNKNOWN CLIENT	=item UNKNOWN CLIENT

If the anti-spoofing algorithm cannot verify the client,	If the anti-spoofing algorithm cannot verify the client,

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

Removed from v.1.131
changed lines
	Added in v.1.142