version 1.1.1.1, 1999/10/13 17:48:51
|
version 1.22, 2000/12/05 03:24:48
|
Line 2
|
Line 2
|
# The LearningOnline Network |
# The LearningOnline Network |
# lond "LON Daemon" Server (port "LOND" 5663) |
# lond "LON Daemon" Server (port "LOND" 5663) |
# 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,10/7,10/8,10/9,10/11 Gerd Kortemeyer |
# 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, |
|
# 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 |
|
# |
# 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 16 use Symbol;
|
Line 22 use Symbol;
|
use POSIX; |
use POSIX; |
use Crypt::IDEA; |
use Crypt::IDEA; |
use LWP::UserAgent(); |
use LWP::UserAgent(); |
|
use GDBM_File; |
|
use Authen::Krb4; |
|
|
|
# -------------------------------- 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 |
|
|
open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; |
open (CONFIG,"/etc/httpd/conf/access.conf") |
|
|| catchdie "Can't read access.conf"; |
|
|
while ($configline=<CONFIG>) { |
while ($configline=<CONFIG>) { |
if ($configline =~ /PerlSetVar/) { |
if ($configline =~ /PerlSetVar/) { |
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
$perlvar{$varname}=$varvalue; |
$perlvar{$varname}=$varvalue; |
} |
} |
} |
} |
close(CONFIG); |
close(CONFIG); |
|
|
|
# --------------------------------------------- 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) { catchdie "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 |
|
|
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") |
|
|| catchdie "Can't read host file"; |
|
|
while ($configline=<CONFIG>) { |
while ($configline=<CONFIG>) { |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
Line 50 $server = IO::Socket::INET->new(LocalPor
|
Line 77 $server = IO::Socket::INET->new(LocalPor
|
Proto => 'tcp', |
Proto => 'tcp', |
Reuse => 1, |
Reuse => 1, |
Listen => 10 ) |
Listen => 10 ) |
or die "making socket: $@\n"; |
or catchdie "making socket: $@\n"; |
|
|
# --------------------------------------------------------- Do global variables |
# --------------------------------------------------------- Do global variables |
|
|
Line 74 sub HUNTSMAN { # si
|
Line 101 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 82 sub HUPSMAN { # sig
|
Line 109 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>"); |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
exec("$execdir/lond"); # here we go again |
exec("$execdir/lond"); # here we go again |
} |
} |
Line 98 sub logthis {
|
Line 125 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 115 sub reconlonc {
|
Line 159 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 157 sub reply {
|
Line 205 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 186 sub ishome {
|
Line 260 sub ishome {
|
|
|
$fpid=fork; |
$fpid=fork; |
exit if $fpid; |
exit if $fpid; |
die "Couldn't fork: $!" unless defined ($fpid); |
catchdie "Couldn't fork: $!" unless defined ($fpid); |
|
|
POSIX::setsid() or die "Can't start new session: $!"; |
POSIX::setsid() or catchdie "Can't start new session: $!"; |
|
|
# ------------------------------------------------------- Write our PID on disk |
# ------------------------------------------------------- Write our PID on disk |
|
|
Line 196 $execdir=$perlvar{'lonDaemons'};
|
Line 270 $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 227 sub make_new_child {
|
Line 301 sub make_new_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 catchdie "Can't block SIGINT for fork: $!\n"; |
|
|
die "fork: $!" unless defined ($pid = fork); |
catchdie "fork: $!" unless defined ($pid = fork); |
|
|
if ($pid) { |
if ($pid) { |
# Parent records the child's birth and returns. |
# Parent records the child's birth and returns. |
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or catchdie "Can't unblock SIGINT for fork: $!\n"; |
$children{$pid} = 1; |
$children{$pid} = 1; |
$children++; |
$children++; |
return; |
return; |
Line 244 sub make_new_child {
|
Line 318 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 catchdie "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 253 sub make_new_child {
|
Line 329 sub make_new_child {
|
# ============================================================================= |
# ============================================================================= |
# do something with the connection |
# do something with the connection |
# ----------------------------------------------------------------------------- |
# ----------------------------------------------------------------------------- |
# see if we know client |
# see if we know client and check for spoof IP by challenge |
my $caller=getpeername($client); |
my $caller=getpeername($client); |
my ($port,$iaddr)=unpack_sockaddr_in($caller); |
my ($port,$iaddr)=unpack_sockaddr_in($caller); |
my $clientip=inet_ntoa($iaddr); |
my $clientip=inet_ntoa($iaddr); |
my $clientrec=($hostid{$clientip} ne undef); |
my $clientrec=($hostid{$clientip} ne undef); |
&logthis("Connect from $clientip ($hostid{$clientip})"); |
&logthis( |
|
"<font color=yellow>INFO: Connect from $clientip ($hostid{$clientip})</font>"); |
|
my $clientok; |
if ($clientrec) { |
if ($clientrec) { |
|
my $remotereq=<$client>; |
|
$remotereq=~s/\W//g; |
|
if ($remotereq eq 'init') { |
|
my $challenge="$$".time; |
|
print $client "$challenge\n"; |
|
$remotereq=<$client>; |
|
$remotereq=~s/\W//g; |
|
if ($challenge eq $remotereq) { |
|
$clientok=1; |
|
print $client "ok\n"; |
|
} else { |
|
&logthis( |
|
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
|
print $client "bye\n"; |
|
} |
|
} else { |
|
&logthis( |
|
"<font color=blue>WARNING: " |
|
."$clientip failed to initialize: >$remotereq< </font>"); |
|
print $client "bye\n"; |
|
} |
|
} else { |
|
&logthis( |
|
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
|
print $client "bye\n"; |
|
} |
|
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 318 sub make_new_child {
|
Line 425 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) { |
my $pf = IO::File->new($passfilename); |
my $pf = IO::File->new($passfilename); |
my $realpasswd=<$pf>; |
my $realpasswd=<$pf>; |
chomp($realpasswd); |
chomp($realpasswd); |
if ($realpasswd eq $upass ) { |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
|
my $pwdcorrect=0; |
|
if ($howpwd eq 'internal') { |
|
$pwdcorrect= |
|
(crypt($upass,$contentpwd) eq $contentpwd); |
|
} elsif ($howpwd eq 'unix') { |
|
$contentpwd=(getpwnam($uname))[1]; |
|
$pwdcorrect= |
|
(crypt($upass,$contentpwd) eq $contentpwd); |
|
} elsif ($howpwd eq 'krb4') { |
|
$pwdcorrect=( |
|
Authen::Krb4::get_pw_in_tkt($uname,"", |
|
$contentpwd,'krbtgt',$contentpwd,1, |
|
$upass) == 0); |
|
} |
|
if ($pwdcorrect) { |
print $client "authorized\n"; |
print $client "authorized\n"; |
} else { |
} else { |
print $client "non_authorized\n"; |
print $client "non_authorized\n"; |
Line 348 sub make_new_child {
|
Line 471 sub make_new_child {
|
{ my $pf = IO::File->new($passfilename); |
{ my $pf = IO::File->new($passfilename); |
$realpasswd=<$pf>; } |
$realpasswd=<$pf>; } |
chomp($realpasswd); |
chomp($realpasswd); |
if ($realpasswd eq $upass ) { |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
|
if ($howpwd eq 'internal') { |
|
if (crypt($upass,$contentpwd) eq $contentpwd) { |
|
my $salt=time; |
|
$salt=substr($salt,6,2); |
|
my $ncpass=crypt($npass,$salt); |
{ my $pf = IO::File->new(">$passfilename"); |
{ my $pf = IO::File->new(">$passfilename"); |
print $pf "$npass\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"; |
|
} |
|
} else { |
|
print $client "auth_mode_error\n"; |
} |
} |
} else { |
} else { |
print $client "unknown_user\n"; |
print $client "unknown_user\n"; |
Line 403 sub make_new_child {
|
Line 534 sub make_new_child {
|
&logthis( |
&logthis( |
"LWP GET: $message for $fname ($remoteurl)"); |
"LWP GET: $message for $fname ($remoteurl)"); |
} else { |
} else { |
|
if ($remoteurl!~/\.meta$/) { |
|
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 431 sub make_new_child {
|
Line 571 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=IO::File->new(">$fname.$hostid{$clientip}"); |
Line 439 sub make_new_child {
|
Line 582 sub make_new_child {
|
$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/\W//g; |
$namespace=~s/\//\_/g; |
|
$namespace=~s/\W//g; |
|
if ($namespace ne 'roles') { |
chomp($what); |
chomp($what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $now=time; |
my $now=time; |
Line 460 sub make_new_child {
|
Line 621 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 (dbmopen(%hash,"$proname/$namespace.db",0644)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
|
foreach $pair (@pairs) { |
|
($key,$value)=split(/=/,$pair); |
|
$hash{$key}=$value; |
|
} |
|
if (untie(%hash)) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
|
# -------------------------------------------------------------------- rolesput |
|
} elsif ($userinput =~ /^rolesput/) { |
|
if ($wasenc==1) { |
|
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
|
=split(/:/,$userinput); |
|
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 "P:$now:$exedom:$exeuser:$what\n"; |
|
} |
|
} |
|
my @pairs=split(/\&/,$what); |
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
foreach $pair (@pairs) { |
foreach $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
Line 473 sub make_new_child {
|
Line 668 sub make_new_child {
|
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
} |
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
# ------------------------------------------------------------------------- get |
# ------------------------------------------------------------------------- get |
} 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 (dbmopen(%hash,"$proname/$namespace.db",0644)) { |
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]}&"; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
Line 499 sub make_new_child {
|
Line 698 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 (dbmopen(%hash,"$proname/$namespace.db",0644)) { |
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]}&"; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
if ($cipher) { |
if ($cipher) { |
my $cmdlength=length($qresult); |
my $cmdlength=length($qresult); |
Line 534 sub make_new_child {
|
Line 734 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); |
Line 545 sub make_new_child {
|
Line 746 sub make_new_child {
|
) { print $hfh "D:$now:$what\n"; } |
) { print $hfh "D:$now:$what\n"; } |
} |
} |
my @keys=split(/\&/,$what); |
my @keys=split(/\&/,$what); |
if (dbmopen(%hash,"$proname/$namespace.db",0644)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
foreach $key (@keys) { |
foreach $key (@keys) { |
delete($hash{$key}); |
delete($hash{$key}); |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
Line 561 sub make_new_child {
|
Line 762 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 (dbmopen(%hash,"$proname/$namespace.db",0644)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
foreach $key (keys %hash) { |
foreach $key (keys %hash) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
Line 582 sub make_new_child {
|
Line 783 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 (dbmopen(%hash,"$proname/$namespace.db",0644)) { |
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}&"; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
|
$qresult=~s/\&$//; |
|
print $client "$qresult\n"; |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
# ----------------------------------------------------------------------- store |
|
} elsif ($userinput =~ /^store/) { |
|
my ($cmd,$udom,$uname,$namespace,$rid,$what) |
|
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
|
$namespace=~s/\W//g; |
|
if ($namespace ne 'roles') { |
|
chomp($what); |
|
my $proname=propath($udom,$uname); |
|
my $now=time; |
|
{ |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { print $hfh "P:$now:$rid:$what\n"; } |
|
} |
|
my @pairs=split(/\&/,$what); |
|
|
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
|
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
|
my $key; |
|
$hash{"version:$rid"}++; |
|
my $version=$hash{"version:$rid"}; |
|
my $allkeys=''; |
|
foreach $pair (@pairs) { |
|
($key,$value)=split(/=/,$pair); |
|
$allkeys.=$key.':'; |
|
$hash{"$version:$rid:$key"}=$value; |
|
} |
|
$allkeys=~s/:$//; |
|
$hash{"$version:keys:$rid"}=$allkeys; |
|
if (untie(%hash)) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
} else { |
|
print $client "error:$!\n"; |
|
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
|
# --------------------------------------------------------------------- restore |
|
} elsif ($userinput =~ /^restore/) { |
|
my ($cmd,$udom,$uname,$namespace,$rid) |
|
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
|
$namespace=~s/\W//g; |
|
chomp($rid); |
|
my $proname=propath($udom,$uname); |
|
my $qresult=''; |
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
|
my $version=$hash{"version:$rid"}; |
|
$qresult.="version=$version&"; |
|
my $scope; |
|
for ($scope=1;$scope<=$version;$scope++) { |
|
my $vkeys=$hash{"$scope:keys:$rid"}; |
|
my @keys=split(/:/,$vkeys); |
|
my $key; |
|
$qresult.="$scope:keys=$vkeys&"; |
|
foreach $key (@keys) { |
|
$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; |
|
} |
|
} |
|
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
Line 599 sub make_new_child {
|
Line 873 sub make_new_child {
|
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
} |
} |
|
# ------------------------------------------------------------------- querysend |
|
} elsif ($userinput =~ /^querysend/) { |
|
my ($cmd,$query)=split(/:/,$userinput); |
|
$query=~s/\n*$//g; |
|
print $client sqlreply("$hostid{$clientip}\&$query")."\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")) { |
|
print $store $reply; |
|
close $store; |
|
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 613 sub make_new_child {
|
Line 905 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 (dbmopen(%hash,"$proname.db",0644)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { |
foreach $pair (@pairs) { |
foreach $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error:$!\n"; |
Line 634 sub make_new_child {
|
Line 926 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 (dbmopen(%hash,"$proname.db",0644)) { |
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]}&"; |
} |
} |
if (dbmclose(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
Line 647 sub make_new_child {
|
Line 939 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 |
|
} elsif ($userinput =~ /^ls/) { |
|
my ($cmd,$ulsdir)=split(/:/,$userinput); |
|
my $ulsout=''; |
|
my $ulsfn; |
|
if (-e $ulsdir) { |
|
while ($ulsfn=<$ulsdir/*>) { |
|
my @ulsstats=stat($ulsfn); |
|
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; |
|
} |
|
} else { |
|
$ulsout='no_such_dir'; |
|
} |
|
if ($ulsout eq '') { $ulsout='empty'; } |
|
print $client "$ulsout\n"; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
} else { |
} else { |
# unknown command |
# unknown command |
Line 656 sub make_new_child {
|
Line 997 sub make_new_child {
|
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
&logthis("Unknown 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>"); |
# ============================================================================= |
# ============================================================================= |
} |
} |
|
|
Line 671 sub make_new_child {
|
Line 1014 sub make_new_child {
|
} |
} |
} |
} |
|
|
|
# grabs exception and records it to log before exiting |
|
sub catchexception { |
|
my ($signal)=@_; |
|
&logthis("<font color=red>CRITICAL: " |
|
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
|
."$signal with this parameter->[$@]</font>"); |
|
die($@); |
|
} |
|
|
|
# grabs exception and records it to log before exiting |
|
# NOTE: we must NOT use the regular (non-overrided) die function in |
|
# the code because a handler CANNOT be attached to it |
|
# (despite what some of the documentation says about SIG{__DIE__}. |
|
sub catchdie { |
|
my ($message)=@_; |
|
&logthis("<font color=red>CRITICAL: " |
|
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
|
."\_\_DIE\_\_ with this parameter->[$message]</font>"); |
|
die($message); |
|
} |
|
|
|
|
|
|