--- loncom/lond 2002/09/09 14:04:02 1.95
+++ loncom/lond 2003/09/16 10:28:14 1.146
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.95 2002/09/09 14:04:02 harris41 Exp $
+# $Id: lond,v 1.146 2003/09/16 10:28:14 foxr Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,43 +31,69 @@
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
# 03/07,05/31 Gerd Kortemeyer
-# 06/26 Scott Harrison
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
-# 12/05 Scott Harrison
# 12/05,12/13,12/29 Gerd Kortemeyer
# YEAR=2001
-# Jan 01 Scott Harrison
# 02/12 Gerd Kortemeyer
-# 03/15 Scott Harrison
# 03/24 Gerd Kortemeyer
-# 04/02 Scott Harrison
# 05/11,05/28,08/30 Gerd Kortemeyer
-# 9/30,10/22,11/13,11/15,11/16 Scott Harrison
# 11/26,11/27 Gerd Kortemeyer
-# 12/20 Scott Harrison
# 12/22 Gerd Kortemeyer
# YEAR=2002
# 01/20/02,02/05 Gerd Kortemeyer
# 02/05 Guy Albertelli
-# 02/07 Scott Harrison
# 02/12 Gerd Kortemeyer
# 02/19 Matthew Hall
# 02/25 Gerd Kortemeyer
-# 05/11 Scott Harrison
-###
+# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon
+# logic simpler (and there were problems maintaining the preforked
+# 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.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:<process> 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)
+#
-# based on "Perl Cookbook" ISBN 1-56592-243-3
-# preforker - server who forks first
-# runs as a daemon
-# HUPs
-# uses IDEA encryption
+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;
@@ -77,19 +103,336 @@ 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.146 $'; #' 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."
+#
+my $lastpwderror = 13; # Largest error number from lcpasswd.
+my @passwderrors = ("ok",
+ "lcpasswd must be run as user 'www'",
+ "lcpasswd got incorrect number of arguments",
+ "lcpasswd did not get the right nubmer of input text lines",
+ "lcpasswd too many simultaneous pwd changes in progress",
+ "lcpasswd User does not exist.",
+ "lcpasswd Incorrect current passwd",
+ "lcpasswd Unable to su to root.",
+ "lcpasswd Cannot set new passwd.",
+ "lcpasswd Username has invalid characters",
+ "lcpasswd Invalid characters in password",
+ "11", "12",
+ "lcpasswd Password mismatch");
+
+
+# The array below are lcuseradd error strings.:
+
+my $lastadderror = 13;
+my @adderrors = ("ok",
+ "User ID mismatch, lcuseradd must run as user www",
+ "lcuseradd Incorrect number of command line parameters must be 3",
+ "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 su to root",
+ "lcuseradd Unable to set password",
+ "lcuseradd Usrname has invbalid charcters",
+ "lcuseradd Password has an invalid character",
+ "lcuseradd User already exists",
+ "lcuseradd Could not add user.",
+ "lcuseradd Password mismatch");
+
+
+#
+# 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'}.'/';
+ if($process eq 'lonc') {
+ $processpidfile = $processpidfile."lonc.pid";
+ } elsif ($process eq 'lond') {
+ $processpidfile = $processpidfile."lond.pid";
+ } else {
+ &logthis('<font color="yellow" Invalid reinit request for '.$process
+ ."</font>");
+ return "error:Invalid process identifier $process";
+ }
+ &logthis('<font color="red"> Reinitializing '.$process." </font>");
+ return 'ok';
+}
+
+#
+# Convert an error return code from lcpasswd to a string value.
+#
+sub lcpasswdstrerror {
+ my $ErrorCode = shift;
+ if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
+ return "lcpasswd Unrecognized error return value ".$ErrorCode;
+ } else {
+ return $passwderrors[$ErrorCode];
+ }
+}
+
+#
+# Convert an error return code from lcuseradd to a string value:
+#
+sub lcuseraddstrerror {
+ my $ErrorCode = shift;
+ if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
+ return "lcuseradd - Unrecognized error code: ".$ErrorCode;
+ } else {
+ return $adderrors[$ErrorCode];
+ }
+}
+
# grabs exception and records it to log before exiting
sub catchexception {
my ($error)=@_;
$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"; }
@@ -109,14 +452,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: $perlvar{'lonHostID'} 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;
@@ -133,18 +476,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=<CONFIG>) {
+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; }
- $PREFORK++;
}
close(CONFIG);
@@ -160,10 +502,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;
@@ -192,16 +532,29 @@ 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
}
+#
+# 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 {
+}
+
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' => $_) {
@@ -210,17 +563,25 @@ sub checkchildren {
}
}
sleep 5;
+ $SIG{ALRM} = sub { die "timeout" };
+ $SIG{__DIE__} = 'DEFAULT';
foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {
+ eval {
+ alarm(300);
&logthis('Child '.$_.' did not respond');
kill 9 => $_;
- $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
- $subj="LON: $perlvar{'lonHostID'} killed lond process $_";
- 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;
}
# --------------------------------------------------------------------- Logging
@@ -248,7 +609,7 @@ sub logstatus {
my $docdir=$perlvar{'lonDocRoot'};
{
my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
- print $fh $$."\t".$status."\t".$lastlog."\n";
+ print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
$fh->close();
}
{
@@ -265,7 +626,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);
@@ -278,6 +639,7 @@ sub status {
my $now=time;
my $local=localtime($now);
$status=$local.': '.$what;
+ $0='lond: '.$what.' '.$local;
}
# -------------------------------------------------------- Escape Special Chars
@@ -308,13 +670,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: "
@@ -344,12 +699,12 @@ sub subreply {
sub reply {
my ($cmd,$server)=@_;
my $answer;
- if ($server ne $perlvar{'lonHostID'}) {
+ if ($server ne $currenthostid) {
$answer=subreply($cmd,$server);
if ($answer eq 'con_lost') {
$answer=subreply("ping",$server);
if ($answer ne $server) {
- &logthis("sub reply: answer != server");
+ &logthis("sub reply: answer != server answer is $answer, server is $server");
&reconlonc("$perlvar{'lonSockDir'}/$server");
}
$answer=subreply($cmd,$server);
@@ -413,7 +768,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);
@@ -421,50 +776,47 @@ 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);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');
-# ------------------------------------------------------- Now we are on our own
-
-# Fork off our children.
-for (1 .. $PREFORK) {
- make_new_child();
-}
+
# ----------------------------------------------------- Install signal handlers
-&status('Forked children');
$SIG{CHLD} = \&REAPER;
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP} = \&HUPSMAN;
$SIG{USR1} = \&checkchildren;
+$SIG{USR2} = \&UpdateHosts;
+
+
+# --------------------------------------------------------------
+# Accept connections. When a connection comes in, it is validated
+# and if good, a child process is created to process transactions
+# along the connection.
-# And maintain the population.
while (1) {
- &status('Sleeping');
- sleep; # wait for a signal (i.e., child's death)
- &logthis('Woke up');
- &status('Woke up');
- for ($i = $children; $i < $PREFORK; $i++) {
- make_new_child(); # top up the child pool
- }
+ $client = $server->accept() or next;
+ make_new_child($client);
}
sub make_new_child {
my $pid;
my $cipher;
my $sigset;
+
+ $client = shift;
&logthis("Attempting to start child");
# block signal for fork
$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) {
@@ -478,6 +830,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 ';
@@ -487,15 +841,11 @@ 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();
- # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
- for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
- &status('Idle, waiting for connection');
- $client = $server->accept() or last;
&status('Accepted connection');
# =============================================================================
# do something with the connection
@@ -503,20 +853,21 @@ sub make_new_child {
$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 $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(
-"<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"
+"<font color=yellow>INFO: Connection, $clientip ($hostid{$clientip})</font>"
);
&status("Connecting $clientip ($hostid{$clientip})");
my $clientok;
if ($clientrec) {
&status("Waiting for init from $clientip ($hostid{$clientip})");
my $remotereq=<$client>;
- $remotereq=~s/\W//g;
- if ($remotereq eq 'init') {
+ $remotereq=~s/[^\w:]//g;
+ if ($remotereq =~ /^init/) {
+ &sethost("sethost:$perlvar{'lonHostID'}");
my $challenge="$$".time;
print $client "$challenge\n";
&status(
@@ -545,9 +896,15 @@ sub make_new_child {
if ($clientok) {
# ---------------- New known client connecting, could mean machine online again
- &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
- &logthis(
- "<font color=green>Established connection: $hostid{$clientip}</font>");
+ foreach my $id (keys(%hostip)) {
+ if ($hostip{$id} ne $clientip ||
+ $hostip{$currenthostid} eq $clientip) {
+ # no need to try to do recon's to myself
+ next;
+ }
+ &reconlonc("$perlvar{'lonSockDir'}/$id");
+ }
+ &logthis("<font color=green>Established connection: $hostid{$clientip}</font>");
&status('Will listen to '.$hostid{$clientip});
# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {
@@ -575,17 +932,17 @@ sub make_new_child {
# ------------------------------------------------------------- Normal commands
# ------------------------------------------------------------------------ ping
if ($userinput =~ /^ping/) {
- print $client "$perlvar{'lonHostID'}\n";
+ print $client "$currenthostid\n";
# ------------------------------------------------------------------------ pong
- } elsif ($userinput =~ /^pong/) {
- $reply=reply("ping",$hostid{$clientip});
- print $client "$perlvar{'lonHostID'}:$reply\n";
+ }elsif ($userinput =~ /^pong/) {
+ my $reply=&reply("ping",$hostid{$clientip});
+ print $client "$currenthostid:$reply\n";
# ------------------------------------------------------------------------ ekey
} elsif ($userinput =~ /^ekey/) {
my $buildkey=time.$$.int(rand 100000);
$buildkey=~tr/1-6/A-F/;
$buildkey=int(rand 100000).$buildkey.int(rand 100000);
- my $key=$perlvar{'lonHostID'}.$hostid{$clientip};
+ my $key=$currenthostid.$hostid{$clientip};
$key=~tr/a-z/A-Z/;
$key=~tr/G-P/0-9/;
$key=~tr/Q-Z/0-9/;
@@ -602,8 +959,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) {
@@ -618,6 +983,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) {
@@ -633,15 +1025,22 @@ sub make_new_child {
my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
my $pwdcorrect=0;
if ($howpwd eq 'internal') {
+ &Debug("Internal auth");
$pwdcorrect=
(crypt($upass,$contentpwd) eq $contentpwd);
} elsif ($howpwd eq 'unix') {
- $contentpwd=(getpwnam($uname))[1];
- my $pwauth_path="/usr/local/sbin/pwauth";
- unless ($contentpwd eq 'x') {
- $pwdcorrect=
- (crypt($upass,$contentpwd) eq $contentpwd);
- }
+ &Debug("Unix auth");
+ if((getpwnam($uname))[1] eq "") { #no such user!
+ $pwdcorrect = 0;
+ } else {
+ $contentpwd=(getpwnam($uname))[1];
+ my $pwauth_path="/usr/local/sbin/pwauth";
+ unless ($contentpwd eq 'x') {
+ $pwdcorrect=
+ (crypt($upass,$contentpwd) eq
+ $contentpwd);
+ }
+
elsif (-e $pwauth_path) {
open PWAUTH, "|$pwauth_path" or
die "Cannot invoke authentication";
@@ -649,16 +1048,26 @@ sub make_new_child {
close PWAUTH;
$pwdcorrect=!$?;
}
+ }
} elsif ($howpwd eq 'krb4') {
- $null=pack("C",0);
- unless ($upass=~/$null/) {
- $pwdcorrect=(
- Authen::Krb4::get_pw_in_tkt($uname,"",
- $contentpwd,'krbtgt',$contentpwd,1,
- $upass) == 0);
- } else { $pwdcorrect=0; }
+ my $null=pack("C",0);
+ unless ($upass=~/$null/) {
+ my $krb4_error = &Authen::Krb4::get_pw_in_tkt
+ ($uname,"",$contentpwd,'krbtgt',
+ $contentpwd,1,$upass);
+ if (!$krb4_error) {
+ $pwdcorrect = 1;
+ } else {
+ $pwdcorrect=0;
+ # log error if it is not a bad password
+ if ($krb4_error != 62) {
+ &logthis('krb4:'.$uname.','.$contentpwd.','.
+ &Authen::Krb4::get_err_txt($Authen::Krb4::error));
+ }
+ }
+ }
} 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;
@@ -697,7 +1106,7 @@ sub make_new_child {
chomp($npass);
$upass=&unescape($upass);
$npass=&unescape($npass);
- &logthis("Trying to change password for $uname");
+ &Debug("Trying to change password for $uname");
my $proname=propath($udom,$uname);
my $passfilename="$proname/passwd";
if (-e $passfilename) {
@@ -707,14 +1116,23 @@ sub make_new_child {
chomp($realpasswd);
my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
if ($howpwd eq 'internal') {
+ &Debug("internal auth");
if (crypt($upass,$contentpwd) eq $contentpwd) {
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";
}
@@ -723,6 +1141,7 @@ sub make_new_child {
# one way or another.
# First: Make sure the current password is
# correct
+ &Debug("auth is unix");
$contentpwd=(getpwnam($uname))[1];
my $pwdcorrect = "0";
my $pwauth_path="/usr/local/sbin/pwauth";
@@ -734,16 +1153,20 @@ sub make_new_child {
die "Cannot invoke authentication";
print PWAUTH "$uname\n$upass\n";
close PWAUTH;
- $pwdcorrect=!$?;
+ &Debug("exited pwauth with $? ($uname,$upass) ");
+ $pwdcorrect=($? == 0);
}
if ($pwdcorrect) {
my $execdir=$perlvar{'lonDaemons'};
- my $pf = IO::File->new("|$execdir/lcpasswd");
+ &Debug("Opening lcpasswd pipeline");
+ my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");
print $pf "$uname\n$npass\n$npass\n";
close $pf;
- my $result = ($?>0 ? 'pwchange_failure'
+ my $err = $?;
+ my $result = ($err>0 ? 'pwchange_failure'
: 'ok');
- &logthis("Result of password change for $uname: $result");
+ &logthis("Result of password change for $uname: ".
+ &lcpasswdstrerror($?));
print $client "$result\n";
} else {
print $client "non_authorized\n";
@@ -774,22 +1197,24 @@ sub make_new_child {
$passfilename);
if (-e $passfilename) {
print $client "already_exists\n";
- } elsif ($udom ne $perlvar{'lonDefDomain'}) {
+ } elsif ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
- @fpparts=split(/\//,$proname);
- $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)) {
- $fperror="error:$!";
+ $fperror="error: ".($!+0)
+ ." mkdir failed while attempting "
+ ."makeuser\n";
}
}
}
unless ($fperror) {
- my $result=&make_passwd_file($umode,$npass,
+ my $result=&make_passwd_file($uname, $umode,$npass,
$passfilename);
print $client $result;
} else {
@@ -812,10 +1237,10 @@ sub make_new_child {
$npass=&unescape($npass);
my $proname=&propath($udom,$uname);
my $passfilename="$proname/passwd";
- if ($udom ne $perlvar{'lonDefDomain'}) {
+ if ($udom ne $currentdomainid) {
print $client "not_right_domain\n";
} else {
- my $result=&make_passwd_file($umode,$npass,
+ my $result=&make_passwd_file($uname, $umode,$npass,
$passfilename);
print $client $result;
}
@@ -842,11 +1267,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";
@@ -917,16 +1342,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=<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/) {
@@ -939,6 +1364,10 @@ sub make_new_child {
# ------------------------------------------------------------------- subscribe
} elsif ($userinput =~ /^sub/) {
print $client &subscribe($userinput,$clientip);
+# ------------------------------------------------------------- current version
+ } elsif ($userinput =~ /^currentversion/) {
+ my ($cmd,$fname)=split(/:/,$userinput);
+ print $client ¤tversion($fname)."\n";
# ------------------------------------------------------------------------- log
} elsif ($userinput =~ /^log/) {
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
@@ -951,7 +1380,9 @@ sub make_new_child {
print $hfh "$now:$hostid{$clientip}:$what\n";
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." IO::File->new Failed "
+ ."while attempting log\n";
}
}
# ------------------------------------------------------------------------- put
@@ -971,18 +1402,23 @@ 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)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) failed ".
+ "while attempting put\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!)
+ ." tie(GDBM) Failed ".
+ "while attempting put\n";
}
} else {
print $client "refused\n";
@@ -1009,22 +1445,68 @@ 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";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting rolesput\n";
+ }
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting rolesput\n";
+ }
+ } else {
+ print $client "refused\n";
+ }
+# -------------------------------------------------------------------- rolesdel
+ } elsif ($userinput =~ /^rolesdel/) {
+ &Debug("rolesdel");
+ if ($wasenc==1) {
+ my ($cmd,$exedom,$exeuser,$udom,$uname,$what)
+ =split(/:/,$userinput);
+ &Debug("cmd = ".$cmd." exedom= ".$exedom.
+ "user = ".$exeuser." udom=".$udom.
+ "what = ".$what);
+ my $namespace='roles';
+ chomp($what);
+ my $proname=propath($udom,$uname);
+ my $now=time;
+ {
+ my $hfh;
+ if (
+ $hfh=IO::File->new(">>$proname/$namespace.hist")
+ ) {
+ print $hfh "D:$now:$exedom:$exeuser:$what\n";
+ }
+ }
+ my @rolekeys=split(/\&/,$what);
+ 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";
+ } else {
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting rolesdel\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting rolesdel\n";
}
} else {
print $client "refused\n";
@@ -1039,18 +1521,28 @@ 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)) {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting get\n";
}
} else {
- print $client "error:$!\n";
+ if ($!+0 == 2) {
+ print $client "error:No such file or ".
+ "GDBM reported bad block error\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting get\n";
+ }
}
# ------------------------------------------------------------------------ eget
} elsif ($userinput =~ /^eget/) {
@@ -1062,8 +1554,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)) {
@@ -1083,10 +1576,14 @@ sub make_new_child {
print $client "error:no_key\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting eget\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting eget\n";
}
# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {
@@ -1104,17 +1601,22 @@ 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)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting del\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting del\n";
}
# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {
@@ -1124,18 +1626,69 @@ 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)) {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting keys\n";
+ }
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting keys\n";
+ }
+# ----------------------------------------------------------------- dumpcurrent
+ } elsif ($userinput =~ /^currentdump/) {
+ my ($cmd,$udom,$uname,$namespace)
+ =split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ my $qresult='';
+ my $proname=propath($udom,$uname);
+ my %hash;
+ if (tie(%hash,'GDBM_File',
+ "$proname/$namespace.db",
+ &GDBM_READER(),0640)) {
+ # Structure of %data:
+ # $data{$symb}->{$parameter}=$value;
+ # $data{$symb}->{'v.'.$parameter}=$version;
+ # since $parameter will be unescaped, we do not
+ # have to worry about silly parameter names...
+ my %data = ();
+ while (my ($key,$value) = each(%hash)) {
+ my ($v,$symb,$param) = split(/:/,$key);
+ next if ($v eq 'version' || $symb eq 'keys');
+ next if (exists($data{$symb}) &&
+ exists($data{$symb}->{$param}) &&
+ $data{$symb}->{'v.'.$param} > $v);
+ $data{$symb}->{$param}=$value;
+ $data{$symb}->{'v.'.$param}=$v;
+ }
+ if (untie(%hash)) {
+ while (my ($symb,$param_hash) = each(%data)) {
+ while(my ($param,$value) = each (%$param_hash)){
+ next if ($param =~ /^v\./);
+ $qresult.=$symb.':'.$param.'='.$value.'&';
+ }
+ }
+ chop($qresult);
+ print $client "$qresult\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {
@@ -1148,24 +1701,33 @@ sub make_new_child {
} else {
$regexp='.';
}
- my $proname=propath($udom,$uname);
my $qresult='';
- if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
+ my $proname=propath($udom,$uname);
+ my %hash;
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);
- foreach $key (keys %hash) {
- my $unescapeKey = &unescape($key);
- if (eval('$unescapeKey=~/$regexp/')) {
- $qresult.="$key=$hash{$key}&";
- }
+ while (my ($key,$value) = each(%hash)) {
+ if ($regexp eq '.') {
+ $qresult.=$key.'='.$value.'&';
+ } else {
+ my $unescapeKey = &unescape($key);
+ if (eval('$unescapeKey=~/$regexp/')) {
+ $qresult.="$key=$value&";
+ }
+ }
}
- if (untie(%hash)) {
- $qresult=~s/\&$//;
- print $client "$qresult\n";
+ if (untie(%hash)) {
+ chop($qresult);
+ print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting dump\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting dump\n";
}
# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {
@@ -1184,15 +1746,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;
}
@@ -1202,10 +1764,14 @@ sub make_new_child {
if (untie(%hash)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
print $client "refused\n";
@@ -1219,7 +1785,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;
@@ -1236,10 +1803,14 @@ sub make_new_child {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting restore\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting restore\n";
}
# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {
@@ -1248,9 +1819,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/\:$//;
@@ -1278,8 +1850,77 @@ sub make_new_child {
print $client "ok\n";
}
else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." IO::File->new Failed ".
+ "while attempting queryreply\n";
}
+# ----------------------------------------------------------------- courseidput
+ } elsif ($userinput =~ /^courseidput/) {
+ my ($cmd,$udom,$what)=split(/:/,$userinput);
+ chomp($what);
+ $udom=~s/\W//g;
+ my $proname=
+ "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
+ my $now=time;
+ my @pairs=split(/\&/,$what);
+ 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)) {
+ print $client "ok\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting courseidput\n";
+ }
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting courseidput\n";
+ }
+# ---------------------------------------------------------------- courseiddump
+ } elsif ($userinput =~ /^courseiddump/) {
+ my ($cmd,$udom,$since,$description)
+ =split(/:/,$userinput);
+ if (defined($description)) {
+ $description=&unescape($description);
+ } else {
+ $description='.';
+ }
+ unless (defined($since)) { $since=0; }
+ my $qresult='';
+ my $proname=
+ "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
+ 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 ($description eq '.') {
+ $qresult.=$key.'='.$descr.'&';
+ } else {
+ my $unescapeVal = &unescape($descr);
+ if (eval('$unescapeVal=~/$description/i')) {
+ $qresult.="$key=$descr&";
+ }
+ }
+ }
+ if (untie(%hash)) {
+ chop($qresult);
+ print $client "$qresult\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting courseiddump\n";
+ }
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting courseiddump\n";
+ }
# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);
@@ -1294,18 +1935,23 @@ 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)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting idput\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting idput\n";
}
# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {
@@ -1315,18 +1961,23 @@ 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:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting idget\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting idget\n";
}
# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {
@@ -1343,7 +1994,9 @@ sub make_new_child {
print $client "$id\n";
}
else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ."IO::File->new Failed ".
+ "while attempting tmpput\n";
}
# ---------------------------------------------------------------------- tmpget
@@ -1359,9 +2012,24 @@ sub make_new_child {
close $store;
}
else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ."IO::File->new Failed ".
+ "while attempting tmpget\n";
}
+# ---------------------------------------------------------------------- tmpdel
+ } elsif ($userinput =~ /^tmpdel/) {
+ my ($cmd,$id)=split(/:/,$userinput);
+ chomp($id);
+ $id=~s/\W/\_/g;
+ my $execdir=$perlvar{'lonDaemons'};
+ if (unlink("$execdir/tmp/$id.tmp")) {
+ print $client "ok\n";
+ } else {
+ print $client "error: ".($!+0)
+ ."Unlink tmp Failed ".
+ "while attempting tmpdel\n";
+ }
# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {
my ($cmd,$ulsdir)=split(/:/,$userinput);
@@ -1386,6 +2054,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/)) {
@@ -1395,6 +2076,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";
@@ -1410,21 +2095,19 @@ sub make_new_child {
&logthis("<font color=blue>WARNING: "
."Rejected client $clientip, closing connection</font>");
}
- }
+ }
# =============================================================================
&logthis("<font color=red>CRITICAL: "
."Disconnect from $clientip ($hostid{$clientip})</font>");
- # tidy up gracefully and finish
-
- $server->close();
+
# this exit is VERY important, otherwise the child will become
# a producer of more and more children, forking yourself into
# process death.
exit;
- }
+
}
@@ -1447,11 +2130,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");
}
}
@@ -1494,6 +2177,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;}
@@ -1508,7 +2192,7 @@ sub addline {
}
sub getchat {
- my ($cdom,$cname)=@_;
+ my ($cdom,$cname,$udom,$uname)=@_;
my %hash;
my $proname=&propath($cdom,$cname);
my @entries=();
@@ -1517,7 +2201,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 {
@@ -1525,10 +2221,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';
@@ -1548,6 +2244,12 @@ sub chatadd {
}
untie %hash;
}
+ {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/chatroom.log")) {
+ print $hfh "$time:".&unescape($newchat)."\n";
+ }
+ }
}
sub unsub {
@@ -1567,18 +2269,80 @@ sub unsub {
return $result;
}
+sub currentversion {
+ my $fname=shift;
+ my $version=-1;
+ my $ulsdir='';
+ if ($fname=~/^(.+)\/[^\/]+$/) {
+ $ulsdir=$1;
+ }
+ my ($fnamere1,$fnamere2);
+ # remove version if already specified
+ $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
+ # get the bits that go before and after the version number
+ if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
+ $fnamere1=$1;
+ $fnamere2='.'.$2;
+ }
+ if (-e $fname) { $version=1; }
+ if (-e $ulsdir) {
+ if(-d $ulsdir) {
+ if (opendir(LSDIR,$ulsdir)) {
+ 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;
+}
+
+sub thisversion {
+ my $fname=shift;
+ my $version=-1;
+ if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
+ $version=$1;
+ }
+ return $version;
+}
+
sub subscribe {
my ($userinput,$clientip)=@_;
my $result;
my ($cmd,$fname)=split(/:/,$userinput);
my $ownership=&ishome($fname);
if ($ownership eq 'owner') {
+# explitly asking for the current version?
+ unless (-e $fname) {
+ my $currentversion=¤tversion($fname);
+ if (&thisversion($fname)==$currentversion) {
+ if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
+ my $root=$1;
+ my $extension=$2;
+ symlink($root.'.'.$extension,
+ $root.'.'.$currentversion.'.'.$extension);
+ unless ($extension=~/\.meta$/) {
+ symlink($root.'.'.$extension.'.meta',
+ $root.'.'.$currentversion.'.'.$extension.'.meta');
+ }
+ }
+ }
+ }
if (-e $fname) {
if (-d $fname) {
$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"; }
@@ -1600,7 +2364,7 @@ sub subscribe {
}
sub make_passwd_file {
- my ($umode,$npass,$passfilename)=@_;
+ my ($uname, $umode,$npass,$passfilename)=@_;
my $result="ok\n";
if ($umode eq 'krb4' or $umode eq 'krb5') {
{
@@ -1626,11 +2390,16 @@ sub make_passwd_file {
my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
{
&Debug("Executing external: ".$execpath);
- my $se = IO::File->new("|$execpath");
+ &Debug("user = ".$uname.", Password =". $npass);
+ my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
print $se "$uname\n";
print $se "$npass\n";
print $se "$npass\n";
}
+ my $useraddok = $?;
+ if($useraddok > 0) {
+ &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
+ }
my $pf = IO::File->new(">$passfilename");
print $pf "unix:\n";
}
@@ -1645,6 +2414,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
@@ -1754,6 +2568,17 @@ each connection is logged.
=item *
+SIGUSR2
+
+Parent Signal assignment:
+ $SIG{USR2} = \&UpdateHosts
+
+Child signal assignment:
+ NONE
+
+
+=item *
+
SIGCHLD
Parent signal assignment:
@@ -1914,6 +2739,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)
@@ -1924,6 +2760,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,