version 1.1, 2000/05/08 15:14:27
|
version 1.49, 2002/06/24 14:22:05
|
Line 1
|
Line 1
|
#!/usr/bin/perl |
#!/usr/bin/perl |
|
|
# The LearningOnline Network |
# The LearningOnline Network |
# lonsql |
# lonsql - LON TCP-MySQL-Server Daemon for handling database requests. |
# provides unix domain sockets to receive queries from lond and send replies to lonc |
|
# |
# |
# PID in subdir logs/lonc.pid |
# $Id$ |
# kill kills |
# |
# HUP restarts |
# Copyright Michigan State University Board of Trustees |
# USR1 tries to open connections again |
# |
|
# This file is part of the LearningOnline Network with CAPA (LON-CAPA). |
# 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19, |
# |
# 10/8,10/9,10/15,11/18,12/22, |
# LON-CAPA is free software; you can redistribute it and/or modify |
# 2/8 Gerd Kortemeyer |
# it under the terms of the GNU General Public License as published by |
# based on nonforker from Perl Cookbook |
# the Free Software Foundation; either version 2 of the License, or |
# - server who multiplexes without forking |
# (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/ |
|
# |
|
# YEAR=2000 |
|
# lonsql-based on the preforker:harsha jagasia:date:5/10/00 |
|
# 7/25 Gerd Kortemeyer |
|
# many different dates Scott Harrison |
|
# YEAR=2001 |
|
# many different dates Scott Harrison |
|
# 03/22/2001 Scott Harrison |
|
# 8/30 Gerd Kortemeyer |
|
# 10/17,11/28,11/29,12/20 Scott Harrison |
|
# YEAR=2001 |
|
# 5/11 Scott Harrison |
|
# |
|
### |
|
|
|
############################################################################### |
|
## ## |
|
## ORGANIZATION OF THIS PERL SCRIPT ## |
|
## 1. Modules used ## |
|
## 2. Enable find subroutine ## |
|
## 3. Read httpd config files and get variables ## |
|
## 4. Make sure that database can be accessed ## |
|
## 5. Make sure this process is running from user=www ## |
|
## 6. Check if other instance is running ## |
|
## 7. POD (plain old documentation, CPAN style) ## |
|
## ## |
|
############################################################################### |
|
|
|
use lib '/home/httpd/lib/perl/'; |
|
use LONCAPA::Configuration; |
|
|
use POSIX; |
|
use IO::Socket; |
use IO::Socket; |
|
use Symbol; |
|
use POSIX; |
use IO::Select; |
use IO::Select; |
use IO::File; |
use IO::File; |
use Socket; |
use Socket; |
use Fcntl; |
use Fcntl; |
use Tie::RefHash; |
use Tie::RefHash; |
use Crypt::IDEA; |
|
use DBI; |
use DBI; |
|
|
|
my @metalist; |
|
# ----------------- Code to enable 'find' subroutine listing of the .meta files |
|
require "find.pl"; |
|
sub wanted { |
|
(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && |
|
-f _ && |
|
/^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ && |
|
push(@metalist,"$dir/$_"); |
|
} |
|
|
$childmaxattempts=10; |
$childmaxattempts=10; |
$run =0; |
$run =0;#running counter to generate the query-id |
# ------------------------------------ Read httpd access.conf and get variables |
|
|
|
open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; |
|
|
|
while ($configline=<CONFIG>) { |
# -------------------------------- Read loncapa_apache.conf and loncapa.conf |
if ($configline =~ /PerlSetVar/) { |
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf', |
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
'loncapa.conf'); |
chomp($varvalue); |
my %perlvar=%{$perlvarref}; |
$perlvar{$varname}=$varvalue; |
|
|
# ------------------------------------- Make sure that database can be accessed |
|
{ |
|
my $dbh; |
|
unless ( |
|
$dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) |
|
) { |
|
print "Cannot connect to database!\n"; |
|
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
|
$subj="LON: $perlvar{'lonHostID'} Cannot connect to database!"; |
|
system("echo 'Cannot connect to MySQL database!' |\ |
|
mailto $emailto -s '$subj' > /dev/null"); |
|
exit 1; |
|
} |
|
else { |
|
$dbh->disconnect; |
} |
} |
} |
} |
close(CONFIG); |
|
|
# --------------------------------------------- Check if other instance running |
|
|
|
my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.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 |
#$PREFORK=4; # number of children to maintain, at least four spare |
$PREFORK=4; # number of children to maintain, at least four spare |
|
|
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
|
|
Line 50 while ($configline=<CONFIG>) {
|
Line 123 while ($configline=<CONFIG>) {
|
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); |
chomp($ip); |
chomp($ip); |
|
|
#$hostip{$ip}=$id; |
$hostip{$ip}=$id; |
$hostip{$id}=$ip; |
|
|
|
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
|
|
#$PREFORK++; |
$PREFORK++; |
} |
} |
close(CONFIG); |
close(CONFIG); |
|
|
|
$PREFORK=int($PREFORK/4); |
|
|
|
$unixsock = "mysqlsock"; |
|
my $localfile="$perlvar{'lonSockDir'}/$unixsock"; |
|
my $server; |
|
unlink ($localfile); |
|
unless ($server=IO::Socket::UNIX->new(Local =>"$localfile", |
|
Type => SOCK_STREAM, |
|
Listen => 10)) |
|
{ |
|
print "in socket error:$@\n"; |
|
} |
|
|
# -------------------------------------------------------- Routines for forking |
# -------------------------------------------------------- Routines for forking |
# global variables |
# global variables |
#$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process |
$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process |
%children = (); # keys are current child process IDs |
%children = (); # keys are current child process IDs |
#$children = 0; # current number of children |
$children = 0; # current number of children |
%childpid = (); # the other way around |
|
|
|
%childatt = (); # number of attempts to start server |
|
# for ID |
|
|
|
|
|
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 --; |
#$children --; |
&logthis("Child $pid died"); |
#&logthis("Child $pid died"); |
|
#delete $children{$pid}; |
|
|
|
my $wasserver=$children{$pid}; |
|
&logthis("<font color=red>CRITICAL: " |
|
."Child $pid for server $wasserver died ($childatt{$wasserver})</font>"); |
|
delete $children{$pid}; |
delete $children{$pid}; |
delete $childpid{$wasserver}; |
|
my $port = "$perlvar{'lonSockDir'}/$wasserver"; |
|
unlink($port); |
|
|
|
|
|
} |
} |
|
|
sub HUNTSMAN { # signal handler for SIGINT |
sub HUNTSMAN { # signal handler for SIGINT |
Line 96 sub HUNTSMAN { # si
|
Line 163 sub HUNTSMAN { # si
|
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
unlink("$execdir/logs/lonsql.pid"); |
unlink("$execdir/logs/lonsql.pid"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
|
$unixsock = "mysqlsock"; |
|
my $port="$perlvar{'lonSockDir'}/$unixsock"; |
|
unlink(port); |
exit; # clean up with dignity |
exit; # clean up with dignity |
} |
} |
|
|
Line 105 sub HUPSMAN { # sig
|
Line 175 sub HUPSMAN { # sig
|
close($server); # free up socket |
close($server); # free up socket |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
|
$unixsock = "mysqlsock"; |
|
my $port="$perlvar{'lonSockDir'}/$unixsock"; |
|
unlink(port); |
exec("$execdir/lonsql"); # here we go again |
exec("$execdir/lonsql"); # here we go again |
} |
} |
|
|
sub logthis { |
sub logthis { |
my $message=shift; |
my $message=shift; |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
my $fh=IO::File->new(">>$execdir/logs/lonsql.log"); |
my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log"); |
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
print $fh "$local ($$): $message\n"; |
print $fh "$local ($$): $message\n"; |
} |
} |
|
|
# ----------------------------------------------------------- Send USR1 to lonc |
# ------------------------------------------------------------------ Course log |
sub reconlonc { |
|
my $peerfile=shift; |
sub courselog { |
&logthis("Trying to reconnect for $peerfile"); |
my ($path,$command)=@_; |
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; |
my %filters=(); |
if (my $fh=IO::File->new("$loncfile")) { |
foreach (split(/\:/,&unescape($command))) { |
my $loncpid=<$fh>; |
my ($name,$value)=split(/\=/,$_); |
chomp($loncpid); |
$filters{$name}=$value; |
if (kill 0 => $loncpid) { |
} |
&logthis("lonc at pid $loncpid responding, sending USR1"); |
my @results=(); |
kill USR1 => $loncpid; |
open(IN,$path.'/activity.log') or return ('file_error'); |
sleep 1; |
while ($line=<IN>) { |
if (-e "$peerfile") { return; } |
chomp($line); |
&logthis("$peerfile still not there, give it another try"); |
my ($timestamp,$host,$log)=split(/\:/,$line); |
sleep 5; |
# |
if (-e "$peerfile") { return; } |
# $log has the actual log entries; currently still escaped, and |
&logthis( |
# %26(timestamp)%3a(url)%3a(user)%3a(domain) |
"<font color=blue>WARNING: $peerfile still not there, giving up</font>"); |
# then additionally |
} else { |
# %3aPOST%3a(name)%3d(value)%3a(name)%3d(value) |
&logthis( |
# or |
"<font color=red>CRITICAL: " |
# %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value) |
."lonc at pid $loncpid not responding, giving up</font>"); |
# |
} |
# get delimiter between timestamped entries to be &&& |
} else { |
$log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g; |
&logthis('<font color=red>CRITICAL: lonc not running, giving up</font>'); |
# now go over all log entries |
|
foreach (split(/\&\&\&/,&unescape($log))) { |
|
my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_); |
|
my $values=&unescape(join(':',@values)); |
|
$values=~s/\&/\:/g; |
|
$res=&unescape($res); |
|
my $include=1; |
|
if (($filters{'username'}) && ($uname ne $filters{'username'})) |
|
{ $include=0; } |
|
if (($filters{'domain'}) && ($udom ne $filters{'domain'})) |
|
{ $include=0; } |
|
if (($filters{'url'}) && ($res!~/$filters{'url'}/)) |
|
{ $include=0; } |
|
if (($filters{'start'}) && ($time<$filters{'start'})) |
|
{ $include=0; } |
|
if (($filters{'end'}) && ($time>$filters{'end'})) |
|
{ $include=0; } |
|
if (($filters{'action'} eq 'view') && ($action)) |
|
{ $include=0; } |
|
if (($filters{'action'} eq 'submit') && ($action ne 'POST')) |
|
{ $include=0; } |
|
if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) |
|
{ $include=0; } |
|
if ($include) { |
|
push(@results,($time<1000000000?'0':'').$time.':'.$res.':'. |
|
$uname.':'.$udom.':'. |
|
$action.':'.$values); |
|
} |
|
} |
} |
} |
|
close IN; |
|
return join('&',sort(@results)); |
} |
} |
|
|
# -------------------------------------------------- Non-critical communication |
# -------------------------------------------------------------------- User log |
sub subreply { |
|
my ($cmd,$server)=@_; |
|
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
|
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; |
|
} |
|
|
|
sub reply { |
sub userlog { |
my ($cmd,$server)=@_; |
my ($path,$command)=@_; |
my $answer; |
my %filters=(); |
if ($server ne $perlvar{'lonHostID'}) { |
foreach (split(/\:/,&unescape($command))) { |
$answer=subreply($cmd,$server); |
my ($name,$value)=split(/\=/,$_); |
if ($answer eq 'con_lost') { |
$filters{$name}=$value; |
$answer=subreply("ping",$server); |
} |
if ($answer ne $server) { |
my @results=(); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
open(IN,$path.'/activity.log') or return ('file_error'); |
|
while ($line=<IN>) { |
|
chomp($line); |
|
my ($timestamp,$host,$log)=split(/\:/,$line); |
|
$log=&unescape($log); |
|
my $include=1; |
|
if (($filters{'start'}) && ($timestamp<$filters{'start'})) |
|
{ $include=0; } |
|
if (($filters{'end'}) && ($timestamp>$filters{'end'})) |
|
{ $include=0; } |
|
if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; } |
|
if (($filters{'action'} eq 'check') && ($log!~/^Check/)) |
|
{ $include=0; } |
|
if ($include) { |
|
push(@results,$timestamp.':'.$log); |
} |
} |
$answer=subreply($cmd,$server); |
|
} |
} |
} else { |
close IN; |
$answer='self_reply'; |
return join('&',sort(@results)); |
} |
|
return $answer; |
|
} |
} |
|
|
$unixsock = "msua1_sql"; |
|
my $localfile="$perlvar{'lonSockDir'}/$unixsock"; |
|
my $server=IO::Socket::UNIX->new(LocalAddr =>"$localfile", |
|
Type => SOCK_STREAM, |
|
Timeout => 10); |
|
|
|
# ---------------------------------------------------- Fork once and dissociate |
# ---------------------------------------------------- Fork once and dissociate |
$fpid=fork; |
$fpid=fork; |
Line 201 close(PIDSAVE);
|
Line 297 close(PIDSAVE);
|
|
|
# ----------------------------- Ignore signals generated during initial startup |
# ----------------------------- Ignore signals generated during initial startup |
$SIG{HUP}=$SIG{USR1}='IGNORE'; |
$SIG{HUP}=$SIG{USR1}='IGNORE'; |
|
# ------------------------------------------------------- Now we are on our own |
# ------------------------------------------------------- Now we are on our own |
# Fork off our children. |
#Fork of children one for every server |
for (1 .. $PREFORK) { |
|
make_new_child(); |
#for (1 .. $PREFORK) { |
|
# make_new_child($thisserver); |
|
#} |
|
|
|
foreach $thisserver (keys %hostip) { |
|
make_new_child($thisserver); |
|
} |
} |
|
|
&logthis("Done starting initial servers"); |
# 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; |
Line 223 $SIG{HUP} = \&HUPSMAN;
|
Line 311 $SIG{HUP} = \&HUPSMAN;
|
# And maintain the population. |
# And maintain the population. |
while (1) { |
while (1) { |
sleep; # wait for a signal (i.e., child's death) |
sleep; # wait for a signal (i.e., child's death) |
|
for ($i = $children; $i < $PREFORK; $i++) { |
#for ($i = $children; $i < $PREFORK; $i++) { |
make_new_child(); # top up the child pool |
# make_new_child(); # top up the child pool |
|
#} |
|
|
|
foreach $thisserver (keys %hostip) { |
|
if (!$childpid{$thisserver}) { |
|
if ($childatt{$thisserver}<=$childmaxattempts) { |
|
$childatt{$thisserver}++; |
|
&logthis( |
|
"<font color=yellow>INFO: Trying to reconnect for $thisserver " |
|
."($childatt{$thisserver} of $childmaxattempts attempts)</font>"); |
|
make_new_child($thisserver); |
|
} |
|
} |
|
} |
} |
} |
} |
|
|
|
|
sub make_new_child { |
sub make_new_child { |
my $conserver=shift; |
|
my $pid; |
my $pid; |
my $sigset; |
my $sigset; |
my $queryid; |
|
|
|
&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"; |
|
|
die "fork: $!" unless defined ($pid = fork);#do the forking of children |
die "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) |
Line 263 sub make_new_child {
|
Line 336 sub make_new_child {
|
$children++; |
$children++; |
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 |
|
|
# 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"; |
|
|
#connect to the database |
|
|
#open database handle |
|
# making dbh global to avoid garbage collector |
unless ( |
unless ( |
my $dbh = DBI->connect("DBI:mysql:loncapa","root","mysql",{ RaiseError =>1,}) |
$dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) |
) { |
) { |
my $st=120+int(rand(240)); |
sleep(10+int(rand(20))); |
&logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>"); |
&logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>"); |
sleep($st); |
print "database handle error\n"; |
exit;#do I need to cleanup before exit if can't connect to database |
exit; |
}; |
|
|
}; |
|
# make sure that a database disconnection occurs with ending kill signals |
|
$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; |
|
|
# 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++) { |
$client = $server->accept() or last; |
$client = $server->accept() or last; |
$run = $run+1; |
|
# ============================================================================= |
|
# do something with the connection |
# do something with the connection |
# ----------------------------------------------------------------------------- |
$run = $run+1; |
my $userinput = "1"; |
my $userinput = <$client>; |
#while (my $userinput=<$client>) { |
chomp($userinput); |
while (my $userinput="1") { |
|
print ("here we go\n"); |
my ($conserver,$query, |
chomp($userinput); |
$arg1,$arg2,$arg3)=split(/&/,$userinput); |
|
my $query=unescape($query); |
#send query id which is pid_unixdatetime_runningcounter |
|
$queryid = $conserver; |
#send query id which is pid_unixdatetime_runningcounter |
$queryid .=($$)."_"; |
$queryid = $thisserver; |
$queryid .= time."_"; |
$queryid .="_".($$)."_"; |
$queryid .= run; |
$queryid .= time."_"; |
print $client "$queryid\n"; |
$queryid .= $run; |
|
print $client "$queryid\n"; |
#prepare and execute the query |
|
|
&logthis("QUERY: $query - $arg1 - $arg2 - $arg3"); |
my $sth = $dbh->prepare("select * into outfile \"$queryid\" from resource");#can't use $userinput directly since we the query to write to a file which depends on the query id generated |
sleep 1; |
|
|
$sth->execute(); |
my $result=''; |
if (-e "$queryid") { print "Oops ,file is already there!\n";} |
|
else |
# ---------- At this point, query is received, query-ID assigned and sent back |
{ |
# $query eq 'logquery' will mean that this is a query against log-files |
print "error reading into file\n"; |
|
} |
|
|
if (($query eq 'userlog') || ($query eq 'courselog')) { |
#connect to lonc and send the query results |
# ----------------------------------------------------- beginning of log query |
$reply = reply($queryid,$conserver); |
# |
|
# this goes against a user's log file |
} |
# |
# ============================================================================= |
my $udom=&unescape($arg1); |
|
my $uname=&unescape($arg2); |
|
my $command=&unescape($arg3); |
|
my $path=&propath($udom,$uname); |
|
if (-e "$path/activity.log") { |
|
if ($query eq 'userlog') { |
|
$result=&userlog($path,$command); |
|
} else { |
|
$result=&courselog($path,$command); |
|
} |
|
} else { |
|
&logthis('Unable to do log query: '.$uname.'@'.$udom); |
|
$result='no_such_file'; |
|
} |
|
# ------------------------------------------------------------ end of log query |
|
} else { |
|
# -------------------------------------------------------- This is an sql query |
|
my $custom=unescape($arg1); |
|
my $customshow=unescape($arg2); |
|
#prepare and execute the query |
|
my $sth = $dbh->prepare($query); |
|
|
|
my @files; |
|
my $subsetflag=0; |
|
if ($query) { |
|
unless ($sth->execute()) |
|
{ |
|
&logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>"); |
|
$result=""; |
|
} |
|
else { |
|
my $r1=$sth->fetchall_arrayref; |
|
my @r2; |
|
foreach (@$r1) {my $a=$_; |
|
my @b=map {escape($_)} @$a; |
|
push @files,@{$a}[3]; |
|
push @r2,join(",", @b) |
|
} |
|
$result=join("&",@r2); |
|
} |
|
} |
|
# do custom metadata searching here and build into result |
|
if ($custom or $customshow) { |
|
&logthis("am going to do custom query for $custom"); |
|
if ($query) { |
|
@metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files; |
|
} |
|
else { |
|
@metalist=(); pop @metalist; |
|
opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"); |
|
my @homeusers=grep |
|
{&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")} |
|
grep {!/^\.\.?$/} readdir(RESOURCES); |
|
closedir RESOURCES; |
|
foreach my $user (@homeusers) { |
|
&find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user"); |
|
} |
|
} |
|
# &logthis("FILELIST:" . join(":::",@metalist)); |
|
# if file is indicated in sql database and |
|
# not part of sql-relevant query, do not pattern match. |
|
# if file is not in sql database, output error. |
|
# if file is indicated in sql database and is |
|
# part of query result list, then do the pattern match. |
|
my $customresult=''; |
|
my @r2; |
|
foreach my $m (@metalist) { |
|
my $fh=IO::File->new($m); |
|
my @lines=<$fh>; |
|
my $stuff=join('',@lines); |
|
if ($stuff=~/$custom/s) { |
|
foreach my $f ('abstract','author','copyright', |
|
'creationdate','keywords','language', |
|
'lastrevisiondate','mime','notes', |
|
'owner','subject','title') { |
|
$stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s; |
|
} |
|
my $m2=$m; my $docroot=$perlvar{'lonDocRoot'}; |
|
$m2=~s/^$docroot//; |
|
$m2=~s/\.meta$//; |
|
unless ($query) { |
|
my $q2="select * from metadata where url like binary '$m2'"; |
|
my $sth = $dbh->prepare($q2); |
|
$sth->execute(); |
|
my $r1=$sth->fetchall_arrayref; |
|
foreach (@$r1) {my $a=$_; |
|
my @b=map {escape($_)} @$a; |
|
push @files,@{$a}[3]; |
|
push @r2,join(",", @b) |
|
} |
|
} |
|
# &logthis("found: $stuff"); |
|
$customresult.='&custom='.escape($m2).','.escape($stuff); |
|
} |
|
} |
|
$result=join("&",@r2) unless $query; |
|
$result.=$customresult; |
|
} |
|
# ------------------------------------------------------------ end of sql query |
|
} |
|
|
|
# result does need to be escaped |
|
|
|
$result=&escape($result); |
|
|
|
# reply with result, append \n unless already there |
|
|
|
$result.="\n" unless ($result=~/\n$/); |
|
&reply("queryreply:$queryid:$result",$conserver); |
|
|
} |
} |
|
|
# tidy up gracefully and finish |
# tidy up gracefully and finish |
|
|
|
#close the database handle |
|
$dbh->disconnect |
|
or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</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; |
} |
} |
} |
} |
|
|
|
|
|
sub DISCONNECT { |
|
$dbh->disconnect or |
|
&logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>"); |
|
exit; |
|
} |
|
|
|
# -------------------------------------------------- Non-critical communication |
|
|
|
sub subreply { |
|
my ($cmd,$server)=@_; |
|
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
|
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; |
|
} |
|
|
|
sub reply { |
|
my ($cmd,$server)=@_; |
|
my $answer; |
|
if ($server ne $perlvar{'lonHostID'}) { |
|
$answer=subreply($cmd,$server); |
|
if ($answer eq 'con_lost') { |
|
$answer=subreply("ping",$server); |
|
$answer=subreply($cmd,$server); |
|
} |
|
} else { |
|
$answer='self_reply'; |
|
$answer=subreply($cmd,$server); |
|
} |
|
return $answer; |
|
} |
|
|
|
# -------------------------------------------------------- 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; |
|
} |
|
|
|
# --------------------------------------- Is this the home server of an author? |
|
# (copied from lond, modification of the return value) |
|
sub ishome { |
|
my $author=shift; |
|
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
|
my ($udom,$uname)=split(/\//,$author); |
|
my $proname=propath($udom,$uname); |
|
if (-e $proname) { |
|
return 1; |
|
} else { |
|
return 0; |
|
} |
|
} |
|
|
|
# -------------------------------------------- Return path to profile directory |
|
# (copied from lond) |
|
sub propath { |
|
my ($udom,$uname)=@_; |
|
$udom=~s/\W//g; |
|
$uname=~s/\W//g; |
|
my $subdir=$uname.'__'; |
|
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
|
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
|
return $proname; |
|
} |
|
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|
|
=head1 NAME |
|
|
|
lonsql - LON TCP-MySQL-Server Daemon for handling database requests. |
|
|
|
=head1 SYNOPSIS |
|
|
|
This script should be run as user=www. The following is an example invocation |
|
from the loncron script. Note that a lonsql.pid file contains the pid of |
|
the parent process. |
|
|
|
if (-e $lonsqlfile) { |
|
my $lfh=IO::File->new("$lonsqlfile"); |
|
my $lonsqlpid=<$lfh>; |
|
chomp($lonsqlpid); |
|
if (kill 0 => $lonsqlpid) { |
|
print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>"; |
|
$restartflag=0; |
|
} else { |
|
$errors++; $errors++; |
|
print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>"; |
|
$restartflag=1; |
|
print $fh |
|
"<h3>Decided to clean up stale .pid file and restart lonsql</h3>"; |
|
} |
|
} |
|
if ($restartflag==1) { |
|
$errors++; |
|
print $fh '<br><font color="red">Killall lonsql: '. |
|
system('killall lonsql').' - '; |
|
sleep 60; |
|
print $fh unlink($lonsqlfile).' - '. |
|
system('killall -9 lonsql'). |
|
'</font><br>'; |
|
print $fh "<h3>lonsql not running, trying to start</h3>"; |
|
system( |
|
"$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors"); |
|
sleep 10; |
|
|
|
=head1 DESCRIPTION |
|
|
|
Not yet written. |
|
|
|
=head1 README |
|
|
|
Not yet written. |
|
|
|
=head1 PREREQUISITES |
|
|
|
IO::Socket |
|
Symbol |
|
POSIX |
|
IO::Select |
|
IO::File |
|
Socket |
|
Fcntl |
|
Tie::RefHash |
|
DBI |
|
|
|
=head1 COREQUISITES |
|
|
|
=head1 OSNAMES |
|
|
|
linux |
|
|
|
=head1 SCRIPT CATEGORIES |
|
|
|
Server/Process |
|
|
|
=cut |