Annotation of nsdl/lonsql, revision 1.11
1.1 www 1: #!/usr/bin/perl
2:
3: # The LearningOnline Network
1.11 ! www 4: # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
1.1 www 5: #
1.11 ! www 6: # $Id: lonsql,v 1.77 2006/05/11 17:53:22 albertel Exp $
1.1 www 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:
31: =pod
32:
33: =head1 NAME
34:
35: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
36:
37: =head1 SYNOPSIS
38:
39: This script should be run as user=www.
40: Note that a lonsql.pid file contains the pid of the parent process.
41:
42: =head1 OVERVIEW
43:
44: =head2 Purpose within LON-CAPA
45:
46: LON-CAPA is meant to distribute A LOT of educational content to A LOT
47: of people. It is ineffective to directly rely on contents within the
48: ext2 filesystem to be speedily scanned for on-the-fly searches of
49: content descriptions. (Simply put, it takes a cumbersome amount of
50: time to open, read, analyze, and close thousands of files.)
51:
52: The solution is to index various data fields that are descriptive of
53: the educational resources on a LON-CAPA server machine in a
54: database. Descriptive data fields are referred to as "metadata". The
55: question then arises as to how this metadata is handled in terms of
56: the rest of the LON-CAPA network without burdening client and daemon
57: processes.
58:
59: The obvious solution, using lonc to send a query to a lond process,
60: doesn't work so well in general as you can see in the following
61: example:
62:
63: lonc= loncapa client process A-lonc= a lonc process on Server A
64: lond= loncapa daemon process
65:
66: database command
67: A-lonc --------TCP/IP----------------> B-lond
68:
69: The problem emerges that A-lonc and B-lond are kept waiting for the
70: MySQL server to "do its stuff", or in other words, perform the
71: conceivably sophisticated, data-intensive, time-sucking database
72: transaction. By tying up a lonc and lond process, this significantly
73: cripples the capabilities of LON-CAPA servers.
74:
75: The solution is to offload the work onto another process, and use
76: lonc and lond just for requests and notifications of completed
77: processing:
78:
79: database command
80:
81: A-lonc ---------TCP/IP-----------------> B-lond =====> B-lonsql
82: <---------------------------------/ |
83: "ok, I'll get back to you..." |
84: |
85: /
86: A-lond <------------------------------- B-lonc <======
87: "Guess what? I have the result!"
88:
89: Of course, depending on success or failure, the messages may vary, but
90: the principle remains the same where a separate pool of children
91: processes (lonsql's) handle the MySQL database manipulations.
92:
93: Thus, lonc and lond spend effectively no time waiting on results from
94: the database.
95:
96: =head1 Internals
97:
98: =over 4
99:
100: =cut
101:
102: use strict;
103:
104: use lib '/home/httpd/lib/perl/';
1.11 ! www 105: use LONCAPA;
1.1 www 106: use LONCAPA::Configuration;
107: use LONCAPA::lonmetadata();
108:
109: use IO::Socket;
110: use Symbol;
111: use POSIX;
112: use IO::Select;
113: use IO::File;
114: use Socket;
115: use Fcntl;
116: use Tie::RefHash;
1.11 ! www 117: use DBI;
1.1 www 118: use File::Find;
119: use localenroll;
120:
1.11 ! www 121: # FOR NSDL
! 122:
! 123: use HTML::LCParser();
! 124: use LWP::UserAgent();
! 125: use HTTP::Headers;
! 126: use HTTP::Date;
! 127:
! 128: ########################################################
! 129: ########################################################
! 130:
! 131: =pod
! 132:
! 133: =item Global Variables
! 134:
! 135: =over 4
! 136:
! 137: =item dbh
! 138:
! 139: =back
! 140:
! 141: =cut
! 142:
! 143: ########################################################
! 144: ########################################################
! 145: my $dbh;
! 146:
1.1 www 147: ########################################################
148: ########################################################
149:
150: =pod
151:
152: =item Variables required for forking
153:
154: =over 4
155:
156: =item $MAX_CLIENTS_PER_CHILD
157:
158: The number of clients each child should process.
159:
160: =item %children
161:
162: The keys to %children are the current child process IDs
163:
164: =item $children
165:
166: The current number of children
167:
168: =back
169:
170: =cut
171:
172: ########################################################
173: ########################################################
174: my $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
175: my %children = (); # keys are current child process IDs
176: my $children = 0; # current number of children
177:
178: ###################################################################
179: ###################################################################
180:
181: =pod
182:
183: =item Main body of code.
184:
185: =over 4
186:
187: =item Read data from loncapa_apache.conf and loncapa.conf.
188:
189: =item Ensure we can access the database.
190:
191: =item Determine if there are other instances of lonsql running.
192:
193: =item Read the hosts file.
194:
195: =item Create a socket for lonsql.
196:
197: =item Fork once and dissociate from parent.
198:
199: =item Write PID to disk.
200:
201: =item Prefork children and maintain the population of children.
202:
203: =back
204:
205: =cut
206:
207: ###################################################################
208: ###################################################################
209: my $childmaxattempts=10;
210: my $run =0; # running counter to generate the query-id
211: #
212: # Read loncapa_apache.conf and loncapa.conf
213: #
214: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
215: my %perlvar=%{$perlvarref};
216: #
217: # Write the /home/www/.my.cnf file
218: my $conf_file = '/home/www/.my.cnf';
219: if (! -e $conf_file) {
220: if (open MYCNF, ">$conf_file") {
221: print MYCNF <<"ENDMYCNF";
222: [client]
223: user=www
224: password=$perlvar{'lonSqlAccess'}
225: ENDMYCNF
226: close MYCNF;
227: } else {
228: warn "Unable to write $conf_file, continuing";
229: }
230: }
231:
232:
233: #
1.11 ! www 234: # Make sure that database can be accessed
! 235: #
! 236: my $dbh;
! 237: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
! 238: $perlvar{'lonSqlAccess'},
! 239: { RaiseError =>0,PrintError=>0})) {
! 240: print "Cannot connect to database!\n";
! 241: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
! 242: my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
! 243: system("echo 'Cannot connect to MySQL database!' |".
! 244: " mailto $emailto -s '$subj' > /dev/null");
! 245:
! 246: open(SMP,'>/home/httpd/html/lon-status/mysql.txt');
! 247: print SMP 'time='.time.'&mysql=defunct'."\n";
! 248: close(SMP);
! 249:
! 250: exit 1;
! 251: } else {
! 252: unlink('/home/httpd/html/lon-status/mysql.txt');
! 253: $dbh->disconnect;
! 254: }
! 255:
! 256: #
1.1 www 257: # Check if other instance running
258: #
259: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
260: if (-e $pidfile) {
261: my $lfh=IO::File->new("$pidfile");
262: my $pide=<$lfh>;
263: chomp($pide);
264: if (kill 0 => $pide) { die "already running"; }
265: }
266:
267: #
268: # Read hosts file
269: #
270: my $thisserver;
1.11 ! www 271: my %hostname;
1.1 www 272: my $PREFORK=4; # number of children to maintain, at least four spare
273: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
274: while (my $configline=<CONFIG>) {
275: my ($id,$domain,$role,$name)=split(/:/,$configline);
276: $name=~s/\s//g;
277: $thisserver=$name if ($id eq $perlvar{'lonHostID'});
1.11 ! www 278: $hostname{$id}=$name;
1.1 www 279: #$PREFORK++;
280: }
281: close(CONFIG);
282: #
283: #$PREFORK=int($PREFORK/4);
284:
285: #
286: # Create a socket to talk to lond
287: #
288: my $unixsock = "mysqlsock";
289: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
290: my $server;
291: unlink ($localfile);
292: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
293: Type => SOCK_STREAM,
294: Listen => 10)) {
295: print "in socket error:$@\n";
296: }
297:
298: #
299: # Fork once and dissociate
300: #
301: my $fpid=fork;
302: exit if $fpid;
303: die "Couldn't fork: $!" unless defined ($fpid);
304: POSIX::setsid() or die "Can't start new session: $!";
305:
306: #
307: # Write our PID on disk
308: my $execdir=$perlvar{'lonDaemons'};
309: open (PIDSAVE,">$execdir/logs/lonsql.pid");
310: print PIDSAVE "$$\n";
311: close(PIDSAVE);
312: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
313:
314: #
315: # Ignore signals generated during initial startup
316: $SIG{HUP}=$SIG{USR1}='IGNORE';
317: # Now we are on our own
318: # Fork off our children.
319: for (1 .. $PREFORK) {
320: make_new_child();
321: }
322:
323: #
324: # Install signal handlers.
325: $SIG{CHLD} = \&REAPER;
326: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
327: $SIG{HUP} = \&HUPSMAN;
328:
329: #
330: # And maintain the population.
331: while (1) {
332: sleep; # wait for a signal (i.e., child's death)
333: for (my $i = $children; $i < $PREFORK; $i++) {
334: make_new_child(); # top up the child pool
335: }
336: }
337:
338: ########################################################
339: ########################################################
340:
341: =pod
342:
343: =item &make_new_child
344:
345: Inputs: None
346:
347: Returns: None
348:
349: =cut
350:
351: ########################################################
352: ########################################################
353: sub make_new_child {
354: my $pid;
355: my $sigset;
356: #
357: # block signal for fork
358: $sigset = POSIX::SigSet->new(SIGINT);
359: sigprocmask(SIG_BLOCK, $sigset)
360: or die "Can't block SIGINT for fork: $!\n";
361: #
362: die "fork: $!" unless defined ($pid = fork);
363: #
364: if ($pid) {
365: # Parent records the child's birth and returns.
366: sigprocmask(SIG_UNBLOCK, $sigset)
367: or die "Can't unblock SIGINT for fork: $!\n";
368: $children{$pid} = 1;
369: $children++;
370: return;
371: } else {
372: # Child can *not* return from this subroutine.
373: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
374: # unblock signals
375: sigprocmask(SIG_UNBLOCK, $sigset)
376: or die "Can't unblock SIGINT for fork: $!\n";
1.11 ! www 377: #open database handle
! 378: # making dbh global to avoid garbage collector
! 379: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
! 380: $perlvar{'lonSqlAccess'},
! 381: { RaiseError =>0,PrintError=>0})) {
! 382: sleep(10+int(rand(20)));
! 383: &logthis("<font color='blue'>WARNING: Couldn't connect to database".
! 384: ": $@</font>");
! 385: # "($st secs): $@</font>");
! 386: print "database handle error\n";
! 387: exit;
! 388: }
! 389: # make sure that a database disconnection occurs with
! 390: # ending kill signals
1.1 www 391: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
392: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
393: for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
394: my $client = $server->accept() or last;
395: # do something with the connection
396: $run = $run+1;
397: my $userinput = <$client>;
398: chomp($userinput);
1.11 ! www 399: $userinput=~s/\:(\w+)$//;
! 400: my $searchdomain=$1;
1.1 www 401: #
402: my ($conserver,$query,
403: $arg1,$arg2,$arg3)=split(/&/,$userinput);
404: my $query=unescape($query);
405: #
406: #send query id which is pid_unixdatetime_runningcounter
407: my $queryid = $thisserver;
408: $queryid .="_".($$)."_";
409: $queryid .= time."_";
410: $queryid .= $run;
411: print $client "$queryid\n";
412: #
413: # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
414: sleep 1;
415: #
416: my $result='';
417: #
418: # At this point, query is received, query-ID assigned and sent
419: # back, $query eq 'logquery' will mean that this is a query
420: # against log-files
421: if (($query eq 'userlog') || ($query eq 'courselog')) {
422: # beginning of log query
423: my $udom = &unescape($arg1);
424: my $uname = &unescape($arg2);
425: my $command = &unescape($arg3);
426: my $path = &propath($udom,$uname);
427: if (-e "$path/activity.log") {
428: if ($query eq 'userlog') {
429: $result=&userlog($path,$command);
430: } else {
431: $result=&courselog($path,$command);
432: }
433: } else {
434: &logthis('Unable to do log query: '.$uname.'@'.$udom);
435: $result='no_such_file';
436: }
437: # end of log query
1.11 ! www 438: } elsif (($query eq 'fetchenrollment') ||
! 439: ($query eq 'institutionalphotos')) {
1.1 www 440: # retrieve institutional class lists
441: my $dom = &unescape($arg1);
442: my %affiliates = ();
443: my %replies = ();
444: my $locresult = '';
445: my $querystr = &unescape($arg3);
446: foreach (split/%%/,$querystr) {
1.2 www 447: if (/^([^=]+)=([^=]+)$/) {
1.1 www 448: @{$affiliates{$1}} = split/,/,$2;
449: }
450: }
1.11 ! www 451: if ($query eq 'fetchenrollment') {
! 452: $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);
! 453: } elsif ($query eq 'institutionalphotos') {
! 454: my $crs = &unescape($arg2);
! 455: eval {
! 456: local($SIG{__DIE__})='DEFAULT';
! 457: $locresult = &localenroll::institutional_photos($dom,$crs,\%affiliates,\%replies,'update');
! 458: };
! 459: if ($@) {
! 460: $locresult = 'error';
! 461: }
! 462: }
1.1 www 463: $result = &escape($locresult.':');
464: if ($locresult) {
465: $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));
466: }
467: } elsif ($query eq 'prepare activity log') {
468: my ($cid,$domain) = map {&unescape($_);} ($arg1,$arg2);
469: &logthis('preparing activity log tables for '.$cid);
470: my $command =
471: qq{$perlvar{'lonDaemons'}/parse_activity_log.pl -course=$cid -domain=$domain};
472: system($command);
473: &logthis($command);
474: my $returnvalue = $?>>8;
475: if ($returnvalue) {
476: $result = 'error: parse_activity_log.pl returned '.
477: $returnvalue;
478: } else {
479: $result = 'success';
480: }
481: } else {
482: # Do an sql query
1.11 ! www 483: $result = &nsdl_query($query,$arg1,$arg2,$searchdomain);
1.1 www 484: }
485: # result does not need to be escaped because it has already been
486: # escaped.
487: #$result=&escape($result);
488: &reply("queryreply:$queryid:$result",$conserver);
489: }
490: # tidy up gracefully and finish
491: #
1.11 ! www 492: # close the database handle
! 493: $dbh->disconnect
! 494: or &logthis("<font color='blue'>WARNING: Couldn't disconnect".
! 495: " from database $DBI::errstr : $@</font>");
1.1 www 496: # this exit is VERY important, otherwise the child will become
497: # a producer of more and more children, forking yourself into
498: # process death.
499: exit;
500: }
501: }
1.11 ! www 502:
! 503:
! 504: ########################################################
! 505: ########################################################
! 506:
! 507: #
! 508: # Takes SQL query
! 509: # sends it to NSDL
! 510: #
! 511:
! 512: sub nsdl_query {
! 513: my $query=shift;
! 514: my ($keyword)=($query=~/\"\%([^\%]+)\%\"/);
! 515: $keyword=&escape($keyword);
! 516: my $url='http://search.nsdl.org?verb=Search&s=0&n=500&q=-link.primaryCollection:oai\:nsdl.org\:nsdl.nsdl\:00254%20'.$keyword;
! 517: my $ua=new LWP::UserAgent;
! 518: my $response=$ua->get($url);
! 519: my $parser=HTML::LCParser->new(\$response->content);
! 520: my $is='';
! 521: my $cont='';
! 522: my $token;
! 523: my %result=();
! 524: my $allresults='';
! 525: while ($token=$parser->get_token) {
! 526: if ($token->[0] eq 'T') {
! 527: $cont.=$token->[1];
! 528: } elsif ($token->[0] eq 'S') {
! 529: if ($token->[1] eq 'record') {
! 530: %result=();
! 531: } elsif ($token->[1]=~/^dc\:/) {
! 532: $is=$token->[1];
! 533: $cont='';
! 534: }
! 535: } elsif ($token->[0] eq 'E') {
! 536: if ($token->[1] eq 'record') {
! 537: #
! 538: # Now store it away
! 539: #
! 540: my $url=$result{'dc:identifier'};
! 541: if ($url=~/^http\:/) {
! 542: $url=~s/^http:\//\/ext/;
! 543: } else {
! 544: $url='';
! 545: }
! 546: if ($url) {
! 547: my ($mime)=($url=~/\.(\w+)$/);
! 548: $mime=~tr/A-Z/a-z/;
! 549: my $createdate=$result{'dc:date'};
! 550: if ($createdate) {
! 551: unless ($createdate=~/\:\d+$/) {
! 552: $createdate.=' 00:00:00';
! 553: }
! 554: }
! 555: unless ($createdate=~/^\d+\-\d+\-\d+\s+\d+\:\d+\:\d+$/) {
! 556: $createdate='';
! 557: }
! 558: $createdate=&escape($createdate);
! 559:
! 560: $allresults.='&'.
! 561: &escape($result{'dc:title'}).','.
! 562: &escape($result{'dc:creator'}).','.
! 563: &escape($result{'dc:subject'}).','.
! 564: &escape($url).',,,,'.
! 565: &escape($result{'dc:description'}).','.
! 566: &escape($mime).',seniso,'.$createdate.','.$createdate.','.&escape('public@nsdl').
! 567: ',public,nsdl,,,,,,,,,,,,,,,,,,,,,,,,,,,,';
! 568: }
! 569: %result=();
! 570: } elsif ($token->[1]=~/^dc\:/) {
! 571: $result{$is}=$cont;
! 572: }
! 573: }
! 574: }
! 575: $allresults=~s/^\&//;
! 576:
! 577: return $allresults;
! 578: }
! 579:
! 580:
! 581: ########################################################
1.1 www 582: ########################################################
583:
584: =pod
585:
586: =item &logthis
587:
588: Inputs: $message, the message to log
589:
590: Returns: nothing
591:
592: Writes $message to the logfile.
593:
594: =cut
595:
596: ########################################################
597: ########################################################
598: sub logthis {
599: my $message=shift;
600: my $execdir=$perlvar{'lonDaemons'};
601: my $fh=IO::File->new(">>$execdir/logs/lonsql.log");
602: my $now=time;
603: my $local=localtime($now);
604: print $fh "$local ($$): $message\n";
605: }
606:
607: # -------------------------------------------------- Non-critical communication
608:
609: ########################################################
610: ########################################################
611:
612: =pod
613:
614: =item &subreply
615:
616: Sends a command to a server. Called only by &reply.
617:
618: Inputs: $cmd,$server
619:
620: Returns: The results of the message or 'con_lost' on error.
621:
622: =cut
623:
624: ########################################################
625: ########################################################
626: sub subreply {
627: my ($cmd,$server)=@_;
1.11 ! www 628: my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
1.1 www 629: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
630: Type => SOCK_STREAM,
631: Timeout => 10)
632: or return "con_lost";
1.11 ! www 633: print $sclient "sethost:$server:$cmd\n";
1.1 www 634: my $answer=<$sclient>;
635: chomp($answer);
636: $answer="con_lost" if (!$answer);
637: return $answer;
638: }
639:
640: ########################################################
641: ########################################################
642:
643: =pod
644:
645: =item &reply
646:
647: Sends a command to a server.
648:
649: Inputs: $cmd,$server
650:
651: Returns: The results of the message or 'con_lost' on error.
652:
653: =cut
654:
655: ########################################################
656: ########################################################
657: sub reply {
658: my ($cmd,$server)=@_;
659: my $answer;
660: if ($server ne $perlvar{'lonHostID'}) {
661: $answer=subreply($cmd,$server);
662: if ($answer eq 'con_lost') {
663: $answer=subreply("ping",$server);
664: $answer=subreply($cmd,$server);
665: }
666: } else {
667: $answer='self_reply';
668: $answer=subreply($cmd,$server);
669: }
670: return $answer;
671: }
672:
673: ########################################################
674: ########################################################
675:
676: =pod
677:
678: =item &ishome
679:
680: Determine if the current machine is the home server for a user.
681: The determination is made by checking the filesystem for the users information.
682:
683: Inputs: $author
684:
685: Returns: 0 - this is not the authors home server, 1 - this is.
686:
687: =cut
688:
689: ########################################################
690: ########################################################
691: sub ishome {
692: my $author=shift;
693: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
694: my ($udom,$uname)=split(/\//,$author);
695: my $proname=propath($udom,$uname);
696: if (-e $proname) {
697: return 1;
698: } else {
699: return 0;
700: }
701: }
702:
703: ########################################################
704: ########################################################
705:
706: =pod
707:
708: =item &propath
709:
710: Inputs: user name, user domain
711:
712: Returns: The full path to the users directory.
713:
714: =cut
715:
716: ########################################################
717: ########################################################
718: sub propath {
719: my ($udom,$uname)=@_;
720: $udom=~s/\W//g;
721: $uname=~s/\W//g;
722: my $subdir=$uname.'__';
723: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
724: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
725: return $proname;
726: }
727:
728: ########################################################
729: ########################################################
730:
731: =pod
732:
733: =item &courselog
734:
735: Inputs: $path, $command
736:
737: Returns: unescaped string of values.
738:
739: =cut
740:
741: ########################################################
742: ########################################################
743: sub courselog {
744: my ($path,$command)=@_;
745: my %filters=();
746: foreach (split(/\:/,&unescape($command))) {
747: my ($name,$value)=split(/\=/,$_);
748: $filters{$name}=$value;
749: }
750: my @results=();
751: open(IN,$path.'/activity.log') or return ('file_error');
752: while (my $line=<IN>) {
753: chomp($line);
754: my ($timestamp,$host,$log)=split(/\:/,$line);
755: #
756: # $log has the actual log entries; currently still escaped, and
757: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
758: # then additionally
759: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
760: # or
761: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
762: #
763: # get delimiter between timestamped entries to be &&&
764: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
765: # now go over all log entries
766: foreach (split(/\&\&\&/,&unescape($log))) {
767: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
768: my $values=&unescape(join(':',@values));
769: $values=~s/\&/\:/g;
770: $res=&unescape($res);
771: my $include=1;
772: if (($filters{'username'}) && ($uname ne $filters{'username'}))
773: { $include=0; }
774: if (($filters{'domain'}) && ($udom ne $filters{'domain'}))
775: { $include=0; }
776: if (($filters{'url'}) && ($res!~/$filters{'url'}/))
777: { $include=0; }
778: if (($filters{'start'}) && ($time<$filters{'start'}))
779: { $include=0; }
780: if (($filters{'end'}) && ($time>$filters{'end'}))
781: { $include=0; }
782: if (($filters{'action'} eq 'view') && ($action))
783: { $include=0; }
784: if (($filters{'action'} eq 'submit') && ($action ne 'POST'))
785: { $include=0; }
786: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE'))
787: { $include=0; }
788: if ($include) {
789: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
790: $uname.':'.$udom.':'.
791: $action.':'.$values);
792: }
793: }
794: }
795: close IN;
796: return join('&',sort(@results));
797: }
798:
799: ########################################################
800: ########################################################
801:
802: =pod
803:
804: =item &userlog
805:
806: Inputs: $path, $command
807:
808: Returns: unescaped string of values.
809:
810: =cut
811:
812: ########################################################
813: ########################################################
814: sub userlog {
815: my ($path,$command)=@_;
816: my %filters=();
817: foreach (split(/\:/,&unescape($command))) {
818: my ($name,$value)=split(/\=/,$_);
819: $filters{$name}=$value;
820: }
821: my @results=();
822: open(IN,$path.'/activity.log') or return ('file_error');
823: while (my $line=<IN>) {
824: chomp($line);
825: my ($timestamp,$host,$log)=split(/\:/,$line);
826: $log=&unescape($log);
827: my $include=1;
828: if (($filters{'start'}) && ($timestamp<$filters{'start'}))
829: { $include=0; }
830: if (($filters{'end'}) && ($timestamp>$filters{'end'}))
831: { $include=0; }
832: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
833: if (($filters{'action'} eq 'check') && ($log!~/^Check/))
834: { $include=0; }
835: if ($include) {
836: push(@results,$timestamp.':'.$log);
837: }
838: }
839: close IN;
840: return join('&',sort(@results));
841: }
842:
843: ########################################################
844: ########################################################
845:
846: =pod
847:
848: =item Functions required for forking
849:
850: =over 4
851:
852: =item REAPER
853:
854: REAPER takes care of dead children.
855:
856: =item HUNTSMAN
857:
858: Signal handler for SIGINT.
859:
860: =item HUPSMAN
861:
862: Signal handler for SIGHUP
863:
864: =item DISCONNECT
865:
866: Disconnects from database.
867:
868: =back
869:
870: =cut
871:
872: ########################################################
873: ########################################################
874: sub REAPER { # takes care of dead children
875: $SIG{CHLD} = \&REAPER;
876: my $pid = wait;
877: $children --;
878: &logthis("Child $pid died");
879: delete $children{$pid};
880: }
881:
882: sub HUNTSMAN { # signal handler for SIGINT
883: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
884: kill 'INT' => keys %children;
885: my $execdir=$perlvar{'lonDaemons'};
886: unlink("$execdir/logs/lonsql.pid");
887: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
888: $unixsock = "mysqlsock";
889: my $port="$perlvar{'lonSockDir'}/$unixsock";
890: unlink($port);
891: exit; # clean up with dignity
892: }
893:
894: sub HUPSMAN { # signal handler for SIGHUP
895: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
896: kill 'INT' => keys %children;
897: close($server); # free up socket
898: &logthis("<font color='red'>CRITICAL: Restarting</font>");
899: my $execdir=$perlvar{'lonDaemons'};
900: $unixsock = "mysqlsock";
901: my $port="$perlvar{'lonSockDir'}/$unixsock";
902: unlink($port);
903: exec("$execdir/lonsql"); # here we go again
904: }
905:
1.11 ! www 906: sub DISCONNECT {
! 907: $dbh->disconnect or
! 908: &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".
! 909: " $DBI::errstr : $@</font>");
! 910: exit;
! 911: }
1.9 www 912:
1.1 www 913:
914: =pod
915:
916: =back
917:
918: =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] / nsdl