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.50 2002/07/05 15:07:59 matthew 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:
193: # ------------------------------------------------------------------ Course log
194:
195: sub courselog {
196: my ($path,$command)=@_;
197: my %filters=();
198: foreach (split(/\:/,&unescape($command))) {
199: my ($name,$value)=split(/\=/,$_);
200: $filters{$name}=$value;
201: }
202: my @results=();
203: open(IN,$path.'/activity.log') or return ('file_error');
204: while ($line=<IN>) {
205: chomp($line);
206: my ($timestamp,$host,$log)=split(/\:/,$line);
207: #
208: # $log has the actual log entries; currently still escaped, and
209: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
210: # then additionally
211: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
212: # or
213: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
214: #
215: # get delimiter between timestamped entries to be &&&
216: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
217: # now go over all log entries
218: foreach (split(/\&\&\&/,&unescape($log))) {
219: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
220: my $values=&unescape(join(':',@values));
221: $values=~s/\&/\:/g;
222: $res=&unescape($res);
223: my $include=1;
224: if (($filters{'username'}) && ($uname ne $filters{'username'}))
225: { $include=0; }
226: if (($filters{'domain'}) && ($udom ne $filters{'domain'}))
227: { $include=0; }
228: if (($filters{'url'}) && ($res!~/$filters{'url'}/))
229: { $include=0; }
230: if (($filters{'start'}) && ($time<$filters{'start'}))
231: { $include=0; }
232: if (($filters{'end'}) && ($time>$filters{'end'}))
233: { $include=0; }
234: if (($filters{'action'} eq 'view') && ($action))
235: { $include=0; }
236: if (($filters{'action'} eq 'submit') && ($action ne 'POST'))
237: { $include=0; }
238: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE'))
239: { $include=0; }
240: if ($include) {
241: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
242: $uname.':'.$udom.':'.
243: $action.':'.$values);
244: }
245: }
246: }
247: close IN;
248: return join('&',sort(@results));
249: }
250:
251: # -------------------------------------------------------------------- User log
252:
253: sub userlog {
254: my ($path,$command)=@_;
255: my %filters=();
256: foreach (split(/\:/,&unescape($command))) {
257: my ($name,$value)=split(/\=/,$_);
258: $filters{$name}=$value;
259: }
260: my @results=();
261: open(IN,$path.'/activity.log') or return ('file_error');
262: while ($line=<IN>) {
263: chomp($line);
264: my ($timestamp,$host,$log)=split(/\:/,$line);
265: $log=&unescape($log);
266: my $include=1;
267: if (($filters{'start'}) && ($timestamp<$filters{'start'}))
268: { $include=0; }
269: if (($filters{'end'}) && ($timestamp>$filters{'end'}))
270: { $include=0; }
271: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
272: if (($filters{'action'} eq 'check') && ($log!~/^Check/))
273: { $include=0; }
274: if ($include) {
275: push(@results,$timestamp.':'.$log);
276: }
277: }
278: close IN;
279: return join('&',sort(@results));
280: }
281:
282:
283: # ---------------------------------------------------- Fork once and dissociate
284: $fpid=fork;
285: exit if $fpid;
286: die "Couldn't fork: $!" unless defined ($fpid);
287:
288: POSIX::setsid() or die "Can't start new session: $!";
289:
290: # ------------------------------------------------------- Write our PID on disk
291:
292: $execdir=$perlvar{'lonDaemons'};
293: open (PIDSAVE,">$execdir/logs/lonsql.pid");
294: print PIDSAVE "$$\n";
295: close(PIDSAVE);
296: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
297:
298: # ----------------------------- Ignore signals generated during initial startup
299: $SIG{HUP}=$SIG{USR1}='IGNORE';
300: # ------------------------------------------------------- Now we are on our own
301: # Fork off our children.
302: for (1 .. $PREFORK) {
303: make_new_child();
304: }
305:
306: # Install signal handlers.
307: $SIG{CHLD} = \&REAPER;
308: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
309: $SIG{HUP} = \&HUPSMAN;
310:
311: # And maintain the population.
312: while (1) {
313: sleep; # wait for a signal (i.e., child's death)
314: for ($i = $children; $i < $PREFORK; $i++) {
315: make_new_child(); # top up the child pool
316: }
317: }
318:
319:
320: sub make_new_child {
321: my $pid;
322: my $sigset;
323:
324: # block signal for fork
325: $sigset = POSIX::SigSet->new(SIGINT);
326: sigprocmask(SIG_BLOCK, $sigset)
327: or die "Can't block SIGINT for fork: $!\n";
328:
329: die "fork: $!" unless defined ($pid = fork);
330:
331: if ($pid) {
332: # Parent records the child's birth and returns.
333: sigprocmask(SIG_UNBLOCK, $sigset)
334: or die "Can't unblock SIGINT for fork: $!\n";
335: $children{$pid} = 1;
336: $children++;
337: return;
338: } else {
339: # Child can *not* return from this subroutine.
340: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
341:
342: # unblock signals
343: sigprocmask(SIG_UNBLOCK, $sigset)
344: or die "Can't unblock SIGINT for fork: $!\n";
345:
346:
347: #open database handle
348: # making dbh global to avoid garbage collector
349: unless (
350: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
351: ) {
352: sleep(10+int(rand(20)));
353: &logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>");
354: print "database handle error\n";
355: exit;
356:
357: };
358: # make sure that a database disconnection occurs with ending kill signals
359: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
360:
361: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
362: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
363: $client = $server->accept() or last;
364:
365: # do something with the connection
366: $run = $run+1;
367: my $userinput = <$client>;
368: chomp($userinput);
369:
370: my ($conserver,$query,
371: $arg1,$arg2,$arg3)=split(/&/,$userinput);
372: my $query=unescape($query);
373:
374: #send query id which is pid_unixdatetime_runningcounter
375: $queryid = $thisserver;
376: $queryid .="_".($$)."_";
377: $queryid .= time."_";
378: $queryid .= $run;
379: print $client "$queryid\n";
380:
381: &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
382: sleep 1;
383:
384: my $result='';
385:
386: # ---------- At this point, query is received, query-ID assigned and sent back
387: # $query eq 'logquery' will mean that this is a query against log-files
388:
389:
390: if (($query eq 'userlog') || ($query eq 'courselog')) {
391: # ----------------------------------------------------- beginning of log query
392: #
393: # this goes against a user's log file
394: #
395: my $udom=&unescape($arg1);
396: my $uname=&unescape($arg2);
397: my $command=&unescape($arg3);
398: my $path=&propath($udom,$uname);
399: if (-e "$path/activity.log") {
400: if ($query eq 'userlog') {
401: $result=&userlog($path,$command);
402: } else {
403: $result=&courselog($path,$command);
404: }
405: } else {
406: &logthis('Unable to do log query: '.$uname.'@'.$udom);
407: $result='no_such_file';
408: }
409: # ------------------------------------------------------------ end of log query
410: } else {
411: # -------------------------------------------------------- This is an sql query
412: my $custom=unescape($arg1);
413: my $customshow=unescape($arg2);
414: #prepare and execute the query
415: my $sth = $dbh->prepare($query);
416:
417: my @files;
418: my $subsetflag=0;
419: if ($query) {
420: unless ($sth->execute())
421: {
422: &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
423: $result="";
424: }
425: else {
426: my $r1=$sth->fetchall_arrayref;
427: my @r2;
428: foreach (@$r1) {my $a=$_;
429: my @b=map {escape($_)} @$a;
430: push @files,@{$a}[3];
431: push @r2,join(",", @b)
432: }
433: $result=join("&",@r2);
434: }
435: }
436: # do custom metadata searching here and build into result
437: if ($custom or $customshow) {
438: &logthis("am going to do custom query for $custom");
439: if ($query) {
440: @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
441: }
442: else {
443: @metalist=(); pop @metalist;
444: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
445: my @homeusers=grep
446: {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
447: grep {!/^\.\.?$/} readdir(RESOURCES);
448: closedir RESOURCES;
449: foreach my $user (@homeusers) {
450: &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
451: }
452: }
453: # &logthis("FILELIST:" . join(":::",@metalist));
454: # if file is indicated in sql database and
455: # not part of sql-relevant query, do not pattern match.
456: # if file is not in sql database, output error.
457: # if file is indicated in sql database and is
458: # part of query result list, then do the pattern match.
459: my $customresult='';
460: my @r2;
461: foreach my $m (@metalist) {
462: my $fh=IO::File->new($m);
463: my @lines=<$fh>;
464: my $stuff=join('',@lines);
465: if ($stuff=~/$custom/s) {
466: foreach my $f ('abstract','author','copyright',
467: 'creationdate','keywords','language',
468: 'lastrevisiondate','mime','notes',
469: 'owner','subject','title') {
470: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
471: }
472: my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
473: $m2=~s/^$docroot//;
474: $m2=~s/\.meta$//;
475: unless ($query) {
476: my $q2="select * from metadata where url like binary '$m2'";
477: my $sth = $dbh->prepare($q2);
478: $sth->execute();
479: my $r1=$sth->fetchall_arrayref;
480: foreach (@$r1) {my $a=$_;
481: my @b=map {escape($_)} @$a;
482: push @files,@{$a}[3];
483: push @r2,join(",", @b)
484: }
485: }
486: # &logthis("found: $stuff");
487: $customresult.='&custom='.escape($m2).','.escape($stuff);
488: }
489: }
490: $result=join("&",@r2) unless $query;
491: $result.=$customresult;
492: }
493: # ------------------------------------------------------------ end of sql query
494: }
495:
496: # result does not need to be escaped because it has already been
497: # escaped.
498: #$result=&escape($result);
499:
500: # reply with result, append \n unless already there
501:
502: $result.="\n" unless ($result=~/\n$/);
503: &reply("queryreply:$queryid:$result",$conserver);
504:
505: }
506:
507: # tidy up gracefully and finish
508:
509: #close the database handle
510: $dbh->disconnect
511: or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
512:
513: # this exit is VERY important, otherwise the child will become
514: # a producer of more and more children, forking yourself into
515: # process death.
516: exit;
517: }
518: }
519:
520: sub DISCONNECT {
521: $dbh->disconnect or
522: &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
523: exit;
524: }
525:
526: # -------------------------------------------------- Non-critical communication
527:
528: sub subreply {
529: my ($cmd,$server)=@_;
530: my $peerfile="$perlvar{'lonSockDir'}/$server";
531: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
532: Type => SOCK_STREAM,
533: Timeout => 10)
534: or return "con_lost";
535: print $sclient "$cmd\n";
536: my $answer=<$sclient>;
537: chomp($answer);
538: if (!$answer) { $answer="con_lost"; }
539: return $answer;
540: }
541:
542: sub reply {
543: my ($cmd,$server)=@_;
544: my $answer;
545: if ($server ne $perlvar{'lonHostID'}) {
546: $answer=subreply($cmd,$server);
547: if ($answer eq 'con_lost') {
548: $answer=subreply("ping",$server);
549: $answer=subreply($cmd,$server);
550: }
551: } else {
552: $answer='self_reply';
553: $answer=subreply($cmd,$server);
554: }
555: return $answer;
556: }
557:
558: # -------------------------------------------------------- Escape Special Chars
559:
560: sub escape {
561: my $str=shift;
562: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
563: return $str;
564: }
565:
566: # ----------------------------------------------------- Un-Escape Special Chars
567:
568: sub unescape {
569: my $str=shift;
570: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
571: return $str;
572: }
573:
574: # --------------------------------------- Is this the home server of an author?
575: # (copied from lond, modification of the return value)
576: sub ishome {
577: my $author=shift;
578: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
579: my ($udom,$uname)=split(/\//,$author);
580: my $proname=propath($udom,$uname);
581: if (-e $proname) {
582: return 1;
583: } else {
584: return 0;
585: }
586: }
587:
588: # -------------------------------------------- Return path to profile directory
589: # (copied from lond)
590: sub propath {
591: my ($udom,$uname)=@_;
592: $udom=~s/\W//g;
593: $uname=~s/\W//g;
594: my $subdir=$uname.'__';
595: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
596: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
597: return $proname;
598: }
599:
600: # ----------------------------------- POD (plain old documentation, CPAN style)
601:
602: =head1 NAME
603:
604: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
605:
606: =head1 SYNOPSIS
607:
608: This script should be run as user=www. The following is an example invocation
609: from the loncron script. Note that a lonsql.pid file contains the pid of
610: the parent process.
611:
612: if (-e $lonsqlfile) {
613: my $lfh=IO::File->new("$lonsqlfile");
614: my $lonsqlpid=<$lfh>;
615: chomp($lonsqlpid);
616: if (kill 0 => $lonsqlpid) {
617: print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>";
618: $restartflag=0;
619: } else {
620: $errors++; $errors++;
621: print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>";
622: $restartflag=1;
623: print $fh
624: "<h3>Decided to clean up stale .pid file and restart lonsql</h3>";
625: }
626: }
627: if ($restartflag==1) {
628: $errors++;
629: print $fh '<br><font color="red">Killall lonsql: '.
630: system('killall lonsql').' - ';
631: sleep 60;
632: print $fh unlink($lonsqlfile).' - '.
633: system('killall -9 lonsql').
634: '</font><br>';
635: print $fh "<h3>lonsql not running, trying to start</h3>";
636: system(
637: "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors");
638: sleep 10;
639:
640: =head1 DESCRIPTION
641:
642: Not yet written.
643:
644: =head1 README
645:
646: Not yet written.
647:
648: =head1 PREREQUISITES
649:
650: IO::Socket
651: Symbol
652: POSIX
653: IO::Select
654: IO::File
655: Socket
656: Fcntl
657: Tie::RefHash
658: DBI
659:
660: =head1 COREQUISITES
661:
662: =head1 OSNAMES
663:
664: linux
665:
666: =head1 SCRIPT CATEGORIES
667:
668: Server/Process
669:
670: =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