--- loncom/lond 2003/03/25 22:03:23 1.118
+++ loncom/lond 2003/05/08 21:35:48 1.128
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.118 2003/03/25 22:03:23 www Exp $
+# $Id: lond,v 1.128 2003/05/08 21:35:48 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -57,7 +57,7 @@ use LONCAPA::Configuration;
use IO::Socket;
use IO::File;
-use Apache::File;
+#use Apache::File;
use Symbol;
use POSIX;
use Crypt::IDEA;
@@ -73,6 +73,8 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
+my $VERSION='$Revision: 1.128 $'; #' stupid emacs
+my $remoteVERSION;
my $currenthostid;
my $currentdomainid;
#
@@ -373,13 +375,6 @@ sub reconlonc {
if (kill 0 => $loncpid) {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
- sleep 5;
- if (-e "$peerfile") { return; }
- &logthis("$peerfile still not there, give it another try");
- sleep 10;
- if (-e "$peerfile") { return; }
- &logthis(
- "WARNING: $peerfile still not there, giving up");
} else {
&logthis(
"CRITICAL: "
@@ -515,22 +510,6 @@ while (1) {
make_new_child($client);
}
-sub init_host_and_domain {
- 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 0;
- }
- return 1;
-}
-
sub make_new_child {
my $client;
my $pid;
@@ -557,6 +536,8 @@ sub make_new_child {
} else {
# Child can *not* return from this subroutine.
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
+ $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns
+ #don't get intercepted
$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;
$lastlog='Forked ';
@@ -592,14 +573,7 @@ sub make_new_child {
my $remotereq=<$client>;
$remotereq=~s/[^\w:]//g;
if ($remotereq =~ /^init/) {
- if (!&init_host_and_domain($remotereq)) {
- &status("Got bad init message, exiting");
- print $client "refused\n";
- $client->close();
- &logthis("WARNING: "
- ."Bad init message $remotereq, closing connection");
- exit;
- }
+ &sethost("sethost:$perlvar{'lonHostID'}");
my $challenge="$$".time;
print $client "$challenge\n";
&status(
@@ -691,8 +665,12 @@ sub make_new_child {
$loadavg=<$loadfile>;
}
$loadavg =~ s/\s.*//g;
- my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
+ my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
print $client "$loadpercent\n";
+# -------------------------------------------------------------------- userload
+ } elsif ($userinput =~ /^userload/) {
+ my $userloadpercent=&userload();
+ print $client "$userloadpercent\n";
# ----------------------------------------------------------------- currentauth
} elsif ($userinput =~ /^currentauth/) {
if ($wasenc==1) {
@@ -1091,7 +1069,7 @@ sub make_new_child {
) { print $hfh "P:$now:$what\n"; }
}
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) {
($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
@@ -1133,7 +1111,7 @@ sub make_new_child {
}
}
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) {
($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,
@@ -1179,7 +1157,7 @@ sub make_new_child {
}
}
my @rolekeys=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 (@rolekeys) {
delete $hash{$key};
@@ -1209,7 +1187,7 @@ sub make_new_child {
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
@@ -1241,7 +1219,7 @@ sub make_new_child {
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
@@ -1287,7 +1265,7 @@ sub make_new_child {
) { print $hfh "D:$now:$what\n"; }
}
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) {
delete($hash{$key});
}
@@ -1311,7 +1289,7 @@ sub make_new_child {
$namespace=~s/\W//g;
my $proname=propath($udom,$uname);
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) {
$qresult.="$key&";
}
@@ -1429,7 +1407,7 @@ sub make_new_child {
}
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 $key;
$hash{"version:$rid"}++;
@@ -1467,7 +1445,7 @@ sub make_new_child {
chomp($rid);
my $proname=propath($udom,$uname);
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"};
$qresult.="version=$version&";
my $scope;
@@ -1500,9 +1478,10 @@ sub make_new_child {
print $client "ok\n";
# -------------------------------------------------------------------- chatretr
} elsif ($userinput =~ /^chatretr/) {
- my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);
+ my
+ ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
my $reply='';
- foreach (&getchat($cdom,$cnum)) {
+ foreach (&getchat($cdom,$cnum,$udom,$uname)) {
$reply.=&escape($_).':';
}
$reply=~s/\:$//;
@@ -1543,7 +1522,7 @@ sub make_new_child {
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
my $now=time;
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) {
($key,$value)=split(/=/,$pair);
$hash{$key}=$value.':'.$now;
@@ -1581,7 +1560,7 @@ sub make_new_child {
$qresult.=$key.'='.$descr.'&';
} else {
my $unescapeVal = &unescape($descr);
- if (eval('$unescapeVal=~/$description/')) {
+ if (eval('$unescapeVal=~/$description/i')) {
$qresult.="$key=$descr&";
}
}
@@ -1613,7 +1592,7 @@ sub make_new_child {
) { print $hfh "P:$now:$what\n"; }
}
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) {
($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
@@ -1638,7 +1617,7 @@ sub make_new_child {
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my @queries=split(/\&/,$what);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
@@ -1739,6 +1718,10 @@ sub make_new_child {
$client->close();
last;
# ------------------------------------------------------------- unknown command
+ } elsif ($userinput =~ /^sethost:/) {
+ print $client &sethost($userinput)."\n";
+ } elsif ($userinput =~/^version:/) {
+ print $client &version($userinput)."\n";
} else {
# unknown command
print $client "unknown_cmd\n";
@@ -1850,7 +1833,7 @@ sub addline {
}
sub getchat {
- my ($cdom,$cname)=@_;
+ my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();
@@ -1859,7 +1842,19 @@ sub getchat {
@entries=map { $_.':'.$hash{$_} } sort keys %hash;
untie %hash;
}
- return @entries;
+ my @participants=();
+ $cutoff=time-60;
+ if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
+ &GDBM_WRCREAT(),0640)) {
+ $hash{$uname.':'.$udom}=time;
+ foreach (sort keys %hash) {
+ if ($hash{$_}>$cutoff) {
+ $participants[$#participants+1]='active_participant:'.$_;
+ }
+ }
+ untie %hash;
+ }
+ return (@participants,@entries);
}
sub chatadd {
@@ -2054,6 +2049,50 @@ sub make_passwd_file {
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";
+}
+
+#There is a copy of this in lonnet.pm
+sub userload {
+ my $numusers=0;
+ {
+ opendir(LONIDS,$perlvar{'lonIDsDir'});
+ my $filename;
+ my $curtime=time;
+ while ($filename=readdir(LONIDS)) {
+ if ($filename eq '.' || $filename eq '..') {next;}
+ my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8];
+ if ($curtime-$atime < 3600) { $num_users++; }
+ }
+ closedir(LONIDS);
+ }
+ my $userloadpercent=0;
+ my $maxuserload=$perlvar{'lonUserLoadLim'};
+ if ($maxuserload) {
+ $userloadpercent=100*$num_users/$maxuserload;
+ }
+ return $userloadpercent;
+}
+
# ----------------------------------- POD (plain old documentation, CPAN style)
=head1 NAME