version 1.104, 2002/12/18 20:43:29
|
version 1.135, 2003/08/12 09:39:23
|
Line 31
|
Line 31
|
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, |
# 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, |
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8, |
# 03/07,05/31 Gerd Kortemeyer |
# 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 |
# 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 |
# 12/05,12/13,12/29 Gerd Kortemeyer |
# YEAR=2001 |
# YEAR=2001 |
# Jan 01 Scott Harrison |
|
# 02/12 Gerd Kortemeyer |
# 02/12 Gerd Kortemeyer |
# 03/15 Scott Harrison |
|
# 03/24 Gerd Kortemeyer |
# 03/24 Gerd Kortemeyer |
# 04/02 Scott Harrison |
|
# 05/11,05/28,08/30 Gerd Kortemeyer |
# 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 |
# 11/26,11/27 Gerd Kortemeyer |
# 12/20 Scott Harrison |
|
# 12/22 Gerd Kortemeyer |
# 12/22 Gerd Kortemeyer |
# YEAR=2002 |
# YEAR=2002 |
# 01/20/02,02/05 Gerd Kortemeyer |
# 01/20/02,02/05 Gerd Kortemeyer |
# 02/05 Guy Albertelli |
# 02/05 Guy Albertelli |
# 02/07 Scott Harrison |
|
# 02/12 Gerd Kortemeyer |
# 02/12 Gerd Kortemeyer |
# 02/19 Matthew Hall |
# 02/19 Matthew Hall |
# 02/25 Gerd Kortemeyer |
# 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 |
### |
### |
|
|
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
use strict; |
# preforker - server who forks first |
|
# runs as a daemon |
|
# HUPs |
|
# uses IDEA encryption |
|
|
|
use lib '/home/httpd/lib/perl/'; |
use lib '/home/httpd/lib/perl/'; |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
|
|
use IO::Socket; |
use IO::Socket; |
use IO::File; |
use IO::File; |
use Apache::File; |
#use Apache::File; |
use Symbol; |
use Symbol; |
use POSIX; |
use POSIX; |
use Crypt::IDEA; |
use Crypt::IDEA; |
Line 83 my $DEBUG = 0; # Non zero to ena
|
Line 81 my $DEBUG = 0; # Non zero to ena
|
my $status=''; |
my $status=''; |
my $lastlog=''; |
my $lastlog=''; |
|
|
|
my $VERSION='$Revision$'; #' stupid emacs |
|
my $remoteVERSION; |
|
my $currenthostid; |
|
my $currentdomainid; |
|
|
|
my $client; |
|
my $server; |
|
my $thisserver; |
|
|
|
my %hostid; |
|
my %hostdom; |
|
my %hostip; |
|
|
# |
# |
# The array below are password error strings." |
# The array below are password error strings." |
# |
# |
Line 151 sub catchexception {
|
Line 162 sub catchexception {
|
$SIG{'QUIT'}='DEFAULT'; |
$SIG{'QUIT'}='DEFAULT'; |
$SIG{__DIE__}='DEFAULT'; |
$SIG{__DIE__}='DEFAULT'; |
&logthis("<font color=red>CRITICAL: " |
&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>"); |
."a crash with this error msg->[$error]</font>"); |
&logthis('Famous last words: '.$status.' - '.$lastlog); |
&logthis('Famous last words: '.$status.' - '.$lastlog); |
if ($client) { print $client "error: $error\n"; } |
if ($client) { print $client "error: $error\n"; } |
Line 177 undef $perlvarref;
|
Line 188 undef $perlvarref;
|
# ----------------------------- Make sure this process is running from user=www |
# ----------------------------- Make sure this process is running from user=www |
my $wwwid=getpwnam('www'); |
my $wwwid=getpwnam('www'); |
if ($wwwid!=$<) { |
if ($wwwid!=$<) { |
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
$subj="LON: $perlvar{'lonHostID'} User ID mismatch"; |
my $subj="LON: $currenthostid User ID mismatch"; |
system("echo 'User ID mismatch. lond must be run as user www.' |\ |
system("echo 'User ID mismatch. lond must be run as user www.' |\ |
mailto $emailto -s '$subj' > /dev/null"); |
mailto $emailto -s '$subj' > /dev/null"); |
exit 1; |
exit 1; |
Line 195 if (-e $pidfile) {
|
Line 206 if (-e $pidfile) {
|
if (kill 0 => $pide) { die "already running"; } |
if (kill 0 => $pide) { die "already running"; } |
} |
} |
|
|
$PREFORK=4; # number of children to maintain, at least four spare |
|
|
|
# ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
|
|
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host 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); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
chomp($ip); $ip=~s/\D+$//; |
chomp($ip); $ip=~s/\D+$//; |
$hostid{$ip}=$id; |
$hostid{$ip}=$id; |
|
$hostdom{$id}=$domain; |
|
$hostip{$id}=$ip; |
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
$PREFORK++; |
|
} |
} |
close(CONFIG); |
close(CONFIG); |
|
|
Line 222 $server = IO::Socket::INET->new(LocalPor
|
Line 232 $server = IO::Socket::INET->new(LocalPor
|
|
|
# global variables |
# global variables |
|
|
$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should |
my %children = (); # keys are current child process IDs |
# process |
my $children = 0; # current number of children |
%children = (); # keys are current child process IDs |
|
$children = 0; # current number of children |
|
|
|
sub REAPER { # takes care of dead children |
sub REAPER { # takes care of dead children |
$SIG{CHLD} = \&REAPER; |
$SIG{CHLD} = \&REAPER; |
Line 254 sub HUPSMAN { # sig
|
Line 262 sub HUPSMAN { # sig
|
kill 'INT' => keys %children; |
kill 'INT' => keys %children; |
&logthis("Free socket: ".shutdown($server,2)); # free up socket |
&logthis("Free socket: ".shutdown($server,2)); # free up socket |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
unlink("$execdir/logs/lond.pid"); |
|
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
|
unlink("$execdir/logs/lond.pid"); |
exec("$execdir/lond"); # here we go again |
exec("$execdir/lond"); # here we go again |
} |
} |
|
|
Line 263 sub checkchildren {
|
Line 271 sub checkchildren {
|
&initnewstatus(); |
&initnewstatus(); |
&logstatus(); |
&logstatus(); |
&logthis('Going to check on the children'); |
&logthis('Going to check on the children'); |
$docdir=$perlvar{'lonDocRoot'}; |
my $docdir=$perlvar{'lonDocRoot'}; |
foreach (sort keys %children) { |
foreach (sort keys %children) { |
sleep 1; |
sleep 1; |
unless (kill 'USR1' => $_) { |
unless (kill 'USR1' => $_) { |
Line 272 sub checkchildren {
|
Line 280 sub checkchildren {
|
} |
} |
} |
} |
sleep 5; |
sleep 5; |
|
$SIG{ALRM} = sub { die "timeout" }; |
|
$SIG{__DIE__} = 'DEFAULT'; |
foreach (sort keys %children) { |
foreach (sort keys %children) { |
unless (-e "$docdir/lon-status/londchld/$_.txt") { |
unless (-e "$docdir/lon-status/londchld/$_.txt") { |
|
eval { |
|
alarm(300); |
&logthis('Child '.$_.' did not respond'); |
&logthis('Child '.$_.' did not respond'); |
kill 9 => $_; |
kill 9 => $_; |
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
#$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
$subj="LON: $perlvar{'lonHostID'} killed lond process $_"; |
#$subj="LON: $currenthostid killed lond process $_"; |
my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; |
#my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; |
$execdir=$perlvar{'lonDaemons'}; |
#$execdir=$perlvar{'lonDaemons'}; |
$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_` |
#$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; |
|
alarm(0); |
|
} |
} |
} |
} |
} |
|
$SIG{ALRM} = 'DEFAULT'; |
|
$SIG{__DIE__} = \&cathcexception; |
} |
} |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
Line 310 sub logstatus {
|
Line 326 sub logstatus {
|
my $docdir=$perlvar{'lonDocRoot'}; |
my $docdir=$perlvar{'lonDocRoot'}; |
{ |
{ |
my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); |
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(); |
$fh->close(); |
} |
} |
{ |
{ |
Line 327 sub initnewstatus {
|
Line 343 sub initnewstatus {
|
my $local=localtime($now); |
my $local=localtime($now); |
print $fh "LOND status $local - parent $$\n\n"; |
print $fh "LOND status $local - parent $$\n\n"; |
opendir(DIR,"$docdir/lon-status/londchld"); |
opendir(DIR,"$docdir/lon-status/londchld"); |
while ($filename=readdir(DIR)) { |
while (my $filename=readdir(DIR)) { |
unlink("$docdir/lon-status/londchld/$filename"); |
unlink("$docdir/lon-status/londchld/$filename"); |
} |
} |
closedir(DIR); |
closedir(DIR); |
Line 371 sub reconlonc {
|
Line 387 sub reconlonc {
|
if (kill 0 => $loncpid) { |
if (kill 0 => $loncpid) { |
&logthis("lonc at pid $loncpid responding, sending USR1"); |
&logthis("lonc at pid $loncpid responding, sending USR1"); |
kill USR1 => $loncpid; |
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 { |
} else { |
&logthis( |
&logthis( |
"<font color=red>CRITICAL: " |
"<font color=red>CRITICAL: " |
Line 407 sub subreply {
|
Line 416 sub subreply {
|
sub reply { |
sub reply { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
my $answer; |
my $answer; |
if ($server ne $perlvar{'lonHostID'}) { |
if ($server ne $currenthostid) { |
$answer=subreply($cmd,$server); |
$answer=subreply($cmd,$server); |
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
$answer=subreply("ping",$server); |
$answer=subreply("ping",$server); |
if ($answer ne $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"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
} |
} |
$answer=subreply($cmd,$server); |
$answer=subreply($cmd,$server); |
Line 476 sub ishome {
|
Line 485 sub ishome {
|
# ======================================================= Continue main program |
# ======================================================= Continue main program |
# ---------------------------------------------------- Fork once and dissociate |
# ---------------------------------------------------- Fork once and dissociate |
|
|
$fpid=fork; |
my $fpid=fork; |
exit if $fpid; |
exit if $fpid; |
die "Couldn't fork: $!" unless defined ($fpid); |
die "Couldn't fork: $!" unless defined ($fpid); |
|
|
Line 484 POSIX::setsid() or die "Can't start new
|
Line 493 POSIX::setsid() or die "Can't start new
|
|
|
# ------------------------------------------------------- Write our PID on disk |
# ------------------------------------------------------- Write our PID on disk |
|
|
$execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
open (PIDSAVE,">$execdir/logs/lond.pid"); |
open (PIDSAVE,">$execdir/logs/lond.pid"); |
print PIDSAVE "$$\n"; |
print PIDSAVE "$$\n"; |
close(PIDSAVE); |
close(PIDSAVE); |
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
&status('Starting'); |
&status('Starting'); |
|
|
# ------------------------------------------------------- Now we are on our own |
|
|
|
# Fork off our children. |
|
for (1 .. $PREFORK) { |
|
make_new_child(); |
|
} |
|
|
|
# ----------------------------------------------------- Install signal handlers |
# ----------------------------------------------------- Install signal handlers |
|
|
&status('Forked children'); |
|
|
|
$SIG{CHLD} = \&REAPER; |
$SIG{CHLD} = \&REAPER; |
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
$SIG{HUP} = \&HUPSMAN; |
$SIG{HUP} = \&HUPSMAN; |
$SIG{USR1} = \&checkchildren; |
$SIG{USR1} = \&checkchildren; |
|
|
# And maintain the population. |
|
|
|
|
# -------------------------------------------------------------- |
|
# Accept connections. When a connection comes in, it is validated |
|
# and if good, a child process is created to process transactions |
|
# along the connection. |
|
|
while (1) { |
while (1) { |
&status('Sleeping'); |
$client = $server->accept() or next; |
sleep; # wait for a signal (i.e., child's death) |
make_new_child($client); |
&logthis('Woke up'); |
|
&status('Woke up'); |
|
for ($i = $children; $i < $PREFORK; $i++) { |
|
make_new_child(); # top up the child pool |
|
} |
|
} |
} |
|
|
sub make_new_child { |
sub make_new_child { |
my $pid; |
my $pid; |
my $cipher; |
my $cipher; |
my $sigset; |
my $sigset; |
|
|
|
$client = shift; |
&logthis("Attempting to start child"); |
&logthis("Attempting to start child"); |
# block signal for fork |
# block signal for fork |
$sigset = POSIX::SigSet->new(SIGINT); |
$sigset = POSIX::SigSet->new(SIGINT); |
sigprocmask(SIG_BLOCK, $sigset) |
sigprocmask(SIG_BLOCK, $sigset) |
or die "Can't block SIGINT for fork: $!\n"; |
or die "Can't block SIGINT for fork: $!\n"; |
|
|
|
my $clientip; |
die "fork: $!" unless defined ($pid = fork); |
die "fork: $!" unless defined ($pid = fork); |
|
|
if ($pid) { |
if ($pid) { |
Line 541 sub make_new_child {
|
Line 548 sub make_new_child {
|
} else { |
} else { |
# Child can *not* return from this subroutine. |
# Child can *not* return from this subroutine. |
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before |
$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{USR1}= \&logstatus; |
$SIG{ALRM}= \&timeout; |
$SIG{ALRM}= \&timeout; |
$lastlog='Forked '; |
$lastlog='Forked '; |
Line 550 sub make_new_child {
|
Line 559 sub make_new_child {
|
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
|
|
$tmpsnum=0; |
my $tmpsnum=0; |
#---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_ets(); |
&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'); |
&status('Accepted connection'); |
# ============================================================================= |
# ============================================================================= |
# do something with the connection |
# do something with the connection |
Line 566 sub make_new_child {
|
Line 571 sub make_new_child {
|
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of |
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of |
# connection liveness. |
# connection liveness. |
# see if we know client and check for spoof IP by challenge |
# 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 ($port,$iaddr)=unpack_sockaddr_in($caller); |
my $clientip=inet_ntoa($iaddr); |
$clientip=inet_ntoa($iaddr); |
my $clientrec=($hostid{$clientip} ne undef); |
my $clientrec=($hostid{$clientip} ne undef); |
&logthis( |
&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})"); |
&status("Connecting $clientip ($hostid{$clientip})"); |
my $clientok; |
my $clientok; |
if ($clientrec) { |
if ($clientrec) { |
&status("Waiting for init from $clientip ($hostid{$clientip})"); |
&status("Waiting for init from $clientip ($hostid{$clientip})"); |
my $remotereq=<$client>; |
my $remotereq=<$client>; |
$remotereq=~s/\W//g; |
$remotereq=~s/[^\w:]//g; |
if ($remotereq eq 'init') { |
if ($remotereq =~ /^init/) { |
|
&sethost("sethost:$perlvar{'lonHostID'}"); |
my $challenge="$$".time; |
my $challenge="$$".time; |
print $client "$challenge\n"; |
print $client "$challenge\n"; |
&status( |
&status( |
Line 608 sub make_new_child {
|
Line 614 sub make_new_child {
|
if ($clientok) { |
if ($clientok) { |
# ---------------- New known client connecting, could mean machine online again |
# ---------------- New known client connecting, could mean machine online again |
|
|
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); |
foreach my $id (keys(%hostip)) { |
&logthis( |
if ($hostip{$id} ne $clientip || |
"<font color=green>Established connection: $hostid{$clientip}</font>"); |
$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}); |
&status('Will listen to '.$hostid{$clientip}); |
# ------------------------------------------------------------ Process requests |
# ------------------------------------------------------------ Process requests |
while (my $userinput=<$client>) { |
while (my $userinput=<$client>) { |
Line 638 sub make_new_child {
|
Line 650 sub make_new_child {
|
# ------------------------------------------------------------- Normal commands |
# ------------------------------------------------------------- Normal commands |
# ------------------------------------------------------------------------ ping |
# ------------------------------------------------------------------------ ping |
if ($userinput =~ /^ping/) { |
if ($userinput =~ /^ping/) { |
print $client "$perlvar{'lonHostID'}\n"; |
print $client "$currenthostid\n"; |
# ------------------------------------------------------------------------ pong |
# ------------------------------------------------------------------------ pong |
} elsif ($userinput =~ /^pong/) { |
} elsif ($userinput =~ /^pong/) { |
$reply=reply("ping",$hostid{$clientip}); |
my $reply=&reply("ping",$hostid{$clientip}); |
print $client "$perlvar{'lonHostID'}:$reply\n"; |
print $client "$currenthostid:$reply\n"; |
# ------------------------------------------------------------------------ ekey |
# ------------------------------------------------------------------------ ekey |
} elsif ($userinput =~ /^ekey/) { |
} elsif ($userinput =~ /^ekey/) { |
my $buildkey=time.$$.int(rand 100000); |
my $buildkey=time.$$.int(rand 100000); |
$buildkey=~tr/1-6/A-F/; |
$buildkey=~tr/1-6/A-F/; |
$buildkey=int(rand 100000).$buildkey.int(rand 100000); |
$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/a-z/A-Z/; |
$key=~tr/G-P/0-9/; |
$key=~tr/G-P/0-9/; |
$key=~tr/Q-Z/0-9/; |
$key=~tr/Q-Z/0-9/; |
Line 665 sub make_new_child {
|
Line 677 sub make_new_child {
|
$loadavg=<$loadfile>; |
$loadavg=<$loadfile>; |
} |
} |
$loadavg =~ s/\s.*//g; |
$loadavg =~ s/\s.*//g; |
my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; |
my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; |
print $client "$loadpercent\n"; |
print $client "$loadpercent\n"; |
|
# -------------------------------------------------------------------- userload |
|
} elsif ($userinput =~ /^userload/) { |
|
my $userloadpercent=&userload(); |
|
print $client "$userloadpercent\n"; |
# ----------------------------------------------------------------- currentauth |
# ----------------------------------------------------------------- currentauth |
} elsif ($userinput =~ /^currentauth/) { |
} elsif ($userinput =~ /^currentauth/) { |
if ($wasenc==1) { |
if ($wasenc==1) { |
Line 721 sub make_new_child {
|
Line 737 sub make_new_child {
|
} |
} |
} |
} |
} elsif ($howpwd eq 'krb4') { |
} elsif ($howpwd eq 'krb4') { |
$null=pack("C",0); |
my $null=pack("C",0); |
unless ($upass=~/$null/) { |
unless ($upass=~/$null/) { |
my $krb4_error = &Authen::Krb4::get_pw_in_tkt |
my $krb4_error = &Authen::Krb4::get_pw_in_tkt |
($uname,"",$contentpwd,'krbtgt', |
($uname,"",$contentpwd,'krbtgt', |
Line 738 sub make_new_child {
|
Line 754 sub make_new_child {
|
} |
} |
} |
} |
} elsif ($howpwd eq 'krb5') { |
} elsif ($howpwd eq 'krb5') { |
$null=pack("C",0); |
my $null=pack("C",0); |
unless ($upass=~/$null/) { |
unless ($upass=~/$null/) { |
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); |
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); |
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; |
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; |
Line 822 sub make_new_child {
|
Line 838 sub make_new_child {
|
if ($pwdcorrect) { |
if ($pwdcorrect) { |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
&Debug("Opening lcpasswd pipeline"); |
&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"; |
print $pf "$uname\n$npass\n$npass\n"; |
close $pf; |
close $pf; |
my $err = $?; |
my $err = $?; |
Line 860 sub make_new_child {
|
Line 876 sub make_new_child {
|
$passfilename); |
$passfilename); |
if (-e $passfilename) { |
if (-e $passfilename) { |
print $client "already_exists\n"; |
print $client "already_exists\n"; |
} elsif ($udom ne $perlvar{'lonDefDomain'}) { |
} elsif ($udom ne $currentdomainid) { |
print $client "not_right_domain\n"; |
print $client "not_right_domain\n"; |
} else { |
} else { |
@fpparts=split(/\//,$proname); |
my @fpparts=split(/\//,$proname); |
$fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; |
my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; |
$fperror=''; |
my $fperror=''; |
for ($i=3;$i<=$#fpparts;$i++) { |
for (my $i=3;$i<=$#fpparts;$i++) { |
$fpnow.='/'.$fpparts[$i]; |
$fpnow.='/'.$fpparts[$i]; |
unless (-e $fpnow) { |
unless (-e $fpnow) { |
unless (mkdir($fpnow,0777)) { |
unless (mkdir($fpnow,0777)) { |
$fperror="error:$!"; |
$fperror="error: ".($!+0) |
|
." mkdir failed while attempting " |
|
."makeuser\n"; |
} |
} |
} |
} |
} |
} |
Line 898 sub make_new_child {
|
Line 916 sub make_new_child {
|
$npass=&unescape($npass); |
$npass=&unescape($npass); |
my $proname=&propath($udom,$uname); |
my $proname=&propath($udom,$uname); |
my $passfilename="$proname/passwd"; |
my $passfilename="$proname/passwd"; |
if ($udom ne $perlvar{'lonDefDomain'}) { |
if ($udom ne $currentdomainid) { |
print $client "not_right_domain\n"; |
print $client "not_right_domain\n"; |
} else { |
} else { |
my $result=&make_passwd_file($uname, $umode,$npass, |
my $result=&make_passwd_file($uname, $umode,$npass, |
Line 928 sub make_new_child {
|
Line 946 sub make_new_child {
|
$uid,$gid,$rdev,$size, |
$uid,$gid,$rdev,$size, |
$atime,$mtime,$ctime, |
$atime,$mtime,$ctime, |
$blksize,$blocks)=stat($fname); |
$blksize,$blocks)=stat($fname); |
$now=time; |
my $now=time; |
$since=$now-$atime; |
my $since=$now-$atime; |
if ($since>$perlvar{'lonExpire'}) { |
if ($since>$perlvar{'lonExpire'}) { |
$reply= |
my $reply= |
reply("unsub:$fname","$hostid{$clientip}"); |
&reply("unsub:$fname","$hostid{$clientip}"); |
unlink("$fname"); |
unlink("$fname"); |
} else { |
} else { |
my $transname="$fname.in.transfer"; |
my $transname="$fname.in.transfer"; |
Line 1003 sub make_new_child {
|
Line 1021 sub make_new_child {
|
} elsif ($userinput =~ /^tokenauthuserfile/) { |
} elsif ($userinput =~ /^tokenauthuserfile/) { |
my ($cmd,$fname,$session)=split(/:/,$userinput); |
my ($cmd,$fname,$session)=split(/:/,$userinput); |
chomp($session); |
chomp($session); |
$reply='non_auth'; |
my $reply='non_auth'; |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
$session.'.id')) { |
$session.'.id')) { |
while ($line=<ENVIN>) { |
while (my $line=<ENVIN>) { |
if ($line=~/userfile\.$fname\=/) { $reply='ok'; } |
if ($line=~/userfile\.$fname\=/) { $reply='ok'; } |
} |
} |
close(ENVIN); |
close(ENVIN); |
print $client $reply."\n"; |
print $client $reply."\n"; |
} else { |
} else { |
print $client "invalid_token\n"; |
print $client "invalid_token\n"; |
} |
} |
# ----------------------------------------------------------------- unsubscribe |
# ----------------------------------------------------------------- unsubscribe |
} elsif ($userinput =~ /^unsub/) { |
} elsif ($userinput =~ /^unsub/) { |
Line 1041 sub make_new_child {
|
Line 1059 sub make_new_child {
|
print $hfh "$now:$hostid{$clientip}:$what\n"; |
print $hfh "$now:$hostid{$clientip}:$what\n"; |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." IO::File->new Failed " |
|
."while attempting log\n"; |
} |
} |
} |
} |
# ------------------------------------------------------------------------- put |
# ------------------------------------------------------------------------- put |
Line 1061 sub make_new_child {
|
Line 1081 sub make_new_child {
|
) { print $hfh "P:$now:$what\n"; } |
) { print $hfh "P:$now:$what\n"; } |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
my %hash; |
foreach $pair (@pairs) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
($key,$value)=split(/=/,$pair); |
foreach my $pair (@pairs) { |
|
my ($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) failed ". |
|
"while attempting put\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!) |
|
." tie(GDBM) Failed ". |
|
"while attempting put\n"; |
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
Line 1099 sub make_new_child {
|
Line 1124 sub make_new_child {
|
} |
} |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
my %hash; |
foreach $pair (@pairs) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
($key,$value)=split(/=/,$pair); |
foreach my $pair (@pairs) { |
|
my ($key,$value)=split(/=/,$pair); |
&ManagePermissions($key, $udom, $uname, |
&ManagePermissions($key, $udom, $uname, |
&GetAuthType( $udom, |
&GetAuthType( $udom, |
$uname)); |
$uname)); |
$hash{$key}=$value; |
$hash{$key}=$value; |
|
|
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} 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 { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting rolesdel\n"; |
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
Line 1129 sub make_new_child {
|
Line 1200 sub make_new_child {
|
my @queries=split(/\&/,$what); |
my @queries=split(/\&/,$what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
my %hash; |
for ($i=0;$i<=$#queries;$i++) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
for (my $i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting get\n"; |
} |
} |
} else { |
} 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 |
# ------------------------------------------------------------------------ eget |
} elsif ($userinput =~ /^eget/) { |
} elsif ($userinput =~ /^eget/) { |
Line 1152 sub make_new_child {
|
Line 1233 sub make_new_child {
|
my @queries=split(/\&/,$what); |
my @queries=split(/\&/,$what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
my %hash; |
for ($i=0;$i<=$#queries;$i++) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
for (my $i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
Line 1173 sub make_new_child {
|
Line 1255 sub make_new_child {
|
print $client "error:no_key\n"; |
print $client "error:no_key\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting eget\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting eget\n"; |
} |
} |
# ------------------------------------------------------------------------- del |
# ------------------------------------------------------------------------- del |
} elsif ($userinput =~ /^del/) { |
} elsif ($userinput =~ /^del/) { |
Line 1194 sub make_new_child {
|
Line 1280 sub make_new_child {
|
) { print $hfh "D:$now:$what\n"; } |
) { print $hfh "D:$now:$what\n"; } |
} |
} |
my @keys=split(/\&/,$what); |
my @keys=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
my %hash; |
foreach $key (@keys) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
foreach my $key (@keys) { |
delete($hash{$key}); |
delete($hash{$key}); |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting del\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting del\n"; |
} |
} |
# ------------------------------------------------------------------------ keys |
# ------------------------------------------------------------------------ keys |
} elsif ($userinput =~ /^keys/) { |
} elsif ($userinput =~ /^keys/) { |
Line 1214 sub make_new_child {
|
Line 1305 sub make_new_child {
|
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
my %hash; |
foreach $key (keys %hash) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
|
foreach my $key (keys %hash) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting keys\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
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: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting currentdump\n"; |
} |
} |
# ------------------------------------------------------------------------ dump |
# ------------------------------------------------------------------------ dump |
} elsif ($userinput =~ /^dump/) { |
} elsif ($userinput =~ /^dump/) { |
Line 1240 sub make_new_child {
|
Line 1382 sub make_new_child {
|
} |
} |
my $qresult=''; |
my $qresult=''; |
my $proname=propath($udom,$uname); |
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); |
study($regexp); |
while (($key,$value) = each(%hash)) { |
while (my ($key,$value) = each(%hash)) { |
if ($regexp eq '.') { |
if ($regexp eq '.') { |
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} else { |
} else { |
Line 1256 sub make_new_child {
|
Line 1399 sub make_new_child {
|
chop($qresult); |
chop($qresult); |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting dump\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting dump\n"; |
} |
} |
# ----------------------------------------------------------------------- store |
# ----------------------------------------------------------------------- store |
} elsif ($userinput =~ /^store/) { |
} elsif ($userinput =~ /^store/) { |
Line 1278 sub make_new_child {
|
Line 1425 sub make_new_child {
|
) { print $hfh "P:$now:$rid:$what\n"; } |
) { print $hfh "P:$now:$rid:$what\n"; } |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
|
my %hash; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
my $key; |
my $key; |
$hash{"version:$rid"}++; |
$hash{"version:$rid"}++; |
my $version=$hash{"version:$rid"}; |
my $version=$hash{"version:$rid"}; |
my $allkeys=''; |
my $allkeys=''; |
foreach $pair (@pairs) { |
foreach my $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$allkeys.=$key.':'; |
$allkeys.=$key.':'; |
$hash{"$version:$rid:$key"}=$value; |
$hash{"$version:$rid:$key"}=$value; |
} |
} |
Line 1296 sub make_new_child {
|
Line 1443 sub make_new_child {
|
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting store\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting store\n"; |
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
Line 1313 sub make_new_child {
|
Line 1464 sub make_new_child {
|
chomp($rid); |
chomp($rid); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
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"}; |
my $version=$hash{"version:$rid"}; |
$qresult.="version=$version&"; |
$qresult.="version=$version&"; |
my $scope; |
my $scope; |
Line 1330 sub make_new_child {
|
Line 1482 sub make_new_child {
|
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting restore\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting restore\n"; |
} |
} |
# -------------------------------------------------------------------- chatsend |
# -------------------------------------------------------------------- chatsend |
} elsif ($userinput =~ /^chatsend/) { |
} elsif ($userinput =~ /^chatsend/) { |
Line 1342 sub make_new_child {
|
Line 1498 sub make_new_child {
|
print $client "ok\n"; |
print $client "ok\n"; |
# -------------------------------------------------------------------- chatretr |
# -------------------------------------------------------------------- chatretr |
} elsif ($userinput =~ /^chatretr/) { |
} elsif ($userinput =~ /^chatretr/) { |
my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); |
my |
|
($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); |
my $reply=''; |
my $reply=''; |
foreach (&getchat($cdom,$cnum)) { |
foreach (&getchat($cdom,$cnum,$udom,$uname)) { |
$reply.=&escape($_).':'; |
$reply.=&escape($_).':'; |
} |
} |
$reply=~s/\:$//; |
$reply=~s/\:$//; |
Line 1372 sub make_new_child {
|
Line 1529 sub make_new_child {
|
print $client "ok\n"; |
print $client "ok\n"; |
} |
} |
else { |
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 |
# ----------------------------------------------------------------------- idput |
} elsif ($userinput =~ /^idput/) { |
} elsif ($userinput =~ /^idput/) { |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
Line 1388 sub make_new_child {
|
Line 1614 sub make_new_child {
|
) { print $hfh "P:$now:$what\n"; } |
) { print $hfh "P:$now:$what\n"; } |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { |
my %hash; |
foreach $pair (@pairs) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
($key,$value)=split(/=/,$pair); |
foreach my $pair (@pairs) { |
|
my ($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting idput\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting idput\n"; |
} |
} |
# ----------------------------------------------------------------------- idget |
# ----------------------------------------------------------------------- idget |
} elsif ($userinput =~ /^idget/) { |
} elsif ($userinput =~ /^idget/) { |
Line 1409 sub make_new_child {
|
Line 1640 sub make_new_child {
|
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
my @queries=split(/\&/,$what); |
my @queries=split(/\&/,$what); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { |
my %hash; |
for ($i=0;$i<=$#queries;$i++) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
|
for (my $i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting idget\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting idget\n"; |
} |
} |
# ---------------------------------------------------------------------- tmpput |
# ---------------------------------------------------------------------- tmpput |
} elsif ($userinput =~ /^tmpput/) { |
} elsif ($userinput =~ /^tmpput/) { |
Line 1437 sub make_new_child {
|
Line 1673 sub make_new_child {
|
print $client "$id\n"; |
print $client "$id\n"; |
} |
} |
else { |
else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
."IO::File->new Failed ". |
|
"while attempting tmpput\n"; |
} |
} |
|
|
# ---------------------------------------------------------------------- tmpget |
# ---------------------------------------------------------------------- tmpget |
Line 1453 sub make_new_child {
|
Line 1691 sub make_new_child {
|
close $store; |
close $store; |
} |
} |
else { |
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 |
# -------------------------------------------------------------------------- ls |
} elsif ($userinput =~ /^ls/) { |
} elsif ($userinput =~ /^ls/) { |
my ($cmd,$ulsdir)=split(/:/,$userinput); |
my ($cmd,$ulsdir)=split(/:/,$userinput); |
Line 1489 sub make_new_child {
|
Line 1742 sub make_new_child {
|
$client->close(); |
$client->close(); |
last; |
last; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
|
} elsif ($userinput =~ /^sethost:/) { |
|
print $client &sethost($userinput)."\n"; |
|
} elsif ($userinput =~/^version:/) { |
|
print $client &version($userinput)."\n"; |
} else { |
} else { |
# unknown command |
# unknown command |
print $client "unknown_cmd\n"; |
print $client "unknown_cmd\n"; |
Line 1504 sub make_new_child {
|
Line 1761 sub make_new_child {
|
&logthis("<font color=blue>WARNING: " |
&logthis("<font color=blue>WARNING: " |
."Rejected client $clientip, closing connection</font>"); |
."Rejected client $clientip, closing connection</font>"); |
} |
} |
} |
} |
|
|
# ============================================================================= |
# ============================================================================= |
|
|
&logthis("<font color=red>CRITICAL: " |
&logthis("<font color=red>CRITICAL: " |
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
# tidy up gracefully and finish |
|
|
|
$server->close(); |
|
|
|
# this exit is VERY important, otherwise the child will become |
# this exit is VERY important, otherwise the child will become |
# a producer of more and more children, forking yourself into |
# a producer of more and more children, forking yourself into |
# process death. |
# process death. |
exit; |
exit; |
} |
|
} |
} |
|
|
|
|
Line 1541 sub ManagePermissions
|
Line 1796 sub ManagePermissions
|
my $authtype= shift; |
my $authtype= shift; |
|
|
# See if the request is of the form /$domain/_au |
# See if the request is of the form /$domain/_au |
|
&logthis("ruequest is $request"); |
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
my $execdir = $perlvar{'lonDaemons'}; |
my $execdir = $perlvar{'lonDaemons'}; |
my $userhome= "/home/$user" ; |
my $userhome= "/home/$user" ; |
Debug("system $execdir/lchtmldir $userhome $system $authtype"); |
&logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
system("$execdir/lchtmldir $userhome $user $authtype"); |
system("$execdir/lchtmldir $userhome $user $authtype"); |
} |
} |
} |
} |
Line 1588 sub addline {
|
Line 1843 sub addline {
|
my $found=0; |
my $found=0; |
my $expr='^'.$hostid.':'.$ip.':'; |
my $expr='^'.$hostid.':'.$ip.':'; |
$expr =~ s/\./\\\./g; |
$expr =~ s/\./\\\./g; |
|
my $sh; |
if ($sh=IO::File->new("$fname.subscription")) { |
if ($sh=IO::File->new("$fname.subscription")) { |
while (my $subline=<$sh>) { |
while (my $subline=<$sh>) { |
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} |
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} |
Line 1602 sub addline {
|
Line 1858 sub addline {
|
} |
} |
|
|
sub getchat { |
sub getchat { |
my ($cdom,$cname)=@_; |
my ($cdom,$cname,$udom,$uname)=@_; |
my %hash; |
my %hash; |
my $proname=&propath($cdom,$cname); |
my $proname=&propath($cdom,$cname); |
my @entries=(); |
my @entries=(); |
Line 1611 sub getchat {
|
Line 1867 sub getchat {
|
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
untie %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 { |
sub chatadd { |
Line 1668 sub currentversion {
|
Line 1936 sub currentversion {
|
if ($fname=~/^(.+)\/[^\/]+$/) { |
if ($fname=~/^(.+)\/[^\/]+$/) { |
$ulsdir=$1; |
$ulsdir=$1; |
} |
} |
|
my ($fnamere1,$fnamere2); |
|
# remove version if already specified |
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; |
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; |
$fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/; |
# get the bits that go before and after the version number |
|
if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { |
|
$fnamere1=$1; |
|
$fnamere2='.'.$2; |
|
} |
if (-e $fname) { $version=1; } |
if (-e $fname) { $version=1; } |
if (-e $ulsdir) { |
if (-e $ulsdir) { |
if(-d $ulsdir) { |
if(-d $ulsdir) { |
if (opendir(LSDIR,$ulsdir)) { |
if (opendir(LSDIR,$ulsdir)) { |
while ($ulsfn=readdir(LSDIR)) { |
my $ulsfn; |
|
while ($ulsfn=readdir(LSDIR)) { |
# see if this is a regular file (ignore links produced earlier) |
# see if this is a regular file (ignore links produced earlier) |
my $thisfile=$ulsdir.'/'.$ulsfn; |
my $thisfile=$ulsdir.'/'.$ulsfn; |
unless (-l $thisfile) { |
unless (-l $thisfile) { |
if ($thisfile=~/$fname/) { |
if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { |
if ($1>$version) { $version=$1; } |
if ($1>$version) { $version=$1; } |
} |
} |
} |
} |
} |
} |
closedir(LSDIR); |
closedir(LSDIR); |
$version++; |
$version++; |
} |
} |
} |
} |
} |
} |
return $version; |
return $version; |
} |
} |
|
|
sub thisversion { |
sub thisversion { |
Line 1728 sub subscribe {
|
Line 2002 sub subscribe {
|
$result="directory\n"; |
$result="directory\n"; |
} else { |
} else { |
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} |
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} |
$now=time; |
my $now=time; |
my $found=&addline($fname,$hostid{$clientip},$clientip, |
my $found=&addline($fname,$hostid{$clientip},$clientip, |
"$hostid{$clientip}:$clientip:$now\n"); |
"$hostid{$clientip}:$clientip:$now\n"); |
if ($found) { $result="$fname\n"; } |
if ($found) { $result="$fname\n"; } |
Line 1777 sub make_passwd_file {
|
Line 2051 sub make_passwd_file {
|
{ |
{ |
&Debug("Executing external: ".$execpath); |
&Debug("Executing external: ".$execpath); |
&Debug("user = ".$uname.", Password =". $npass); |
&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 "$uname\n"; |
print $se "$npass\n"; |
print $se "$npass\n"; |
print $se "$npass\n"; |
print $se "$npass\n"; |
Line 1800 sub make_passwd_file {
|
Line 2074 sub make_passwd_file {
|
return $result; |
return $result; |
} |
} |
|
|
|
sub sethost { |
|
my ($remotereq) = @_; |
|
my (undef,$hostid)=split(/:/,$remotereq); |
|
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } |
|
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { |
|
$currenthostid=$hostid; |
|
$currentdomainid=$hostdom{$hostid}; |
|
&logthis("Setting hostid to $hostid, and domain to $currentdomainid"); |
|
} else { |
|
&logthis("Requested host id $hostid not an alias of ". |
|
$perlvar{'lonHostID'}." refusing connection"); |
|
return 'unable_to_set'; |
|
} |
|
return 'ok'; |
|
} |
|
|
|
sub version { |
|
my ($userinput)=@_; |
|
$remoteVERSION=(split(/:/,$userinput))[1]; |
|
return "version:$VERSION"; |
|
} |
|
|
|
#There is a copy of this in lonnet.pm |
|
sub userload { |
|
my $numusers=0; |
|
{ |
|
opendir(LONIDS,$perlvar{'lonIDsDir'}); |
|
my $filename; |
|
my $curtime=time; |
|
while ($filename=readdir(LONIDS)) { |
|
if ($filename eq '.' || $filename eq '..') {next;} |
|
my ($atime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[8]; |
|
if ($curtime-$atime < 3600) { $numusers++; } |
|
} |
|
closedir(LONIDS); |
|
} |
|
my $userloadpercent=0; |
|
my $maxuserload=$perlvar{'lonUserLoadLim'}; |
|
if ($maxuserload) { |
|
$userloadpercent=100*$numusers/$maxuserload; |
|
} |
|
$userloadpercent=sprintf("%.2f",$userloadpercent); |
|
return $userloadpercent; |
|
} |
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|
=head1 NAME |
=head1 NAME |
Line 2069 Send along temporarily stored informatio
|
Line 2388 Send along temporarily stored informatio
|
|
|
List part of a user's directory. |
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) |
=item Hanging up (exit or init) |
|
|
What to do when a client tells the server that they (the client) |
What to do when a client tells the server that they (the client) |
Line 2079 are leaving the network.
|
Line 2409 are leaving the network.
|
If B<lond> is sent an unknown command (not in the list above), |
If B<lond> is sent an unknown command (not in the list above), |
it replys to the client "unknown_cmd". |
it replys to the client "unknown_cmd". |
|
|
|
|
=item UNKNOWN CLIENT |
=item UNKNOWN CLIENT |
|
|
If the anti-spoofing algorithm cannot verify the client, |
If the anti-spoofing algorithm cannot verify the client, |