--- loncom/lond 2003/03/02 03:58:55 1.110
+++ loncom/lond 2003/03/18 22:51:03 1.115
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.110 2003/03/02 03:58:55 www Exp $
+# $Id: lond,v 1.115 2003/03/18 22:51:03 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -52,7 +52,6 @@
# preforking is not really needed.
###
-
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
@@ -74,6 +73,8 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
+my $currenthostid;
+my $currentdomainid;
#
# The array below are password error strings."
#
@@ -169,7 +170,7 @@ undef $perlvarref;
my $wwwid=getpwnam('www');
if ($wwwid!=$<) {
$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.' |\
mailto $emailto -s '$subj' > /dev/null");
exit 1;
@@ -196,7 +197,9 @@ while ($configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
chomp($ip); $ip=~s/\D+$//;
$hostid{$ip}=$id;
- if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
+ $hostdom{$id}=$domain;
+ $hostip{$id}=$ip;
+ if ($id eq $perlvar{'lonHostId'}) { $thisserver=$name; }
$PREFORK++;
}
close(CONFIG);
@@ -263,17 +266,25 @@ sub checkchildren {
}
}
sleep 5;
+ $SIG{ALRM} = sub { die "timeout" };
+ $SIG{__DIE__} = 'DEFAULT';
foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {
+ eval {
+ alarm(300);
&logthis('Child '.$_.' did not respond');
kill 9 => $_;
$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`;
$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
@@ -301,7 +312,7 @@ sub logstatus {
my $docdir=$perlvar{'lonDocRoot'};
{
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();
}
{
@@ -398,12 +409,12 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
my $answer;
- if ($server ne $perlvar{'lonHostID'}) {
+ if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
$answer=subreply("ping",$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");
}
$answer=subreply($cmd,$server);
@@ -504,6 +515,22 @@ 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;
@@ -556,15 +583,23 @@ sub make_new_child {
my $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);
&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})");
my $clientok;
if ($clientrec) {
&status("Waiting for init from $clientip ($hostid{$clientip})");
my $remotereq=<$client>;
- $remotereq=~s/\W//g;
- if ($remotereq eq 'init') {
+ $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("<font color=blue>WARNING: "
+ ."Bad init message $remotereq, closing connection</font>");
+ exit;
+ }
my $challenge="$$".time;
print $client "$challenge\n";
&status(
@@ -593,9 +628,15 @@ sub make_new_child {
if ($clientok) {
# ---------------- New known client connecting, could mean machine online again
- &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
- &logthis(
- "<font color=green>Established connection: $hostid{$clientip}</font>");
+ foreach my $id (keys(%hostip)) {
+ if ($hostip{$id} ne $clientip ||
+ $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});
# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {
@@ -623,17 +664,17 @@ sub make_new_child {
# ------------------------------------------------------------- Normal commands
# ------------------------------------------------------------------------ ping
if ($userinput =~ /^ping/) {
- print $client "$perlvar{'lonHostID'}\n";
+ print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong
} elsif ($userinput =~ /^pong/) {
$reply=reply("ping",$hostid{$clientip});
- print $client "$perlvar{'lonHostID'}:$reply\n";
+ print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {
my $buildkey=time.$$.int(rand 100000);
$buildkey=~tr/1-6/A-F/;
$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/G-P/0-9/;
$key=~tr/Q-Z/0-9/;
@@ -845,7 +886,7 @@ sub make_new_child {
$passfilename);
if (-e $passfilename) {
print $client "already_exists\n";
- } elsif ($udom ne $perlvar{'lonDefDomain'}) {
+ } elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
@fpparts=split(/\//,$proname);
@@ -856,7 +897,8 @@ sub make_new_child {
unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)
- ." mkdir failed\n";
+ ." mkdir failed while attempting "
+ ."makeuser\n";
}
}
}
@@ -884,7 +926,7 @@ sub make_new_child {
$npass=&unescape($npass);
my $proname=&propath($udom,$uname);
my $passfilename="$proname/passwd";
- if ($udom ne $perlvar{'lonDefDomain'}) {
+ if ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
my $result=&make_passwd_file($uname, $umode,$npass,
@@ -1028,7 +1070,8 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." IO::File->new Failed\n";
+ ." IO::File->new Failed "
+ ."while attempting log\n";
}
}
# ------------------------------------------------------------------------- put
@@ -1057,11 +1100,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) failed\n";
+ ." untie(GDBM) failed ".
+ "while attempting put\n";
}
} else {
print $client "error: ".($!)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting put\n";
}
} else {
print $client "refused\n";
@@ -1101,11 +1146,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting rolesput\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting rolesput\n";
}
} else {
print $client "refused\n";
@@ -1129,11 +1176,18 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting get\n";
}
} else {
- print $client "error: ".($!+0)
- ." tie(GDBM) Failed\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
} elsif ($userinput =~ /^eget/) {
@@ -1167,11 +1221,13 @@ sub make_new_child {
}
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting eget\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting eget\n";
}
# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {
@@ -1197,11 +1253,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting del\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting del\n";
}
# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {
@@ -1220,11 +1278,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting keys\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting keys\n";
}
# ----------------------------------------------------------------- dumpcurrent
} elsif ($userinput =~ /^currentdump/) {
@@ -1263,11 +1323,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {
@@ -1299,11 +1361,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting dump\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting dump\n";
}
# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {
@@ -1341,11 +1405,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
print $client "refused\n";
@@ -1377,11 +1443,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting restore\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting restore\n";
}
# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {
@@ -1421,7 +1489,8 @@ sub make_new_child {
}
else {
print $client "error: ".($!+0)
- ." IO::File->new Failed\n";
+ ." IO::File->new Failed ".
+ "while attempting queryreply\n";
}
# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {
@@ -1446,11 +1515,13 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting idput\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting idput\n";
}
# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {
@@ -1469,11 +1540,13 @@ sub make_new_child {
print $client "$qresult\n";
} else {
print $client "error: ".($!+0)
- ." untie(GDBM) Failed\n";
+ ." untie(GDBM) Failed ".
+ "while attempting idget\n";
}
} else {
print $client "error: ".($!+0)
- ." tie(GDBM) Failed\n";
+ ." tie(GDBM) Failed ".
+ "while attempting idget\n";
}
# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {
@@ -1491,7 +1564,8 @@ sub make_new_child {
}
else {
print $client "error: ".($!+0)
- ."IO::File->new Failed\n";
+ ."IO::File->new Failed ".
+ "while attempting tmpput\n";
}
# ---------------------------------------------------------------------- tmpget
@@ -1508,7 +1582,8 @@ sub make_new_child {
}
else {
print $client "error: ".($!+0)
- ."IO::File->new Failed\n";
+ ."IO::File->new Failed ".
+ "while attempting tmpget\n";
}
# ---------------------------------------------------------------------- tmpdel
@@ -1521,7 +1596,8 @@ sub make_new_child {
print $client "ok\n";
} else {
print $client "error: ".($!+0)
- ."Unlink tmp Failed\n";
+ ."Unlink tmp Failed ".
+ "while attempting tmpdel\n";
}
# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {
@@ -1733,20 +1809,26 @@ sub currentversion {
if ($fname=~/^(.+)\/[^\/]+$/) {
$ulsdir=$1;
}
+ my ($fnamere1,$fnamere2);
+ # remove version if already specified
$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 $ulsdir) {
if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {
+
while ($ulsfn=readdir(LSDIR)) {
# see if this is a regular file (ignore links produced earlier)
my $thisfile=$ulsdir.'/'.$ulsfn;
unless (-l $thisfile) {
- if ($thisfile=~/$fname/) {
- if ($1>$version) { $version=$1; }
- }
+ if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
+ if ($1>$version) { $version=$1; }
+ }
}
}
closedir(LSDIR);