File:
[LON-CAPA] /
loncom /
lonsql
Revision
1.70:
download - view:
text,
annotated -
select for diffs
Tue Feb 7 05:08:27 2006 UTC (18 years, 7 months ago) by
raeburn
Branches:
MAIN
CVS tags:
HEAD
Add support for student photo import from an institutional repository. Availability of photos of registered students in a course controlled by course environment parameter: 'internal.studentphoto'. This may be configured to require initial acceptance of conditions of use by course owner. View classlist in ENRL, and Automated Enrollment Manager now includes option to display thumbnails of student photos. Nightly enrollment update can import student photos for students added to a course. Student photos can be updated via the Automated Enrollment Manager.
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.70 2006/02/07 05:08:27 raeburn 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:
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/';
105: use LONCAPA::Configuration;
106: use LONCAPA::lonmetadata();
107:
108: use IO::Socket;
109: use Symbol;
110: use POSIX;
111: use IO::Select;
112: use IO::File;
113: use Socket;
114: use Fcntl;
115: use Tie::RefHash;
116: use DBI;
117: use File::Find;
118: use localenroll;
119:
120: ########################################################
121: ########################################################
122:
123: =pod
124:
125: =item Global Variables
126:
127: =over 4
128:
129: =item dbh
130:
131: =back
132:
133: =cut
134:
135: ########################################################
136: ########################################################
137: my $dbh;
138:
139: ########################################################
140: ########################################################
141:
142: =pod
143:
144: =item Variables required for forking
145:
146: =over 4
147:
148: =item $MAX_CLIENTS_PER_CHILD
149:
150: The number of clients each child should process.
151:
152: =item %children
153:
154: The keys to %children are the current child process IDs
155:
156: =item $children
157:
158: The current number of children
159:
160: =back
161:
162: =cut
163:
164: ########################################################
165: ########################################################
166: my $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
167: my %children = (); # keys are current child process IDs
168: my $children = 0; # current number of children
169:
170: ###################################################################
171: ###################################################################
172:
173: =pod
174:
175: =item Main body of code.
176:
177: =over 4
178:
179: =item Read data from loncapa_apache.conf and loncapa.conf.
180:
181: =item Ensure we can access the database.
182:
183: =item Determine if there are other instances of lonsql running.
184:
185: =item Read the hosts file.
186:
187: =item Create a socket for lonsql.
188:
189: =item Fork once and dissociate from parent.
190:
191: =item Write PID to disk.
192:
193: =item Prefork children and maintain the population of children.
194:
195: =back
196:
197: =cut
198:
199: ###################################################################
200: ###################################################################
201: my $childmaxattempts=10;
202: my $run =0; # running counter to generate the query-id
203: #
204: # Read loncapa_apache.conf and loncapa.conf
205: #
206: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
207: my %perlvar=%{$perlvarref};
208: #
209: # Write the /home/www/.my.cnf file
210: my $conf_file = '/home/www/.my.cnf';
211: if (! -e $conf_file) {
212: if (open MYCNF, ">$conf_file") {
213: print MYCNF <<"ENDMYCNF";
214: [client]
215: user=www
216: password=$perlvar{'lonSqlAccess'}
217: ENDMYCNF
218: close MYCNF;
219: } else {
220: warn "Unable to write $conf_file, continuing";
221: }
222: }
223:
224:
225: #
226: # Make sure that database can be accessed
227: #
228: my $dbh;
229: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
230: $perlvar{'lonSqlAccess'},
231: { RaiseError =>0,PrintError=>0})) {
232: print "Cannot connect to database!\n";
233: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
234: my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
235: system("echo 'Cannot connect to MySQL database!' |".
236: " mailto $emailto -s '$subj' > /dev/null");
237:
238: open(SMP,'>/home/httpd/html/lon-status/mysql.txt');
239: print SMP 'time='.time.'&mysql=defunct'."\n";
240: close(SMP);
241:
242: exit 1;
243: } else {
244: unlink('/home/httpd/html/lon-status/mysql.txt');
245: $dbh->disconnect;
246: }
247:
248: #
249: # Check if other instance running
250: #
251: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
252: if (-e $pidfile) {
253: my $lfh=IO::File->new("$pidfile");
254: my $pide=<$lfh>;
255: chomp($pide);
256: if (kill 0 => $pide) { die "already running"; }
257: }
258:
259: #
260: # Read hosts file
261: #
262: my $thisserver;
263: my $PREFORK=4; # number of children to maintain, at least four spare
264: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
265: while (my $configline=<CONFIG>) {
266: my ($id,$domain,$role,$name)=split(/:/,$configline);
267: $name=~s/\s//g;
268: $thisserver=$name if ($id eq $perlvar{'lonHostID'});
269: #$PREFORK++;
270: }
271: close(CONFIG);
272: #
273: #$PREFORK=int($PREFORK/4);
274:
275: #
276: # Create a socket to talk to lond
277: #
278: my $unixsock = "mysqlsock";
279: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
280: my $server;
281: unlink ($localfile);
282: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
283: Type => SOCK_STREAM,
284: Listen => 10)) {
285: print "in socket error:$@\n";
286: }
287:
288: #
289: # Fork once and dissociate
290: #
291: my $fpid=fork;
292: exit if $fpid;
293: die "Couldn't fork: $!" unless defined ($fpid);
294: POSIX::setsid() or die "Can't start new session: $!";
295:
296: #
297: # Write our PID on disk
298: my $execdir=$perlvar{'lonDaemons'};
299: open (PIDSAVE,">$execdir/logs/lonsql.pid");
300: print PIDSAVE "$$\n";
301: close(PIDSAVE);
302: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
303:
304: #
305: # Ignore signals generated during initial startup
306: $SIG{HUP}=$SIG{USR1}='IGNORE';
307: # Now we are on our own
308: # Fork off our children.
309: for (1 .. $PREFORK) {
310: make_new_child();
311: }
312:
313: #
314: # Install signal handlers.
315: $SIG{CHLD} = \&REAPER;
316: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
317: $SIG{HUP} = \&HUPSMAN;
318:
319: #
320: # And maintain the population.
321: while (1) {
322: sleep; # wait for a signal (i.e., child's death)
323: for (my $i = $children; $i < $PREFORK; $i++) {
324: make_new_child(); # top up the child pool
325: }
326: }
327:
328: ########################################################
329: ########################################################
330:
331: =pod
332:
333: =item &make_new_child
334:
335: Inputs: None
336:
337: Returns: None
338:
339: =cut
340:
341: ########################################################
342: ########################################################
343: sub make_new_child {
344: my $pid;
345: my $sigset;
346: #
347: # block signal for fork
348: $sigset = POSIX::SigSet->new(SIGINT);
349: sigprocmask(SIG_BLOCK, $sigset)
350: or die "Can't block SIGINT for fork: $!\n";
351: #
352: die "fork: $!" unless defined ($pid = fork);
353: #
354: if ($pid) {
355: # Parent records the child's birth and returns.
356: sigprocmask(SIG_UNBLOCK, $sigset)
357: or die "Can't unblock SIGINT for fork: $!\n";
358: $children{$pid} = 1;
359: $children++;
360: return;
361: } else {
362: # Child can *not* return from this subroutine.
363: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
364: # unblock signals
365: sigprocmask(SIG_UNBLOCK, $sigset)
366: or die "Can't unblock SIGINT for fork: $!\n";
367: #open database handle
368: # making dbh global to avoid garbage collector
369: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
370: $perlvar{'lonSqlAccess'},
371: { RaiseError =>0,PrintError=>0})) {
372: sleep(10+int(rand(20)));
373: &logthis("<font color='blue'>WARNING: Couldn't connect to database".
374: ": $@</font>");
375: # "($st secs): $@</font>");
376: print "database handle error\n";
377: exit;
378: }
379: # make sure that a database disconnection occurs with
380: # ending kill signals
381: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
382: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
383: for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
384: my $client = $server->accept() or last;
385: # do something with the connection
386: $run = $run+1;
387: my $userinput = <$client>;
388: chomp($userinput);
389: #
390: my ($conserver,$query,
391: $arg1,$arg2,$arg3)=split(/&/,$userinput);
392: my $query=unescape($query);
393: #
394: #send query id which is pid_unixdatetime_runningcounter
395: my $queryid = $thisserver;
396: $queryid .="_".($$)."_";
397: $queryid .= time."_";
398: $queryid .= $run;
399: print $client "$queryid\n";
400: #
401: # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
402: sleep 1;
403: #
404: my $result='';
405: #
406: # At this point, query is received, query-ID assigned and sent
407: # back, $query eq 'logquery' will mean that this is a query
408: # against log-files
409: if (($query eq 'userlog') || ($query eq 'courselog')) {
410: # beginning of log query
411: my $udom = &unescape($arg1);
412: my $uname = &unescape($arg2);
413: my $command = &unescape($arg3);
414: my $path = &propath($udom,$uname);
415: if (-e "$path/activity.log") {
416: if ($query eq 'userlog') {
417: $result=&userlog($path,$command);
418: } else {
419: $result=&courselog($path,$command);
420: }
421: } else {
422: &logthis('Unable to do log query: '.$uname.'@'.$udom);
423: $result='no_such_file';
424: }
425: # end of log query
426: } elsif (($query eq 'fetchenrollment') ||
427: ($query eq 'institutionalphotos')) {
428: # retrieve institutional class lists
429: my $dom = &unescape($arg1);
430: my %affiliates = ();
431: my %replies = ();
432: my $locresult = '';
433: my $querystr = &unescape($arg3);
434: foreach (split/%%/,$querystr) {
435: if (/^([^=]+)=([^=]+)$/) {
436: @{$affiliates{$1}} = split/,/,$2;
437: }
438: }
439: if ($query eq 'fetchenrollment') {
440: $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);
441: } elsif ($query eq 'institutionalphotos') {
442: my $crs = &unescape($arg2);
443: $locresult = &localenroll::institutional_photos($dom,$crs,\%affiliates,\%replies,'update');
444: }
445: $result = &escape($locresult.':');
446: if ($locresult) {
447: $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));
448: }
449: } elsif ($query eq 'prepare activity log') {
450: my ($cid,$domain) = map {&unescape($_);} ($arg1,$arg2);
451: &logthis('preparing activity log tables for '.$cid);
452: my $command =
453: qq{$perlvar{'lonDaemons'}/parse_activity_log.pl -course=$cid -domain=$domain};
454: system($command);
455: &logthis($command);
456: my $returnvalue = $?>>8;
457: if ($returnvalue) {
458: $result = 'error: parse_activity_log.pl returned '.
459: $returnvalue;
460: } else {
461: $result = 'success';
462: }
463: } else {
464: # Do an sql query
465: $result = &do_sql_query($query,$arg1,$arg2);
466: }
467: # result does not need to be escaped because it has already been
468: # escaped.
469: #$result=&escape($result);
470: &reply("queryreply:$queryid:$result",$conserver);
471: }
472: # tidy up gracefully and finish
473: #
474: # close the database handle
475: $dbh->disconnect
476: or &logthis("<font color='blue'>WARNING: Couldn't disconnect".
477: " from database $DBI::errstr : $@</font>");
478: # this exit is VERY important, otherwise the child will become
479: # a producer of more and more children, forking yourself into
480: # process death.
481: exit;
482: }
483: }
484:
485: ########################################################
486: ########################################################
487:
488: =pod
489:
490: =item &do_sql_query
491:
492: Runs an sql metadata table query.
493:
494: Inputs: $query, $custom, $customshow
495:
496: Returns: A string containing escaped results.
497:
498: =cut
499:
500: ########################################################
501: ########################################################
502: {
503: my @metalist;
504:
505: sub process_file {
506: if ( -e $_ && # file exists
507: -f $_ && # and is a normal file
508: /\.meta$/ && # ends in meta
509: ! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version
510: ) {
511: push(@metalist,$File::Find::name);
512: }
513: }
514:
515: sub do_sql_query {
516: my ($query,$custom,$customshow) = @_;
517: # &logthis('doing query '.$query);
518: $custom = &unescape($custom);
519: $customshow = &unescape($customshow);
520: #
521: @metalist = ();
522: #
523: my $result = '';
524: my @results = ();
525: my @files;
526: my $subsetflag=0;
527: #
528: if ($query) {
529: #prepare and execute the query
530: my $sth = $dbh->prepare($query);
531: unless ($sth->execute()) {
532: &logthis('<font color="blue">'.
533: 'WARNING: Could not retrieve from database:'.
534: $sth->errstr().'</font>');
535: } else {
536: my $aref=$sth->fetchall_arrayref;
537: foreach my $row (@$aref) {
538: push @files,@{$row}[3] if ($custom or $customshow);
539: my @b=map { &escape($_); } @$row;
540: push @results,join(",", @b);
541: # Build up the @files array with the LON-CAPA urls
542: # of the resources.
543: }
544: }
545: }
546: # do custom metadata searching here and build into result
547: return join("&",@results) if (! ($custom or $customshow));
548: # Only get here if there is a custom query or custom show request
549: &logthis("Doing custom query for $custom");
550: if ($query) {
551: @metalist=map {
552: $perlvar{'lonDocRoot'}.$_.'.meta';
553: } @files;
554: } else {
555: my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";
556: @metalist=();
557: opendir(RESOURCES,$dir);
558: my @homeusers=grep {
559: &ishome($dir.'/'.$_);
560: } grep {!/^\.\.?$/} readdir(RESOURCES);
561: closedir RESOURCES;
562: # Define the
563: foreach my $user (@homeusers) {
564: find (\&process_file,$dir.'/'.$user);
565: }
566: }
567: # if file is indicated in sql database and
568: # not part of sql-relevant query, do not pattern match.
569: #
570: # if file is not in sql database, output error.
571: #
572: # if file is indicated in sql database and is
573: # part of query result list, then do the pattern match.
574: my $customresult='';
575: my @results;
576: foreach my $metafile (@metalist) {
577: my $fh=IO::File->new($metafile);
578: my @lines=<$fh>;
579: my $stuff=join('',@lines);
580: if ($stuff=~/$custom/s) {
581: foreach my $f ('abstract','author','copyright',
582: 'creationdate','keywords','language',
583: 'lastrevisiondate','mime','notes',
584: 'owner','subject','title') {
585: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
586: }
587: my $mfile=$metafile;
588: my $docroot=$perlvar{'lonDocRoot'};
589: $mfile=~s/^$docroot//;
590: $mfile=~s/\.meta$//;
591: unless ($query) {
592: my $q2="SELECT * FROM metadata WHERE url ".
593: " LIKE BINARY '?'";
594: my $sth = $dbh->prepare($q2);
595: $sth->execute($mfile);
596: my $aref=$sth->fetchall_arrayref;
597: foreach my $a (@$aref) {
598: my @b=map { &escape($_)} @$a;
599: push @results,join(",", @b);
600: }
601: }
602: # &logthis("found: $stuff");
603: $customresult.='&custom='.&escape($mfile).','.
604: escape($stuff);
605: }
606: }
607: $result=join("&",@results) unless $query;
608: $result.=$customresult;
609: #
610: return $result;
611: } # End of &do_sql_query
612:
613: } # End of scoping curly braces for &process_file and &do_sql_query
614: ########################################################
615: ########################################################
616:
617: =pod
618:
619: =item &logthis
620:
621: Inputs: $message, the message to log
622:
623: Returns: nothing
624:
625: Writes $message to the logfile.
626:
627: =cut
628:
629: ########################################################
630: ########################################################
631: sub logthis {
632: my $message=shift;
633: my $execdir=$perlvar{'lonDaemons'};
634: my $fh=IO::File->new(">>$execdir/logs/lonsql.log");
635: my $now=time;
636: my $local=localtime($now);
637: print $fh "$local ($$): $message\n";
638: }
639:
640: # -------------------------------------------------- Non-critical communication
641:
642: ########################################################
643: ########################################################
644:
645: =pod
646:
647: =item &subreply
648:
649: Sends a command to a server. Called only by &reply.
650:
651: Inputs: $cmd,$server
652:
653: Returns: The results of the message or 'con_lost' on error.
654:
655: =cut
656:
657: ########################################################
658: ########################################################
659: sub subreply {
660: my ($cmd,$server)=@_;
661: my $peerfile="$perlvar{'lonSockDir'}/$server";
662: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
663: Type => SOCK_STREAM,
664: Timeout => 10)
665: or return "con_lost";
666: print $sclient "$cmd\n";
667: my $answer=<$sclient>;
668: chomp($answer);
669: $answer="con_lost" if (!$answer);
670: return $answer;
671: }
672:
673: ########################################################
674: ########################################################
675:
676: =pod
677:
678: =item &reply
679:
680: Sends a command to a server.
681:
682: Inputs: $cmd,$server
683:
684: Returns: The results of the message or 'con_lost' on error.
685:
686: =cut
687:
688: ########################################################
689: ########################################################
690: sub reply {
691: my ($cmd,$server)=@_;
692: my $answer;
693: if ($server ne $perlvar{'lonHostID'}) {
694: $answer=subreply($cmd,$server);
695: if ($answer eq 'con_lost') {
696: $answer=subreply("ping",$server);
697: $answer=subreply($cmd,$server);
698: }
699: } else {
700: $answer='self_reply';
701: $answer=subreply($cmd,$server);
702: }
703: return $answer;
704: }
705:
706: ########################################################
707: ########################################################
708:
709: =pod
710:
711: =item &escape
712:
713: Escape special characters in a string.
714:
715: Inputs: string to escape
716:
717: Returns: The input string with special characters escaped.
718:
719: =cut
720:
721: ########################################################
722: ########################################################
723: sub escape {
724: my $str=shift;
725: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
726: return $str;
727: }
728:
729: ########################################################
730: ########################################################
731:
732: =pod
733:
734: =item &unescape
735:
736: Unescape special characters in a string.
737:
738: Inputs: string to unescape
739:
740: Returns: The input string with special characters unescaped.
741:
742: =cut
743:
744: ########################################################
745: ########################################################
746: sub unescape {
747: my $str=shift;
748: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
749: return $str;
750: }
751:
752: ########################################################
753: ########################################################
754:
755: =pod
756:
757: =item &ishome
758:
759: Determine if the current machine is the home server for a user.
760: The determination is made by checking the filesystem for the users information.
761:
762: Inputs: $author
763:
764: Returns: 0 - this is not the authors home server, 1 - this is.
765:
766: =cut
767:
768: ########################################################
769: ########################################################
770: sub ishome {
771: my $author=shift;
772: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
773: my ($udom,$uname)=split(/\//,$author);
774: my $proname=propath($udom,$uname);
775: if (-e $proname) {
776: return 1;
777: } else {
778: return 0;
779: }
780: }
781:
782: ########################################################
783: ########################################################
784:
785: =pod
786:
787: =item &propath
788:
789: Inputs: user name, user domain
790:
791: Returns: The full path to the users directory.
792:
793: =cut
794:
795: ########################################################
796: ########################################################
797: sub propath {
798: my ($udom,$uname)=@_;
799: $udom=~s/\W//g;
800: $uname=~s/\W//g;
801: my $subdir=$uname.'__';
802: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
803: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
804: return $proname;
805: }
806:
807: ########################################################
808: ########################################################
809:
810: =pod
811:
812: =item &courselog
813:
814: Inputs: $path, $command
815:
816: Returns: unescaped string of values.
817:
818: =cut
819:
820: ########################################################
821: ########################################################
822: sub courselog {
823: my ($path,$command)=@_;
824: my %filters=();
825: foreach (split(/\:/,&unescape($command))) {
826: my ($name,$value)=split(/\=/,$_);
827: $filters{$name}=$value;
828: }
829: my @results=();
830: open(IN,$path.'/activity.log') or return ('file_error');
831: while (my $line=<IN>) {
832: chomp($line);
833: my ($timestamp,$host,$log)=split(/\:/,$line);
834: #
835: # $log has the actual log entries; currently still escaped, and
836: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
837: # then additionally
838: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
839: # or
840: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
841: #
842: # get delimiter between timestamped entries to be &&&
843: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
844: # now go over all log entries
845: foreach (split(/\&\&\&/,&unescape($log))) {
846: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
847: my $values=&unescape(join(':',@values));
848: $values=~s/\&/\:/g;
849: $res=&unescape($res);
850: my $include=1;
851: if (($filters{'username'}) && ($uname ne $filters{'username'}))
852: { $include=0; }
853: if (($filters{'domain'}) && ($udom ne $filters{'domain'}))
854: { $include=0; }
855: if (($filters{'url'}) && ($res!~/$filters{'url'}/))
856: { $include=0; }
857: if (($filters{'start'}) && ($time<$filters{'start'}))
858: { $include=0; }
859: if (($filters{'end'}) && ($time>$filters{'end'}))
860: { $include=0; }
861: if (($filters{'action'} eq 'view') && ($action))
862: { $include=0; }
863: if (($filters{'action'} eq 'submit') && ($action ne 'POST'))
864: { $include=0; }
865: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE'))
866: { $include=0; }
867: if ($include) {
868: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
869: $uname.':'.$udom.':'.
870: $action.':'.$values);
871: }
872: }
873: }
874: close IN;
875: return join('&',sort(@results));
876: }
877:
878: ########################################################
879: ########################################################
880:
881: =pod
882:
883: =item &userlog
884:
885: Inputs: $path, $command
886:
887: Returns: unescaped string of values.
888:
889: =cut
890:
891: ########################################################
892: ########################################################
893: sub userlog {
894: my ($path,$command)=@_;
895: my %filters=();
896: foreach (split(/\:/,&unescape($command))) {
897: my ($name,$value)=split(/\=/,$_);
898: $filters{$name}=$value;
899: }
900: my @results=();
901: open(IN,$path.'/activity.log') or return ('file_error');
902: while (my $line=<IN>) {
903: chomp($line);
904: my ($timestamp,$host,$log)=split(/\:/,$line);
905: $log=&unescape($log);
906: my $include=1;
907: if (($filters{'start'}) && ($timestamp<$filters{'start'}))
908: { $include=0; }
909: if (($filters{'end'}) && ($timestamp>$filters{'end'}))
910: { $include=0; }
911: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
912: if (($filters{'action'} eq 'check') && ($log!~/^Check/))
913: { $include=0; }
914: if ($include) {
915: push(@results,$timestamp.':'.$log);
916: }
917: }
918: close IN;
919: return join('&',sort(@results));
920: }
921:
922: ########################################################
923: ########################################################
924:
925: =pod
926:
927: =item Functions required for forking
928:
929: =over 4
930:
931: =item REAPER
932:
933: REAPER takes care of dead children.
934:
935: =item HUNTSMAN
936:
937: Signal handler for SIGINT.
938:
939: =item HUPSMAN
940:
941: Signal handler for SIGHUP
942:
943: =item DISCONNECT
944:
945: Disconnects from database.
946:
947: =back
948:
949: =cut
950:
951: ########################################################
952: ########################################################
953: sub REAPER { # takes care of dead children
954: $SIG{CHLD} = \&REAPER;
955: my $pid = wait;
956: $children --;
957: &logthis("Child $pid died");
958: delete $children{$pid};
959: }
960:
961: sub HUNTSMAN { # signal handler for SIGINT
962: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
963: kill 'INT' => keys %children;
964: my $execdir=$perlvar{'lonDaemons'};
965: unlink("$execdir/logs/lonsql.pid");
966: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
967: $unixsock = "mysqlsock";
968: my $port="$perlvar{'lonSockDir'}/$unixsock";
969: unlink($port);
970: exit; # clean up with dignity
971: }
972:
973: sub HUPSMAN { # signal handler for SIGHUP
974: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
975: kill 'INT' => keys %children;
976: close($server); # free up socket
977: &logthis("<font color='red'>CRITICAL: Restarting</font>");
978: my $execdir=$perlvar{'lonDaemons'};
979: $unixsock = "mysqlsock";
980: my $port="$perlvar{'lonSockDir'}/$unixsock";
981: unlink($port);
982: exec("$execdir/lonsql"); # here we go again
983: }
984:
985: sub DISCONNECT {
986: $dbh->disconnect or
987: &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".
988: " $DBI::errstr : $@</font>");
989: exit;
990: }
991:
992:
993: =pod
994:
995: =back
996:
997: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>