#!/usr/bin/perl
# lonsql-based on the preforker:harsha jagasia:date:5/10/00
# 7/25 Gerd Kortemeyer
# many different dates Scott Harrison
# 03/22/2001 Scott Harrison
use IO::Socket;
use Symbol;
use POSIX;
use IO::Select;
use IO::File;
use Socket;
use Fcntl;
use Tie::RefHash;
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$/ &&
push(@metalist,"$dir/$_");
}
$childmaxattempts=10;
$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>) {
if ($configline =~ /PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);
$perlvar{$varname}=$varvalue;
}
}
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
$PREFORK=4; # number of children to maintain, at least four spare
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
while ($configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
chomp($ip);
$hostip{$ip}=$id;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
$PREFORK++;
}
close(CONFIG);
$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
# global variables
$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
%children = (); # keys are current child process IDs
$children = 0; # current number of children
sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;
my $pid = wait;
$children --;
&logthis("Child $pid died");
delete $children{$pid};
}
sub HUNTSMAN { # signal handler for SIGINT
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
kill 'INT' => keys %children;
my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lonsql.pid");
&logthis("<font color=red>CRITICAL: Shutting down</font>");
$unixsock = "mysqlsock";
my $port="$perlvar{'lonSockDir'}/$unixsock";
unlink(port);
exit; # clean up with dignity
}
sub HUPSMAN { # signal handler for SIGHUP
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
kill 'INT' => keys %children;
close($server); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");
my $execdir=$perlvar{'lonDaemons'};
$unixsock = "mysqlsock";
my $port="$perlvar{'lonSockDir'}/$unixsock";
unlink(port);
exec("$execdir/lonsql"); # here we go again
}
sub logthis {
my $message=shift;
my $execdir=$perlvar{'lonDaemons'};
my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
my $now=time;
my $local=localtime($now);
print $fh "$local ($$): $message\n";
}
# ---------------------------------------------------- Fork once and dissociate
$fpid=fork;
exit if $fpid;
die "Couldn't fork: $!" unless defined ($fpid);
POSIX::setsid() or die "Can't start new session: $!";
# ------------------------------------------------------- Write our PID on disk
$execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lonsql.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
# ----------------------------- Ignore signals generated during initial startup
$SIG{HUP}=$SIG{USR1}='IGNORE';
# ------------------------------------------------------- Now we are on our own
# Fork off our children.
for (1 .. $PREFORK) {
make_new_child();
}
# Install signal handlers.
$SIG{CHLD} = \&REAPER;
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP} = \&HUPSMAN;
# And maintain the population.
while (1) {
sleep; # wait for a signal (i.e., child's death)
for ($i = $children; $i < $PREFORK; $i++) {
make_new_child(); # top up the child pool
}
}
sub make_new_child {
my $pid;
my $sigset;
# block signal for fork
$sigset = POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset)
or die "Can't block SIGINT for fork: $!\n";
die "fork: $!" unless defined ($pid = fork);
if ($pid) {
# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = 1;
$children++;
return;
} else {
# Child can *not* return from this subroutine.
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
# unblock signals
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
#open database handle
# making dbh global to avoid garbage collector
unless (
$dbh = DBI->connect("DBI:mysql:loncapa","www","123",{ RaiseError =>0,PrintError=>0})
) {
my $st=120+int(rand(240));
&logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>");
print "database handle error\n";
sleep($st);
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
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
$client = $server->accept() or last;
# do something with the connection
$run = $run+1;
my $userinput = <$client>;
chomp($userinput);
my ($conserver,$querytmp,$customtmp)=split(/&/,$userinput);
my $query=unescape($querytmp);
my $custom=unescape($customtmp);
#send query id which is pid_unixdatetime_runningcounter
$queryid = $thisserver;
$queryid .="_".($$)."_";
$queryid .= time."_";
$queryid .= $run;
print $client "$queryid\n";
#prepare and execute the query
my $sth = $dbh->prepare($query);
my $result;
unless ($sth->execute())
{
&logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
$result="";
}
else {
my $r1=$sth->fetchall_arrayref;
my @r2; map {my $a=$_; my @b=map {escape($_)} @$a; push @r2,join(",", @b)} (@$r1);
$result=join("&",@r2) . "\n";
}
# do custom metadata searching here and build into result
if ($custom) {
&logthis("am going to do custom query for $custom");
@metalist=(); pop @metalist;
&find("$perlvar{'lonDocRoot'}/res");
&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='';
foreach my $m (@metalist) {
my $fh=IO::File->new($m);
my @lines=<$fh>;
my $stuff=join('',@lines);
if ($stuff=~/$custom/s) {
&logthis("found: $stuff");
}
$customresult.='&custom='.escape($stuff);
}
# $result.=$customresult;
}
# reply with result
$result.="ABCABC";
&reply("queryreply:$queryid:${result}DEF",$conserver);
}
# 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
# a producer of more and more children, forking yourself into
# process death.
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';
}
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;
}
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>