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,
@@ -1157,6 +1135,48 @@ sub make_new_child {
} 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 {
+ print $client "refused\n";
+ }
# ------------------------------------------------------------------------- get
} elsif ($userinput =~ /^get/) {
my ($cmd,$udom,$uname,$namespace,$what)
@@ -1167,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]}&";
}
@@ -1199,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]}&";
}
@@ -1245,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});
}
@@ -1269,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&";
}
@@ -1387,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"}++;
@@ -1425,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;
@@ -1458,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/\:$//;
@@ -1492,6 +1513,71 @@ sub make_new_child {
." 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
} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);
@@ -1506,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;
@@ -1531,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]}&";
}
@@ -1632,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";
@@ -1743,7 +1833,7 @@ sub addline {
}
sub getchat {
- my ($cdom,$cname)=@_;
+ my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();
@@ -1752,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 {
@@ -1947,6 +2049,51 @@ 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) { $numusers++; }
+ }
+ closedir(LONIDS);
+ }
+ my $userloadpercent=0;
+ my $maxuserload=$perlvar{'lonUserLoadLim'};
+ if ($maxuserload) {
+ $userloadpercent=100*$numusers/$maxuserload;
+ }
+ $userloadpercent=sprintf("%.2f",$userloadpercent);
+ return $userloadpercent;
+}
+
# ----------------------------------- POD (plain old documentation, CPAN style)
=head1 NAME
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.