Return to lonsql CVS log

Up to [LON-CAPA] / loncom

adding POD; removing void context map statements -Scott Harrison

#!/usr/bin/perl

# The LearningOnline Network
# lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
#
# $Id: lonsql,v 1.41 2001/12/20 17:43:05 harris41 Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (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
#
###

###############################################################################
##                                                                           ##
## ORGANIZATION OF THIS PERL SCRIPT                                          ##
## 1. Modules used                                                           ##
## 2. Enable find subroutine                                                 ##
## 3. Read httpd access.conf 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 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$/ && !/^.+\.\d+\.[^\.]+\.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);

# ------------------------------------- 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;
    }
}

# --------------------------------------------- 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);

$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
# 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",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
		) { 
  	            sleep(10+int(rand(20)));
		    &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
		    print "database handle error\n";
		    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,$customshowtmp)=split(/&/,$userinput);
	    my $query=unescape($querytmp);
	    my $custom=unescape($customtmp);
	    my $customshow=unescape($customshowtmp);

            #send query id which is pid_unixdatetime_runningcounter
	    $queryid = $thisserver;
	    $queryid .="_".($$)."_";
	    $queryid .= time."_";
	    $queryid .= $run;
	    print $client "$queryid\n";
	    
	    &logthis("QUERY: $query");
	    &logthis("QUERY: $query");
	    sleep 1;
            #prepare and execute the query
	    my $sth = $dbh->prepare($query);
	    my $result;
	    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;
	    }
	    # reply with result
	    $result.="\n" if $result;
            &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';
    $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