) {
if ($configline =~ /PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
+ chomp($varvalue);
$perlvar{$varname}=$varvalue;
}
}
close(CONFIG);
+# ----------------------------- Make sure this process is running from user=www
+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
# ------------------------------------------------------------- Read hosts file
@@ -74,7 +126,7 @@ sub HUNTSMAN { # si
kill 'INT' => keys %children;
my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");
- &logthis("Shutting down");
+ &logthis("CRITICAL: Shutting down");
exit; # clean up with dignity
}
@@ -82,7 +134,8 @@ sub HUPSMAN { # sig
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
kill 'INT' => keys %children;
close($server); # free up socket
- &logthis("Restarting");
+ &logthis("CRITICAL: Restarting");
+ unlink("$execdir/logs/lond.pid");
my $execdir=$perlvar{'lonDaemons'};
exec("$execdir/lond"); # here we go again
}
@@ -98,6 +151,23 @@ sub logthis {
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
sub reconlonc {
@@ -115,16 +185,20 @@ sub reconlonc {
&logthis("$peerfile still not there, give it another try");
sleep 5;
if (-e "$peerfile") { return; }
- &logthis("$peerfile still not there, giving up");
+ &logthis(
+ "WARNING: $peerfile still not there, giving up");
} else {
- &logthis("lonc at pid $loncpid not responding, giving up");
+ &logthis(
+ "CRITICAL: "
+ ."lonc at pid $loncpid not responding, giving up");
}
} else {
- &logthis('lonc not running, giving up');
+ &logthis('CRITICAL: lonc not running, giving up');
}
}
# -------------------------------------------------- Non-critical communication
+
sub subreply {
my ($cmd,$server)=@_;
my $peerfile="$perlvar{'lonSockDir'}/$server";
@@ -157,18 +231,44 @@ sub reply {
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
+
sub propath {
my ($udom,$uname)=@_;
$udom=~s/\W//g;
$uname=~s/\W//g;
- my $subdir=$uname;
+ my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
return $proname;
}
# --------------------------------------- Is this the home server of an author?
+
sub ishome {
my $author=shift;
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
@@ -196,7 +296,7 @@ $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);
-&logthis("Starting");
+&logthis("CRITICAL: ---------- Starting ----------");
# ------------------------------------------------------- Now we are on our own
@@ -245,6 +345,8 @@ sub make_new_child {
# unblock signals
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
+
+ $tmpsnum=0;
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
@@ -253,15 +355,46 @@ sub make_new_child {
# =============================================================================
# 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 ($port,$iaddr)=unpack_sockaddr_in($caller);
my $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);
- &logthis("Connect from $clientip ($hostid{$clientip})");
+ &logthis(
+"INFO: Connect from $clientip ($hostid{$clientip})");
+ my $clientok;
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(
+ "WARNING: $clientip did not reply challenge");
+ print $client "bye\n";
+ }
+ } else {
+ &logthis(
+ "WARNING: "
+ ."$clientip failed to initialize: >$remotereq< ");
+ print $client "bye\n";
+ }
+ } else {
+ &logthis(
+ "WARNING: Unknown client $clientip");
+ print $client "bye\n";
+ }
+ if ($clientok) {
# ---------------- New known client connecting, could mean machine online again
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");
+ &logthis(
+ "Established connection: $hostid{$clientip}");
# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {
chomp($userinput);
@@ -318,13 +451,29 @@ sub make_new_child {
if ($wasenc==1) {
my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
chomp($upass);
+ $upass=unescape($upass);
my $proname=propath($udom,$uname);
my $passfilename="$proname/passwd";
if (-e $passfilename) {
my $pf = IO::File->new($passfilename);
my $realpasswd=<$pf>;
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";
} else {
print $client "non_authorized\n";
@@ -341,6 +490,8 @@ sub make_new_child {
my
($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
chomp($npass);
+ $upass=&unescape($upass);
+ $npass=&unescape($npass);
my $proname=propath($udom,$uname);
my $passfilename="$proname/passwd";
if (-e $passfilename) {
@@ -348,12 +499,20 @@ sub make_new_child {
{ my $pf = IO::File->new($passfilename);
$realpasswd=<$pf>; }
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");
- print $pf "$npass\n";; }
+ print $pf "internal:$ncpass\n"; }
print $client "ok\n";
- } else {
+ } else {
print $client "non_authorized\n";
+ }
+ } else {
+ print $client "auth_mode_error\n";
}
} else {
print $client "unknown_user\n";
@@ -361,6 +520,63 @@ sub make_new_child {
} else {
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 '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
} elsif ($userinput =~ /^home/) {
my ($cmd,$udom,$uname)=split(/:/,$userinput);
@@ -398,11 +614,21 @@ sub make_new_child {
$response=$ua->request($request,$transname);
}
if ($response->is_error()) {
- unline($transname);
+ unlink($transname);
my $message=$response->status_line;
&logthis(
"LWP GET: $message for $fname ($remoteurl)");
} 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);
}
}
@@ -431,25 +657,49 @@ sub make_new_child {
my $ownership=ishome($fname);
if ($ownership eq 'owner') {
if (-e $fname) {
+ if (-d $fname) {
+ print $client "directory\n";
+ } else {
$now=time;
{
- my $sh=IO::File->new(">$fname.$hostid{$clientip}");
- print $sh "$clientip:$now\n";
+ my $sh;
+ if ($sh=
+ IO::File->new(">$fname.$hostid{$clientip}")) {
+ print $sh "$clientip:$now\n";
+ }
}
$fname=~s/\/home\/httpd\/html\/res/raw/;
$fname="http://$thisserver/".$fname;
print $client "$fname\n";
+ }
} else {
print $client "not_found\n";
}
} else {
print $client "rejected\n";
}
+# ------------------------------------------------------------------------- log
+ } 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
} elsif ($userinput =~ /^put/) {
- my ($cmd,$udom,$uname,$namespace,$what)
+ my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);
- $namespace=~s/\W//g;
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ if ($namespace ne 'roles') {
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
@@ -460,12 +710,12 @@ sub make_new_child {
) { print $hfh "P:$now:$what\n"; }
}
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 (dbmclose(%hash)) {
+ if (untie(%hash)) {
print $client "ok\n";
} else {
print $client "error:$!\n";
@@ -473,20 +723,58 @@ sub make_new_child {
} 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) {
+ ($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";
+ }
# ------------------------------------------------------------------------- get
} elsif ($userinput =~ /^get/) {
my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
$namespace=~s/\W//g;
chomp($what);
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
- if (dbmclose(%hash)) {
+ if (untie(%hash)) {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
@@ -499,16 +787,17 @@ sub make_new_child {
} elsif ($userinput =~ /^eget/) {
my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
$namespace=~s/\W//g;
chomp($what);
my @queries=split(/\&/,$what);
my $proname=propath($udom,$uname);
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++) {
$qresult.="$hash{$queries[$i]}&";
}
- if (dbmclose(%hash)) {
+ if (untie(%hash)) {
$qresult=~s/\&$//;
if ($cipher) {
my $cmdlength=length($qresult);
@@ -534,6 +823,7 @@ sub make_new_child {
} elsif ($userinput =~ /^del/) {
my ($cmd,$udom,$uname,$namespace,$what)
=split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
$namespace=~s/\W//g;
chomp($what);
my $proname=propath($udom,$uname);
@@ -545,11 +835,11 @@ sub make_new_child {
) { print $hfh "D:$now:$what\n"; }
}
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) {
delete($hash{$key});
}
- if (dbmclose(%hash)) {
+ if (untie(%hash)) {
print $client "ok\n";
} else {
print $client "error:$!\n";
@@ -561,15 +851,15 @@ sub make_new_child {
} elsif ($userinput =~ /^keys/) {
my ($cmd,$udom,$uname,$namespace)
=split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
$namespace=~s/\W//g;
- chomp($namespace);
my $proname=propath($udom,$uname);
my $qresult='';
- if (dbmopen(%hash,"$proname/$namespace.db",0644)) {
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
foreach $key (keys %hash) {
$qresult.="$key&";
}
- if (dbmclose(%hash)) {
+ if (untie(%hash)) {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
@@ -582,15 +872,89 @@ sub make_new_child {
} elsif ($userinput =~ /^dump/) {
my ($cmd,$udom,$uname,$namespace)
=split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
$namespace=~s/\W//g;
- chomp($namespace);
my $proname=propath($udom,$uname);
my $qresult='';
- if (dbmopen(%hash,"$proname/$namespace.db",0644)) {
+ if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {
foreach $key (keys %hash) {
$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;
+ }
+ $hash{"$version:$rid:timestamp"}=$now;
+ $allkeys.='timestamp';
+ $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/\&$//;
print $client "$qresult\n";
} else {
@@ -599,6 +963,25 @@ sub make_new_child {
} else {
print $client "error:$!\n";
}
+# ------------------------------------------------------------------- querysend
+ } elsif ($userinput =~ /^querysend/) {
+ my ($cmd,$query,$custom)=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
} elsif ($userinput =~ /^idput/) {
my ($cmd,$udom,$what)=split(/:/,$userinput);
@@ -613,12 +996,12 @@ sub make_new_child {
) { print $hfh "P:$now:$what\n"; }
}
my @pairs=split(/\&/,$what);
- if (dbmopen(%hash,"$proname.db",0644)) {
+ if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {
foreach $pair (@pairs) {
($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
}
- if (dbmclose(%hash)) {
+ if (untie(%hash)) {
print $client "ok\n";
} else {
print $client "error:$!\n";
@@ -634,11 +1017,11 @@ sub make_new_child {
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my @queries=split(/\&/,$what);
my $qresult='';
- if (dbmopen(%hash,"$proname.db",0644)) {
+ if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {
for ($i=0;$i<=$#queries;$i++) {
$qresult.="$hash{$queries[$i]}&";
}
- if (dbmclose(%hash)) {
+ if (untie(%hash)) {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
@@ -647,6 +1030,55 @@ sub make_new_child {
} else {
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
} else {
# unknown command
@@ -656,9 +1088,11 @@ sub make_new_child {
}
} else {
print $client "refused\n";
- &logthis("Unknown client $clientip, closing connection");
+ &logthis("WARNING: "
+ ."Rejected client $clientip, closing connection");
}
- &logthis("Disconnect from $clientip ($hostid{$clientip})");
+ &logthis("CRITICAL: "
+ ."Disconnect from $clientip ($hostid{$clientip})");
# =============================================================================
}
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.