Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.103 and 1.122

version 1.103, 2002/10/30 14:50:04	version 1.122, 2003/03/28 18:26:28
Line 31	Line 31
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,	# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,	# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
# 03/07,05/31 Gerd Kortemeyer	# 03/07,05/31 Gerd Kortemeyer
# 06/26 Scott Harrison
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer	# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
# 12/05 Scott Harrison
# 12/05,12/13,12/29 Gerd Kortemeyer	# 12/05,12/13,12/29 Gerd Kortemeyer
# YEAR=2001	# YEAR=2001
# Jan 01 Scott Harrison
# 02/12 Gerd Kortemeyer	# 02/12 Gerd Kortemeyer
# 03/15 Scott Harrison
# 03/24 Gerd Kortemeyer	# 03/24 Gerd Kortemeyer
# 04/02 Scott Harrison
# 05/11,05/28,08/30 Gerd Kortemeyer	# 05/11,05/28,08/30 Gerd Kortemeyer
# 9/30,10/22,11/13,11/15,11/16 Scott Harrison
# 11/26,11/27 Gerd Kortemeyer	# 11/26,11/27 Gerd Kortemeyer
# 12/20 Scott Harrison
# 12/22 Gerd Kortemeyer	# 12/22 Gerd Kortemeyer
# YEAR=2002	# YEAR=2002
# 01/20/02,02/05 Gerd Kortemeyer	# 01/20/02,02/05 Gerd Kortemeyer
# 02/05 Guy Albertelli	# 02/05 Guy Albertelli
# 02/07 Scott Harrison
# 02/12 Gerd Kortemeyer	# 02/12 Gerd Kortemeyer
# 02/19 Matthew Hall	# 02/19 Matthew Hall
# 02/25 Gerd Kortemeyer	# 02/25 Gerd Kortemeyer
# 05/11 Scott Harrison	# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon
	# logic simpler (and there were problems maintaining the preforked
	# population). Since the time averaged connection rate is close to zero
	# because lonc's purpose is to maintain near continuous connnections,
	# preforking is not really needed.
###	###

# based on "Perl Cookbook" ISBN 1-56592-243-3
# preforker - server who forks first
# runs as a daemon
# HUPs
# uses IDEA encryption

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

Line 83 my $DEBUG = 0; # Non zero to ena	Line 73 my $DEBUG = 0; # Non zero to ena
my $status='';	my $status='';
my $lastlog='';	my $lastlog='';

	my $VERSION='$Revision$'; #' stupid emacs
	my $remoteVERSION;
	my $currenthostid;
	my $currentdomainid;
#	#
# The array below are password error strings."	# The array below are password error strings."
#	#
Line 178 undef $perlvarref;	Line 172 undef $perlvarref;
my $wwwid=getpwnam('www');	my $wwwid=getpwnam('www');
if ($wwwid!=$<) {	if ($wwwid!=$<) {
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";	$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $perlvar{'lonHostID'} User ID mismatch";	$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 205 while ($configline=<CONFIG>) {	Line 199 while ($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;
	$hostip{$id}=$ip;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }	if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
$PREFORK++;	$PREFORK++;
}	}
Line 272 sub checkchildren {	Line 268 sub checkchildren {
}	}
}	}
sleep 5;	sleep 5;
	$SIG{ALRM} = sub { die "timeout" };
	$SIG{__DIE__} = 'DEFAULT';
