|
version 1.8, 2000/01/14 14:46:57
|
version 1.136, 2003/08/12 19:46:04
|
|
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, |
| # 12/7,12/15,01/06,01/11,01/12,01/14 Gerd Kortemeyer |
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8, |
| # based on "Perl Cookbook" ISBN 1-56592-243-3 |
# 03/07,05/31 Gerd Kortemeyer |
| # preforker - server who forks first |
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
| # runs as a daemon |
# 12/05,12/13,12/29 Gerd Kortemeyer |
| # HUPs |
# YEAR=2001 |
| # uses IDEA encryption |
# 02/12 Gerd Kortemeyer |
| |
# 03/24 Gerd Kortemeyer |
| |
# 05/11,05/28,08/30 Gerd Kortemeyer |
| |
# 11/26,11/27 Gerd Kortemeyer |
| |
# 12/22 Gerd Kortemeyer |
| |
# YEAR=2002 |
| |
# 01/20/02,02/05 Gerd Kortemeyer |
| |
# 02/05 Guy Albertelli |
| |
# 02/12 Gerd Kortemeyer |
| |
# 02/19 Matthew Hall |
| |
# 02/25 Gerd Kortemeyer |
| |
# 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 |
| |
### |
| |
|
| |
use strict; |
| |
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; |
| use Symbol; |
use Symbol; |
| use POSIX; |
use POSIX; |
| use Crypt::IDEA; |
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=''; |
| |
|
| |
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." |
| |
# |
| |
my $lastpwderror = 13; # Largest error number from lcpasswd. |
| |
my @passwderrors = ("ok", |
| |
"lcpasswd must be run as user 'www'", |
| |
"lcpasswd got incorrect number of arguments", |
| |
"lcpasswd did not get the right nubmer of input text lines", |
| |
"lcpasswd too many simultaneous pwd changes in progress", |
| |
"lcpasswd User does not exist.", |
| |
"lcpasswd Incorrect current passwd", |
| |
"lcpasswd Unable to su to root.", |
| |
"lcpasswd Cannot set new passwd.", |
| |
"lcpasswd Username has invalid characters", |
| |
"lcpasswd Invalid characters in password", |
| |
"11", "12", |
| |
"lcpasswd Password mismatch"); |
| |
|
| |
|
| |
# The array below are lcuseradd error strings.: |
| |
|
| |
my $lastadderror = 13; |
| |
my @adderrors = ("ok", |
| |
"User ID mismatch, lcuseradd must run as user www", |
| |
"lcuseradd Incorrect number of command line parameters must be 3", |
| |
"lcuseradd Incorrect number of stdinput lines, must be 3", |
| |
"lcuseradd Too many other simultaneous pwd changes in progress", |
| |
"lcuseradd User does not exist", |
| |
"lcuseradd Unabel to mak ewww member of users's group", |
| |
"lcuseradd Unable to su to root", |
| |
"lcuseradd Unable to set password", |
| |
"lcuseradd Usrname has invbalid charcters", |
| |
"lcuseradd Password has an invalid character", |
| |
"lcuseradd User already exists", |
| |
"lcuseradd Could not add user.", |
| |
"lcuseradd Password mismatch"); |
| |
|
| |
|
| |
# |
| |
# Convert an error return code from lcpasswd to a string value. |
| |
# |
| |
sub lcpasswdstrerror { |
| |
my $ErrorCode = shift; |
| |
if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { |
| |
return "lcpasswd Unrecognized error return value ".$ErrorCode; |
| |
} else { |
| |
return $passwderrors[$ErrorCode]; |
| |
} |
| |
} |
| |
|
| |
# |
| |
# Convert an error return code from lcuseradd to a string value: |
| |
# |
| |
sub lcuseraddstrerror { |
| |
my $ErrorCode = shift; |
| |
if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { |
| |
return "lcuseradd - Unrecognized error code: ".$ErrorCode; |
| |
} else { |
| |
return $adderrors[$ErrorCode]; |
| |
} |
| |
} |
| |
|
| # ------------------------------------ Read httpd access.conf and get variables |
# grabs exception and records it to log before exiting |
| |
sub catchexception { |
| |
my ($error)=@_; |
| |
$SIG{'QUIT'}='DEFAULT'; |
| |
$SIG{__DIE__}='DEFAULT'; |
| |
&logthis("<font color=red>CRITICAL: " |
| |
."ABNORMAL EXIT. Child $$ for server $thisserver died through " |
| |
."a crash with this error msg->[$error]</font>"); |
| |
&logthis('Famous last words: '.$status.' - '.$lastlog); |
| |
if ($client) { print $client "error: $error\n"; } |
| |
$server->close(); |
| |
die($error); |
| |
} |
| |
|
| |
sub timeout { |
| |
&logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>"); |
| |
&catchexception('Timeout'); |
| |
} |
| |
# -------------------------------- Set signal handlers to record abnormal exits |
| |
|
| open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; |
$SIG{'QUIT'}=\&catchexception; |
| |
$SIG{__DIE__}=\&catchexception; |
| |
|
| while ($configline=<CONFIG>) { |
# ---------------------------------- Read loncapa_apache.conf and loncapa.conf |
| if ($configline =~ /PerlSetVar/) { |
&status("Read loncapa.conf and loncapa_apache.conf"); |
| my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); |
| chomp($varvalue); |
my %perlvar=%{$perlvarref}; |
| $perlvar{$varname}=$varvalue; |
undef $perlvarref; |
| } |
|
| |
# ----------------------------- Make sure this process is running from user=www |
| |
my $wwwid=getpwnam('www'); |
| |
if ($wwwid!=$<) { |
| |
my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
| |
my $subj="LON: $currenthostid User ID mismatch"; |
| |
system("echo 'User ID mismatch. lond must be run as user www.' |\ |
| |
mailto $emailto -s '$subj' > /dev/null"); |
| |
exit 1; |
| } |
} |
| close(CONFIG); |
|
| |
|
| $PREFORK=4; # number of children to maintain, at least four spare |
# --------------------------------------------- Check if other instance running |
| |
|
| |
my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; |
| |
|
| |
if (-e $pidfile) { |
| |
my $lfh=IO::File->new("$pidfile"); |
| |
my $pide=<$lfh>; |
| |
chomp($pide); |
| |
if (kill 0 => $pide) { die "already running"; } |
| |
} |
| |
|
| # ------------------------------------------------------------- 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); |
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 61 $server = IO::Socket::INET->new(LocalPor
|
Line 232 $server = IO::Socket::INET->new(LocalPor
|
| |
|
| # global variables |
# global variables |
| |
|
| $MAX_CLIENTS_PER_CHILD = 5; # 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; |
| 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("Shutting down"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
| exit; # clean up with dignity |
exit; # clean up with dignity |
| } |
} |
| |
|
| 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("Restarting"); |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
| 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 |
| } |
} |
| |
|
| |
sub checkchildren { |
| |
&initnewstatus(); |
| |
&logstatus(); |
| |
&logthis('Going to check on the children'); |
| |
my $docdir=$perlvar{'lonDocRoot'}; |
| |
foreach (sort keys %children) { |
| |
sleep 1; |
| |
unless (kill 'USR1' => $_) { |
| |
&logthis ('Child '.$_.' is dead'); |
| |
&logstatus($$.' is dead'); |
| |
} |
| |
} |
| |
sleep 5; |
| |
$SIG{ALRM} = sub { die "timeout" }; |
| |
$SIG{__DIE__} = 'DEFAULT'; |
| |
foreach (sort keys %children) { |
| |
unless (-e "$docdir/lon-status/londchld/$_.txt") { |
| |
eval { |
| |
alarm(300); |
| |
&logthis('Child '.$_.' did not respond'); |
| |
kill 9 => $_; |
| |
#$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
| |
#$subj="LON: $currenthostid killed lond process $_"; |
| |
#my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; |
| |
#$execdir=$perlvar{'lonDaemons'}; |
| |
#$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; |
| |
alarm(0); |
| |
} |
| |
} |
| |
} |
| |
$SIG{ALRM} = 'DEFAULT'; |
| |
$SIG{__DIE__} = \&cathcexception; |
| |
} |
| |
|
| # --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
| |
|
| sub logthis { |
sub logthis { |
|
Line 100 sub logthis {
|
Line 309 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".$currenthostid."\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 (my $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; |
| |
$0='lond: '.$what.' '.$local; |
| |
} |
| |
|
| |
# -------------------------------------------------------- Escape Special Chars |
| |
|
| |
sub escape { |
| |
my $str=shift; |
| |
$str =~ s/(\W)/"%".unpack('H2',$1)/eg; |
| |
return $str; |
| |
} |
| |
|
| |
# ----------------------------------------------------- Un-Escape Special Chars |
| |
|
| |
sub unescape { |
| |
my $str=shift; |
| |
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; |
| |
return $str; |
| |
} |
| |
|
| # ----------------------------------------------------------- Send USR1 to lonc |
# ----------------------------------------------------------- Send USR1 to lonc |
| |
|
| sub reconlonc { |
sub reconlonc { |
|
Line 115 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 1; |
|
| if (-e "$peerfile") { return; } |
|
| &logthis("$peerfile still not there, give it another try"); |
|
| sleep 5; |
|
| if (-e "$peerfile") { return; } |
|
| &logthis("$peerfile still not there, giving up"); |
|
| } else { |
} else { |
| &logthis("lonc at pid $loncpid not responding, giving up"); |
&logthis( |
| |
"<font color=red>CRITICAL: " |
| |
."lonc at pid $loncpid not responding, giving up</font>"); |
| } |
} |
| } else { |
} else { |
| &logthis('lonc not running, giving up'); |
&logthis('<font color=red>CRITICAL: lonc not running, giving up</font>'); |
| } |
} |
| } |
} |
| |
|
| # -------------------------------------------------- Non-critical communication |
# -------------------------------------------------- Non-critical communication |
| |
|
| sub subreply { |
sub subreply { |
| my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
| my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
|
Line 147 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 answer is $answer, server is $server"); |
| &reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
| } |
} |
| $answer=subreply($cmd,$server); |
$answer=subreply($cmd,$server); |
|
Line 162 sub reply {
|
Line 432 sub reply {
|
| return $answer; |
return $answer; |
| } |
} |
| |
|
| |
# -------------------------------------------------------------- Talk to lonsql |
| |
|
| |
sub sqlreply { |
| |
my ($cmd)=@_; |
| |
my $answer=subsqlreply($cmd); |
| |
if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); } |
| |
return $answer; |
| |
} |
| |
|
| |
sub subsqlreply { |
| |
my ($cmd)=@_; |
| |
my $unixsock="mysqlsock"; |
| |
my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; |
| |
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
| |
Type => SOCK_STREAM, |
| |
Timeout => 10) |
| |
or return "con_lost"; |
| |
print $sclient "$cmd\n"; |
| |
my $answer=<$sclient>; |
| |
chomp($answer); |
| |
if (!$answer) { $answer="con_lost"; } |
| |
return $answer; |
| |
} |
| |
|
| # -------------------------------------------- Return path to profile directory |
# -------------------------------------------- Return path to profile directory |
| |
|
| sub propath { |
sub propath { |
| my ($udom,$uname)=@_; |
my ($udom,$uname)=@_; |
| $udom=~s/\W//g; |
$udom=~s/\W//g; |
| $uname=~s/\W//g; |
$uname=~s/\W//g; |
| my $subdir=$uname; |
my $subdir=$uname.'__'; |
| $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
| my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
| return $proname; |
return $proname; |
| } |
} |
| |
|
| # --------------------------------------- Is this the home server of an author? |
# --------------------------------------- Is this the home server of an author? |
| |
|
| sub ishome { |
sub ishome { |
| my $author=shift; |
my $author=shift; |
| $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
|
Line 189 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 197 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("Starting"); |
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
| |
&status('Starting'); |
| |
|
| |
|
| # ------------------------------------------------------- Now we are on our own |
|
| |
|
| # Fork off our children. |
|
| for (1 .. $PREFORK) { |
|
| make_new_child(); |
|
| } |
|
| |
|
| # ----------------------------------------------------- Install signal handlers |
# ----------------------------------------------------- Install signal handlers |
| |
|
| |
|
| $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; |
| |
|
| |
|
| |
|
| |
# -------------------------------------------------------------- |
| |
# Accept connections. When a connection comes in, it is validated |
| |
# and if good, a child process is created to process transactions |
| |
# along the connection. |
| |
|
| # And maintain the population. |
|
| while (1) { |
while (1) { |
| sleep; # wait for a signal (i.e., child's death) |
$client = $server->accept() or next; |
| for ($i = $children; $i < $PREFORK; $i++) { |
make_new_child($client); |
| 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 242 sub make_new_child {
|
Line 543 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{CHLD} = 'DEFAULT'; #make this default so that pwauth returns |
| |
#don't get intercepted |
| |
$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"; |
| |
|
| # handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
|
| for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
|
| $client = $server->accept() or last; |
|
| |
|
| |
my $tmpsnum=0; |
| |
#---------------------------------------------------- kerberos 5 initialization |
| |
&Authen::Krb5::init_context(); |
| |
&Authen::Krb5::init_ets(); |
| |
|
| |
&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); |
$clientip=inet_ntoa($iaddr); |
| my $clientrec=($hostid{$clientip} ne undef); |
my $clientrec=($hostid{$clientip} ne undef); |
| &logthis("Connect from $clientip ($hostid{$clientip})"); |
&logthis( |
| |
"<font color=yellow>INFO: Connection, $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 =~ /^init/) { |
| |
&sethost("sethost:$perlvar{'lonHostID'}"); |
| 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) { |
| $clientok=1; |
$clientok=1; |
| print $client "ok\n"; |
print $client "ok\n"; |
| } else { |
} else { |
| &logthis("$clientip did not reply challenge"); |
&logthis( |
| |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
| |
&status('No challenge reply '.$clientip); |
| } |
} |
| } else { |
} else { |
| &logthis("$clientip failed to initialize: >$remotereq<"); |
&logthis( |
| |
"<font color=blue>WARNING: " |
| |
."$clientip failed to initialize: >$remotereq< </font>"); |
| |
&status('No init '.$clientip); |
| } |
} |
| } else { |
} else { |
| &logthis("Unknown client $clientip"); |
&logthis( |
| |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
| |
&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}"); |
|
| |
foreach my $id (keys(%hostip)) { |
| |
if ($hostip{$id} ne $clientip || |
| |
$hostip{$currenthostid} eq $clientip) { |
| |
# no need to try to do recon's to myself |
| |
next; |
| |
} |
| |
&reconlonc("$perlvar{'lonSockDir'}/$id"); |
| |
} |
| |
&logthis("<font color=green>Established connection: $hostid{$clientip}</font>"); |
| |
&status('Will listen to '.$hostid{$clientip}); |
| # ------------------------------------------------------------ Process requests |
# ------------------------------------------------------------ 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 305 sub make_new_child {
|
Line 644 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/) { |
| 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 337 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 |
| |
} 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) { |
| my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); |
my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); |
| chomp($upass); |
chomp($upass); |
| |
$upass=unescape($upass); |
| my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
| my $passfilename="$proname/passwd"; |
my $passfilename="$proname/passwd"; |
| if (-e $passfilename) { |
if (-e $passfilename) { |
|
Line 353 sub make_new_child {
|
Line 712 sub make_new_child {
|
| my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
| my $pwdcorrect=0; |
my $pwdcorrect=0; |
| if ($howpwd eq 'internal') { |
if ($howpwd eq 'internal') { |
| |
&Debug("Internal auth"); |
| $pwdcorrect= |
$pwdcorrect= |
| (crypt($upass,$contentpwd) eq $contentpwd); |
(crypt($upass,$contentpwd) eq $contentpwd); |
| } elsif ($howpwd eq 'unix') { |
} elsif ($howpwd eq 'unix') { |
| $contentpwd=(getpwnam($uname))[1]; |
&Debug("Unix auth"); |
| $pwdcorrect= |
if((getpwnam($uname))[1] eq "") { #no such user! |
| (crypt($upass,$contentpwd) eq $contentpwd); |
$pwdcorrect = 0; |
| |
} else { |
| |
$contentpwd=(getpwnam($uname))[1]; |
| |
my $pwauth_path="/usr/local/sbin/pwauth"; |
| |
unless ($contentpwd eq 'x') { |
| |
$pwdcorrect= |
| |
(crypt($upass,$contentpwd) eq |
| |
$contentpwd); |
| |
} |
| |
|
| |
elsif (-e $pwauth_path) { |
| |
open PWAUTH, "|$pwauth_path" or |
| |
die "Cannot invoke authentication"; |
| |
print PWAUTH "$uname\n$upass\n"; |
| |
close PWAUTH; |
| |
$pwdcorrect=!$?; |
| |
} |
| |
} |
| } elsif ($howpwd eq 'krb4') { |
} elsif ($howpwd eq 'krb4') { |
| $pwdcorrect=( |
my $null=pack("C",0); |
| Authen::Krb4::get_pw_in_tkt($uname,"", |
unless ($upass=~/$null/) { |
| $contentpwd,'krbtgt',$contentpwd,1, |
my $krb4_error = &Authen::Krb4::get_pw_in_tkt |
| $upass) == 0); |
($uname,"",$contentpwd,'krbtgt', |
| } |
$contentpwd,1,$upass); |
| |
if (!$krb4_error) { |
| |
$pwdcorrect = 1; |
| |
} else { |
| |
$pwdcorrect=0; |
| |
# log error if it is not a bad password |
| |
if ($krb4_error != 62) { |
| |
&logthis('krb4:'.$uname.','.$contentpwd.','. |
| |
&Authen::Krb4::get_err_txt($Authen::Krb4::error)); |
| |
} |
| |
} |
| |
} |
| |
} elsif ($howpwd eq 'krb5') { |
| |
my $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 382 sub make_new_child {
|
Line 791 sub make_new_child {
|
| my |
my |
| ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); |
($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); |
| chomp($npass); |
chomp($npass); |
| my $proname=propath($udom,$uname); |
$upass=&unescape($upass); |
| |
$npass=&unescape($npass); |
| |
&Debug("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 391 sub make_new_child {
|
Line 803 sub make_new_child {
|
| chomp($realpasswd); |
chomp($realpasswd); |
| my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
| if ($howpwd eq 'internal') { |
if ($howpwd eq 'internal') { |
| |
&Debug("internal auth"); |
| if (crypt($upass,$contentpwd) eq $contentpwd) { |
if (crypt($upass,$contentpwd) eq $contentpwd) { |
| my $salt=time; |
my $salt=time; |
| $salt=substr($salt,6,2); |
$salt=substr($salt,6,2); |
| 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 |
| |
&Debug("auth is unix"); |
| |
$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; |
| |
&Debug("exited pwauth with $? ($uname,$upass) "); |
| |
$pwdcorrect=($? == 0); |
| |
} |
| |
if ($pwdcorrect) { |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
&Debug("Opening lcpasswd pipeline"); |
| |
my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log"); |
| |
print $pf "$uname\n$npass\n$npass\n"; |
| |
close $pf; |
| |
my $err = $?; |
| |
my $result = ($err>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 410 sub make_new_child {
|
Line 859 sub make_new_child {
|
| } else { |
} else { |
| print $client "refused\n"; |
print $client "refused\n"; |
| } |
} |
| |
# -------------------------------------------------------------------- makeuser |
| |
} elsif ($userinput =~ /^makeuser/) { |
| |
&Debug("Make user received"); |
| |
my $oldumask=umask(0077); |
| |
if ($wasenc==1) { |
| |
my |
| |
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
| |
&Debug("cmd =".$cmd." $udom =".$udom. |
| |
" uname=".$uname); |
| |
chomp($npass); |
| |
$npass=&unescape($npass); |
| |
my $proname=propath($udom,$uname); |
| |
my $passfilename="$proname/passwd"; |
| |
&Debug("Password file created will be:". |
| |
$passfilename); |
| |
if (-e $passfilename) { |
| |
print $client "already_exists\n"; |
| |
} elsif ($udom ne $currentdomainid) { |
| |
print $client "not_right_domain\n"; |
| |
} else { |
| |
my @fpparts=split(/\//,$proname); |
| |
my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; |
| |
my $fperror=''; |
| |
for (my $i=3;$i<=$#fpparts;$i++) { |
| |
$fpnow.='/'.$fpparts[$i]; |
| |
unless (-e $fpnow) { |
| |
unless (mkdir($fpnow,0777)) { |
| |
$fperror="error: ".($!+0) |
| |
." mkdir failed while attempting " |
| |
."makeuser\n"; |
| |
} |
| |
} |
| |
} |
| |
unless ($fperror) { |
| |
my $result=&make_passwd_file($uname, $umode,$npass, |
| |
$passfilename); |
| |
print $client $result; |
| |
} else { |
| |
print $client "$fperror\n"; |
| |
} |
| |
} |
| |
} else { |
| |
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 $currentdomainid) { |
| |
print $client "not_right_domain\n"; |
| |
} else { |
| |
my $result=&make_passwd_file($uname, $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 430 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 447 sub make_new_child {
|
Line 963 sub make_new_child {
|
| $response=$ua->request($request,$transname); |
$response=$ua->request($request,$transname); |
| } |
} |
| if ($response->is_error()) { |
if ($response->is_error()) { |
| unline($transname); |
unlink($transname); |
| my $message=$response->status_line; |
my $message=$response->status_line; |
| &logthis( |
&logthis( |
| "LWP GET: $message for $fname ($remoteurl)"); |
"LWP GET: $message for $fname ($remoteurl)"); |
| } else { |
} else { |
| |
if ($remoteurl!~/\.meta$/) { |
| |
my $ua=new LWP::UserAgent; |
| |
my $mrequest= |
| |
new HTTP::Request('GET',$remoteurl.'.meta'); |
| |
my $mresponse= |
| |
$ua->request($mrequest,$fname.'.meta'); |
| |
if ($mresponse->is_error()) { |
| |
unlink($fname.'.meta'); |
| |
} |
| |
} |
| rename($transname,$fname); |
rename($transname,$fname); |
| } |
} |
| } |
} |
|
Line 462 sub make_new_child {
|
Line 988 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); |
| |
my $reply='non_auth'; |
| |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
| |
$session.'.id')) { |
| |
while (my $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/) { |
| |
print $client &subscribe($userinput,$clientip); |
| |
# ------------------------------------------------------------- current version |
| |
} elsif ($userinput =~ /^currentversion/) { |
| my ($cmd,$fname)=split(/:/,$userinput); |
my ($cmd,$fname)=split(/:/,$userinput); |
| my $ownership=ishome($fname); |
print $client ¤tversion($fname)."\n"; |
| if ($ownership eq 'owner') { |
# ------------------------------------------------------------------------- log |
| if (-e $fname) { |
} elsif ($userinput =~ /^log/) { |
| $now=time; |
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
| { |
chomp($what); |
| my $sh=IO::File->new(">$fname.$hostid{$clientip}"); |
my $proname=propath($udom,$uname); |
| print $sh "$clientip:$now\n"; |
my $now=time; |
| } |
{ |
| $fname=~s/\/home\/httpd\/html\/res/raw/; |
my $hfh; |
| $fname="http://$thisserver/".$fname; |
if ($hfh=IO::File->new(">>$proname/activity.log")) { |
| print $client "$fname\n"; |
print $hfh "$now:$hostid{$clientip}:$what\n"; |
| } else { |
print $client "ok\n"; |
| print $client "not_found\n"; |
} else { |
| } |
print $client "error: ".($!+0) |
| } else { |
." IO::File->new Failed " |
| print $client "rejected\n"; |
."while attempting log\n"; |
| |
} |
| } |
} |
| # ------------------------------------------------------------------------- put |
# ------------------------------------------------------------------------- put |
| } elsif ($userinput =~ /^put/) { |
} elsif ($userinput =~ /^put/) { |
|
Line 504 sub make_new_child {
|
Line 1074 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") |
| ) { 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"; |
| } |
} |
| # -------------------------------------------------------------------- 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 545 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, |
| |
&GetAuthType( $udom, |
| |
$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 { |
} else { |
| print $client "error:$!\n"; |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting rolesput\n"; |
| |
} |
| |
} else { |
| |
print $client "refused\n"; |
| |
} |
| |
# -------------------------------------------------------------------- rolesdel |
| |
} elsif ($userinput =~ /^rolesdel/) { |
| |
&Debug("rolesdel"); |
| |
if ($wasenc==1) { |
| |
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
| |
=split(/:/,$userinput); |
| |
&Debug("cmd = ".$cmd." exedom= ".$exedom. |
| |
"user = ".$exeuser." udom=".$udom. |
| |
"what = ".$what); |
| |
my $namespace='roles'; |
| |
chomp($what); |
| |
my $proname=propath($udom,$uname); |
| |
my $now=time; |
| |
{ |
| |
my $hfh; |
| |
if ( |
| |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
| |
) { |
| |
print $hfh "D:$now:$exedom:$exeuser:$what\n"; |
| |
} |
| |
} |
| |
my @rolekeys=split(/\&/,$what); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
| |
foreach my $key (@rolekeys) { |
| |
delete $hash{$key}; |
| |
} |
| |
if (untie(%hash)) { |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." untie(GDBM) Failed ". |
| |
"while attempting rolesdel\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting rolesdel\n"; |
| } |
} |
| } else { |
} else { |
| print $client "refused\n"; |
print $client "refused\n"; |
|
Line 571 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_WRCREAT,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 594 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_WRCREAT,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 615 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 629 sub make_new_child {
|
Line 1273 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") |
| ) { 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 656 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_WRCREAT,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"; |
| } |
} |
| # ------------------------------------------------------------------------ dump |
# ----------------------------------------------------------------- dumpcurrent |
| } elsif ($userinput =~ /^dump/) { |
} elsif ($userinput =~ /^currentdump/) { |
| my ($cmd,$udom,$uname,$namespace) |
my ($cmd,$udom,$uname,$namespace) |
| =split(/:/,$userinput); |
=split(/:/,$userinput); |
| $namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
| $namespace=~s/\W//g; |
$namespace=~s/\W//g; |
| my $proname=propath($udom,$uname); |
|
| my $qresult=''; |
my $qresult=''; |
| if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
my $proname=propath($udom,$uname); |
| foreach $key (keys %hash) { |
my %hash; |
| $qresult.="$key=$hash{$key}&"; |
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"; |
| } |
} |
| if (untie(%hash)) { |
} else { |
| $qresult=~s/\&$//; |
print $client "error: ".($!+0) |
| print $client "$qresult\n"; |
." tie(GDBM) Failed ". |
| |
"while attempting currentdump\n"; |
| |
} |
| |
# ------------------------------------------------------------------------ dump |
| |
} elsif ($userinput =~ /^dump/) { |
| |
my ($cmd,$udom,$uname,$namespace,$regexp) |
| |
=split(/:/,$userinput); |
| |
$namespace=~s/\//\_/g; |
| |
$namespace=~s/\W//g; |
| |
if (defined($regexp)) { |
| |
$regexp=&unescape($regexp); |
| |
} else { |
| |
$regexp='.'; |
| |
} |
| |
my $qresult=''; |
| |
my $proname=propath($udom,$uname); |
| |
my %hash; |
| |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
| |
study($regexp); |
| |
while (my ($key,$value) = each(%hash)) { |
| |
if ($regexp eq '.') { |
| |
$qresult.=$key.'='.$value.'&'; |
| |
} else { |
| |
my $unescapeKey = &unescape($key); |
| |
if (eval('$unescapeKey=~/$regexp/')) { |
| |
$qresult.="$key=$value&"; |
| |
} |
| |
} |
| |
} |
| |
if (untie(%hash)) { |
| |
chop($qresult); |
| |
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 700 sub make_new_child {
|
Line 1418 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") |
| ) { 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; |
| } |
} |
| $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"; |
| } 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 741 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_WRCREAT,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 751 sub make_new_child {
|
Line 1475 sub make_new_child {
|
| my $key; |
my $key; |
| $qresult.="$scope:keys=$vkeys&"; |
$qresult.="$scope:keys=$vkeys&"; |
| foreach $key (@keys) { |
foreach $key (@keys) { |
| $qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&"; |
$qresult.="$scope:$key=".$hash{"$scope:$rid:$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 restore\n"; |
| |
} |
| |
} else { |
| |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting restore\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,$udom,$uname)=split(/\:/,$userinput); |
| |
my $reply=''; |
| |
foreach (&getchat($cdom,$cnum,$udom,$uname)) { |
| |
$reply.=&escape($_).':'; |
| |
} |
| |
$reply=~s/\:$//; |
| |
print $client $reply."\n"; |
| |
# ------------------------------------------------------------------- querysend |
| |
} elsif ($userinput =~ /^querysend/) { |
| |
my ($cmd,$query, |
| |
$arg1,$arg2,$arg3)=split(/\:/,$userinput); |
| |
$query=~s/\n*$//g; |
| |
print $client "". |
| |
sqlreply("$hostid{$clientip}\&$query". |
| |
"\&$arg1"."\&$arg2"."\&$arg3")."\n"; |
| |
# ------------------------------------------------------------------ queryreply |
| |
} elsif ($userinput =~ /^queryreply/) { |
| |
my ($cmd,$id,$reply)=split(/:/,$userinput); |
| |
my $store; |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
if ($store=IO::File->new(">$execdir/tmp/$id")) { |
| |
$reply=~s/\&/\n/g; |
| |
print $store $reply; |
| |
close $store; |
| |
my $store2=IO::File->new(">$execdir/tmp/$id.end"); |
| |
print $store2 "done\n"; |
| |
close $store2; |
| |
print $client "ok\n"; |
| |
} |
| |
else { |
| |
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 { |
} else { |
| print $client "error:$!\n"; |
print $client "error: ".($!+0) |
| |
." tie(GDBM) Failed ". |
| |
"while attempting courseiddump\n"; |
| } |
} |
| # ----------------------------------------------------------------------- idput |
# ----------------------------------------------------------------------- idput |
| } elsif ($userinput =~ /^idput/) { |
} elsif ($userinput =~ /^idput/) { |
|
Line 777 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 798 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_WRCREAT,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 |
| |
} elsif ($userinput =~ /^tmpput/) { |
| |
my ($cmd,$what)=split(/:/,$userinput); |
| |
my $store; |
| |
$tmpsnum++; |
| |
my $id=$$.'_'.$clientip.'_'.$tmpsnum; |
| |
$id=~s/\W/\_/g; |
| |
$what=~s/\n//g; |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { |
| |
print $store $what; |
| |
close $store; |
| |
print $client "$id\n"; |
| |
} |
| |
else { |
| |
print $client "error: ".($!+0) |
| |
."IO::File->new Failed ". |
| |
"while attempting tmpput\n"; |
| |
} |
| |
|
| |
# ---------------------------------------------------------------------- tmpget |
| |
} elsif ($userinput =~ /^tmpget/) { |
| |
my ($cmd,$id)=split(/:/,$userinput); |
| |
chomp($id); |
| |
$id=~s/\W/\_/g; |
| |
my $store; |
| |
my $execdir=$perlvar{'lonDaemons'}; |
| |
if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { |
| |
my $reply=<$store>; |
| |
print $client "$reply\n"; |
| |
close $store; |
| |
} |
| |
else { |
| |
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); |
| 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'; } |
| print $client "$ulsout\n"; |
print $client "$ulsout\n"; |
| |
# ----------------------------------------------------------------- setannounce |
| |
} elsif ($userinput =~ /^setannounce/) { |
| |
my ($cmd,$announcement)=split(/:/,$userinput); |
| |
chomp($announcement); |
| |
$announcement=&unescape($announcement); |
| |
if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. |
| |
'/announcement.txt')) { |
| |
print $store $announcement; |
| |
close $store; |
| |
print $client "ok\n"; |
| |
} else { |
| |
print $client "error: ".($!+0)."\n"; |
| |
} |
| |
# ------------------------------------------------------------------ Hanging up |
| |
} elsif (($userinput =~ /^exit/) || |
| |
($userinput =~ /^init/)) { |
| |
&logthis( |
| |
"Client $clientip ($hostid{$clientip}) hanging up: $userinput"); |
| |
print $client "bye\n"; |
| |
$client->close(); |
| |
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"; |
| } |
} |
| # ------------------------------------------------------ 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"; |
| &logthis("Rejected client $clientip, closing connection"); |
$client->close(); |
| } |
&logthis("<font color=blue>WARNING: " |
| &logthis("Disconnect from $clientip ($hostid{$clientip})"); |
."Rejected client $clientip, closing connection</font>"); |
| |
} |
| |
} |
| |
|
| # ============================================================================= |
# ============================================================================= |
| } |
|
| |
&logthis("<font color=red>CRITICAL: " |
| # tidy up gracefully and finish |
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
| |
|
| |
|
| # 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; |
| |
|
| |
} |
| |
|
| |
|
| |
# |
| |
# 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 |
| |
&logthis("ruequest is $request"); |
| |
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
| |
my $execdir = $perlvar{'lonDaemons'}; |
| |
my $userhome= "/home/$user" ; |
| |
&logthis("system $execdir/lchtmldir $userhome $user $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; |
| |
my $sh; |
| |
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,$udom,$uname)=@_; |
| |
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; |
| |
} |
| |
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 { |
| |
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 currentversion { |
| |
my $fname=shift; |
| |
my $version=-1; |
| |
my $ulsdir=''; |
| |
if ($fname=~/^(.+)\/[^\/]+$/) { |
| |
$ulsdir=$1; |
| |
} |
| |
my ($fnamere1,$fnamere2); |
| |
# remove version if already specified |
| |
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; |
| |
# get the bits that go before and after the version number |
| |
if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { |
| |
$fnamere1=$1; |
| |
$fnamere2='.'.$2; |
| |
} |
| |
if (-e $fname) { $version=1; } |
| |
if (-e $ulsdir) { |
| |
if(-d $ulsdir) { |
| |
if (opendir(LSDIR,$ulsdir)) { |
| |
my $ulsfn; |
| |
while ($ulsfn=readdir(LSDIR)) { |
| |
# see if this is a regular file (ignore links produced earlier) |
| |
my $thisfile=$ulsdir.'/'.$ulsfn; |
| |
unless (-l $thisfile) { |
| |
if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { |
| |
if ($1>$version) { $version=$1; } |
| |
} |
| |
} |
| |
} |
| |
closedir(LSDIR); |
| |
$version++; |
| |
} |
| |
} |
| |
} |
| |
return $version; |
| |
} |
| |
|
| |
sub thisversion { |
| |
my $fname=shift; |
| |
my $version=-1; |
| |
if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { |
| |
$version=$1; |
| |
} |
| |
return $version; |
| |
} |
| |
|
| |
sub subscribe { |
| |
my ($userinput,$clientip)=@_; |
| |
my $result; |
| |
my ($cmd,$fname)=split(/:/,$userinput); |
| |
my $ownership=&ishome($fname); |
| |
if ($ownership eq 'owner') { |
| |
# explitly asking for the current version? |
| |
unless (-e $fname) { |
| |
my $currentversion=¤tversion($fname); |
| |
if (&thisversion($fname)==$currentversion) { |
| |
if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { |
| |
my $root=$1; |
| |
my $extension=$2; |
| |
symlink($root.'.'.$extension, |
| |
$root.'.'.$currentversion.'.'.$extension); |
| |
unless ($extension=~/\.meta$/) { |
| |
symlink($root.'.'.$extension.'.meta', |
| |
$root.'.'.$currentversion.'.'.$extension.'.meta'); |
| |
} |
| |
} |
| |
} |
| |
} |
| |
if (-e $fname) { |
| |
if (-d $fname) { |
| |
$result="directory\n"; |
| |
} else { |
| |
if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} |
| |
my $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 ($uname, $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); |
| |
&Debug("user = ".$uname.", Password =". $npass); |
| |
my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); |
| |
print $se "$uname\n"; |
| |
print $se "$npass\n"; |
| |
print $se "$npass\n"; |
| |
} |
| |
my $useraddok = $?; |
| |
if($useraddok > 0) { |
| |
&logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); |
| |
} |
| |
my $pf = IO::File->new(">$passfilename"); |
| |
print $pf "unix:\n"; |
| |
} |
| |
} elsif ($umode eq 'none') { |
| |
{ |
| |
my $pf = IO::File->new(">$passfilename"); |
| |
print $pf "none:\n"; |
| |
} |
| |
} else { |
| |
$result="auth_mode_error\n"; |
| } |
} |
| |
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) |
| |
|
| |
=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 pushtable |
| |
|
| |
Pushes a file in /home/httpd/lonTab directory. Currently limited to: |
| |
hosts.tab and domain.tab. The old file is copied to *.tab.backup but |
| |
must be restored manually in case of a problem with the new table file. |
| |
pushtable requires that the request be encrypted and validated via |
| |
ValidateManager. The form of the command is: |
| |
enc:pushtable tablename <tablecontents> \n |
| |
where pushtable, tablename and <tablecontents> will be encrypted, but \n is a |
| |
cleartext newline. |
| |
|
| |
=item Hanging up (exit or init) |
| |
|
| |
What to do when a client tells the server that they (the client) |
| |
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 |
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom