--- loncom/lond 2003/03/28 23:16:25 1.124
+++ loncom/lond 2003/10/08 20:37:48 1.155
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.124 2003/03/28 23:16:25 www Exp $
+# $Id: lond,v 1.155 2003/10/08 20:37:48 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -50,14 +50,25 @@
# 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:
+#
+
+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,16 +78,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.124 $'; #' stupid emacs
+my $VERSION='$Revision: 1.155 $'; #' 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."
#
@@ -105,10 +129,10 @@ my @adderrors = ("ok",
"lcuseradd Incorrect number of stdinput lines, must be 3",
"lcuseradd Too many other simultaneous pwd changes in progress",
"lcuseradd User does not exist",
- "lcuseradd Unabel to mak ewww member of users's group",
+ "lcuseradd Unable to make www member of users's group",
"lcuseradd Unable to su to root",
"lcuseradd Unable to set password",
- "lcuseradd Usrname has invbalid charcters",
+ "lcuseradd Usrname has invalid characters",
"lcuseradd Password has an invalid character",
"lcuseradd User already exists",
"lcuseradd Could not add user.",
@@ -116,6 +140,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('<font color="yellow">Authenticating manager'.
+ " $hostentry</font>");
+ return 1;
+ } else {
+ &logthis('<font color="red"> Failed manager authentication '.
+ "$certificate </font>");
+ }
+}
+#
+# 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 <name>.tmp
+# - The <name>.tmp file is then mv'd to <name>
+# 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('<font color="red"> Unable to create '.$TempFile."</font>");
+ 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 <filename.saved>
+# - 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('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
+ return "error:$!";
+ }
+ &logthis('<font color="green"> Pushfile: backed up '
+ .$tablefile." to $backupfile</font>");
+
+ # Install the new file:
+
+ if(!InstallFile($tablefile, $contents)) {
+ &logthis('<font color="red"> Pushfile: unable to install '
+ .$tablefile." $! </font>");
+ return "error:$!";
+ }
+ else {
+ &logthis('<font color="green"> Installed new '.$tablefile
+ ."</font>");
+
+ }
+
+
+ # 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:<process>
+# where <process> 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 = <PIDFILE>;
+ close(PIDFILE);
+ logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
+ ."</font>");
+ kill("USR2", $loncpid);
+ } elsif ($process eq 'lond') {
+ logthis('<font color="red"> Reinitializing self (lond) </font>');
+ &UpdateHosts; # Lond is us!!
+ } else {
+ &logthis('<font color="yellow" Invalid reinit request for '.$process
+ ."</font>");
+ return "error:Invalid process identifier $process";
+ }
+ return 'ok';
+}
+
+#
# Convert an error return code from lcpasswd to a string value.
#
sub lcpasswdstrerror {
@@ -145,7 +415,7 @@ sub catchexception {
$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';
&logthis("<font color=red>CRITICAL: "
- ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
+ ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);
if ($client) { print $client "error: $error\n"; }
@@ -165,14 +435,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;
@@ -189,22 +459,9 @@ 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=<CONFIG>) {
- 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);
# establish SERVER socket, bind and listen.
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
@@ -218,10 +475,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,16 +505,101 @@ sub HUPSMAN { # sig
kill 'INT' => keys %children;
&logthis("Free socket: ".shutdown($server,2)); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");
- unlink("$execdir/logs/lond.pid");
my $execdir=$perlvar{'lonDaemons'};
+ unlink("$execdir/logs/lond.pid");
exec("$execdir/lond"); # here we go again
}
+#
+# Kill off hashes that describe the host table prior to re-reading it.
+# Hashes affected are:
+# %hostid, %hostdom %hostip
+#
+sub KillHostHashes {
+ foreach my $key (keys %hostid) {
+ delete $hostid{$key};
+ }
+ foreach my $key (keys %hostdom) {
+ delete $hostdom{$key};
+ }
+ foreach my $key (keys %hostip) {
+ delete $hostip{$key};
+ }
+}
+#
+# Read in the host table from file and distribute it into the various hashes:
+#
+# - %hostid - Indexed by IP, the loncapa hostname.
+# - %hostdom - Indexed by loncapa hostname, the domain.
+# - %hostip - Indexed by hostid, the Ip address of the host.
+sub ReadHostTable {
+
+ open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
+
+ while (my $configline=<CONFIG>) {
+ 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; }
+ }
+ close(CONFIG);
+}
+#
+# Reload the Apache daemon's state.
+# This is done by invoking /home/httpd/perl/apachereload
+# a setuid perl script that can be root for us to do this job.
+#
+sub ReloadApache {
+ my $execdir = $perlvar{'lonDaemons'};
+ my $script = $execdir."/apachereload";
+ system($script);
+}
+
+#
+# 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('<font color="blue"> Updating connections </font>');
+ #
+ # The %children hash has the set of IP's we currently have children
+ # on. These need to be matched against records in the hosts.tab
+ # Any ip's no longer in the table get killed off they correspond to
+ # either dropped or changed hosts. Note that the re-read of the table
+ # will take care of new and changed hosts as connections come into being.
+
+
+ KillHostHashes;
+ ReadHostTable;
+
+ foreach my $child (keys %children) {
+ my $childip = $children{$child};
+ if(!$hostid{$childip}) {
+ logthis('<font color="blue"> UpdateHosts killing child '
+ ." $child for ip $childip </font>");
+ kill('INT', $child);
+ } else {
+ logthis('<font color="green"> keeping child for ip '
+ ." $childip (pid=$child) </font>");
+ }
+ }
+ ReloadApache;
+}
+
+
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,17 +616,17 @@ 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);
}
}
}
$SIG{ALRM} = 'DEFAULT';
- $SIG{__DIE__} = \&cathcexception;
+ $SIG{__DIE__} = \&catchexception;
}
# --------------------------------------------------------------------- Logging
@@ -331,7 +671,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 +715,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(
- "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
} else {
&logthis(
"<font color=red>CRITICAL: "
@@ -480,7 +813,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 +821,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);
@@ -504,8 +837,11 @@ $SIG{CHLD} = \&REAPER;
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP} = \&HUPSMAN;
$SIG{USR1} = \&checkchildren;
+$SIG{USR2} = \&UpdateHosts;
+# Read the host hashes:
+ReadHostTable;
# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated
@@ -518,7 +854,6 @@ while (1) {
}
sub make_new_child {
- my $client;
my $pid;
my $cipher;
my $sigset;
@@ -529,20 +864,33 @@ 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);
+
+ $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
+ # connection liveness.
+
+ #
+ # Figure out who we're talking to so we can record the peer in
+ # the pid hash.
+ #
+ my $caller = getpeername($client);
+ my ($port,$iaddr)=unpack_sockaddr_in($caller);
+ $clientip=inet_ntoa($iaddr);
if ($pid) {
# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
- $children{$pid} = 1;
+ $children{$pid} = $clientip;
$children++;
&status('Started child '.$pid);
return;
} 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 +900,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();
@@ -561,12 +909,8 @@ sub make_new_child {
# =============================================================================
# do something with the connection
# -----------------------------------------------------------------------------
- $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
- # connection liveness.
- # 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);
+ # see if we know client and check for spoof IP by challenge
+
my $clientrec=($hostid{$clientip} ne undef);
&logthis(
"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
@@ -645,8 +989,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 +1014,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 +1038,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) {
@@ -726,7 +1105,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 +1122,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 +1176,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 +1214,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 +1255,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 +1322,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";
@@ -979,47 +1366,53 @@ sub make_new_child {
}
# -------------------------------------- fetch a user file from a remote server
} elsif ($userinput =~ /^fetchuserfile/) {
- my ($cmd,$fname)=split(/:/,$userinput);
- my ($udom,$uname,$ufile)=split(/\//,$fname);
- my $udir=propath($udom,$uname).'/userfiles';
- unless (-e $udir) { mkdir($udir,0770); }
+ my ($cmd,$fname)=split(/:/,$userinput);
+ my ($udom,$uname,$ufile)=split(/\//,$fname);
+ my $udir=propath($udom,$uname).'/userfiles';
+ unless (-e $udir) { mkdir($udir,0770); }
if (-e $udir) {
- $ufile=~s/^[\.\~]+//;
- $ufile=~s/\///g;
- my $transname=$udir.'/'.$ufile;
- my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
- my $response;
- {
- my $ua=new LWP::UserAgent;
- my $request=new HTTP::Request('GET',"$remoteurl");
- $response=$ua->request($request,$transname);
- }
- if ($response->is_error()) {
- unlink($transname);
- my $message=$response->status_line;
- &logthis(
- "LWP GET: $message for $fname ($remoteurl)");
- print $client "failed\n";
- } else {
- print $client "ok\n";
- }
- } else {
- print $client "not_home\n";
- }
+ $ufile=~s/^[\.\~]+//;
+ $ufile=~s/\///g;
+ my $destname=$udir.'/'.$ufile;
+ my $transname=$udir.'/'.$ufile.'.in.transit';
+ my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
+ my $response;
+ {
+ my $ua=new LWP::UserAgent;
+ my $request=new HTTP::Request('GET',"$remoteurl");
+ $response=$ua->request($request,$transname);
+ }
+ if ($response->is_error()) {
+ unlink($transname);
+ my $message=$response->status_line;
+ &logthis("LWP GET: $message for $fname ($remoteurl)");
+ print $client "failed\n";
+ } else {
+ if (!rename($transname,$destname)) {
+ &logthis("Unable to move $transname to $destname");
+ unlink($transname);
+ print $client "failed\n";
+ } else {
+ print $client "ok\n";
+ }
+ }
+ } else {
+ print $client "not_home\n";
+ }
# ------------------------------------------ authenticate access to a user file
} 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=<ENVIN>) {
- if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
- }
- close(ENVIN);
- print $client $reply."\n";
+ $session.'.id')) {
+ while (my $line=<ENVIN>) {
+ 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 +1463,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 +1506,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 +1552,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 +1582,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 +1615,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 +1662,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 +1687,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 +1713,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 +1764,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 +1807,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 +1846,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 +1924,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 +1955,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 +1996,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 +2022,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 +2115,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 +2191,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 +2238,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;}
@@ -1844,7 +2263,7 @@ sub getchat {
untie %hash;
}
my @participants=();
- $cutoff=time-60;
+ my $cutoff=time-60;
if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
&GDBM_WRCREAT(),0640)) {
$hash{$uname.':'.$udom}=time;
@@ -1863,10 +2282,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';
@@ -1886,6 +2305,12 @@ sub chatadd {
}
untie %hash;
}
+ {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
+ print $hfh "$time:".&unescape($newchat)."\n";
+ }
+ }
}
sub unsub {
@@ -1922,24 +2347,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 {
@@ -1978,7 +2403,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"; }
@@ -2027,7 +2452,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";
@@ -2072,6 +2497,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
@@ -2181,6 +2629,17 @@ each connection is logged.
=item *
+SIGUSR2
+
+Parent Signal assignment:
+ $SIG{USR2} = \&UpdateHosts
+
+Child signal assignment:
+ NONE
+
+
+=item *
+
SIGCHLD
Parent signal assignment:
@@ -2341,6 +2800,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 <tablecontents> \n
+where pushtable, tablename and <tablecontents> 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)
@@ -2351,6 +2821,7 @@ are leaving the network.
If B<lond> 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,