--- 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);