File:
[LON-CAPA] /
loncom /
lonsql
Revision
1.44:
download - view:
text,
annotated -
select for diffs
Mon Jun 17 14:00:09 2002 UTC (22 years, 3 months ago) by
www
Branches:
MAIN
CVS tags:
HEAD
Towards bug 121
If the query command is 'logquery' instead of an SQL command, lonsql will
go into another program block. Functionality to query logs should be
implemented there.
Also bugfix: a query-reply must ALWAYS have an "\n" in the end, or the
remote end will wait forever. Previous statement "append if $result" might
lead to lengthy timeout results if database is offline.
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.44 2002/06/17 14:00:09 www 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 config files 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 loncapa_apache.conf and loncapa.conf
84: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
85: 'loncapa.conf');
86: my %perlvar=%{$perlvarref};
87:
88: # ------------------------------------- Make sure that database can be accessed
89: {
90: my $dbh;
91: unless (
92: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
93: ) {
94: print "Cannot connect to database!\n";
95: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
96: $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
97: system("echo 'Cannot connect to MySQL database!' |\
98: mailto $emailto -s '$subj' > /dev/null");
99: exit 1;
100: }
101: else {
102: $dbh->disconnect;
103: }
104: }
105:
106: # --------------------------------------------- Check if other instance running
107:
108: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
109:
110: if (-e $pidfile) {
111: my $lfh=IO::File->new("$pidfile");
112: my $pide=<$lfh>;
113: chomp($pide);
114: if (kill 0 => $pide) { die "already running"; }
115: }
116:
117: # ------------------------------------------------------------- Read hosts file
118: $PREFORK=4; # number of children to maintain, at least four spare
119:
120: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
121:
122: while ($configline=<CONFIG>) {
123: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
124: chomp($ip);
125:
126: $hostip{$ip}=$id;
127: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
128:
129: $PREFORK++;
130: }
131: close(CONFIG);
132:
133: $PREFORK=int($PREFORK/4);
134:
135: $unixsock = "mysqlsock";
136: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
137: my $server;
138: unlink ($localfile);
139: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
140: Type => SOCK_STREAM,
141: Listen => 10))
142: {
143: print "in socket error:$@\n";
144: }
145:
146: # -------------------------------------------------------- Routines for forking
147: # global variables
148: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
149: %children = (); # keys are current child process IDs
150: $children = 0; # current number of children
151:
152: sub REAPER { # takes care of dead children
153: $SIG{CHLD} = \&REAPER;
154: my $pid = wait;
155: $children --;
156: &logthis("Child $pid died");
157: delete $children{$pid};
158: }
159:
160: sub HUNTSMAN { # signal handler for SIGINT
161: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
162: kill 'INT' => keys %children;
163: my $execdir=$perlvar{'lonDaemons'};
164: unlink("$execdir/logs/lonsql.pid");
165: &logthis("<font color=red>CRITICAL: Shutting down</font>");
166: $unixsock = "mysqlsock";
167: my $port="$perlvar{'lonSockDir'}/$unixsock";
168: unlink(port);
169: exit; # clean up with dignity
170: }
171:
172: sub HUPSMAN { # signal handler for SIGHUP
173: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
174: kill 'INT' => keys %children;
175: close($server); # free up socket
176: &logthis("<font color=red>CRITICAL: Restarting</font>");
177: my $execdir=$perlvar{'lonDaemons'};
178: $unixsock = "mysqlsock";
179: my $port="$perlvar{'lonSockDir'}/$unixsock";
180: unlink(port);
181: exec("$execdir/lonsql"); # here we go again
182: }
183:
184: sub logthis {
185: my $message=shift;
186: my $execdir=$perlvar{'lonDaemons'};
187: my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
188: my $now=time;
189: my $local=localtime($now);
190: print $fh "$local ($$): $message\n";
191: }
192: # ---------------------------------------------------- Fork once and dissociate
193: $fpid=fork;
194: exit if $fpid;
195: die "Couldn't fork: $!" unless defined ($fpid);
196:
197: POSIX::setsid() or die "Can't start new session: $!";
198:
199: # ------------------------------------------------------- Write our PID on disk
200:
201: $execdir=$perlvar{'lonDaemons'};
202: open (PIDSAVE,">$execdir/logs/lonsql.pid");
203: print PIDSAVE "$$\n";
204: close(PIDSAVE);
205: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
206:
207: # ----------------------------- Ignore signals generated during initial startup
208: $SIG{HUP}=$SIG{USR1}='IGNORE';
209: # ------------------------------------------------------- Now we are on our own
210: # Fork off our children.
211: for (1 .. $PREFORK) {
212: make_new_child();
213: }
214:
215: # Install signal handlers.
216: $SIG{CHLD} = \&REAPER;
217: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
218: $SIG{HUP} = \&HUPSMAN;
219:
220: # And maintain the population.
221: while (1) {
222: sleep; # wait for a signal (i.e., child's death)
223: for ($i = $children; $i < $PREFORK; $i++) {
224: make_new_child(); # top up the child pool
225: }
226: }
227:
228:
229: sub make_new_child {
230: my $pid;
231: my $sigset;
232:
233: # block signal for fork
234: $sigset = POSIX::SigSet->new(SIGINT);
235: sigprocmask(SIG_BLOCK, $sigset)
236: or die "Can't block SIGINT for fork: $!\n";
237:
238: die "fork: $!" unless defined ($pid = fork);
239:
240: if ($pid) {
241: # Parent records the child's birth and returns.
242: sigprocmask(SIG_UNBLOCK, $sigset)
243: or die "Can't unblock SIGINT for fork: $!\n";
244: $children{$pid} = 1;
245: $children++;
246: return;
247: } else {
248: # Child can *not* return from this subroutine.
249: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
250:
251: # unblock signals
252: sigprocmask(SIG_UNBLOCK, $sigset)
253: or die "Can't unblock SIGINT for fork: $!\n";
254:
255:
256: #open database handle
257: # making dbh global to avoid garbage collector
258: unless (
259: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
260: ) {
261: sleep(10+int(rand(20)));
262: &logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>");
263: print "database handle error\n";
264: exit;
265:
266: };
267: # make sure that a database disconnection occurs with ending kill signals
268: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
269:
270: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
271: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
272: $client = $server->accept() or last;
273:
274: # do something with the connection
275: $run = $run+1;
276: my $userinput = <$client>;
277: chomp($userinput);
278:
279: my ($conserver,$querytmp,
280: $customtmp,$customshowtmp)=split(/&/,$userinput);
281: my $query=unescape($querytmp);
282: my $custom=unescape($customtmp);
283: my $customshow=unescape($customshowtmp);
284:
285: #send query id which is pid_unixdatetime_runningcounter
286: $queryid = $thisserver;
287: $queryid .="_".($$)."_";
288: $queryid .= time."_";
289: $queryid .= $run;
290: print $client "$queryid\n";
291:
292: &logthis("QUERY: $query");
293: sleep 1;
294:
295: # ---------- At this point, query is received, query-ID assigned and sent back
296: # $query eq 'logquery' will mean that this is a query against log-files
297:
298: unless ($query eq 'logquery') {
299: # -------------------------------------------------------- This is an sql query
300: #prepare and execute the query
301: my $sth = $dbh->prepare($query);
302: my $result;
303: my @files;
304: my $subsetflag=0;
305: if ($query) {
306: unless ($sth->execute())
307: {
308: &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
309: $result="";
310: }
311: else {
312: my $r1=$sth->fetchall_arrayref;
313: my @r2;
314: foreach (@$r1) {my $a=$_;
315: my @b=map {escape($_)} @$a;
316: push @files,@{$a}[3];
317: push @r2,join(",", @b)
318: }
319: $result=join("&",@r2);
320: }
321: }
322: # do custom metadata searching here and build into result
323: if ($custom or $customshow) {
324: &logthis("am going to do custom query for $custom");
325: if ($query) {
326: @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
327: }
328: else {
329: @metalist=(); pop @metalist;
330: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
331: my @homeusers=grep
332: {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
333: grep {!/^\.\.?$/} readdir(RESOURCES);
334: closedir RESOURCES;
335: foreach my $user (@homeusers) {
336: &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
337: }
338: }
339: # &logthis("FILELIST:" . join(":::",@metalist));
340: # if file is indicated in sql database and
341: # not part of sql-relevant query, do not pattern match.
342: # if file is not in sql database, output error.
343: # if file is indicated in sql database and is
344: # part of query result list, then do the pattern match.
345: my $customresult='';
346: my @r2;
347: foreach my $m (@metalist) {
348: my $fh=IO::File->new($m);
349: my @lines=<$fh>;
350: my $stuff=join('',@lines);
351: if ($stuff=~/$custom/s) {
352: foreach my $f ('abstract','author','copyright',
353: 'creationdate','keywords','language',
354: 'lastrevisiondate','mime','notes',
355: 'owner','subject','title') {
356: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
357: }
358: my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
359: $m2=~s/^$docroot//;
360: $m2=~s/\.meta$//;
361: unless ($query) {
362: my $q2="select * from metadata where url like binary '$m2'";
363: my $sth = $dbh->prepare($q2);
364: $sth->execute();
365: my $r1=$sth->fetchall_arrayref;
366: foreach (@$r1) {my $a=$_;
367: my @b=map {escape($_)} @$a;
368: push @files,@{$a}[3];
369: push @r2,join(",", @b)
370: }
371: }
372: # &logthis("found: $stuff");
373: $customresult.='&custom='.escape($m2).','.escape($stuff);
374: }
375: }
376: $result=join("&",@r2) unless $query;
377: $result.=$customresult;
378: }
379: # ------------------------------------------------------------ end of sql query
380: } else {
381: # ------------------------------------------------------ beginning of log query
382: #
383: # do log queries here
384: #
385: $result='not_yet_implemented';
386: # ------------------------------------------------------------ end of log query
387: }
388: # reply with result, append \n unless already there
389: $result.="\n" unless ($result=~/\n$/);
390: &reply("queryreply:$queryid:$result",$conserver);
391:
392: }
393:
394: # tidy up gracefully and finish
395:
396: #close the database handle
397: $dbh->disconnect
398: or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
399:
400: # this exit is VERY important, otherwise the child will become
401: # a producer of more and more children, forking yourself into
402: # process death.
403: exit;
404: }
405: }
406:
407: sub DISCONNECT {
408: $dbh->disconnect or
409: &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
410: exit;
411: }
412:
413: # -------------------------------------------------- Non-critical communication
414:
415: sub subreply {
416: my ($cmd,$server)=@_;
417: my $peerfile="$perlvar{'lonSockDir'}/$server";
418: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
419: Type => SOCK_STREAM,
420: Timeout => 10)
421: or return "con_lost";
422: print $sclient "$cmd\n";
423: my $answer=<$sclient>;
424: chomp($answer);
425: if (!$answer) { $answer="con_lost"; }
426: return $answer;
427: }
428:
429: sub reply {
430: my ($cmd,$server)=@_;
431: my $answer;
432: if ($server ne $perlvar{'lonHostID'}) {
433: $answer=subreply($cmd,$server);
434: if ($answer eq 'con_lost') {
435: $answer=subreply("ping",$server);
436: $answer=subreply($cmd,$server);
437: }
438: } else {
439: $answer='self_reply';
440: $answer=subreply($cmd,$server);
441: }
442: return $answer;
443: }
444:
445: # -------------------------------------------------------- Escape Special Chars
446:
447: sub escape {
448: my $str=shift;
449: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
450: return $str;
451: }
452:
453: # ----------------------------------------------------- Un-Escape Special Chars
454:
455: sub unescape {
456: my $str=shift;
457: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
458: return $str;
459: }
460:
461: # --------------------------------------- Is this the home server of an author?
462: # (copied from lond, modification of the return value)
463: sub ishome {
464: my $author=shift;
465: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
466: my ($udom,$uname)=split(/\//,$author);
467: my $proname=propath($udom,$uname);
468: if (-e $proname) {
469: return 1;
470: } else {
471: return 0;
472: }
473: }
474:
475: # -------------------------------------------- Return path to profile directory
476: # (copied from lond)
477: sub propath {
478: my ($udom,$uname)=@_;
479: $udom=~s/\W//g;
480: $uname=~s/\W//g;
481: my $subdir=$uname.'__';
482: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
483: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
484: return $proname;
485: }
486:
487: # ----------------------------------- POD (plain old documentation, CPAN style)
488:
489: =head1 NAME
490:
491: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
492:
493: =head1 SYNOPSIS
494:
495: This script should be run as user=www. The following is an example invocation
496: from the loncron script. Note that a lonsql.pid file contains the pid of
497: the parent process.
498:
499: if (-e $lonsqlfile) {
500: my $lfh=IO::File->new("$lonsqlfile");
501: my $lonsqlpid=<$lfh>;
502: chomp($lonsqlpid);
503: if (kill 0 => $lonsqlpid) {
504: print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>";
505: $restartflag=0;
506: } else {
507: $errors++; $errors++;
508: print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>";
509: $restartflag=1;
510: print $fh
511: "<h3>Decided to clean up stale .pid file and restart lonsql</h3>";
512: }
513: }
514: if ($restartflag==1) {
515: $errors++;
516: print $fh '<br><font color="red">Killall lonsql: '.
517: system('killall lonsql').' - ';
518: sleep 60;
519: print $fh unlink($lonsqlfile).' - '.
520: system('killall -9 lonsql').
521: '</font><br>';
522: print $fh "<h3>lonsql not running, trying to start</h3>";
523: system(
524: "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors");
525: sleep 10;
526:
527: =head1 DESCRIPTION
528:
529: Not yet written.
530:
531: =head1 README
532:
533: Not yet written.
534:
535: =head1 PREREQUISITES
536:
537: IO::Socket
538: Symbol
539: POSIX
540: IO::Select
541: IO::File
542: Socket
543: Fcntl
544: Tie::RefHash
545: DBI
546:
547: =head1 COREQUISITES
548:
549: =head1 OSNAMES
550:
551: linux
552:
553: =head1 SCRIPT CATEGORIES
554:
555: Server/Process
556:
557: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>