--- loncom/lond 2003/03/28 18:26:28 1.122 +++ loncom/lond 2003/08/26 11:15:57 1.140 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.122 2003/03/28 18:26:28 www Exp $ +# $Id: lond,v 1.140 2003/08/26 11:15:57 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -50,14 +50,22 @@ # population). Since the time averaged connection rate is close to zero # because lonc's purpose is to maintain near continuous connnections, # preforking is not really needed. +# 08/xx/2003 Ron Fox: Add management requests. Management requests +# will be validated via a call to ValidateManager. At present, this +# is done by simple host verification. In the future we can modify +# this function to do a certificate check. +# Management functions supported include: +# - pushing /home/httpd/lonTabs/hosts.tab +# - pushing /home/httpd/lonTabs/domain.tab ### +use strict; 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; @@ -73,10 +81,21 @@ my $DEBUG = 0; # Non zero to ena my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.122 $'; #' stupid emacs +my $VERSION='$Revision: 1.140 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; + +my $client; +my $clientip; + +my $server; +my $thisserver; + +my %hostid; +my %hostdom; +my %hostip; + # # The array below are password error strings." # @@ -116,6 +135,44 @@ my @adderrors = ("ok", # +# GetCertificate: Given a transaction that requires a certificate, +# this function will extract the certificate from the transaction +# request. Note that at this point, the only concept of a certificate +# is the hostname to which we are connected. +# +# Parameter: +# request - The request sent by our client (this parameterization may +# need to change when we really use a certificate granting +# authority. +# +sub GetCertificate { + my $request = shift; + + return $clientip; +} + + +# +# ValidManager: Determines if a given certificate represents a valid manager. +# in this primitive implementation, the 'certificate' is +# just the connecting loncapa client name. This is checked +# against a valid client list in the configuration. +# +# +sub ValidManager { + my $certificate = shift; + + my $hostentry = $hostid{$certificate}; + if ($hostentry ne undef) { + &logthis('Authenticating manager'. + " $hostentry"); + return 1; + } else { + &logthis(' Failed manager authentication '. + "$certificate "); + } +} +# # Convert an error return code from lcpasswd to a string value. # sub lcpasswdstrerror { @@ -145,7 +202,7 @@ sub catchexception { $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; &logthis("CRITICAL: " - ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."ABNORMAL EXIT. Child $$ for server $thisserver died through " ."a crash with this error msg->[$error]"); &logthis('Famous last words: '.$status.' - '.$lastlog); if ($client) { print $client "error: $error\n"; } @@ -171,8 +228,8 @@ undef $perlvarref; # ----------------------------- Make sure this process is running from user=www my $wwwid=getpwnam('www'); if ($wwwid!=$<) { - $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - $subj="LON: $currenthostid User ID mismatch"; + my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + my $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; @@ -189,20 +246,17 @@ if (-e $pidfile) { if (kill 0 => $pide) { die "already running"; } } -$PREFORK=4; # number of children to maintain, at least four spare - # ------------------------------------------------------------- Read hosts file open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; -while ($configline=) { +while (my $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++; } close(CONFIG); @@ -218,10 +272,8 @@ $server = IO::Socket::INET->new(LocalPor # global variables -$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should - # process -%children = (); # keys are current child process IDs -$children = 0; # current number of children +my %children = (); # keys are current child process IDs +my $children = 0; # current number of children sub REAPER { # takes care of dead children $SIG{CHLD} = \&REAPER; @@ -250,8 +302,8 @@ sub HUPSMAN { # sig kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket &logthis("CRITICAL: Restarting"); - unlink("$execdir/logs/lond.pid"); my $execdir=$perlvar{'lonDaemons'}; + unlink("$execdir/logs/lond.pid"); exec("$execdir/lond"); # here we go again } @@ -259,7 +311,7 @@ sub checkchildren { &initnewstatus(); &logstatus(); &logthis('Going to check on the children'); - $docdir=$perlvar{'lonDocRoot'}; + my $docdir=$perlvar{'lonDocRoot'}; foreach (sort keys %children) { sleep 1; unless (kill 'USR1' => $_) { @@ -276,11 +328,11 @@ sub checkchildren { alarm(300); &logthis('Child '.$_.' did not respond'); kill 9 => $_; - $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.$_`; + #$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); } } @@ -331,7 +383,7 @@ sub initnewstatus { my $local=localtime($now); print $fh "LOND status $local - parent $$\n\n"; opendir(DIR,"$docdir/lon-status/londchld"); - while ($filename=readdir(DIR)) { + while (my $filename=readdir(DIR)) { unlink("$docdir/lon-status/londchld/$filename"); } closedir(DIR); @@ -375,13 +427,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: " @@ -480,7 +525,7 @@ sub ishome { # ======================================================= Continue main program # ---------------------------------------------------- Fork once and dissociate -$fpid=fork; +my $fpid=fork; exit if $fpid; die "Couldn't fork: $!" unless defined ($fpid); @@ -488,7 +533,7 @@ POSIX::setsid() or die "Can't start new # ------------------------------------------------------- Write our PID on disk -$execdir=$perlvar{'lonDaemons'}; +my $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lond.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); @@ -518,7 +563,6 @@ while (1) { } sub make_new_child { - my $client; my $pid; my $cipher; my $sigset; @@ -529,7 +573,7 @@ sub make_new_child { $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!\n"; - + die "fork: $!" unless defined ($pid = fork); if ($pid) { @@ -543,6 +587,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 '; @@ -552,7 +598,7 @@ sub make_new_child { sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; - $tmpsnum=0; + my $tmpsnum=0; #---------------------------------------------------- kerberos 5 initialization &Authen::Krb5::init_context(); &Authen::Krb5::init_ets(); @@ -566,7 +612,7 @@ sub make_new_child { # see if we know client and check for spoof IP by challenge my $caller = getpeername($client); my ($port,$iaddr)=unpack_sockaddr_in($caller); - my $clientip=inet_ntoa($iaddr); + $clientip=inet_ntoa($iaddr); my $clientrec=($hostid{$clientip} ne undef); &logthis( "INFO: Connection, $clientip ($hostid{$clientip})" @@ -645,8 +691,8 @@ sub make_new_child { if ($userinput =~ /^ping/) { print $client "$currenthostid\n"; # ------------------------------------------------------------------------ pong - } elsif ($userinput =~ /^pong/) { - $reply=reply("ping",$hostid{$clientip}); + }elsif ($userinput =~ /^pong/) { + my $reply=&reply("ping",$hostid{$clientip}); print $client "$currenthostid:$reply\n"; # ------------------------------------------------------------------------ ekey } elsif ($userinput =~ /^ekey/) { @@ -670,8 +716,16 @@ 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"; + +# +# Transactions requiring encryption: +# # ----------------------------------------------------------------- currentauth } elsif ($userinput =~ /^currentauth/) { if ($wasenc==1) { @@ -686,6 +740,30 @@ sub make_new_child { } else { print $client "refused\n"; } +#--------------------------------------------------------------------- pushfile + } elsif($userinput =~ /^pushfile/) { + if($wasenc == 1) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + print $client "ok\n"; + } else { + print $client "refused\n"; + } + } else { + print $client "refused\n"; + } +#--------------------------------------------------------------------- reinit + } elsif($userinput =~ /^reinit/) { + if ($wasenc == 1) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + print $client "ok\n"; + } else { + print $client "refused\n"; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------ auth } elsif ($userinput =~ /^auth/) { if ($wasenc==1) { @@ -726,7 +804,7 @@ sub make_new_child { } } } elsif ($howpwd eq 'krb4') { - $null=pack("C",0); + my $null=pack("C",0); unless ($upass=~/$null/) { my $krb4_error = &Authen::Krb4::get_pw_in_tkt ($uname,"",$contentpwd,'krbtgt', @@ -743,7 +821,7 @@ sub make_new_child { } } } elsif ($howpwd eq 'krb5') { - $null=pack("C",0); + my $null=pack("C",0); unless ($upass=~/$null/) { my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; @@ -797,10 +875,18 @@ sub make_new_child { my $salt=time; $salt=substr($salt,6,2); my $ncpass=crypt($npass,$salt); - { my $pf = IO::File->new(">$passfilename"); - print $pf "internal:$ncpass\n"; } - &logthis("Result of password change for $uname: pwchange_success"); - print $client "ok\n"; + { + my $pf; + if ($pf = IO::File->new(">$passfilename")) { + print $pf "internal:$ncpass\n"; + &logthis("Result of password change for $uname: pwchange_success"); + print $client "ok\n"; + } else { + &logthis("Unable to open $uname passwd to change password"); + print $client "non_authorized\n"; + } + } + } else { print $client "non_authorized\n"; } @@ -827,7 +913,7 @@ sub make_new_child { if ($pwdcorrect) { my $execdir=$perlvar{'lonDaemons'}; &Debug("Opening lcpasswd pipeline"); - my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log"); + my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log"); print $pf "$uname\n$npass\n$npass\n"; close $pf; my $err = $?; @@ -868,10 +954,10 @@ sub make_new_child { } elsif ($udom ne $currentdomainid) { print $client "not_right_domain\n"; } else { - @fpparts=split(/\//,$proname); - $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; - $fperror=''; - for ($i=3;$i<=$#fpparts;$i++) { + my @fpparts=split(/\//,$proname); + my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; + my $fperror=''; + for (my $i=3;$i<=$#fpparts;$i++) { $fpnow.='/'.$fpparts[$i]; unless (-e $fpnow) { unless (mkdir($fpnow,0777)) { @@ -935,11 +1021,11 @@ sub make_new_child { $uid,$gid,$rdev,$size, $atime,$mtime,$ctime, $blksize,$blocks)=stat($fname); - $now=time; - $since=$now-$atime; + my $now=time; + my $since=$now-$atime; if ($since>$perlvar{'lonExpire'}) { - $reply= - reply("unsub:$fname","$hostid{$clientip}"); + my $reply= + &reply("unsub:$fname","$hostid{$clientip}"); unlink("$fname"); } else { my $transname="$fname.in.transfer"; @@ -1010,16 +1096,16 @@ sub make_new_child { } elsif ($userinput =~ /^tokenauthuserfile/) { my ($cmd,$fname,$session)=split(/:/,$userinput); chomp($session); - $reply='non_auth'; + my $reply='non_auth'; if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. - $session.'.id')) { - while ($line=) { - if ($line=~/userfile\.$fname\=/) { $reply='ok'; } - } - close(ENVIN); - print $client $reply."\n"; + $session.'.id')) { + while (my $line=) { + if ($line=~/userfile\.$fname\=/) { $reply='ok'; } + } + close(ENVIN); + print $client $reply."\n"; } else { - print $client "invalid_token\n"; + print $client "invalid_token\n"; } # ----------------------------------------------------------------- unsubscribe } elsif ($userinput =~ /^unsub/) { @@ -1070,9 +1156,10 @@ 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)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $hash{$key}=$value; } if (untie(%hash)) { @@ -1112,14 +1199,14 @@ sub make_new_child { } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); &ManagePermissions($key, $udom, $uname, &GetAuthType( $udom, $uname)); $hash{$key}=$value; - } if (untie(%hash)) { print $client "ok\n"; @@ -1158,10 +1245,10 @@ sub make_new_child { } } my @rolekeys=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { - foreach $key (@rolekeys) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $key (@rolekeys) { delete $hash{$key}; - } if (untie(%hash)) { print $client "ok\n"; @@ -1188,8 +1275,9 @@ 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)) { - for ($i=0;$i<=$#queries;$i++) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } if (untie(%hash)) { @@ -1220,8 +1308,9 @@ 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)) { - for ($i=0;$i<=$#queries;$i++) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } if (untie(%hash)) { @@ -1266,8 +1355,9 @@ 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)) { - foreach $key (@keys) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $key (@keys) { delete($hash{$key}); } if (untie(%hash)) { @@ -1290,8 +1380,9 @@ 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)) { - foreach $key (keys %hash) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + foreach my $key (keys %hash) { $qresult.="$key&"; } if (untie(%hash)) { @@ -1315,6 +1406,7 @@ sub make_new_child { $namespace=~s/\W//g; my $qresult=''; my $proname=propath($udom,$uname); + my %hash; if (tie(%hash,'GDBM_File', "$proname/$namespace.db", &GDBM_READER(),0640)) { @@ -1365,9 +1457,10 @@ sub make_new_child { } my $qresult=''; my $proname=propath($udom,$uname); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { study($regexp); - while (($key,$value) = each(%hash)) { + while (my ($key,$value) = each(%hash)) { if ($regexp eq '.') { $qresult.=$key.'='.$value.'&'; } else { @@ -1407,15 +1500,15 @@ sub make_new_child { ) { print $hfh "P:$now:$rid:$what\n"; } } my @pairs=split(/\&/,$what); - - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { my @previouskeys=split(/&/,$hash{"keys:$rid"}); my $key; $hash{"version:$rid"}++; my $version=$hash{"version:$rid"}; my $allkeys=''; - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $allkeys.=$key.':'; $hash{"$version:$rid:$key"}=$value; } @@ -1446,7 +1539,8 @@ sub make_new_child { chomp($rid); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { my $version=$hash{"version:$rid"}; $qresult.="version=$version&"; my $scope; @@ -1523,9 +1617,10 @@ sub make_new_child { "$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); + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $hash{$key}=$value.':'.$now; } if (untie(%hash)) { @@ -1553,11 +1648,12 @@ sub make_new_child { 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 %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + while (my ($key,$value) = each(%hash)) { my ($descr,$lasttime)=split(/\:/,$value); if ($lasttime<$since) { next; } - if ($regexp eq '.') { + if ($description eq '.') { $qresult.=$key.'='.$descr.'&'; } else { my $unescapeVal = &unescape($descr); @@ -1593,9 +1689,10 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $hash{$key}=$value; } if (untie(%hash)) { @@ -1618,17 +1715,18 @@ 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)) { - for ($i=0;$i<=$#queries;$i++) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; + $qresult=~s/\&$//; + print $client "$qresult\n"; } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting idget\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting idget\n"; } } else { print $client "error: ".($!+0) @@ -1710,6 +1808,19 @@ sub make_new_child { } if ($ulsout eq '') { $ulsout='empty'; } print $client "$ulsout\n"; +# ----------------------------------------------------------------- setannounce + } elsif ($userinput =~ /^setannounce/) { + my ($cmd,$announcement)=split(/:/,$userinput); + chomp($announcement); + $announcement=&unescape($announcement); + if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. + '/announcement.txt')) { + print $store $announcement; + close $store; + print $client "ok\n"; + } else { + print $client "error: ".($!+0)."\n"; + } # ------------------------------------------------------------------ Hanging up } elsif (($userinput =~ /^exit/) || ($userinput =~ /^init/)) { @@ -1773,11 +1884,11 @@ sub ManagePermissions my $authtype= shift; # See if the request is of the form /$domain/_au - + &logthis("ruequest is $request"); if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... my $execdir = $perlvar{'lonDaemons'}; my $userhome= "/home/$user" ; - Debug("system $execdir/lchtmldir $userhome $system $authtype"); + &logthis("system $execdir/lchtmldir $userhome $user $authtype"); system("$execdir/lchtmldir $userhome $user $authtype"); } } @@ -1820,6 +1931,7 @@ sub addline { my $found=0; my $expr='^'.$hostid.':'.$ip.':'; $expr =~ s/\./\\\./g; + my $sh; if ($sh=IO::File->new("$fname.subscription")) { while (my $subline=<$sh>) { if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} @@ -1843,7 +1955,19 @@ sub getchat { @entries=map { $_.':'.$hash{$_} } sort keys %hash; untie %hash; } - return @entries; + my @participants=(); + my $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 { @@ -1910,24 +2034,24 @@ sub currentversion { } if (-e $fname) { $version=1; } if (-e $ulsdir) { - if(-d $ulsdir) { - if (opendir(LSDIR,$ulsdir)) { - - while ($ulsfn=readdir(LSDIR)) { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + my $ulsfn; + while ($ulsfn=readdir(LSDIR)) { # see if this is a regular file (ignore links produced earlier) - my $thisfile=$ulsdir.'/'.$ulsfn; - unless (-l $thisfile) { - if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { - if ($1>$version) { $version=$1; } - } - } - } - closedir(LSDIR); - $version++; - } - } - } - return $version; + my $thisfile=$ulsdir.'/'.$ulsfn; + unless (-l $thisfile) { + if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { + if ($1>$version) { $version=$1; } + } + } + } + closedir(LSDIR); + $version++; + } + } + } + return $version; } sub thisversion { @@ -1966,7 +2090,7 @@ sub subscribe { $result="directory\n"; } else { if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} - $now=time; + my $now=time; my $found=&addline($fname,$hostid{$clientip},$clientip, "$hostid{$clientip}:$clientip:$now\n"); if ($found) { $result="$fname\n"; } @@ -2015,7 +2139,7 @@ sub make_passwd_file { { &Debug("Executing external: ".$execpath); &Debug("user = ".$uname.", Password =". $npass); - my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log"); + my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); print $se "$uname\n"; print $se "$npass\n"; print $se "$npass\n"; @@ -2060,6 +2184,29 @@ sub version { 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 ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 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 @@ -2329,6 +2476,17 @@ Send along temporarily stored informatio List part of a user's directory. +=item pushtable + +Pushes a file in /home/httpd/lonTab directory. Currently limited to: +hosts.tab and domain.tab. The old file is copied to *.tab.backup but +must be restored manually in case of a problem with the new table file. +pushtable requires that the request be encrypted and validated via +ValidateManager. The form of the command is: +enc:pushtable tablename \n +where pushtable, tablename and will be encrypted, but \n is a +cleartext newline. + =item Hanging up (exit or init) What to do when a client tells the server that they (the client) @@ -2339,6 +2497,7 @@ are leaving the network. If B is sent an unknown command (not in the list above), it replys to the client "unknown_cmd". + =item UNKNOWN CLIENT If the anti-spoofing algorithm cannot verify the client,