--- loncom/lond 2003/03/26 00:17:04 1.119 +++ loncom/lond 2003/09/23 11:23:31 1.147 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.119 2003/03/26 00:17:04 albertel Exp $ +# $Id: lond,v 1.147 2003/09/23 11:23:31 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -50,14 +50,56 @@ # 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 +# 09/08/2003 Ron Fox: Told lond to take care of change logging so we +# don't have to remember it: +# $Log: lond,v $ +# Revision 1.147 2003/09/23 11:23:31 foxr +# Comlplete implementation of reinit functionality. Must still implement +# the actual initialization functionality, but the process can now +# receive the request and either invoke the appropriate internal function or +# signal the correct lonc. +# +# Revision 1.146 2003/09/16 10:28:14 foxr +# ReinitProcess - decode the process selector and produce the associated pid +# filename. Note: While it is possible to test that valid process selectors are +# handled properly I am not able to test that invalid process selectors produce +# the appropriate error as lonManage also blocks the use of invalid process selectors. +# +# Revision 1.145 2003/09/16 10:13:20 foxr +# Added ReinitProcess function to oversee the parsing and processing of the +# reinit: client request. +# +# Revision 1.144 2003/09/16 09:47:01 foxr +# Added skeletal support for SIGUSR2 (update hosts.tab) +# +# Revision 1.143 2003/09/15 10:03:52 foxr +# Completed and tested code for pushfile. +# +# Revision 1.142 2003/09/09 20:47:46 www +# Permanently store chatroom entries in chatroom.log +# +# Revision 1.141 2003/09/08 10:32:07 foxr +# Added PushFile sub This sub oversees the push of a new configuration table file +# Currently supported files are: +# - hosts.tab (transaction pushfile:hosts:contents) +# - domain.tab (transaction pushfile:domain:contents) +# + +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; @@ -67,14 +109,29 @@ use Authen::Krb4; use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; +use File::Copy; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; +my $VERSION='$Revision: 1.147 $'; #' stupid emacs +my $remoteVERSION; my $currenthostid; my $currentdomainid; + +my $client; +my $clientip; + +my $server; +my $thisserver; + +my %hostid; +my %hostdom; +my %hostip; +my %perlvar; # Will have the apache conf defined perl vars. + # # The array below are password error strings." # @@ -114,6 +171,252 @@ 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 "); + } +} +# +# CopyFile: Called as part of the process of installing a +# new configuration file. This function copies an existing +# file to a backup file. +# Parameters: +# oldfile - Name of the file to backup. +# newfile - Name of the backup file. +# Return: +# 0 - Failure (errno has failure reason). +# 1 - Success. +# +sub CopyFile { + my $oldfile = shift; + my $newfile = shift; + + # The file must exist: + + if(-e $oldfile) { + + # Read the old file. + + my $oldfh = IO::File->new("< $oldfile"); + if(!$oldfh) { + return 0; + } + my @contents = <$oldfh>; # Suck in the entire file. + + # write the backup file: + + my $newfh = IO::File->new("> $newfile"); + if(!(defined $newfh)){ + return 0; + } + my $lines = scalar @contents; + for (my $i =0; $i < $lines; $i++) { + print $newfh ($contents[$i]); + } + + $oldfh->close; + $newfh->close; + + chmod(0660, $newfile); + + return 1; + + } else { + return 0; + } +} + +# +# InstallFile: Called to install an administrative file: +# - The file is created with .tmp +# - The .tmp file is then mv'd to +# This lugubrious procedure is done to ensure that we are never without +# a valid, even if dated, version of the file regardless of who crashes +# and when the crash occurs. +# +# Parameters: +# Name of the file +# File Contents. +# Return: +# nonzero - success. +# 0 - failure and $! has an errno. +# +sub InstallFile { + my $Filename = shift; + my $Contents = shift; + my $TempFile = $Filename.".tmp"; + + # Open the file for write: + + my $fh = IO::File->new("> $TempFile"); # Write to temp. + if(!(defined $fh)) { + &logthis(' Unable to create '.$TempFile.""); + return 0; + } + # write the contents of the file: + + print $fh ($Contents); + $fh->close; # In case we ever have a filesystem w. locking + + chmod(0660, $TempFile); + + # Now we can move install the file in position. + + move($TempFile, $Filename); + + return 1; +} + +# +# PushFile: Called to do an administrative push of a file. +# - Ensure the file being pushed is one we support. +# - Backup the old file to +# - Separate the contents of the new file out from the +# rest of the request. +# - Write the new file. +# Parameter: +# Request - The entire user request. This consists of a : separated +# string pushfile:tablename:contents. +# NOTE: The contents may have :'s in it as well making things a bit +# more interesting... but not much. +# Returns: +# String to send to client ("ok" or "refused" if bad file). +# +sub PushFile { + my $request = shift; + my ($command, $filename, $contents) = split(":", $request, 3); + + # At this point in time, pushes for only the following tables are + # supported: + # hosts.tab ($filename eq host). + # domain.tab ($filename eq domain). + # Construct the destination filename or reject the request. + # + # lonManage is supposed to ensure this, however this session could be + # part of some elaborate spoof that managed somehow to authenticate. + # + + my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir. + if ($filename eq "host") { + $tablefile .= "hosts.tab"; + } elsif ($filename eq "domain") { + $tablefile .= "domain.tab"; + } else { + return "refused"; + } + # + # >copy< the old table to the backup table + # don't rename in case system crashes/reboots etc. in the time + # window between a rename and write. + # + my $backupfile = $tablefile; + $backupfile =~ s/\.tab$/.old/; + if(!CopyFile($tablefile, $backupfile)) { + &logthis(' CopyFile from '.$tablefile." to ".$backupfile." failed "); + return "error:$!"; + } + &logthis(' Pushfile: backed up ' + .$tablefile." to $backupfile"); + + # Install the new file: + + if(!InstallFile($tablefile, $contents)) { + &logthis(' Pushfile: unable to install ' + .$tablefile." $! "); + return "error:$!"; + } + else { + &logthis(' Installed new '.$tablefile + .""); + + } + + + # Indicate success: + + return "ok"; + +} + +# +# Called to re-init either lonc or lond. +# +# Parameters: +# request - The full request by the client. This is of the form +# reinit: +# where is allowed to be either of +# lonc or lond +# +# Returns: +# The string to be sent back to the client either: +# ok - Everything worked just fine. +# error:why - There was a failure and why describes the reason. +# +# +sub ReinitProcess { + my $request = shift; + + + # separate the request (reinit) from the process identifier and + # validate it producing the name of the .pid file for the process. + # + # + my ($junk, $process) = split(":", $request); + my $processpidfile = $perlvar{'lonDaemons'}.'/logs/'; + if($process eq 'lonc') { + $processpidfile = $processpidfile."lonc.pid"; + if (!open(PIDFILE, "< $processpidfile")) { + return "error:Open failed for $processpidfile"; + } + my $loncpid = ; + close(PIDFILE); + logthis(' Reinitializing lonc pid='.$loncpid + .""); + kill("USR2", $loncpid); + } elsif ($process eq 'lond') { + logthis(' Reinitializing self (lond) '); + &UpdateHosts; # Lond is us!! + } else { + &logthis('"); + return "error:Invalid process identifier $process"; + } + return 'ok'; +} + +# # Convert an error return code from lcpasswd to a string value. # sub lcpasswdstrerror { @@ -143,7 +446,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"; } @@ -163,14 +466,14 @@ $SIG{__DIE__}=\&catchexception; # ---------------------------------- Read loncapa_apache.conf and loncapa.conf &status("Read loncapa.conf and loncapa_apache.conf"); my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); -my %perlvar=%{$perlvarref}; +%perlvar=%{$perlvarref}; 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; @@ -187,20 +490,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); @@ -216,10 +516,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; @@ -248,16 +546,30 @@ 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 } +# +# Called in response to a USR2 signal. +# - Reread hosts.tab +# - All children connected to hosts that were removed from hosts.tab +# are killed via SIGINT +# - All children connected to previously existing hosts are sent SIGUSR1 +# - Our internal hosts hash is updated to reflect the new contents of +# hosts.tab causing connections from hosts added to hosts.tab to +# now be honored. +# +sub UpdateHosts { + logthis(' Updating connections '); +} + 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' => $_) { @@ -274,11 +586,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); } } @@ -329,7 +641,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); @@ -373,13 +685,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: " @@ -478,7 +783,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); @@ -486,7 +791,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); @@ -502,7 +807,7 @@ $SIG{CHLD} = \&REAPER; $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; $SIG{USR1} = \&checkchildren; - +$SIG{USR2} = \&UpdateHosts; # -------------------------------------------------------------- @@ -515,24 +820,7 @@ 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; my $cipher; my $sigset; @@ -543,7 +831,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) { @@ -557,6 +845,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 '; @@ -566,7 +856,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(); @@ -580,7 +870,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})" @@ -592,14 +882,7 @@ sub make_new_child { my $remotereq=<$client>; $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; - } + &sethost("sethost:$perlvar{'lonHostID'}"); my $challenge="$$".time; print $client "$challenge\n"; &status( @@ -666,8 +949,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/) { @@ -691,8 +974,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) { @@ -707,6 +998,33 @@ sub make_new_child { } else { print $client "refused\n"; } +#--------------------------------------------------------------------- pushfile + } elsif($userinput =~ /^pushfile/) { + if($wasenc == 1) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + my $reply = PushFile($userinput); + print $client "$reply\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)) { + chomp($userinput); + my $reply = ReinitProcess($userinput); + print $client "$reply\n"; + } else { + print $client "refused\n"; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------ auth } elsif ($userinput =~ /^auth/) { if ($wasenc==1) { @@ -747,7 +1065,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', @@ -764,7 +1082,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; @@ -818,10 +1136,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"; } @@ -848,7 +1174,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 = $?; @@ -889,10 +1215,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)) { @@ -956,11 +1282,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"; @@ -1031,16 +1357,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/) { @@ -1091,9 +1417,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)) { @@ -1133,14 +1460,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"; @@ -1179,10 +1506,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"; @@ -1209,8 +1536,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)) { @@ -1241,8 +1569,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)) { @@ -1287,8 +1616,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)) { @@ -1311,8 +1641,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)) { @@ -1336,6 +1667,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)) { @@ -1386,9 +1718,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 { @@ -1428,15 +1761,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; } @@ -1467,7 +1800,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; @@ -1500,9 +1834,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/\:$//; @@ -1543,9 +1878,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)) { @@ -1573,15 +1909,16 @@ 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); - if (eval('$unescapeVal=~/$description/')) { + if (eval('$unescapeVal=~/$description/i')) { $qresult.="$key=$descr&"; } } @@ -1613,9 +1950,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)) { @@ -1638,17 +1976,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) @@ -1730,6 +2069,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/)) { @@ -1739,6 +2091,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"; @@ -1789,11 +2145,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"); } } @@ -1836,6 +2192,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;} @@ -1850,7 +2207,7 @@ sub addline { } sub getchat { - my ($cdom,$cname)=@_; + my ($cdom,$cname,$udom,$uname)=@_; my %hash; my $proname=&propath($cdom,$cname); my @entries=(); @@ -1859,7 +2216,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 { @@ -1867,10 +2236,10 @@ sub chatadd { my %hash; my $proname=&propath($cdom,$cname); my @entries=(); + my $time=time; if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", &GDBM_WRCREAT(),0640)) { @entries=map { $_.':'.$hash{$_} } sort keys %hash; - my $time=time; my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); my ($thentime,$idnum)=split(/\_/,$lastid); my $newid=$time.'_000000'; @@ -1890,6 +2259,12 @@ sub chatadd { } untie %hash; } + { + my $hfh; + if ($hfh=IO::File->new(">>$proname/chatroom.log")) { + print $hfh "$time:".&unescape($newchat)."\n"; + } + } } sub unsub { @@ -1926,24 +2301,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 { @@ -1982,7 +2357,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"; } @@ -2031,7 +2406,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"; @@ -2054,6 +2429,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 ($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 @@ -2163,6 +2583,17 @@ each connection is logged. =item * +SIGUSR2 + +Parent Signal assignment: + $SIG{USR2} = \&UpdateHosts + +Child signal assignment: + NONE + + +=item * + SIGCHLD Parent signal assignment: @@ -2323,6 +2754,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) @@ -2333,6 +2775,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,