--- loncom/lond 2003/03/13 21:01:52 1.113 +++ loncom/lond 2003/06/16 14:23:56 1.131 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.113 2003/03/13 21:01:52 albertel Exp $ +# $Id: lond,v 1.131 2003/06/16 14:23:56 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -52,13 +52,12 @@ # preforking is not really needed. ### - use lib '/home/httpd/lib/perl/'; use LONCAPA::Configuration; use IO::Socket; use IO::File; -use Apache::File; +#use Apache::File; use Symbol; use POSIX; use Crypt::IDEA; @@ -74,6 +73,10 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; +my $VERSION='$Revision: 1.131 $'; #' stupid emacs +my $remoteVERSION; +my $currenthostid; +my $currentdomainid; # # The array below are password error strings." # @@ -169,7 +172,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 +199,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++; } @@ -271,11 +276,11 @@ sub checkchildren { alarm(300); &logthis('Child '.$_.' did not respond'); kill 9 => $_; - $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - $subj="LON: $perlvar{'lonHostID'} 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.$_`; + #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + #$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.$_`; alarm(0); } } @@ -309,7 +314,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(); } { @@ -370,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: " @@ -406,12 +404,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); @@ -538,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 '; @@ -564,15 +564,16 @@ 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/) { + &sethost("sethost:$perlvar{'lonHostID'}"); my $challenge="$$".time; print $client "$challenge\n"; &status( @@ -601,9 +602,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>) { @@ -631,17 +638,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/; @@ -658,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) { @@ -853,7 +864,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); @@ -893,7 +904,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, @@ -1058,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; @@ -1100,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, @@ -1124,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) @@ -1134,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]}&"; } @@ -1166,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]}&"; } @@ -1212,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}); } @@ -1236,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&"; } @@ -1354,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"}++; @@ -1392,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; @@ -1425,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/\:$//; @@ -1459,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); @@ -1473,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; @@ -1498,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]}&"; } @@ -1599,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"; @@ -1710,7 +1833,7 @@ sub addline { } sub getchat { - my ($cdom,$cname)=@_; + my ($cdom,$cname,$udom,$uname)=@_; my %hash; my $proname=&propath($cdom,$cname); my @entries=(); @@ -1719,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 { @@ -1776,20 +1911,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); @@ -1908,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.