version 1.35, 2001/01/10 17:53:51
|
version 1.96, 2002/09/13 02:46:12
|
Line 1
|
Line 1
|
#!/usr/bin/perl |
#!/usr/bin/perl |
# The LearningOnline Network |
# The LearningOnline Network |
# lond "LON Daemon" Server (port "LOND" 5663) |
# lond "LON Daemon" Server (port "LOND" 5663) |
|
# |
|
# $Id$ |
|
# |
|
# Copyright Michigan State University Board of Trustees |
|
# |
|
# This file is part of the LearningOnline Network with CAPA (LON-CAPA). |
|
# |
|
# LON-CAPA is free software; you can redistribute it and/or modify |
|
# it under the terms of the GNU General Public License as published by |
|
# the Free Software Foundation; either version 2 of the License, or |
|
# (at your option) any later version. |
|
# |
|
# LON-CAPA is distributed in the hope that it will be useful, |
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
# GNU General Public License for more details. |
|
# |
|
# You should have received a copy of the GNU General Public License |
|
# along with LON-CAPA; if not, write to the Free Software |
|
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
|
# |
|
# /home/httpd/html/adm/gpl.txt |
|
# |
|
# http://www.lon-capa.org/ |
|
# |
# 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30, |
# 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30, |
# 7/8,7/9,7/10,7/12,7/17,7/19,9/21, |
# 7/8,7/9,7/10,7/12,7/17,7/19,9/21, |
# 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, |
Line 10
|
Line 35
|
# 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 Scott Harrison |
# 12/05,12/13,12/29 Gerd Kortemeyer |
# 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 |
|
### |
|
|
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# preforker - server who forks first |
# preforker - server who forks first |
# runs as a daemon |
# runs as a daemon |
# HUPs |
# HUPs |
# uses IDEA encryption |
# uses IDEA encryption |
|
|
|
use lib '/home/httpd/lib/perl/'; |
|
use LONCAPA::Configuration; |
|
|
use IO::Socket; |
use IO::Socket; |
use IO::File; |
use IO::File; |
use Apache::File; |
use Apache::File; |
Line 26 use Crypt::IDEA;
|
Line 74 use Crypt::IDEA;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use GDBM_File; |
use GDBM_File; |
use Authen::Krb4; |
use Authen::Krb4; |
|
use Authen::Krb5; |
|
use lib '/home/httpd/lib/perl/'; |
|
use localauth; |
|
|
|
my $DEBUG = 0; # Non zero to enable debug log entries. |
|
|
|
my $status=''; |
|
my $lastlog=''; |
|
|
|
# |
|
# The array below are password error strings." |
|
# |
|
my $lasterror = 10; # 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"); |
|
|
|
# |
|
# Convert an error return code from lcpasswd to a string value. |
|
# |
|
sub lcpasswdstrerror { |
|
my $ErrorCode = shift; |
|
if(($ErrorCode < 0) || ($ErrorCode > $lasterror)) { |
|
return "lcpasswd Unrecognized error return value ".$ErrorCode; |
|
} else { |
|
return $passwderrors($ErrorCode); |
|
} |
|
} |
|
|
# grabs exception and records it to log before exiting |
# grabs exception and records it to log before exiting |
sub catchexception { |
sub catchexception { |
Line 35 sub catchexception {
|
Line 119 sub catchexception {
|
&logthis("<font color=red>CRITICAL: " |
&logthis("<font color=red>CRITICAL: " |
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
."a crash with this error msg->[$error]</font>"); |
."a crash with this error msg->[$error]</font>"); |
|
&logthis('Famous last words: '.$status.' - '.$lastlog); |
if ($client) { print $client "error: $error\n"; } |
if ($client) { print $client "error: $error\n"; } |
|
$server->close(); |
die($error); |
die($error); |
} |
} |
|
|
|
sub timeout { |
|
&logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>"); |
|
&catchexception('Timeout'); |
|
} |
# -------------------------------- Set signal handlers to record abnormal exits |
# -------------------------------- Set signal handlers to record abnormal exits |
|
|
$SIG{'QUIT'}=\&catchexception; |
$SIG{'QUIT'}=\&catchexception; |
$SIG{__DIE__}=\&catchexception; |
$SIG{__DIE__}=\&catchexception; |
|
|
# ------------------------------------ Read httpd access.conf and get variables |
# ---------------------------------- Read loncapa_apache.conf and loncapa.conf |
|
&status("Read loncapa.conf and loncapa_apache.conf"); |
open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; |
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); |
|
my %perlvar=%{$perlvarref}; |
while ($configline=<CONFIG>) { |
undef $perlvarref; |
if ($configline =~ /PerlSetVar/) { |
|
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
|
$perlvar{$varname}=$varvalue; |
|
} |
|
} |
|
close(CONFIG); |
|
|
|
# ----------------------------- 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'}"; |
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
$subj="LON: $perlvar{'lonHostID'} User ID mismatch"; |
$subj="LON: $perlvar{'lonHostID'} User ID mismatch"; |
system("echo 'User ID mismatch. loncron 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 86 open (CONFIG,"$perlvar{'lonTabDir'}/host
|
Line 169 open (CONFIG,"$perlvar{'lonTabDir'}/host
|
|
|
while ($configline=<CONFIG>) { |
while ($configline=<CONFIG>) { |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
chomp($ip); |
chomp($ip); $ip=~s/\D+$//; |
$hostid{$ip}=$id; |
$hostid{$ip}=$id; |
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
$PREFORK++; |
$PREFORK++; |
Line 105 $server = IO::Socket::INET->new(LocalPor
|
Line 188 $server = IO::Socket::INET->new(LocalPor
|
|
|
# global variables |
# global variables |
|
|
$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should |
$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should |
# process |
# process |
%children = (); # keys are current child process IDs |
%children = (); # keys are current child process IDs |
$children = 0; # current number of children |
$children = 0; # current number of children |
Line 113 $children = 0; # cu
|
Line 196 $children = 0; # cu
|
sub REAPER { # takes care of dead children |
sub REAPER { # takes care of dead children |
$SIG{CHLD} = \&REAPER; |
$SIG{CHLD} = \&REAPER; |
my $pid = wait; |
my $pid = wait; |
$children --; |
if (defined($children{$pid})) { |
&logthis("Child $pid died"); |
&logthis("Child $pid died"); |
delete $children{$pid}; |
$children --; |
|
delete $children{$pid}; |
|
} else { |
|
&logthis("Unknown Child $pid died"); |
|
} |
} |
} |
|
|
sub HUNTSMAN { # signal handler for SIGINT |
sub HUNTSMAN { # signal handler for SIGINT |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
kill 'INT' => keys %children; |
kill 'INT' => keys %children; |
|
&logthis("Free socket: ".shutdown($server,2)); # free up socket |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
unlink("$execdir/logs/lond.pid"); |
unlink("$execdir/logs/lond.pid"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
Line 130 sub HUNTSMAN { # si
|
Line 218 sub HUNTSMAN { # si
|
sub HUPSMAN { # signal handler for SIGHUP |
sub HUPSMAN { # signal handler for SIGHUP |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
kill 'INT' => keys %children; |
kill 'INT' => keys %children; |
close($server); # 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"); |
unlink("$execdir/logs/lond.pid"); |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
exec("$execdir/lond"); # here we go again |
exec("$execdir/lond"); # here we go again |
} |
} |
|
|
|
sub checkchildren { |
|
&initnewstatus(); |
|
&logstatus(); |
|
&logthis('Going to check on the children'); |
|
$docdir=$perlvar{'lonDocRoot'}; |
|
foreach (sort keys %children) { |
|
sleep 1; |
|
unless (kill 'USR1' => $_) { |
|
&logthis ('Child '.$_.' is dead'); |
|
&logstatus($$.' is dead'); |
|
} |
|
} |
|
sleep 5; |
|
foreach (sort keys %children) { |
|
unless (-e "$docdir/lon-status/londchld/$_.txt") { |
|
&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.$_` |
|
} |
|
} |
|
} |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
|
sub logthis { |
sub logthis { |
Line 145 sub logthis {
|
Line 259 sub logthis {
|
my $fh=IO::File->new(">>$execdir/logs/lond.log"); |
my $fh=IO::File->new(">>$execdir/logs/lond.log"); |
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
|
$lastlog=$local.': '.$message; |
print $fh "$local ($$): $message\n"; |
print $fh "$local ($$): $message\n"; |
} |
} |
|
|
|
# ------------------------- Conditional log if $DEBUG true. |
|
sub Debug { |
|
my $message = shift; |
|
if($DEBUG) { |
|
&logthis($message); |
|
} |
|
} |
|
# ------------------------------------------------------------------ Log status |
|
|
|
sub logstatus { |
|
my $docdir=$perlvar{'lonDocRoot'}; |
|
{ |
|
my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); |
|
print $fh $$."\t".$status."\t".$lastlog."\n"; |
|
$fh->close(); |
|
} |
|
{ |
|
my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); |
|
print $fh $status."\n".$lastlog."\n".time; |
|
$fh->close(); |
|
} |
|
} |
|
|
|
sub initnewstatus { |
|
my $docdir=$perlvar{'lonDocRoot'}; |
|
my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); |
|
my $now=time; |
|
my $local=localtime($now); |
|
print $fh "LOND status $local - parent $$\n\n"; |
|
opendir(DIR,"$docdir/lon-status/londchld"); |
|
while ($filename=readdir(DIR)) { |
|
unlink("$docdir/lon-status/londchld/$filename"); |
|
} |
|
closedir(DIR); |
|
} |
|
|
|
# -------------------------------------------------------------- Status setting |
|
|
|
sub status { |
|
my $what=shift; |
|
my $now=time; |
|
my $local=localtime($now); |
|
$status=$local.': '.$what; |
|
} |
|
|
# -------------------------------------------------------- Escape Special Chars |
# -------------------------------------------------------- Escape Special Chars |
|
|
Line 177 sub reconlonc {
|
Line 336 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 1; |
sleep 5; |
if (-e "$peerfile") { return; } |
if (-e "$peerfile") { return; } |
&logthis("$peerfile still not there, give it another try"); |
&logthis("$peerfile still not there, give it another try"); |
sleep 5; |
sleep 10; |
if (-e "$peerfile") { return; } |
if (-e "$peerfile") { return; } |
&logthis( |
&logthis( |
"<font color=blue>WARNING: $peerfile still not there, giving up</font>"); |
"<font color=blue>WARNING: $peerfile still not there, giving up</font>"); |
Line 218 sub reply {
|
Line 377 sub reply {
|
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"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
} |
} |
$answer=subreply($cmd,$server); |
$answer=subreply($cmd,$server); |
Line 294 open (PIDSAVE,">$execdir/logs/lond.pid")
|
Line 454 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'); |
|
|
# ------------------------------------------------------- Now we are on our own |
# ------------------------------------------------------- Now we are on our own |
|
|
Line 304 for (1 .. $PREFORK) {
|
Line 465 for (1 .. $PREFORK) {
|
|
|
# ----------------------------------------------------- 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; |
|
|
# And maintain the population. |
# And maintain the population. |
while (1) { |
while (1) { |
|
&status('Sleeping'); |
sleep; # wait for a signal (i.e., child's death) |
sleep; # wait for a signal (i.e., child's death) |
|
&logthis('Woke up'); |
|
&status('Woke up'); |
for ($i = $children; $i < $PREFORK; $i++) { |
for ($i = $children; $i < $PREFORK; $i++) { |
make_new_child(); # top up the child pool |
make_new_child(); # top up the child pool |
} |
} |
Line 334 sub make_new_child {
|
Line 501 sub make_new_child {
|
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
$children{$pid} = 1; |
$children{$pid} = 1; |
$children++; |
$children++; |
|
&status('Started child '.$pid); |
return; |
return; |
} 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{USR1}= \&logstatus; |
|
$SIG{ALRM}= \&timeout; |
|
$lastlog='Forked '; |
|
$status='Forked'; |
|
|
# unblock signals |
# unblock signals |
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; |
$tmpsnum=0; |
|
#---------------------------------------------------- kerberos 5 initialization |
|
&Authen::Krb5::init_context(); |
|
&Authen::Krb5::init_ets(); |
|
|
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
|
&status('Idle, waiting for connection'); |
$client = $server->accept() or last; |
$client = $server->accept() or last; |
|
&status('Accepted connection'); |
# ============================================================================= |
# ============================================================================= |
# do something with the connection |
# do something with the connection |
# ----------------------------------------------------------------------------- |
# ----------------------------------------------------------------------------- |
|
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of |
|
# connection liveness. |
# see if we know client and check for spoof IP by challenge |
# 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); |
my $clientip=inet_ntoa($iaddr); |
my $clientrec=($hostid{$clientip} ne undef); |
my $clientrec=($hostid{$clientip} ne undef); |
&logthis( |
&logthis( |
"<font color=yellow>INFO: Connect from $clientip ($hostid{$clientip})</font>"); |
"<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>" |
|
); |
|
&status("Connecting $clientip ($hostid{$clientip})"); |
my $clientok; |
my $clientok; |
if ($clientrec) { |
if ($clientrec) { |
|
&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 eq 'init') { |
my $challenge="$$".time; |
my $challenge="$$".time; |
print $client "$challenge\n"; |
print $client "$challenge\n"; |
|
&status( |
|
"Waiting for challenge reply from $clientip ($hostid{$clientip})"); |
$remotereq=<$client>; |
$remotereq=<$client>; |
$remotereq=~s/\W//g; |
$remotereq=~s/\W//g; |
if ($challenge eq $remotereq) { |
if ($challenge eq $remotereq) { |
Line 374 sub make_new_child {
|
Line 557 sub make_new_child {
|
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
print $client "bye\n"; |
&status('No challenge reply '.$clientip); |
} |
} |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: " |
"<font color=blue>WARNING: " |
."$clientip failed to initialize: >$remotereq< </font>"); |
."$clientip failed to initialize: >$remotereq< </font>"); |
print $client "bye\n"; |
&status('No init '.$clientip); |
} |
} |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
print $client "bye\n"; |
&status('Hung up on '.$clientip); |
} |
} |
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}"); |
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); |
&logthis( |
&logthis( |
"<font color=green>Established connection: $hostid{$clientip}</font>"); |
"<font color=green>Established connection: $hostid{$clientip}</font>"); |
|
&status('Will listen to '.$hostid{$clientip}); |
# ------------------------------------------------------------ Process requests |
# ------------------------------------------------------------ Process requests |
while (my $userinput=<$client>) { |
while (my $userinput=<$client>) { |
chomp($userinput); |
chomp($userinput); |
|
Debug("Request = $userinput\n"); |
|
&status('Processing '.$hostid{$clientip}.': '.$userinput); |
my $wasenc=0; |
my $wasenc=0; |
|
alarm(120); |
# ------------------------------------------------------------ See if encrypted |
# ------------------------------------------------------------ See if encrypted |
if ($userinput =~ /^enc/) { |
if ($userinput =~ /^enc/) { |
if ($cipher) { |
if ($cipher) { |
Line 409 sub make_new_child {
|
Line 597 sub make_new_child {
|
} |
} |
$userinput=substr($userinput,0,$cmdlength); |
$userinput=substr($userinput,0,$cmdlength); |
$wasenc=1; |
$wasenc=1; |
} |
|
} |
} |
|
} |
|
|
# ------------------------------------------------------------- Normal commands |
# ------------------------------------------------------------- Normal commands |
# ------------------------------------------------------------------------ ping |
# ------------------------------------------------------------------------ ping |
if ($userinput =~ /^ping/) { |
if ($userinput =~ /^ping/) { |
Line 443 sub make_new_child {
|
Line 632 sub make_new_child {
|
$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"; |
|
# ----------------------------------------------------------------- currentauth |
|
} elsif ($userinput =~ /^currentauth/) { |
|
if ($wasenc==1) { |
|
my ($cmd,$udom,$uname)=split(/:/,$userinput); |
|
my $result = GetAuthType($udom, $uname); |
|
if($result eq "nouser") { |
|
print $client "unknown_user\n"; |
|
} |
|
else { |
|
print $client "$result\n" |
|
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
# ------------------------------------------------------------------------ auth |
# ------------------------------------------------------------------------ auth |
} elsif ($userinput =~ /^auth/) { |
} elsif ($userinput =~ /^auth/) { |
if ($wasenc==1) { |
if ($wasenc==1) { |
Line 462 sub make_new_child {
|
Line 665 sub make_new_child {
|
(crypt($upass,$contentpwd) eq $contentpwd); |
(crypt($upass,$contentpwd) eq $contentpwd); |
} elsif ($howpwd eq 'unix') { |
} elsif ($howpwd eq 'unix') { |
$contentpwd=(getpwnam($uname))[1]; |
$contentpwd=(getpwnam($uname))[1]; |
$pwdcorrect= |
my $pwauth_path="/usr/local/sbin/pwauth"; |
(crypt($upass,$contentpwd) eq $contentpwd); |
unless ($contentpwd eq 'x') { |
|
$pwdcorrect= |
|
(crypt($upass,$contentpwd) eq $contentpwd); |
|
} |
|
elsif (-e $pwauth_path) { |
|
open PWAUTH, "|$pwauth_path" or |
|
die "Cannot invoke authentication"; |
|
print PWAUTH "$uname\n$upass\n"; |
|
close PWAUTH; |
|
$pwdcorrect=!$?; |
|
} |
} elsif ($howpwd eq 'krb4') { |
} elsif ($howpwd eq 'krb4') { |
|
$null=pack("C",0); |
|
unless ($upass=~/$null/) { |
$pwdcorrect=( |
$pwdcorrect=( |
Authen::Krb4::get_pw_in_tkt($uname,"", |
Authen::Krb4::get_pw_in_tkt($uname,"", |
$contentpwd,'krbtgt',$contentpwd,1, |
$contentpwd,'krbtgt',$contentpwd,1, |
$upass) == 0); |
$upass) == 0); |
} |
} else { $pwdcorrect=0; } |
|
} elsif ($howpwd eq 'krb5') { |
|
$null=pack("C",0); |
|
unless ($upass=~/$null/) { |
|
my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); |
|
my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; |
|
my $krbserver=&Authen::Krb5::parse_name($krbservice); |
|
my $credentials=&Authen::Krb5::cc_default(); |
|
$credentials->initialize($krbclient); |
|
my $krbreturn = |
|
&Authen::Krb5::get_in_tkt_with_password( |
|
$krbclient,$krbserver,$upass,$credentials); |
|
# unless ($krbreturn) { |
|
# &logthis("Krb5 Error: ". |
|
# &Authen::Krb5::error()); |
|
# } |
|
$pwdcorrect = ($krbreturn == 1); |
|
} else { $pwdcorrect=0; } |
|
} elsif ($howpwd eq 'localauth') { |
|
$pwdcorrect=&localauth::localauth($uname,$upass, |
|
$contentpwd); |
|
} |
if ($pwdcorrect) { |
if ($pwdcorrect) { |
print $client "authorized\n"; |
print $client "authorized\n"; |
} else { |
} else { |
Line 489 sub make_new_child {
|
Line 725 sub make_new_child {
|
chomp($npass); |
chomp($npass); |
$upass=&unescape($upass); |
$upass=&unescape($upass); |
$npass=&unescape($npass); |
$npass=&unescape($npass); |
my $proname=propath($udom,$uname); |
&logthis("Trying to change password for $uname"); |
|
my $proname=propath($udom,$uname); |
my $passfilename="$proname/passwd"; |
my $passfilename="$proname/passwd"; |
if (-e $passfilename) { |
if (-e $passfilename) { |
my $realpasswd; |
my $realpasswd; |
Line 504 sub make_new_child {
|
Line 741 sub make_new_child {
|
my $ncpass=crypt($npass,$salt); |
my $ncpass=crypt($npass,$salt); |
{ my $pf = IO::File->new(">$passfilename"); |
{ my $pf = IO::File->new(">$passfilename"); |
print $pf "internal:$ncpass\n"; } |
print $pf "internal:$ncpass\n"; } |
|
&logthis("Result of password change for $uname: pwchange_success"); |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "non_authorized\n"; |
print $client "non_authorized\n"; |
} |
} |
} else { |
} elsif ($howpwd eq 'unix') { |
|
# Unix means we have to access /etc/password |
|
# one way or another. |
|
# First: Make sure the current password is |
|
# correct |
|
$contentpwd=(getpwnam($uname))[1]; |
|
my $pwdcorrect = "0"; |
|
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"; |
|
print PWAUTH "$uname\n$upass\n"; |
|
close PWAUTH; |
|
$pwdcorrect=!$?; |
|
} |
|
if ($pwdcorrect) { |
|
my $execdir=$perlvar{'lonDaemons'}; |
|
my $pf = IO::File->new("|$execdir/lcpasswd"); |
|
print $pf "$uname\n$npass\n$npass\n"; |
|
close $pf; |
|
my $result = ($?>0 ? 'pwchange_failure' |
|
: 'ok'); |
|
&logthis("Result of password change for $uname: ". |
|
&lcpasswdstrerror($?)); |
|
print $client "$result\n"; |
|
} else { |
|
print $client "non_authorized\n"; |
|
} |
|
} else { |
print $client "auth_mode_error\n"; |
print $client "auth_mode_error\n"; |
} |
} |
} else { |
} else { |
Line 519 sub make_new_child {
|
Line 788 sub make_new_child {
|
} |
} |
# -------------------------------------------------------------------- makeuser |
# -------------------------------------------------------------------- makeuser |
} elsif ($userinput =~ /^makeuser/) { |
} elsif ($userinput =~ /^makeuser/) { |
|
&Debug("Make user received"); |
|
my $oldumask=umask(0077); |
if ($wasenc==1) { |
if ($wasenc==1) { |
my |
my |
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
|
&Debug("cmd =".$cmd." $udom =".$udom. |
|
" uname=".$uname); |
chomp($npass); |
chomp($npass); |
$npass=&unescape($npass); |
$npass=&unescape($npass); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $passfilename="$proname/passwd"; |
my $passfilename="$proname/passwd"; |
|
&Debug("Password file created will be:". |
|
$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 $perlvar{'lonDefDomain'}) { |
Line 538 sub make_new_child {
|
Line 813 sub make_new_child {
|
$fpnow.='/'.$fpparts[$i]; |
$fpnow.='/'.$fpparts[$i]; |
unless (-e $fpnow) { |
unless (-e $fpnow) { |
unless (mkdir($fpnow,0777)) { |
unless (mkdir($fpnow,0777)) { |
$fperror="error:$!\n"; |
$fperror="error:$!"; |
} |
} |
} |
} |
} |
} |
unless ($fperror) { |
unless ($fperror) { |
if ($umode eq 'krb4') { |
my $result=&make_passwd_file($umode,$npass, |
{ |
$passfilename); |
my $pf = IO::File->new(">$passfilename"); |
print $client $result; |
print $pf "krb4:$npass\n"; |
|
} |
|
print $client "ok\n"; |
|
} elsif ($umode eq 'internal') { |
|
my $salt=time; |
|
$salt=substr($salt,6,2); |
|
my $ncpass=crypt($npass,$salt); |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "internal:$ncpass\n"; |
|
} |
|
print $client "ok\n"; |
|
} elsif ($umode eq 'none') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "none:\n"; |
|
} |
|
print $client "ok\n"; |
|
} else { |
|
print $client "auth_mode_error\n"; |
|
} |
|
} else { |
} else { |
print $client "$fperror\n"; |
print $client "$fperror\n"; |
} |
} |
Line 574 sub make_new_child {
|
Line 828 sub make_new_child {
|
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
} |
} |
|
umask($oldumask); |
|
# -------------------------------------------------------------- changeuserauth |
|
} elsif ($userinput =~ /^changeuserauth/) { |
|
&Debug("Changing authorization"); |
|
if ($wasenc==1) { |
|
my |
|
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
|
chomp($npass); |
|
&Debug("cmd = ".$cmd." domain= ".$udom. |
|
"uname =".$uname." umode= ".$umode); |
|
$npass=&unescape($npass); |
|
my $proname=&propath($udom,$uname); |
|
my $passfilename="$proname/passwd"; |
|
if ($udom ne $perlvar{'lonDefDomain'}) { |
|
print $client "not_right_domain\n"; |
|
} else { |
|
my $result=&make_passwd_file($umode,$npass, |
|
$passfilename); |
|
print $client $result; |
|
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
# ------------------------------------------------------------------------ home |
# ------------------------------------------------------------------------ home |
} elsif ($userinput =~ /^home/) { |
} elsif ($userinput =~ /^home/) { |
my ($cmd,$udom,$uname)=split(/:/,$userinput); |
my ($cmd,$udom,$uname)=split(/:/,$userinput); |
Line 636 sub make_new_child {
|
Line 913 sub make_new_child {
|
} else { |
} else { |
print $client "rejected\n"; |
print $client "rejected\n"; |
} |
} |
|
# -------------------------------------- fetch a user file from a remote server |
|
} elsif ($userinput =~ /^fetchuserfile/) { |
|
my ($cmd,$fname)=split(/:/,$userinput); |
|
my ($udom,$uname,$ufile)=split(/\//,$fname); |
|
my $udir=propath($udom,$uname).'/userfiles'; |
|
unless (-e $udir) { mkdir($udir,0770); } |
|
if (-e $udir) { |
|
$ufile=~s/^[\.\~]+//; |
|
$ufile=~s/\///g; |
|
my $transname=$udir.'/'.$ufile; |
|
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; |
|
my $response; |
|
{ |
|
my $ua=new LWP::UserAgent; |
|
my $request=new HTTP::Request('GET',"$remoteurl"); |
|
$response=$ua->request($request,$transname); |
|
} |
|
if ($response->is_error()) { |
|
unlink($transname); |
|
my $message=$response->status_line; |
|
&logthis( |
|
"LWP GET: $message for $fname ($remoteurl)"); |
|
print $client "failed\n"; |
|
} else { |
|
print $client "ok\n"; |
|
} |
|
} else { |
|
print $client "not_home\n"; |
|
} |
|
# ------------------------------------------ authenticate access to a user file |
|
} elsif ($userinput =~ /^tokenauthuserfile/) { |
|
my ($cmd,$fname,$session)=split(/:/,$userinput); |
|
chomp($session); |
|
$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"; |
|
} else { |
|
print $client "invalid_token\n"; |
|
} |
# ----------------------------------------------------------------- unsubscribe |
# ----------------------------------------------------------------- unsubscribe |
} elsif ($userinput =~ /^unsub/) { |
} elsif ($userinput =~ /^unsub/) { |
my ($cmd,$fname)=split(/:/,$userinput); |
my ($cmd,$fname)=split(/:/,$userinput); |
if (-e $fname) { |
if (-e $fname) { |
if (unlink("$fname.$hostid{$clientip}")) { |
print $client &unsub($client,$fname,$clientip); |
print $client "ok\n"; |
|
} else { |
|
print $client "not_subscribed\n"; |
|
} |
|
} else { |
} else { |
print $client "not_found\n"; |
print $client "not_found\n"; |
} |
} |
# ------------------------------------------------------------------- subscribe |
# ------------------------------------------------------------------- subscribe |
} elsif ($userinput =~ /^sub/) { |
} elsif ($userinput =~ /^sub/) { |
my ($cmd,$fname)=split(/:/,$userinput); |
print $client &subscribe($userinput,$clientip); |
my $ownership=ishome($fname); |
|
if ($ownership eq 'owner') { |
|
if (-e $fname) { |
|
if (-d $fname) { |
|
print $client "directory\n"; |
|
} else { |
|
$now=time; |
|
{ |
|
my $sh; |
|
if ($sh= |
|
IO::File->new(">$fname.$hostid{$clientip}")) { |
|
print $sh "$clientip:$now\n"; |
|
} |
|
} |
|
$fname=~s/\/home\/httpd\/html\/res/raw/; |
|
$fname="http://$thisserver/".$fname; |
|
print $client "$fname\n"; |
|
} |
|
} else { |
|
print $client "not_found\n"; |
|
} |
|
} else { |
|
print $client "rejected\n"; |
|
} |
|
# ------------------------------------------------------------------------- log |
# ------------------------------------------------------------------------- log |
} elsif ($userinput =~ /^log/) { |
} elsif ($userinput =~ /^log/) { |
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
Line 700 sub make_new_child {
|
Line 993 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
unless ($namespace=~/^nohist\_/) { |
my $hfh; |
my $hfh; |
if ( |
if ( |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
Line 725 sub make_new_child {
|
Line 1018 sub make_new_child {
|
} |
} |
# -------------------------------------------------------------------- rolesput |
# -------------------------------------------------------------------- rolesput |
} elsif ($userinput =~ /^rolesput/) { |
} elsif ($userinput =~ /^rolesput/) { |
|
&Debug("rolesput"); |
if ($wasenc==1) { |
if ($wasenc==1) { |
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
&Debug("cmd = ".$cmd." exedom= ".$exedom. |
|
"user = ".$exeuser." udom=".$udom. |
|
"what = ".$what); |
my $namespace='roles'; |
my $namespace='roles'; |
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
Line 744 sub make_new_child {
|
Line 1041 sub make_new_child {
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
foreach $pair (@pairs) { |
foreach $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
($key,$value)=split(/=/,$pair); |
|
&ManagePermissions($key, $udom, $uname, |
|
&GetAuthType( $udom, |
|
$uname)); |
$hash{$key}=$value; |
$hash{$key}=$value; |
|
|
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
Line 825 sub make_new_child {
|
Line 1126 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
unless ($namespace=~/^nohist\_/) { |
my $hfh; |
my $hfh; |
if ( |
if ( |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
Line 867 sub make_new_child {
|
Line 1168 sub make_new_child {
|
} |
} |
# ------------------------------------------------------------------------ dump |
# ------------------------------------------------------------------------ dump |
} elsif ($userinput =~ /^dump/) { |
} elsif ($userinput =~ /^dump/) { |
my ($cmd,$udom,$uname,$namespace) |
my ($cmd,$udom,$uname,$namespace,$regexp) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
$namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
|
if (defined($regexp)) { |
|
$regexp=&unescape($regexp); |
|
} else { |
|
$regexp='.'; |
|
} |
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)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
|
study($regexp); |
foreach $key (keys %hash) { |
foreach $key (keys %hash) { |
$qresult.="$key=$hash{$key}&"; |
my $unescapeKey = &unescape($key); |
|
if (eval('$unescapeKey=~/$regexp/')) { |
|
$qresult.="$key=$hash{$key}&"; |
|
} |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
Line 896 sub make_new_child {
|
Line 1206 sub make_new_child {
|
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
unless ($namespace=~/^nohist\_/) { |
my $hfh; |
my $hfh; |
if ( |
if ( |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
Line 915 sub make_new_child {
|
Line 1225 sub make_new_child {
|
$allkeys.=$key.':'; |
$allkeys.=$key.':'; |
$hash{"$version:$rid:$key"}=$value; |
$hash{"$version:$rid:$key"}=$value; |
} |
} |
$allkeys=~s/:$//; |
$hash{"$version:$rid:timestamp"}=$now; |
|
$allkeys.='timestamp'; |
$hash{"$version:keys:$rid"}=$allkeys; |
$hash{"$version:keys:$rid"}=$allkeys; |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
Line 959 sub make_new_child {
|
Line 1270 sub make_new_child {
|
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
} |
} |
|
# -------------------------------------------------------------------- chatsend |
|
} elsif ($userinput =~ /^chatsend/) { |
|
my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); |
|
&chatadd($cdom,$cnum,$newpost); |
|
print $client "ok\n"; |
|
# -------------------------------------------------------------------- chatretr |
|
} elsif ($userinput =~ /^chatretr/) { |
|
my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); |
|
my $reply=''; |
|
foreach (&getchat($cdom,$cnum)) { |
|
$reply.=&escape($_).':'; |
|
} |
|
$reply=~s/\:$//; |
|
print $client $reply."\n"; |
# ------------------------------------------------------------------- querysend |
# ------------------------------------------------------------------- querysend |
} elsif ($userinput =~ /^querysend/) { |
} elsif ($userinput =~ /^querysend/) { |
my ($cmd,$query)=split(/:/,$userinput); |
my ($cmd,$query, |
|
$arg1,$arg2,$arg3)=split(/\:/,$userinput); |
$query=~s/\n*$//g; |
$query=~s/\n*$//g; |
print $client sqlreply("$hostid{$clientip}\&$query")."\n"; |
print $client "". |
|
sqlreply("$hostid{$clientip}\&$query". |
|
"\&$arg1"."\&$arg2"."\&$arg3")."\n"; |
# ------------------------------------------------------------------ queryreply |
# ------------------------------------------------------------------ queryreply |
} elsif ($userinput =~ /^queryreply/) { |
} elsif ($userinput =~ /^queryreply/) { |
my ($cmd,$id,$reply)=split(/:/,$userinput); |
my ($cmd,$id,$reply)=split(/:/,$userinput); |
my $store; |
my $store; |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
if ($store=IO::File->new(">$execdir/tmp/$id")) { |
if ($store=IO::File->new(">$execdir/tmp/$id")) { |
|
$reply=~s/\&/\n/g; |
print $store $reply; |
print $store $reply; |
close $store; |
close $store; |
|
my $store2=IO::File->new(">$execdir/tmp/$id.end"); |
|
print $store2 "done\n"; |
|
close $store2; |
print $client "ok\n"; |
print $client "ok\n"; |
} |
} |
else { |
else { |
Line 1065 sub make_new_child {
|
Line 1397 sub make_new_child {
|
my $ulsout=''; |
my $ulsout=''; |
my $ulsfn; |
my $ulsfn; |
if (-e $ulsdir) { |
if (-e $ulsdir) { |
while ($ulsfn=<$ulsdir/*>) { |
if(-d $ulsdir) { |
my @ulsstats=stat($ulsfn); |
if (opendir(LSDIR,$ulsdir)) { |
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
while ($ulsfn=readdir(LSDIR)) { |
} |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
} else { |
$ulsout.=$ulsfn.'&'. |
|
join('&',@ulsstats).':'; |
|
} |
|
closedir(LSDIR); |
|
} |
|
} else { |
|
my @ulsstats=stat($ulsdir); |
|
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
|
} |
|
} else { |
$ulsout='no_such_dir'; |
$ulsout='no_such_dir'; |
} |
} |
if ($ulsout eq '') { $ulsout='empty'; } |
if ($ulsout eq '') { $ulsout='empty'; } |
print $client "$ulsout\n"; |
print $client "$ulsout\n"; |
|
# ------------------------------------------------------------------ Hanging up |
|
} elsif (($userinput =~ /^exit/) || |
|
($userinput =~ /^init/)) { |
|
&logthis( |
|
"Client $clientip ($hostid{$clientip}) hanging up: $userinput"); |
|
print $client "bye\n"; |
|
$client->close(); |
|
last; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
} else { |
} else { |
# unknown command |
# unknown command |
print $client "unknown_cmd\n"; |
print $client "unknown_cmd\n"; |
} |
} |
# ------------------------------------------------------ client unknown, refuse |
# -------------------------------------------------------------------- complete |
|
alarm(0); |
|
&status('Listening to '.$hostid{$clientip}); |
} |
} |
|
# --------------------------------------------- client unknown or fishy, refuse |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
|
$client->close(); |
&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: " |
} |
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
|
# ============================================================================= |
# ============================================================================= |
} |
|
|
&logthis("<font color=red>CRITICAL: " |
|
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
# tidy up gracefully and finish |
# 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. |
Line 1101 sub make_new_child {
|
Line 1457 sub make_new_child {
|
} |
} |
|
|
|
|
|
# |
|
# Checks to see if the input roleput request was to set |
|
# an author role. If so, invokes the lchtmldir script to set |
|
# up a correct public_html |
|
# Parameters: |
|
# request - The request sent to the rolesput subchunk. |
|
# We're looking for /domain/_au |
|
# domain - The domain in which the user is having roles doctored. |
|
# user - Name of the user for which the role is being put. |
|
# authtype - The authentication type associated with the user. |
|
# |
|
sub ManagePermissions |
|
{ |
|
my $request = shift; |
|
my $domain = shift; |
|
my $user = shift; |
|
my $authtype= shift; |
|
|
|
# See if the request is of the form /$domain/_au |
|
|
|
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
|
my $execdir = $perlvar{'lonDaemons'}; |
|
my $userhome= "/home/$user" ; |
|
Debug("system $execdir/lchtmldir $userhome $system $authtype"); |
|
system("$execdir/lchtmldir $userhome $user $authtype"); |
|
} |
|
} |
|
# |
|
# GetAuthType - Determines the authorization type of a user in a domain. |
|
|
|
# Returns the authorization type or nouser if there is no such user. |
|
# |
|
sub GetAuthType |
|
{ |
|
my $domain = shift; |
|
my $user = shift; |
|
|
|
Debug("GetAuthType( $domain, $user ) \n"); |
|
my $proname = &propath($domain, $user); |
|
my $passwdfile = "$proname/passwd"; |
|
if( -e $passwdfile ) { |
|
my $pf = IO::File->new($passwdfile); |
|
my $realpassword = <$pf>; |
|
chomp($realpassword); |
|
Debug("Password info = $realpassword\n"); |
|
my ($authtype, $contentpwd) = split(/:/, $realpassword); |
|
Debug("Authtype = $authtype, content = $contentpwd\n"); |
|
my $availinfo = ''; |
|
if($authtype eq 'krb4' or $authtype eq 'krb5') { |
|
$availinfo = $contentpwd; |
|
} |
|
|
|
return "$authtype:$availinfo"; |
|
} |
|
else { |
|
Debug("Returning nouser"); |
|
return "nouser"; |
|
} |
|
} |
|
|
|
sub addline { |
|
my ($fname,$hostid,$ip,$newline)=@_; |
|
my $contents; |
|
my $found=0; |
|
my $expr='^'.$hostid.':'.$ip.':'; |
|
$expr =~ s/\./\\\./g; |
|
if ($sh=IO::File->new("$fname.subscription")) { |
|
while (my $subline=<$sh>) { |
|
if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} |
|
} |
|
$sh->close(); |
|
} |
|
$sh=IO::File->new(">$fname.subscription"); |
|
if ($contents) { print $sh $contents; } |
|
if ($newline) { print $sh $newline; } |
|
$sh->close(); |
|
return $found; |
|
} |
|
|
|
sub getchat { |
|
my ($cdom,$cname)=@_; |
|
my %hash; |
|
my $proname=&propath($cdom,$cname); |
|
my @entries=(); |
|
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", |
|
&GDBM_READER(),0640)) { |
|
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
|
untie %hash; |
|
} |
|
return @entries; |
|
} |
|
|
|
sub chatadd { |
|
my ($cdom,$cname,$newchat)=@_; |
|
my %hash; |
|
my $proname=&propath($cdom,$cname); |
|
my @entries=(); |
|
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'; |
|
if ($thentime==$time) { |
|
$idnum=~s/^0+//; |
|
$idnum++; |
|
$idnum=substr('000000'.$idnum,-6,6); |
|
$newid=$time.'_'.$idnum; |
|
} |
|
$hash{$newid}=$newchat; |
|
my $expired=$time-3600; |
|
foreach (keys %hash) { |
|
my ($thistime)=($_=~/(\d+)\_/); |
|
if ($thistime<$expired) { |
|
delete $hash{$_}; |
|
} |
|
} |
|
untie %hash; |
|
} |
|
} |
|
|
|
sub unsub { |
|
my ($fname,$clientip)=@_; |
|
my $result; |
|
if (unlink("$fname.$hostid{$clientip}")) { |
|
$result="ok\n"; |
|
} else { |
|
$result="not_subscribed\n"; |
|
} |
|
if (-e "$fname.subscription") { |
|
my $found=&addline($fname,$hostid{$clientip},$clientip,''); |
|
if ($found) { $result="ok\n"; } |
|
} else { |
|
if ($result != "ok\n") { $result="not_subscribed\n"; } |
|
} |
|
return $result; |
|
} |
|
|
|
sub subscribe { |
|
my ($userinput,$clientip)=@_; |
|
my $result; |
|
my ($cmd,$fname)=split(/:/,$userinput); |
|
my $ownership=&ishome($fname); |
|
if ($ownership eq 'owner') { |
|
if (-e $fname) { |
|
if (-d $fname) { |
|
$result="directory\n"; |
|
} else { |
|
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} |
|
$now=time; |
|
my $found=&addline($fname,$hostid{$clientip},$clientip, |
|
"$hostid{$clientip}:$clientip:$now\n"); |
|
if ($found) { $result="$fname\n"; } |
|
# if they were subscribed to only meta data, delete that |
|
# subscription, when you subscribe to a file you also get |
|
# the metadata |
|
unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } |
|
$fname=~s/\/home\/httpd\/html\/res/raw/; |
|
$fname="http://$thisserver/".$fname; |
|
$result="$fname\n"; |
|
} |
|
} else { |
|
$result="not_found\n"; |
|
} |
|
} else { |
|
$result="rejected\n"; |
|
} |
|
return $result; |
|
} |
|
|
|
sub make_passwd_file { |
|
my ($umode,$npass,$passfilename)=@_; |
|
my $result="ok\n"; |
|
if ($umode eq 'krb4' or $umode eq 'krb5') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "$umode:$npass\n"; |
|
} |
|
} elsif ($umode eq 'internal') { |
|
my $salt=time; |
|
$salt=substr($salt,6,2); |
|
my $ncpass=crypt($npass,$salt); |
|
{ |
|
&Debug("Creating internal auth"); |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "internal:$ncpass\n"; |
|
} |
|
} elsif ($umode eq 'localauth') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "localauth:$npass\n"; |
|
} |
|
} elsif ($umode eq 'unix') { |
|
{ |
|
my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; |
|
{ |
|
&Debug("Executing external: ".$execpath); |
|
my $se = IO::File->new("|$execpath"); |
|
print $se "$uname\n"; |
|
print $se "$npass\n"; |
|
print $se "$npass\n"; |
|
} |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "unix:\n"; |
|
} |
|
} elsif ($umode eq 'none') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "none:\n"; |
|
} |
|
} else { |
|
$result="auth_mode_error\n"; |
|
} |
|
return $result; |
|
} |
|
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|
|
=head1 NAME |
|
|
|
lond - "LON Daemon" Server (port "LOND" 5663) |
|
|
|
=head1 SYNOPSIS |
|
|
|
Usage: B<lond> |
|
|
|
Should only be run as user=www. This is a command-line script which |
|
is invoked by B<loncron>. There is no expectation that a typical user |
|
will manually start B<lond> from the command-line. (In other words, |
|
DO NOT START B<lond> YOURSELF.) |
|
|
|
=head1 DESCRIPTION |
|
|
|
There are two characteristics associated with the running of B<lond>, |
|
PROCESS MANAGEMENT (starting, stopping, handling child processes) |
|
and SERVER-SIDE ACTIVITIES (password authentication, user creation, |
|
subscriptions, etc). These are described in two large |
|
sections below. |
|
|
|
B<PROCESS MANAGEMENT> |
|
|
|
Preforker - server who forks first. Runs as a daemon. HUPs. |
|
Uses IDEA encryption |
|
|
|
B<lond> forks off children processes that correspond to the other servers |
|
in the network. Management of these processes can be done at the |
|
parent process level or the child process level. |
|
|
|
B<logs/lond.log> is the location of log messages. |
|
|
|
The process management is now explained in terms of linux shell commands, |
|
subroutines internal to this code, and signal assignments: |
|
|
|
=over 4 |
|
|
|
=item * |
|
|
|
PID is stored in B<logs/lond.pid> |
|
|
|
This is the process id number of the parent B<lond> process. |
|
|
|
=item * |
|
|
|
SIGTERM and SIGINT |
|
|
|
Parent signal assignment: |
|
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
|
|
|
Child signal assignment: |
|
$SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) |
|
(The child dies and a SIGALRM is sent to parent, awaking parent from slumber |
|
to restart a new child.) |
|
|
|
Command-line invocations: |
|
B<kill> B<-s> SIGTERM I<PID> |
|
B<kill> B<-s> SIGINT I<PID> |
|
|
|
Subroutine B<HUNTSMAN>: |
|
This is only invoked for the B<lond> parent I<PID>. |
|
This kills all the children, and then the parent. |
|
The B<lonc.pid> file is cleared. |
|
|
|
=item * |
|
|
|
SIGHUP |
|
|
|
Current bug: |
|
This signal can only be processed the first time |
|
on the parent process. Subsequent SIGHUP signals |
|
have no effect. |
|
|
|
Parent signal assignment: |
|
$SIG{HUP} = \&HUPSMAN; |
|
|
|
Child signal assignment: |
|
none (nothing happens) |
|
|
|
Command-line invocations: |
|
B<kill> B<-s> SIGHUP I<PID> |
|
|
|
Subroutine B<HUPSMAN>: |
|
This is only invoked for the B<lond> parent I<PID>, |
|
This kills all the children, and then the parent. |
|
The B<lond.pid> file is cleared. |
|
|
|
=item * |
|
|
|
SIGUSR1 |
|
|
|
Parent signal assignment: |
|
$SIG{USR1} = \&USRMAN; |
|
|
|
Child signal assignment: |
|
$SIG{USR1}= \&logstatus; |
|
|
|
Command-line invocations: |
|
B<kill> B<-s> SIGUSR1 I<PID> |
|
|
|
Subroutine B<USRMAN>: |
|
When invoked for the B<lond> parent I<PID>, |
|
SIGUSR1 is sent to all the children, and the status of |
|
each connection is logged. |
|
|
|
=item * |
|
|
|
SIGCHLD |
|
|
|
Parent signal assignment: |
|
$SIG{CHLD} = \&REAPER; |
|
|
|
Child signal assignment: |
|
none |
|
|
|
Command-line invocations: |
|
B<kill> B<-s> SIGCHLD I<PID> |
|
|
|
Subroutine B<REAPER>: |
|
This is only invoked for the B<lond> parent I<PID>. |
|
Information pertaining to the child is removed. |
|
The socket port is cleaned up. |
|
|
|
=back |
|
|
|
B<SERVER-SIDE ACTIVITIES> |
|
|
|
Server-side information can be accepted in an encrypted or non-encrypted |
|
method. |
|
|
|
=over 4 |
|
|
|
=item ping |
|
|
|
Query a client in the hosts.tab table; "Are you there?" |
|
|
|
=item pong |
|
|
|
Respond to a ping query. |
|
|
|
=item ekey |
|
|
|
Read in encrypted key, make cipher. Respond with a buildkey. |
|
|
|
=item load |
|
|
|
Respond with CPU load based on a computation upon /proc/loadavg. |
|
|
|
=item currentauth |
|
|
|
Reply with current authentication information (only over an |
|
encrypted channel). |
|
|
|
=item auth |
|
|
|
Only over an encrypted channel, reply as to whether a user's |
|
authentication information can be validated. |
|
|
|
=item passwd |
|
|
|
Allow for a password to be set. |
|
|
|
=item makeuser |
|
|
|
Make a user. |
|
|
|
=item passwd |
|
|
|
Allow for authentication mechanism and password to be changed. |
|
|
|
=item home |
|
|
|
Respond to a question "are you the home for a given user?" |
|
|
|
=item update |
|
|
|
Update contents of a subscribed resource. |
|
|
|
=item unsubscribe |
|
|
|
The server is unsubscribing from a resource. |
|
|
|
=item subscribe |
|
|
|
The server is subscribing to a resource. |
|
|
|
=item log |
|
|
|
Place in B<logs/lond.log> |
|
|
|
=item put |
|
|
|
stores hash in namespace |
|
|
|
=item rolesput |
|
|
|
put a role into a user's environment |
|
|
|
=item get |
|
|
|
returns hash with keys from array |
|
reference filled in from namespace |
|
|
|
=item eget |
|
|
|
returns hash with keys from array |
|
reference filled in from namesp (encrypts the return communication) |
|
|
|
=item rolesget |
|
|
|
get a role from a user's environment |
|
|
|
=item del |
|
|
|
deletes keys out of array from namespace |
|
|
|
=item keys |
|
|
|
returns namespace keys |
|
|
|
=item dump |
|
|
|
dumps the complete (or key matching regexp) namespace into a hash |
|
|
|
=item store |
|
|
|
stores hash permanently |
|
for this url; hashref needs to be given and should be a \%hashname; the |
|
remaining args aren't required and if they aren't passed or are '' they will |
|
be derived from the ENV |
|
|
|
=item restore |
|
|
|
returns a hash for a given url |
|
|
|
=item querysend |
|
|
|
Tells client about the lonsql process that has been launched in response |
|
to a sent query. |
|
|
|
=item queryreply |
|
|
|
Accept information from lonsql and make appropriate storage in temporary |
|
file space. |
|
|
|
=item idput |
|
|
|
Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers |
|
for each student, defined perhaps by the institutional Registrar.) |
|
|
|
=item idget |
|
|
|
Returns usernames corresponding to IDs. (These "IDs" are unique identifiers |
|
for each student, defined perhaps by the institutional Registrar.) |
|
|
|
=item tmpput |
|
|
|
Accept and store information in temporary space. |
|
|
|
=item tmpget |
|
|
|
Send along temporarily stored information. |
|
|
|
=item ls |
|
|
|
List part of a user's directory. |
|
|
|
=item Hanging up (exit or init) |
|
|
|
What to do when a client tells the server that they (the client) |
|
are leaving the network. |
|
|
|
=item unknown command |
|
|
|
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, |
|
the client is rejected (with a "refused" message sent |
|
to the client, and the connection is closed. |
|
|
|
=back |
|
|
|
=head1 PREREQUISITES |
|
|
|
IO::Socket |
|
IO::File |
|
Apache::File |
|
Symbol |
|
POSIX |
|
Crypt::IDEA |
|
LWP::UserAgent() |
|
GDBM_File |
|
Authen::Krb4 |
|
Authen::Krb5 |
|
|
|
=head1 COREQUISITES |
|
|
|
=head1 OSNAMES |
|
|
|
linux |
|
|
|
=head1 SCRIPT CATEGORIES |
|
|
|
Server/Process |
|
|
|
=cut |