foreach (sort keys %children) {	foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {	unless (-e "$docdir/lon-status/londchld/$_.txt") {
	eval {
	alarm(300);
&logthis('Child '.$_.' did not respond');	&logthis('Child '.$_.' did not respond');
kill 9 => $_;	kill 9 => $_;
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";	$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $perlvar{'lonHostID'} killed lond process $_";	$subj="LON: $currenthostid killed lond process $_";
my $result=`echo 'Killed lond process $_.' \| mailto $emailto -s '$subj' > /dev/null`;	my $result=`echo 'Killed lond process $_.' \| mailto $emailto -s '$subj' > /dev/null`;
$execdir=$perlvar{'lonDaemons'};	$execdir=$perlvar{'lonDaemons'};
$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`	$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
	alarm(0);
	}
}	}
}	}
	$SIG{ALRM} = 'DEFAULT';
	$SIG{__DIE__} = \&cathcexception;
}	}

# --------------------------------------------------------------------- Logging	# --------------------------------------------------------------------- Logging
Line 310 sub logstatus {	Line 314 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".$status."\t".$lastlog."\n";	print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
$fh->close();	$fh->close();
}	}
{	{
Line 407 sub subreply {	Line 411 sub subreply {
sub reply {	sub reply {
my ($cmd,$server)=@_;	my ($cmd,$server)=@_;
my $answer;	my $answer;
if ($server ne $perlvar{'lonHostID'}) {	if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);	$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {	if ($answer eq 'con_lost') {
$answer=subreply("ping",$server);	$answer=subreply("ping",$server);
if ($answer ne $server) {	if ($answer ne $server) {
&logthis("sub reply: answer != server");	&logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/$server");	&reconlonc("$perlvar{'lonSockDir'}/$server");
}	}
$answer=subreply($cmd,$server);	$answer=subreply($cmd,$server);
Line 491 close(PIDSAVE);	Line 495 close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");	&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');	&status('Starting');

# ------------------------------------------------------- Now we are on our own

# Fork off our children.
for (1 .. $PREFORK) {
make_new_child();
}

# ----------------------------------------------------- Install signal handlers	# ----------------------------------------------------- Install signal handlers

&status('Forked children');

$SIG{CHLD} = \&REAPER;	$SIG{CHLD} = \&REAPER;
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;	$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP} = \&HUPSMAN;	$SIG{HUP} = \&HUPSMAN;
$SIG{USR1} = \&checkchildren;	$SIG{USR1} = \&checkchildren;

# And maintain the population.

	# --------------------------------------------------------------
	# Accept connections. When a connection comes in, it is validated
	# and if good, a child process is created to process transactions
	# along the connection.

while (1) {	while (1) {
&status('Sleeping');	$client = $server->accept() or next;
sleep; # wait for a signal (i.e., child's death)	make_new_child($client);
&logthis('Woke up');
&status('Woke up');
for ($i = $children; $i < $PREFORK; $i++) {
make_new_child(); # top up the child pool
}
}	}

sub make_new_child {	sub make_new_child {
	my $client;
my $pid;	my $pid;
my $cipher;	my $cipher;
my $sigset;	my $sigset;

	$client = shift;
&logthis("Attempting to start child");	&logthis("Attempting to start child");
# block signal for fork	# block signal for fork
$sigset = POSIX::SigSet->new(SIGINT);	$sigset = POSIX::SigSet->new(SIGINT);
Line 555 sub make_new_child {	Line 557 sub make_new_child {
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();

# handle connections until we've reached $MAX_CLIENTS_PER_CHILD
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
&status('Idle, waiting for connection');
$client = $server->accept() or last;
&status('Accepted connection');	&status('Accepted connection');
# =============================================================================	# =============================================================================
# do something with the connection	# do something with the connection
Line 566 sub make_new_child {	Line 564 sub make_new_child {
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of	$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
# connection liveness.	# connection liveness.
# 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);	my $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);	my $clientrec=($hostid{$clientip} ne undef);
&logthis(	&logthis(
"<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"	"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
);	);
&status("Connecting $clientip ($hostid{$clientip})");	&status("Connecting $clientip ($hostid{$clientip})");
my $clientok;	my $clientok;
if ($clientrec) {	if ($clientrec) {
&status("Waiting for init from $clientip ($hostid{$clientip})");	&status("Waiting for init from $clientip ($hostid{$clientip})");
my $remotereq=<$client>;	my $remotereq=<$client>;
$remotereq=~s/\W//g;	$remotereq=~s/[^\w:]//g;
if ($remotereq eq 'init') {	if ($remotereq =~ /^init/) {
	&sethost("sethost:$perlvar{'lonHostID'}");
my $challenge="$$".time;	my $challenge="$$".time;
print $client "$challenge\n";	print $client "$challenge\n";
&status(	&status(
Line 608 sub make_new_child {	Line 607 sub make_new_child {
if ($clientok) {	if ($clientok) {
# ---------------- New known client connecting, could mean machine online again	# ---------------- New known client connecting, could mean machine online again

&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");	foreach my $id (keys(%hostip)) {
&logthis(	if ($hostip{$id} ne $clientip \|\|
"<font color=green>Established connection: $hostid{$clientip}</font>");	$hostip{$currenthostid} eq $clientip) {
	# no need to try to do recon's to myself
	next;
	}
	&reconlonc("$perlvar{'lonSockDir'}/$id");
	}
	&logthis("<font color=green>Established connection: $hostid{$clientip}</font>");
&status('Will listen to '.$hostid{$clientip});	&status('Will listen to '.$hostid{$clientip});
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {	while (my $userinput=<$client>) {
Line 638 sub make_new_child {	Line 643 sub make_new_child {
# ------------------------------------------------------------- Normal commands	# ------------------------------------------------------------- Normal commands
# ------------------------------------------------------------------------ ping	# ------------------------------------------------------------------------ ping
if ($userinput =~ /^ping/) {	if ($userinput =~ /^ping/) {
print $client "$perlvar{'lonHostID'}\n";	print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong	# ------------------------------------------------------------------------ pong
} elsif ($userinput =~ /^pong/) {	} elsif ($userinput =~ /^pong/) {
$reply=reply("ping",$hostid{$clientip});	$reply=reply("ping",$hostid{$clientip});
print $client "$perlvar{'lonHostID'}:$reply\n";	print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey	# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {	} elsif ($userinput =~ /^ekey/) {
my $buildkey=time.$$.int(rand 100000);	my $buildkey=time.$$.int(rand 100000);
$buildkey=~tr/1-6/A-F/;	$buildkey=~tr/1-6/A-F/;
$buildkey=int(rand 100000).$buildkey.int(rand 100000);	$buildkey=int(rand 100000).$buildkey.int(rand 100000);
my $key=$perlvar{'lonHostID'}.$hostid{$clientip};	my $key=$currenthostid.$hostid{$clientip};
$key=~tr/a-z/A-Z/;	$key=~tr/a-z/A-Z/;
$key=~tr/G-P/0-9/;	$key=~tr/G-P/0-9/;
$key=~tr/Q-Z/0-9/;	$key=~tr/Q-Z/0-9/;
Line 721 sub make_new_child {	Line 726 sub make_new_child {
}	}
}	}
} elsif ($howpwd eq 'krb4') {	} elsif ($howpwd eq 'krb4') {
$null=pack("C",0);	$null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
$pwdcorrect=(	my $krb4_error = &Authen::Krb4::get_pw_in_tkt
Authen::Krb4::get_pw_in_tkt($uname,"",	($uname,"",$contentpwd,'krbtgt',
$contentpwd,'krbtgt',$contentpwd,1,	$contentpwd,1,$upass);
$upass) == 0);	if (!$krb4_error) {
} else { $pwdcorrect=0; }	$pwdcorrect = 1;
	} else {
	$pwdcorrect=0;
	# log error if it is not a bad password
	if ($krb4_error != 62) {
	&logthis('krb4:'.$uname.','.$contentpwd.','.
	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
	}
	}
	}
} elsif ($howpwd eq 'krb5') {	} elsif ($howpwd eq 'krb5') {
$null=pack("C",0);	$null=pack("C",0);
unless ($upass=~/$null/) {	unless ($upass=~/$null/) {
Line 851 sub make_new_child {	Line 865 sub make_new_child {
$passfilename);	$passfilename);
if (-e $passfilename) {	if (-e $passfilename) {
print $client "already_exists\n";	print $client "already_exists\n";
} elsif ($udom ne $perlvar{'lonDefDomain'}) {	} elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";	print $client "not_right_domain\n";
} else {	} else {
@fpparts=split(/\//,$proname);	@fpparts=split(/\//,$proname);
Line 861 sub make_new_child {	Line 875 sub make_new_child {
$fpnow.='/'.$fpparts[$i];	$fpnow.='/'.$fpparts[$i];
unless (-e $fpnow) {	unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
$fperror="error:$!";	$fperror="error: ".($!+0)
	." mkdir failed while attempting "
	."makeuser\n";
}	}
}	}
}	}
Line 889 sub make_new_child {	Line 905 sub make_new_child {
$npass=&unescape($npass);	$npass=&unescape($npass);
my $proname=&propath($udom,$uname);	my $proname=&propath($udom,$uname);
my $passfilename="$proname/passwd";	my $passfilename="$proname/passwd";
if ($udom ne $perlvar{'lonDefDomain'}) {	if ($udom ne $currentdomainid) {
print $client "not_right_domain\n";	print $client "not_right_domain\n";
} else {	} else {
my $result=&make_passwd_file($uname, $umode,$npass,	my $result=&make_passwd_file($uname, $umode,$npass,
Line 1032 sub make_new_child {	Line 1048 sub make_new_child {
print $hfh "$now:$hostid{$clientip}:$what\n";	print $hfh "$now:$hostid{$clientip}:$what\n";
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." IO::File->new Failed "
	."while attempting log\n";
}	}
}	}
# ------------------------------------------------------------------------- put	# ------------------------------------------------------------------------- put
Line 1052 sub make_new_child {	Line 1070 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach $pair (@pairs) {	foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);	($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
Line 1060 sub make_new_child {	Line 1078 sub make_new_child {
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) failed ".
	"while attempting put\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!)
	." tie(GDBM) Failed ".
	"while attempting put\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1090 sub make_new_child {	Line 1112 sub make_new_child {
}	}
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach $pair (@pairs) {	foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);	($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,	&ManagePermissions($key, $udom, $uname,
Line 1102 sub make_new_child {	Line 1124 sub make_new_child {
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting rolesput\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting rolesput\n";
	}
	} else {
	print $client "refused\n";
	}
	# -------------------------------------------------------------------- rolesdel
	} elsif ($userinput =~ /^rolesdel/) {
	&Debug("rolesdel");
	if ($wasenc==1) {
	my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
	=split(/:/,$userinput);
	&Debug("cmd = ".$cmd." exedom= ".$exedom.
	"user = ".$exeuser." udom=".$udom.
	"what = ".$what);
	my $namespace='roles';
	chomp($what);
	my $proname=propath($udom,$uname);
	my $now=time;
	{
	my $hfh;
	if (
	$hfh=IO::File->new(">>$proname/$namespace.hist")
	) {
	print $hfh "D:$now:$exedom:$exeuser:$what\n";
	}
	}
	my @rolekeys=split(/\&/,$what);
	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
	foreach $key (@rolekeys) {
	delete $hash{$key};

	}
	if (untie(%hash)) {
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting rolesdel\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting rolesdel\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1120 sub make_new_child {	Line 1188 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
for ($i=0;$i<=$#queries;$i++) {	for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
Line 1128 sub make_new_child {	Line 1196 sub make_new_child {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting get\n";
}	}
} else {	} else {
print $client "error:$!\n";	if ($!+0 == 2) {
	print $client "error:No such file or ".
	"GDBM reported bad block error\n";
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting get\n";
	}
}	}
# ------------------------------------------------------------------------ eget	# ------------------------------------------------------------------------ eget
} elsif ($userinput =~ /^eget/) {	} elsif ($userinput =~ /^eget/) {
Line 1143 sub make_new_child {	Line 1220 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
for ($i=0;$i<=$#queries;$i++) {	for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
Line 1164 sub make_new_child {	Line 1241 sub make_new_child {
print $client "error:no_key\n";	print $client "error:no_key\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting eget\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting eget\n";
}	}
# ------------------------------------------------------------------------- del	# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {	} elsif ($userinput =~ /^del/) {
Line 1185 sub make_new_child {	Line 1266 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach $key (@keys) {	foreach $key (@keys) {
delete($hash{$key});	delete($hash{$key});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting del\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting del\n";
}	}
# ------------------------------------------------------------------------ keys	# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {	} elsif ($userinput =~ /^keys/) {
Line 1205 sub make_new_child {	Line 1290 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)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
foreach $key (keys %hash) {	foreach $key (keys %hash) {
$qresult.="$key&";	$qresult.="$key&";
}	}
Line 1213 sub make_new_child {	Line 1298 sub make_new_child {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting keys\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting keys\n";
	}
	# ----------------------------------------------------------------- dumpcurrent
	} elsif ($userinput =~ /^currentdump/) {
	my ($cmd,$udom,$uname,$namespace)
	=split(/:/,$userinput);
	$namespace=~s/\//\_/g;
	$namespace=~s/\W//g;
	my $qresult='';
	my $proname=propath($udom,$uname);
	if (tie(%hash,'GDBM_File',
	"$proname/$namespace.db",
	&GDBM_READER(),0640)) {
	# Structure of %data:
	# $data{$symb}->{$parameter}=$value;
	# $data{$symb}->{'v.'.$parameter}=$version;
	# since $parameter will be unescaped, we do not
	# have to worry about silly parameter names...
	my %data = ();
	while (my ($key,$value) = each(%hash)) {
	my ($v,$symb,$param) = split(/:/,$key);
	next if ($v eq 'version' \|\| $symb eq 'keys');
	next if (exists($data{$symb}) &&
	exists($data{$symb}->{$param}) &&
	$data{$symb}->{'v.'.$param} > $v);
	$data{$symb}->{$param}=$value;
	$data{$symb}->{'v.'.$param}=$v;
	}
	if (untie(%hash)) {
	while (my ($symb,$param_hash) = each(%data)) {
	while(my ($param,$value) = each (%$param_hash)){
	next if ($param =~ /^v\./);
	$qresult.=$symb.':'.$param.'='.$value.'&';
	}
	}
	chop($qresult);
	print $client "$qresult\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting currentdump\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting currentdump\n";
}	}
# ------------------------------------------------------------------------ dump	# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {	} elsif ($userinput =~ /^dump/) {
Line 1247 sub make_new_child {	Line 1381 sub make_new_child {
chop($qresult);	chop($qresult);
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting dump\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting dump\n";
}	}
# ----------------------------------------------------------------------- store	# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {	} elsif ($userinput =~ /^store/) {
Line 1270 sub make_new_child {	Line 1408 sub make_new_child {
}	}
my @pairs=split(/\&/,$what);	my @pairs=split(/\&/,$what);

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"}++;
Line 1287 sub make_new_child {	Line 1425 sub make_new_child {
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting store\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting store\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1304 sub make_new_child {	Line 1446 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)) {	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 1321 sub make_new_child {	Line 1463 sub make_new_child {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting restore\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting restore\n";
}	}
# -------------------------------------------------------------------- chatsend	# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {	} elsif ($userinput =~ /^chatsend/) {
Line 1333 sub make_new_child {	Line 1479 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
# -------------------------------------------------------------------- chatretr	# -------------------------------------------------------------------- chatretr
} elsif ($userinput =~ /^chatretr/) {	} elsif ($userinput =~ /^chatretr/) {
my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);	my
	($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
my $reply='';	my $reply='';
foreach (&getchat($cdom,$cnum)) {	foreach (&getchat($cdom,$cnum,$udom,$uname)) {
$reply.=&escape($_).':';	$reply.=&escape($_).':';
}	}
$reply=~s/\:$//;	$reply=~s/\:$//;
Line 1363 sub make_new_child {	Line 1510 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." IO::File->new Failed ".
	"while attempting queryreply\n";
	}
	# ----------------------------------------------------------------- courseidput
	} elsif ($userinput =~ /^courseidput/) {
	my ($cmd,$udom,$what)=split(/:/,$userinput);
	chomp($what);
	$udom=~s/\W//g;
	my $proname=
	"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
	my $now=time;
	my @pairs=split(/\&/,$what);
	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
	foreach $pair (@pairs) {
	($key,$value)=split(/=/,$pair);
	$hash{$key}=$value.':'.$now;
	}
	if (untie(%hash)) {
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting courseidput\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting courseidput\n";
	}
	# ---------------------------------------------------------------- courseiddump
	} elsif ($userinput =~ /^courseiddump/) {
	my ($cmd,$udom,$since,$description)
	=split(/:/,$userinput);
	if (defined($description)) {
	$description=&unescape($description);
	} else {
	$description='.';
}	}
	unless (defined($since)) { $since=0; }
	my $qresult='';
	my $proname=
	"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
	while (($key,$value) = each(%hash)) {
	my ($descr,$lasttime)=split(/\:/,$value);
	if ($lasttime<$since) { next; }
	if ($regexp eq '.') {
	$qresult.=$key.'='.$descr.'&';
	} else {
	my $unescapeVal = &unescape($descr);
	if (eval('$unescapeVal=~/$description/i')) {
	$qresult.="$key=$descr&";
	}
	}
	}
	if (untie(%hash)) {
	chop($qresult);
	print $client "$qresult\n";
	} else {
	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting courseiddump\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting courseiddump\n";
	}
# ----------------------------------------------------------------------- idput	# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {	} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);	my ($cmd,$udom,$what)=split(/:/,$userinput);
Line 1379 sub make_new_child {	Line 1593 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)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
foreach $pair (@pairs) {	foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);	($key,$value)=split(/=/,$pair);
$hash{$key}=$value;	$hash{$key}=$value;
Line 1387 sub make_new_child {	Line 1601 sub make_new_child {
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting idput\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting idput\n";
}	}
# ----------------------------------------------------------------------- idget	# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {	} elsif ($userinput =~ /^idget/) {
Line 1400 sub make_new_child {	Line 1618 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)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
for ($i=0;$i<=$#queries;$i++) {	for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";	$qresult.="$hash{$queries[$i]}&";
}	}
Line 1408 sub make_new_child {	Line 1626 sub make_new_child {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
print $client "$qresult\n";	print $client "$qresult\n";
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." untie(GDBM) Failed ".
	"while attempting idget\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed ".
	"while attempting idget\n";
}	}
# ---------------------------------------------------------------------- tmpput	# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {	} elsif ($userinput =~ /^tmpput/) {
Line 1428 sub make_new_child {	Line 1650 sub make_new_child {
print $client "$id\n";	print $client "$id\n";
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	."IO::File->new Failed ".
	"while attempting tmpput\n";
}	}

# ---------------------------------------------------------------------- tmpget	# ---------------------------------------------------------------------- tmpget
Line 1444 sub make_new_child {	Line 1668 sub make_new_child {
close $store;	close $store;
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	."IO::File->new Failed ".
	"while attempting tmpget\n";
}	}

	# ---------------------------------------------------------------------- tmpdel
	} elsif ($userinput =~ /^tmpdel/) {
	my ($cmd,$id)=split(/:/,$userinput);
	chomp($id);
	$id=~s/\W/\_/g;
	my $execdir=$perlvar{'lonDaemons'};
	if (unlink("$execdir/tmp/$id.tmp")) {
	print $client "ok\n";
	} else {
	print $client "error: ".($!+0)
	."Unlink tmp Failed ".
	"while attempting tmpdel\n";
	}
# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
my ($cmd,$ulsdir)=split(/:/,$userinput);	my ($cmd,$ulsdir)=split(/:/,$userinput);
Line 1480 sub make_new_child {	Line 1719 sub make_new_child {
$client->close();	$client->close();
last;	last;
# ------------------------------------------------------------- unknown command	# ------------------------------------------------------------- unknown command
	} elsif ($userinput =~ /^sethost:/) {
	print $client &sethost($userinput)."\n";
	} elsif ($userinput =~/^version:/) {
	print $client &version($userinput)."\n";
} else {	} else {
# unknown command	# unknown command
print $client "unknown_cmd\n";	print $client "unknown_cmd\n";
Line 1495 sub make_new_child {	Line 1738 sub make_new_child {
&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 ($hostid{$clientip})</font>");	."Disconnect from $clientip ($hostid{$clientip})</font>");
# tidy up gracefully and finish

$server->close();

# this exit is VERY important, otherwise the child will become	# this exit is VERY important, otherwise the child will become
# a producer of more and more children, forking yourself into	# a producer of more and more children, forking yourself into
# process death.	# process death.
exit;	exit;
}
}	}


Line 1593 sub addline {	Line 1834 sub addline {
}	}

sub getchat {	sub getchat {
my ($cdom,$cname)=@_;	my ($cdom,$cname,$udom,$uname)=@_;
my %hash;	my %hash;
my $proname=&propath($cdom,$cname);	my $proname=&propath($cdom,$cname);
my @entries=();	my @entries=();
Line 1659 sub currentversion {	Line 1900 sub currentversion {
if ($fname=~/^(.+)\/[^\/]+$/) {	if ($fname=~/^(.+)\/[^\/]+$/) {
$ulsdir=$1;	$ulsdir=$1;
}	}
	my ($fnamere1,$fnamere2);
	# remove version if already specified
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;	$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
$fname=~s/\.(\w+(?:\.meta)*)$/\.$\\d\+$\.$1\$/;	# get the bits that go before and after the version number
	if ( $fname=~/^(.\.)(\w+(?:\.meta))$/ ) {
	$fnamere1=$1;
	$fnamere2='.'.$2;
	}
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)) {

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=~/$fname/) {	if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
if ($1>$version) { $version=$1; }	if ($1>$version) { $version=$1; }
}	}
}	}
}	}
closedir(LSDIR);	closedir(LSDIR);
Line 1791 sub make_passwd_file {	Line 2038 sub make_passwd_file {
return $result;	return $result;
}	}

	sub sethost {
	my ($remotereq) = @_;
	my (undef,$hostid)=split(/:/,$remotereq);
	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
	if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
	$currenthostid=$hostid;
	$currentdomainid=$hostdom{$hostid};
	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
	} else {
	&logthis("Requested host id $hostid not an alias of ".
	$perlvar{'lonHostID'}." refusing connection");
	return 'unable_to_set';
	}
	return 'ok';
	}

	sub version {
	my ($userinput)=@_;
	$remoteVERSION=(split(/:/,$userinput))[1];
	return "version:$VERSION";
	}

# ----------------------------------- POD (plain old documentation, CPAN style)	# ----------------------------------- POD (plain old documentation, CPAN style)

=head1 NAME	=head1 NAME

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

500 Internal Server Error

Internal Server Error

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

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

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

Removed from v.1.103
changed lines
	Added in v.1.122