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