--- loncom/lond 2003/03/01 04:18:22 1.109 +++ loncom/lond 2003/03/25 22:03:23 1.118 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.109 2003/03/01 04:18:22 foxr Exp $ +# $Id: lond,v 1.118 2003/03/25 22:03:23 www 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,6 +197,8 @@ while ($configline=) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); chomp($ip); $ip=~s/\D+$//; $hostid{$ip}=$id; + $hostdom{$id}=$domain; + $hostip{$id}=$ip; if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } $PREFORK++; } @@ -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( -"INFO: Connection $i, $clientip ($hostid{$clientip})" +"INFO: Connection, $clientip ($hostid{$clientip})" ); &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("WARNING: " + ."Bad init message $remotereq, closing connection"); + 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( - "Established connection: $hostid{$clientip}"); + 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("Established connection: $hostid{$clientip}"); &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,55 @@ 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 ". + "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\n"; + ." tie(GDBM) Failed ". + "while attempting rolesdel\n"; } } else { print $client "refused\n"; @@ -1129,11 +1218,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 +1263,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 +1295,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 +1320,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 +1365,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 +1403,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 +1447,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 +1485,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,8 +1531,74 @@ sub make_new_child { } else { print $client "error: ".($!+0) - ." IO::File->new Failed\n"; + ." 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/')) { + $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); @@ -1446,11 +1622,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 +1647,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 +1671,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,9 +1689,23 @@ sub make_new_child { } else { print $client "error: ".($!+0) - ."IO::File->new Failed\n"; + ."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 } elsif ($userinput =~ /^ls/) { my ($cmd,$ulsdir)=split(/:/,$userinput); @@ -1721,20 +1916,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); 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.