#!/usr/bin/perl
# lonsql-based on the preforker:harsha jagasia:date:5/10/00
# 7/25 Gerd Kortemeyer
# many different dates Scott Harrison

use IO::Socket;
use Symbol;
use POSIX;
use IO::Select;
use IO::File;
use Socket;
use Fcntl;
use Tie::RefHash;
use DBI;


$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)=split(/&/,$userinput);
	    my $query=unescape($querytmp);

            #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";
	    }
            &reply("queryreply:$queryid:$result",$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;
}
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<html><head>
<title>500 Internal Server Error</title>
</head><body>
<h1>Internal Server Error</h1>
<p>The server encountered an internal error or
misconfiguration and was unable to complete
your request.</p>
<p>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.</p>
<p>More information about this error may be available
in the server error log.</p>
</body></html>