version 1.7, 2000/01/12 19:30:43
|
version 1.50, 2001/08/24 21:09:53
|
Line 4
|
Line 4
|
# 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 Gerd Kortemeyer |
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8, |
|
# 03/07,05/31 Gerd Kortemeyer |
|
# 06/26 Scott Harrison |
|
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
|
# 12/05 Scott Harrison |
|
# 12/05,12/13,12/29 Gerd Kortemeyer |
|
# Jan 01 Scott Harrison |
|
# 02/12 Gerd Kortemeyer |
|
# 03/15 Scott Harrison |
|
# 03/24 Gerd Kortemeyer |
|
# 04/02 Scott Harrison |
|
# 05/11,05/28 Gerd Kortemeyer |
|
# |
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# preforker - server who forks first |
# preforker - server who forks first |
# runs as a daemon |
# runs as a daemon |
Line 20 use Crypt::IDEA;
|
Line 32 use Crypt::IDEA;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use GDBM_File; |
use GDBM_File; |
use Authen::Krb4; |
use Authen::Krb4; |
|
use lib '/home/httpd/lib/perl/'; |
|
use localauth; |
|
|
|
# grabs exception and records it to log before exiting |
|
sub catchexception { |
|
my ($error)=@_; |
|
$SIG{'QUIT'}='DEFAULT'; |
|
$SIG{__DIE__}='DEFAULT'; |
|
&logthis("<font color=red>CRITICAL: " |
|
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
|
."a crash with this error msg->[$error]</font>"); |
|
if ($client) { print $client "error: $error\n"; } |
|
die($error); |
|
} |
|
|
|
# -------------------------------- Set signal handlers to record abnormal exits |
|
|
|
$SIG{'QUIT'}=\&catchexception; |
|
$SIG{__DIE__}=\&catchexception; |
|
|
# ------------------------------------ Read httpd access.conf and get variables |
# ------------------------------------ Read httpd access.conf and get variables |
|
|
Line 34 while ($configline=<CONFIG>) {
|
Line 65 while ($configline=<CONFIG>) {
|
} |
} |
close(CONFIG); |
close(CONFIG); |
|
|
|
# ----------------------------- Make sure this process is running from user=www |
|
my $wwwid=getpwnam('www'); |
|
if ($wwwid!=$<) { |
|
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
|
$subj="LON: $perlvar{'lonHostID'} User ID mismatch"; |
|
system("echo 'User ID mismatch. lond must be run as user www.' |\ |
|
mailto $emailto -s '$subj' > /dev/null"); |
|
exit 1; |
|
} |
|
|
|
# --------------------------------------------- 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"; } |
|
} |
|
|
$PREFORK=4; # number of children to maintain, at least four spare |
$PREFORK=4; # number of children to maintain, at least four spare |
|
|
# ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
Line 79 sub HUNTSMAN { # si
|
Line 131 sub HUNTSMAN { # si
|
kill 'INT' => keys %children; |
kill 'INT' => keys %children; |
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 |
} |
} |
|
|
Line 87 sub HUPSMAN { # sig
|
Line 139 sub HUPSMAN { # sig
|
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 |
close($server); # free up socket |
&logthis("Restarting"); |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
|
unlink("$execdir/logs/lond.pid"); |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
exec("$execdir/lond"); # here we go again |
exec("$execdir/lond"); # here we go again |
} |
} |
Line 103 sub logthis {
|
Line 156 sub logthis {
|
print $fh "$local ($$): $message\n"; |
print $fh "$local ($$): $message\n"; |
} |
} |
|
|
|
|
|
# -------------------------------------------------------- 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 120 sub reconlonc {
|
Line 190 sub reconlonc {
|
&logthis("$peerfile still not there, give it another try"); |
&logthis("$peerfile still not there, give it another try"); |
sleep 5; |
sleep 5; |
if (-e "$peerfile") { return; } |
if (-e "$peerfile") { return; } |
&logthis("$peerfile still not there, giving up"); |
&logthis( |
|
"<font color=blue>WARNING: $peerfile still not there, giving up</font>"); |
} 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 162 sub reply {
|
Line 236 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 201 $execdir=$perlvar{'lonDaemons'};
|
Line 301 $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>"); |
|
|
# ------------------------------------------------------- Now we are on our own |
# ------------------------------------------------------- Now we are on our own |
|
|
Line 250 sub make_new_child {
|
Line 350 sub make_new_child {
|
# unblock signals |
# unblock signals |
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
|
|
|
$tmpsnum=0; |
|
|
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
Line 263 sub make_new_child {
|
Line 365 sub make_new_child {
|
my ($port,$iaddr)=unpack_sockaddr_in($caller); |
my ($port,$iaddr)=unpack_sockaddr_in($caller); |
my $clientip=inet_ntoa($iaddr); |
my $clientip=inet_ntoa($iaddr); |
my $clientrec=($hostid{$clientip} ne undef); |
my $clientrec=($hostid{$clientip} ne undef); |
&logthis("Connect from $clientip ($hostid{$clientip})"); |
&logthis( |
|
"<font color=yellow>INFO: Connect from $clientip ($hostid{$clientip})</font>"); |
my $clientok; |
my $clientok; |
if ($clientrec) { |
if ($clientrec) { |
my $remotereq=<$client>; |
my $remotereq=<$client>; |
Line 277 sub make_new_child {
|
Line 380 sub make_new_child {
|
$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>"); |
|
print $client "bye\n"; |
} |
} |
} else { |
} else { |
&logthis("$clientip failed to initialize: >$remotereq<"); |
&logthis( |
|
"<font color=blue>WARNING: " |
|
."$clientip failed to initialize: >$remotereq< </font>"); |
|
print $client "bye\n"; |
} |
} |
} else { |
} else { |
&logthis("Unknown client $clientip"); |
&logthis( |
|
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
|
print $client "bye\n"; |
} |
} |
if ($clientok) { |
if ($clientok) { |
# ---------------- New known client connecting, could mean machine online again |
# ---------------- New known client connecting, could mean machine online again |
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); |
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); |
|
&logthis( |
|
"<font color=green>Established connection: $hostid{$clientip}</font>"); |
# ------------------------------------------------------------ Process requests |
# ------------------------------------------------------------ Process requests |
while (my $userinput=<$client>) { |
while (my $userinput=<$client>) { |
chomp($userinput); |
chomp($userinput); |
Line 344 sub make_new_child {
|
Line 456 sub make_new_child {
|
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 364 sub make_new_child {
|
Line 477 sub make_new_child {
|
Authen::Krb4::get_pw_in_tkt($uname,"", |
Authen::Krb4::get_pw_in_tkt($uname,"", |
$contentpwd,'krbtgt',$contentpwd,1, |
$contentpwd,'krbtgt',$contentpwd,1, |
$upass) == 0); |
$upass) == 0); |
} |
} 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 498 sub make_new_child {
|
my |
my |
($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); |
($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput); |
chomp($npass); |
chomp($npass); |
|
$upass=&unescape($upass); |
|
$npass=&unescape($npass); |
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 396 sub make_new_child {
|
Line 514 sub make_new_child {
|
$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"; } |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "non_authorized\n"; |
print $client "non_authorized\n"; |
Line 410 sub make_new_child {
|
Line 528 sub make_new_child {
|
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
} |
} |
|
# -------------------------------------------------------------------- makeuser |
|
} elsif ($userinput =~ /^makeuser/) { |
|
if ($wasenc==1) { |
|
my |
|
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); |
|
chomp($npass); |
|
$npass=&unescape($npass); |
|
my $proname=propath($udom,$uname); |
|
my $passfilename="$proname/passwd"; |
|
if (-e $passfilename) { |
|
print $client "already_exists\n"; |
|
} elsif ($udom ne $perlvar{'lonDefDomain'}) { |
|
print $client "not_right_domain\n"; |
|
} else { |
|
@fpparts=split(/\//,$proname); |
|
$fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; |
|
$fperror=''; |
|
for ($i=3;$i<=$#fpparts;$i++) { |
|
$fpnow.='/'.$fpparts[$i]; |
|
unless (-e $fpnow) { |
|
unless (mkdir($fpnow,0777)) { |
|
$fperror="error:$!\n"; |
|
} |
|
} |
|
} |
|
unless ($fperror) { |
|
if ($umode eq 'krb4') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "krb4:$npass\n"; |
|
} |
|
print $client "ok\n"; |
|
} elsif ($umode eq 'internal') { |
|
my $salt=time; |
|
$salt=substr($salt,6,2); |
|
my $ncpass=crypt($npass,$salt); |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "internal:$ncpass\n"; |
|
} |
|
print $client "ok\n"; |
|
} elsif ($umode eq 'localauth') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "localauth:$npass\n"; |
|
} |
|
print $client "ok\n"; |
|
} elsif ($umode eq 'none') { |
|
{ |
|
my $pf = IO::File->new(">$passfilename"); |
|
print $pf "none:\n"; |
|
} |
|
print $client "ok\n"; |
|
} else { |
|
print $client "auth_mode_error\n"; |
|
} |
|
} else { |
|
print $client "$fperror\n"; |
|
} |
|
} |
|
} 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 447 sub make_new_child {
|
Line 628 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 480 sub make_new_child {
|
Line 671 sub make_new_child {
|
my $ownership=ishome($fname); |
my $ownership=ishome($fname); |
if ($ownership eq 'owner') { |
if ($ownership eq 'owner') { |
if (-e $fname) { |
if (-e $fname) { |
|
if (-d $fname) { |
|
print $client "directory\n"; |
|
} else { |
$now=time; |
$now=time; |
{ |
{ |
my $sh=IO::File->new(">$fname.$hostid{$clientip}"); |
my $sh; |
print $sh "$clientip:$now\n"; |
if ($sh= |
|
IO::File->new(">$fname.$hostid{$clientip}")) { |
|
print $sh "$clientip:$now\n"; |
|
} |
} |
} |
|
unless ($fname=~/\.meta$/) { |
|
unlink("$fname.meta.$hostid{$clientip}"); |
|
} |
$fname=~s/\/home\/httpd\/html\/res/raw/; |
$fname=~s/\/home\/httpd\/html\/res/raw/; |
$fname="http://$thisserver/".$fname; |
$fname="http://$thisserver/".$fname; |
print $client "$fname\n"; |
print $client "$fname\n"; |
|
} |
} else { |
} else { |
print $client "not_found\n"; |
print $client "not_found\n"; |
} |
} |
} else { |
} else { |
print $client "rejected\n"; |
print $client "rejected\n"; |
} |
} |
|
# ------------------------------------------------------------------------- log |
|
} elsif ($userinput =~ /^log/) { |
|
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
|
chomp($what); |
|
my $proname=propath($udom,$uname); |
|
my $now=time; |
|
{ |
|
my $hfh; |
|
if ($hfh=IO::File->new(">>$proname/activity.log")) { |
|
print $hfh "$now:$hostid{$clientip}:$what\n"; |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
} |
# ------------------------------------------------------------------------- put |
# ------------------------------------------------------------------------- put |
} elsif ($userinput =~ /^put/) { |
} elsif ($userinput =~ /^put/) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
if ($namespace ne 'roles') { |
if ($namespace ne 'roles') { |
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
unless ($namespace=~/^nohist\_/) { |
my $hfh; |
my $hfh; |
if ( |
if ( |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
Line 564 sub make_new_child {
|
Line 781 sub make_new_child {
|
} elsif ($userinput =~ /^get/) { |
} elsif ($userinput =~ /^get/) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
chomp($what); |
chomp($what); |
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)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
for ($i=0;$i<=$#queries;$i++) { |
for ($i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
Line 586 sub make_new_child {
|
Line 804 sub make_new_child {
|
} elsif ($userinput =~ /^eget/) { |
} elsif ($userinput =~ /^eget/) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
chomp($what); |
chomp($what); |
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)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
for ($i=0;$i<=$#queries;$i++) { |
for ($i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
Line 621 sub make_new_child {
|
Line 840 sub make_new_child {
|
} elsif ($userinput =~ /^del/) { |
} elsif ($userinput =~ /^del/) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
unless ($namespace=~/^nohist\_/) { |
my $hfh; |
my $hfh; |
if ( |
if ( |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
Line 648 sub make_new_child {
|
Line 868 sub make_new_child {
|
} elsif ($userinput =~ /^keys/) { |
} elsif ($userinput =~ /^keys/) { |
my ($cmd,$udom,$uname,$namespace) |
my ($cmd,$udom,$uname,$namespace) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
chomp($namespace); |
|
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)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
foreach $key (keys %hash) { |
foreach $key (keys %hash) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
Line 669 sub make_new_child {
|
Line 889 sub make_new_child {
|
} elsif ($userinput =~ /^dump/) { |
} elsif ($userinput =~ /^dump/) { |
my ($cmd,$udom,$uname,$namespace) |
my ($cmd,$udom,$uname,$namespace) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
chomp($namespace); |
|
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)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
foreach $key (keys %hash) { |
foreach $key (keys %hash) { |
$qresult.="$key=$hash{$key}&"; |
$qresult.="$key=$hash{$key}&"; |
} |
} |
Line 690 sub make_new_child {
|
Line 910 sub make_new_child {
|
} elsif ($userinput =~ /^store/) { |
} elsif ($userinput =~ /^store/) { |
my ($cmd,$udom,$uname,$namespace,$rid,$what) |
my ($cmd,$udom,$uname,$namespace,$rid,$what) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
if ($namespace ne 'roles') { |
if ($namespace ne 'roles') { |
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
{ |
unless ($namespace=~/^nohist\_/) { |
my $hfh; |
my $hfh; |
if ( |
if ( |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
$hfh=IO::File->new(">>$proname/$namespace.hist") |
Line 714 sub make_new_child {
|
Line 935 sub make_new_child {
|
$allkeys.=$key.':'; |
$allkeys.=$key.':'; |
$hash{"$version:$rid:$key"}=$value; |
$hash{"$version:$rid:$key"}=$value; |
} |
} |
$allkeys=~s/:$//; |
$hash{"$version:$rid:timestamp"}=$now; |
|
$allkeys.='timestamp'; |
$hash{"$version:keys:$rid"}=$allkeys; |
$hash{"$version:keys:$rid"}=$allkeys; |
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
Line 731 sub make_new_child {
|
Line 953 sub make_new_child {
|
} elsif ($userinput =~ /^restore/) { |
} elsif ($userinput =~ /^restore/) { |
my ($cmd,$udom,$uname,$namespace,$rid) |
my ($cmd,$udom,$uname,$namespace,$rid) |
=split(/:/,$userinput); |
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
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)) { |
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 745 sub make_new_child {
|
Line 968 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)) { |
Line 757 sub make_new_child {
|
Line 980 sub make_new_child {
|
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
} |
} |
|
# ------------------------------------------------------------------- querysend |
|
} elsif ($userinput =~ /^querysend/) { |
|
my ($cmd,$query, |
|
$custom,$customshow)=split(/:/,$userinput); |
|
$query=~s/\n*$//g; |
|
unless ($custom or $customshow) { |
|
print $client "". |
|
sqlreply("$hostid{$clientip}\&$query")."\n"; |
|
} |
|
else { |
|
print $client "". |
|
sqlreply("$hostid{$clientip}\&$query". |
|
"\&$custom"."\&$customshow")."\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:$!\n"; |
|
} |
# ----------------------------------------------------------------------- idput |
# ----------------------------------------------------------------------- idput |
} elsif ($userinput =~ /^idput/) { |
} elsif ($userinput =~ /^idput/) { |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
Line 792 sub make_new_child {
|
Line 1046 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)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { |
for ($i=0;$i<=$#queries;$i++) { |
for ($i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
Line 805 sub make_new_child {
|
Line 1059 sub make_new_child {
|
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\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:$!\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:$!\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 (opendir(LSDIR,$ulsdir)) { |
my @ulsstats=stat($ulsfn); |
while ($ulsfn=readdir(LSDIR)) { |
|
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
} |
} |
|
closedir(LSDIR); |
|
} |
} else { |
} else { |
$ulsout='no_such_dir'; |
$ulsout='no_such_dir'; |
} |
} |
|
if ($ulsout eq '') { $ulsout='empty'; } |
print $client "$ulsout\n"; |
print $client "$ulsout\n"; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
} else { |
} else { |
Line 828 sub make_new_child {
|
Line 1120 sub make_new_child {
|
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
&logthis("Rejected client $clientip, closing connection"); |
&logthis("<font color=blue>WARNING: " |
|
."Rejected client $clientip, closing connection</font>"); |
} |
} |
&logthis("Disconnect from $clientip ($hostid{$clientip})"); |
&logthis("<font color=red>CRITICAL: " |
|
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
# ============================================================================= |
# ============================================================================= |
} |
} |
|
|