1: #!/usr/bin/perl
2:
3: # The LearningOnline Network
4: # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
5: #
6: # $Id: lonsql,v 1.42 2002/05/11 21:26:53 harris41 Exp $
7: #
8: # Copyright Michigan State University Board of Trustees
9: #
10: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
11: #
12: # LON-CAPA is free software; you can redistribute it and/or modify
13: # it under the terms of the GNU General Public License as published by
14: # the Free Software Foundation; either version 2 of the License, or
15: # (at your option) any later version.
16: #
17: # LON-CAPA is distributed in the hope that it will be useful,
18: # but WITHOUT ANY WARRANTY; without even the implied warranty of
19: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20: # GNU General Public License for more details.
21: #
22: # You should have received a copy of the GNU General Public License
23: # along with LON-CAPA; if not, write to the Free Software
24: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
25: #
26: # /home/httpd/html/adm/gpl.txt
27: #
28: # http://www.lon-capa.org/
29: #
30: # YEAR=2000
31: # lonsql-based on the preforker:harsha jagasia:date:5/10/00
32: # 7/25 Gerd Kortemeyer
33: # many different dates Scott Harrison
34: # YEAR=2001
35: # many different dates Scott Harrison
36: # 03/22/2001 Scott Harrison
37: # 8/30 Gerd Kortemeyer
38: # 10/17,11/28,11/29,12/20 Scott Harrison
39: # YEAR=2001
40: # 5/11 Scott Harrison
41: #
42: ###
43:
44: ###############################################################################
45: ## ##
46: ## ORGANIZATION OF THIS PERL SCRIPT ##
47: ## 1. Modules used ##
48: ## 2. Enable find subroutine ##
49: ## 3. Read httpd access.conf and get variables ##
50: ## 4. Make sure that database can be accessed ##
51: ## 5. Make sure this process is running from user=www ##
52: ## 6. Check if other instance is running ##
53: ## 7. POD (plain old documentation, CPAN style) ##
54: ## ##
55: ###############################################################################
56:
57: use lib '/home/httpd/lib/perl/';
58: use LONCAPA::Configuration;
59:
60: use IO::Socket;
61: use Symbol;
62: use POSIX;
63: use IO::Select;
64: use IO::File;
65: use Socket;
66: use Fcntl;
67: use Tie::RefHash;
68: use DBI;
69:
70: my @metalist;
71: # ----------------- Code to enable 'find' subroutine listing of the .meta files
72: require "find.pl";
73: sub wanted {
74: (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
75: -f _ &&
76: /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
77: push(@metalist,"$dir/$_");
78: }
79:
80: $childmaxattempts=10;
81: $run =0;#running counter to generate the query-id
82:
83: # ------------------------------------------- Read access.conf and loncapa.conf
84: my $perlvarref=LONCAPA::Configuration::read_conf('access.conf','loncapa.conf');
85: my %perlvar=%{$perlvarref};
86:
87: # ------------------------------------- Make sure that database can be accessed
88: {
89: my $dbh;
90: unless (
91: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
92: ) {
93: print "Cannot connect to database!\n";
94: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
95: $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
96: system("echo 'Cannot connect to MySQL database!' |\
97: mailto $emailto -s '$subj' > /dev/null");
98: exit 1;
99: }
100: else {
101: $dbh->disconnect;
102: }
103: }
104:
105: # --------------------------------------------- Check if other instance running
106:
107: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
108:
109: if (-e $pidfile) {
110: my $lfh=IO::File->new("$pidfile");
111: my $pide=<$lfh>;
112: chomp($pide);
113: if (kill 0 => $pide) { die "already running"; }
114: }
115:
116: # ------------------------------------------------------------- Read hosts file
117: $PREFORK=4; # number of children to maintain, at least four spare
118:
119: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
120:
121: while ($configline=<CONFIG>) {
122: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
123: chomp($ip);
124:
125: $hostip{$ip}=$id;
126: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
127:
128: $PREFORK++;
129: }
130: close(CONFIG);
131:
132: $PREFORK=int($PREFORK/4);
133:
134: $unixsock = "mysqlsock";
135: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
136: my $server;
137: unlink ($localfile);
138: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
139: Type => SOCK_STREAM,
140: Listen => 10))
141: {
142: print "in socket error:$@\n";
143: }
144:
145: # -------------------------------------------------------- Routines for forking
146: # global variables
147: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
148: %children = (); # keys are current child process IDs
149: $children = 0; # current number of children
150:
151: sub REAPER { # takes care of dead children
152: $SIG{CHLD} = \&REAPER;
153: my $pid = wait;
154: $children --;
155: &logthis("Child $pid died");
156: delete $children{$pid};
157: }
158:
159: sub HUNTSMAN { # signal handler for SIGINT
160: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
161: kill 'INT' => keys %children;
162: my $execdir=$perlvar{'lonDaemons'};
163: unlink("$execdir/logs/lonsql.pid");
164: &logthis("<font color=red>CRITICAL: Shutting down</font>");
165: $unixsock = "mysqlsock";
166: my $port="$perlvar{'lonSockDir'}/$unixsock";
167: unlink(port);
168: exit; # clean up with dignity
169: }
170:
171: sub HUPSMAN { # signal handler for SIGHUP
172: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
173: kill 'INT' => keys %children;
174: close($server); # free up socket
175: &logthis("<font color=red>CRITICAL: Restarting</font>");
176: my $execdir=$perlvar{'lonDaemons'};
177: $unixsock = "mysqlsock";
178: my $port="$perlvar{'lonSockDir'}/$unixsock";
179: unlink(port);
180: exec("$execdir/lonsql"); # here we go again
181: }
182:
183: sub logthis {
184: my $message=shift;
185: my $execdir=$perlvar{'lonDaemons'};
186: my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
187: my $now=time;
188: my $local=localtime($now);
189: print $fh "$local ($$): $message\n";
190: }
191: # ---------------------------------------------------- Fork once and dissociate
192: $fpid=fork;
193: exit if $fpid;
194: die "Couldn't fork: $!" unless defined ($fpid);
195:
196: POSIX::setsid() or die "Can't start new session: $!";
197:
198: # ------------------------------------------------------- Write our PID on disk
199:
200: $execdir=$perlvar{'lonDaemons'};
201: open (PIDSAVE,">$execdir/logs/lonsql.pid");
202: print PIDSAVE "$$\n";
203: close(PIDSAVE);
204: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
205:
206: # ----------------------------- Ignore signals generated during initial startup
207: $SIG{HUP}=$SIG{USR1}='IGNORE';
208: # ------------------------------------------------------- Now we are on our own
209: # Fork off our children.
210: for (1 .. $PREFORK) {
211: make_new_child();
212: }
213:
214: # Install signal handlers.
215: $SIG{CHLD} = \&REAPER;
216: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
217: $SIG{HUP} = \&HUPSMAN;
218:
219: # And maintain the population.
220: while (1) {
221: sleep; # wait for a signal (i.e., child's death)
222: for ($i = $children; $i < $PREFORK; $i++) {
223: make_new_child(); # top up the child pool
224: }
225: }
226:
227:
228: sub make_new_child {
229: my $pid;
230: my $sigset;
231:
232: # block signal for fork
233: $sigset = POSIX::SigSet->new(SIGINT);
234: sigprocmask(SIG_BLOCK, $sigset)
235: or die "Can't block SIGINT for fork: $!\n";
236:
237: die "fork: $!" unless defined ($pid = fork);
238:
239: if ($pid) {
240: # Parent records the child's birth and returns.
241: sigprocmask(SIG_UNBLOCK, $sigset)
242: or die "Can't unblock SIGINT for fork: $!\n";
243: $children{$pid} = 1;
244: $children++;
245: return;
246: } else {
247: # Child can *not* return from this subroutine.
248: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
249:
250: # unblock signals
251: sigprocmask(SIG_UNBLOCK, $sigset)
252: or die "Can't unblock SIGINT for fork: $!\n";
253:
254:
255: #open database handle
256: # making dbh global to avoid garbage collector
257: unless (
258: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
259: ) {
260: sleep(10+int(rand(20)));
261: &logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>");
262: print "database handle error\n";
263: exit;
264:
265: };
266: # make sure that a database disconnection occurs with ending kill signals
267: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
268:
269: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
270: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
271: $client = $server->accept() or last;
272:
273: # do something with the connection
274: $run = $run+1;
275: my $userinput = <$client>;
276: chomp($userinput);
277:
278: my ($conserver,$querytmp,
279: $customtmp,$customshowtmp)=split(/&/,$userinput);
280: my $query=unescape($querytmp);
281: my $custom=unescape($customtmp);
282: my $customshow=unescape($customshowtmp);
283:
284: #send query id which is pid_unixdatetime_runningcounter
285: $queryid = $thisserver;
286: $queryid .="_".($$)."_";
287: $queryid .= time."_";
288: $queryid .= $run;
289: print $client "$queryid\n";
290:
291: &logthis("QUERY: $query");
292: &logthis("QUERY: $query");
293: sleep 1;
294: #prepare and execute the query
295: my $sth = $dbh->prepare($query);
296: my $result;
297: my @files;
298: my $subsetflag=0;
299: if ($query) {
300: unless ($sth->execute())
301: {
302: &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
303: $result="";
304: }
305: else {
306: my $r1=$sth->fetchall_arrayref;
307: my @r2;
308: foreach (@$r1) {my $a=$_;
309: my @b=map {escape($_)} @$a;
310: push @files,@{$a}[3];
311: push @r2,join(",", @b)
312: }
313: $result=join("&",@r2);
314: }
315: }
316: # do custom metadata searching here and build into result
317: if ($custom or $customshow) {
318: &logthis("am going to do custom query for $custom");
319: if ($query) {
320: @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
321: }
322: else {
323: @metalist=(); pop @metalist;
324: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
325: my @homeusers=grep
326: {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
327: grep {!/^\.\.?$/} readdir(RESOURCES);
328: closedir RESOURCES;
329: foreach my $user (@homeusers) {
330: &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
331: }
332: }
333: # &logthis("FILELIST:" . join(":::",@metalist));
334: # if file is indicated in sql database and
335: # not part of sql-relevant query, do not pattern match.
336: # if file is not in sql database, output error.
337: # if file is indicated in sql database and is
338: # part of query result list, then do the pattern match.
339: my $customresult='';
340: my @r2;
341: foreach my $m (@metalist) {
342: my $fh=IO::File->new($m);
343: my @lines=<$fh>;
344: my $stuff=join('',@lines);
345: if ($stuff=~/$custom/s) {
346: foreach my $f ('abstract','author','copyright',
347: 'creationdate','keywords','language',
348: 'lastrevisiondate','mime','notes',
349: 'owner','subject','title') {
350: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
351: }
352: my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
353: $m2=~s/^$docroot//;
354: $m2=~s/\.meta$//;
355: unless ($query) {
356: my $q2="select * from metadata where url like binary '$m2'";
357: my $sth = $dbh->prepare($q2);
358: $sth->execute();
359: my $r1=$sth->fetchall_arrayref;
360: foreach (@$r1) {my $a=$_;
361: my @b=map {escape($_)} @$a;
362: push @files,@{$a}[3];
363: push @r2,join(",", @b)
364: }
365: }
366: # &logthis("found: $stuff");
367: $customresult.='&custom='.escape($m2).','.escape($stuff);
368: }
369: }
370: $result=join("&",@r2) unless $query;
371: $result.=$customresult;
372: }
373: # reply with result
374: $result.="\n" if $result;
375: &reply("queryreply:$queryid:$result",$conserver);
376:
377: }
378:
379: # tidy up gracefully and finish
380:
381: #close the database handle
382: $dbh->disconnect
383: or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
384:
385: # this exit is VERY important, otherwise the child will become
386: # a producer of more and more children, forking yourself into
387: # process death.
388: exit;
389: }
390: }
391:
392: sub DISCONNECT {
393: $dbh->disconnect or
394: &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
395: exit;
396: }
397:
398: # -------------------------------------------------- Non-critical communication
399:
400: sub subreply {
401: my ($cmd,$server)=@_;
402: my $peerfile="$perlvar{'lonSockDir'}/$server";
403: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
404: Type => SOCK_STREAM,
405: Timeout => 10)
406: or return "con_lost";
407: print $sclient "$cmd\n";
408: my $answer=<$sclient>;
409: chomp($answer);
410: if (!$answer) { $answer="con_lost"; }
411: return $answer;
412: }
413:
414: sub reply {
415: my ($cmd,$server)=@_;
416: my $answer;
417: if ($server ne $perlvar{'lonHostID'}) {
418: $answer=subreply($cmd,$server);
419: if ($answer eq 'con_lost') {
420: $answer=subreply("ping",$server);
421: $answer=subreply($cmd,$server);
422: }
423: } else {
424: $answer='self_reply';
425: $answer=subreply($cmd,$server);
426: }
427: return $answer;
428: }
429:
430: # -------------------------------------------------------- Escape Special Chars
431:
432: sub escape {
433: my $str=shift;
434: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
435: return $str;
436: }
437:
438: # ----------------------------------------------------- Un-Escape Special Chars
439:
440: sub unescape {
441: my $str=shift;
442: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
443: return $str;
444: }
445:
446: # --------------------------------------- Is this the home server of an author?
447: # (copied from lond, modification of the return value)
448: sub ishome {
449: my $author=shift;
450: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
451: my ($udom,$uname)=split(/\//,$author);
452: my $proname=propath($udom,$uname);
453: if (-e $proname) {
454: return 1;
455: } else {
456: return 0;
457: }
458: }
459:
460: # -------------------------------------------- Return path to profile directory
461: # (copied from lond)
462: sub propath {
463: my ($udom,$uname)=@_;
464: $udom=~s/\W//g;
465: $uname=~s/\W//g;
466: my $subdir=$uname.'__';
467: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
468: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
469: return $proname;
470: }
471:
472: # ----------------------------------- POD (plain old documentation, CPAN style)
473:
474: =head1 NAME
475:
476: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
477:
478: =head1 SYNOPSIS
479:
480: This script should be run as user=www. The following is an example invocation
481: from the loncron script. Note that a lonsql.pid file contains the pid of
482: the parent process.
483:
484: if (-e $lonsqlfile) {
485: my $lfh=IO::File->new("$lonsqlfile");
486: my $lonsqlpid=<$lfh>;
487: chomp($lonsqlpid);
488: if (kill 0 => $lonsqlpid) {
489: print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>";
490: $restartflag=0;
491: } else {
492: $errors++; $errors++;
493: print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>";
494: $restartflag=1;
495: print $fh
496: "<h3>Decided to clean up stale .pid file and restart lonsql</h3>";
497: }
498: }
499: if ($restartflag==1) {
500: $errors++;
501: print $fh '<br><font color="red">Killall lonsql: '.
502: system('killall lonsql').' - ';
503: sleep 60;
504: print $fh unlink($lonsqlfile).' - '.
505: system('killall -9 lonsql').
506: '</font><br>';
507: print $fh "<h3>lonsql not running, trying to start</h3>";
508: system(
509: "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors");
510: sleep 10;
511:
512: =head1 DESCRIPTION
513:
514: Not yet written.
515:
516: =head1 README
517:
518: Not yet written.
519:
520: =head1 PREREQUISITES
521:
522: IO::Socket
523: Symbol
524: POSIX
525: IO::Select
526: IO::File
527: Socket
528: Fcntl
529: Tie::RefHash
530: DBI
531:
532: =head1 COREQUISITES
533:
534: =head1 OSNAMES
535:
536: linux
537:
538: =head1 SCRIPT CATEGORIES
539:
540: Server/Process
541:
542: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonsql CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom