File:
[LON-CAPA] /
loncom /
lonsql
Revision
1.94:
download - view:
text,
annotated -
select for diffs
Wed Aug 5 18:47:12 2015 UTC (8 years, 8 months ago) by
raeburn
Branches:
MAIN
CVS tags:
HEAD
- Bug 5596.
Add a routine to lonnet.pm -- get_multiple_instusers() which makes one call
to lond > lonsql > localenroll.pm to retrieve institutional data
for multiple users when adding users via file upload, to minimize number
of sleep() commands needed. Supports up to 1s per query, on localenroll.pm
side if adding more than 100 new users.
- Add new routine to localenroll.pm -- &get_multusersinfo() -- to retrieve
institutional data for users being added via user file upload.
Note: if this routine does not exist in localenroll.pm, will fall-back
to retrieving institutional data using a separate call to &get_userinfo()
for each user.
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.94 2015/08/05 18:47:12 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: =cut
99:
100: use strict;
101:
102: use lib '/home/httpd/lib/perl/';
103: use LONCAPA;
104: use LONCAPA::Configuration;
105: use LONCAPA::lonmetadata();
106: use Apache::lonnet;
107:
108: use IO::Socket;
109: use Symbol;
110: use POSIX;
111: use IO::Select;
112: use DBI;
113: use File::Find;
114: use localenroll;
115: use GDBM_File;
116:
117: ########################################################
118: ########################################################
119:
120: =pod
121:
122: =over 4
123:
124: =item Global Variables
125:
126: =over 4
127:
128: =item dbh
129:
130: =back
131:
132: =cut
133:
134: ########################################################
135: ########################################################
136: my $dbh;
137:
138: ########################################################
139: ########################################################
140:
141: =pod
142:
143: =item Variables required for forking
144:
145: =over 4
146:
147: =item $MAX_CLIENTS_PER_CHILD
148:
149: The number of clients each child should process.
150:
151: =item %children
152:
153: The keys to %children are the current child process IDs
154:
155: =item $children
156:
157: The current number of children
158:
159: =back
160:
161: =cut
162:
163: ########################################################
164: ########################################################
165: my $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
166: my %children = (); # keys are current child process IDs
167: my $children = 0; # current number of children
168:
169: ###################################################################
170: ###################################################################
171:
172: =pod
173:
174: =item Main body of code.
175:
176: =over 4
177:
178: =item Read data from loncapa_apache.conf and loncapa.conf.
179:
180: =item Ensure we can access the database.
181:
182: =item Determine if there are other instances of lonsql running.
183:
184: =item Read the hosts file.
185:
186: =item Create a socket for lonsql.
187:
188: =item Fork once and dissociate from parent.
189:
190: =item Write PID to disk.
191:
192: =item Prefork children and maintain the population of children.
193:
194: =back
195:
196: =cut
197:
198: ###################################################################
199: ###################################################################
200: my $childmaxattempts=10;
201: my $run =0; # running counter to generate the query-id
202: #
203: # Read loncapa_apache.conf and loncapa.conf
204: #
205: my %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
206: #
207: # Write the /home/www/.my.cnf file
208: my $conf_file = '/home/www/.my.cnf';
209: if (! -e $conf_file) {
210: if (open MYCNF, ">$conf_file") {
211: print MYCNF <<"ENDMYCNF";
212: [client]
213: user=www
214: password=$perlvar{'lonSqlAccess'}
215: ENDMYCNF
216: close MYCNF;
217: } else {
218: warn "Unable to write $conf_file, continuing";
219: }
220: }
221:
222:
223: #
224: # Make sure that database can be accessed
225: #
226: my $dbh;
227: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
228: $perlvar{'lonSqlAccess'},
229: { RaiseError =>0,PrintError=>0})) {
230: print "Cannot connect to database!\n";
231: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
232: my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
233: system("echo 'Cannot connect to MySQL database!' |".
234: " mailto $emailto -s '$subj' > /dev/null");
235:
236: open(SMP,">$perlvar{'lonDocRoot'}/lon-status/mysql.txt");
237: print SMP 'time='.time.'&mysql=defunct'."\n";
238: close(SMP);
239:
240: exit 1;
241: } else {
242: unlink("$perlvar{'lonDocRoot'}/lon-status/mysql.txt");
243: $dbh->disconnect;
244: }
245:
246: #
247: # Check if other instance running
248: #
249: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
250: if (-e $pidfile) {
251: open(my $lfh,"$pidfile");
252: my $pide=<$lfh>;
253: chomp($pide);
254: if (kill 0 => $pide) { die "already running"; }
255: }
256:
257: my $PREFORK=4; # number of children to maintain, at least four spare
258: #
259: #$PREFORK=int($PREFORK/4);
260:
261: #
262: # Create a socket to talk to lond
263: #
264: my $unixsock = "mysqlsock";
265: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
266: my $server;
267: unlink ($localfile);
268: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
269: Type => SOCK_STREAM,
270: Listen => 10)) {
271: print "in socket error:$@\n";
272: }
273:
274: #
275: # Fork once and dissociate
276: #
277: my $fpid=fork;
278: exit if $fpid;
279: die "Couldn't fork: $!" unless defined ($fpid);
280: POSIX::setsid() or die "Can't start new session: $!";
281:
282: #
283: # Write our PID on disk
284: my $execdir=$perlvar{'lonDaemons'};
285: open (PIDSAVE,">$execdir/logs/lonsql.pid");
286: print PIDSAVE "$$\n";
287: close(PIDSAVE);
288: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
289:
290: #
291: # Ignore signals generated during initial startup
292: $SIG{HUP}=$SIG{USR1}='IGNORE';
293: # Now we are on our own
294: # Fork off our children.
295: for (1 .. $PREFORK) {
296: make_new_child();
297: }
298:
299: #
300: # Install signal handlers.
301: $SIG{CHLD} = \&REAPER;
302: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
303: $SIG{HUP} = \&HUPSMAN;
304:
305: #
306: # And maintain the population.
307: while (1) {
308: sleep; # wait for a signal (i.e., child's death)
309: for (my $i = $children; $i < $PREFORK; $i++) {
310: make_new_child(); # top up the child pool
311: }
312: }
313:
314: ########################################################
315: ########################################################
316:
317: =pod
318:
319: =item &make_new_child
320:
321: Inputs: None
322:
323: Returns: None
324:
325: =cut
326:
327: ########################################################
328: ########################################################
329: sub make_new_child {
330: my $pid;
331: my $sigset;
332: #
333: # block signal for fork
334: $sigset = POSIX::SigSet->new(SIGINT);
335: sigprocmask(SIG_BLOCK, $sigset)
336: or die "Can't block SIGINT for fork: $!\n";
337: #
338: die "fork: $!" unless defined ($pid = fork);
339: #
340: if ($pid) {
341: # Parent records the child's birth and returns.
342: sigprocmask(SIG_UNBLOCK, $sigset)
343: or die "Can't unblock SIGINT for fork: $!\n";
344: $children{$pid} = 1;
345: $children++;
346: return;
347: } else {
348: # Child can *not* return from this subroutine.
349: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
350: # unblock signals
351: sigprocmask(SIG_UNBLOCK, $sigset)
352: or die "Can't unblock SIGINT for fork: $!\n";
353: #open database handle
354: # making dbh global to avoid garbage collector
355: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
356: $perlvar{'lonSqlAccess'},
357: { RaiseError =>0,PrintError=>0})) {
358: sleep(10+int(rand(20)));
359: &logthis("<font color='blue'>WARNING: Couldn't connect to database".
360: ": $@</font>");
361: # "($st secs): $@</font>");
362: print "database handle error\n";
363: exit;
364: }
365: # make sure that a database disconnection occurs with
366: # ending kill signals
367: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
368: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
369: for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
370: my $client = $server->accept() or last;
371: # do something with the connection
372: $run = $run+1;
373: my $userinput = <$client>;
374: chomp($userinput);
375: $userinput=~s/\:($LONCAPA::domain_re)$//;
376: my $searchdomain=$1;
377: #
378: my ($conserver,$query,
379: $arg1,$arg2,$arg3)=split(/&/,$userinput);
380: my $query=unescape($query);
381: #
382: #send query id which is pid_unixdatetime_runningcounter
383: my $queryid = &Apache::lonnet::hostname($perlvar{'lonHostID'});
384: $queryid .="_".($$)."_";
385: $queryid .= time."_";
386: $queryid .= $run;
387: print $client "$queryid\n";
388: #
389: # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3 - $queryid");
390: # sleep 1;
391: #
392: my $result='';
393: #
394: # At this point, query is received, query-ID assigned and sent
395: # back, $query eq 'logquery' will mean that this is a query
396: # against log-files
397: if (($query eq 'userlog') || ($query eq 'courselog')) {
398: # beginning of log query
399: my $udom = &unescape($arg1);
400: my $uname = &unescape($arg2);
401: my $command = &unescape($arg3);
402: my $path = &propath($udom,$uname);
403: if (-e "$path/activity.log") {
404: if ($query eq 'userlog') {
405: $result=&userlog($path,$command);
406: } else {
407: $result=&courselog($path,$command);
408: }
409: $result = &escape($result);
410: } else {
411: &logthis('Unable to do log query: '.$uname.'@'.$udom);
412: $result='no_such_file';
413: }
414: # end of log query
415: } elsif (($query eq 'fetchenrollment') ||
416: ($query eq 'institutionalphotos')) {
417: # retrieve institutional class lists
418: my $dom = &unescape($arg1);
419: my %affiliates = ();
420: my %replies = ();
421: my $locresult = '';
422: my $querystr = &unescape($arg3);
423: foreach (split/%%/,$querystr) {
424: if (/^([^=]+)=([^=]+)$/) {
425: @{$affiliates{$1}} = split/,/,$2;
426: }
427: }
428: if ($query eq 'fetchenrollment') {
429: $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);
430: } elsif ($query eq 'institutionalphotos') {
431: my $crs = &unescape($arg2);
432: eval {
433: local($SIG{__DIE__})='DEFAULT';
434: $locresult = &localenroll::institutional_photos($dom,$crs,\%affiliates,\%replies,'update');
435: };
436: if ($@) {
437: $locresult = 'error';
438: }
439: }
440: $result = &escape($locresult.':');
441: if ($locresult) {
442: $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));
443: }
444: } elsif ($query eq 'usersearch') {
445: my ($srchby,$srchtype,$srchterm);
446: if ((&unescape($arg1) eq $searchdomain) &&
447: ($arg2 =~ /\%\%/)) {
448: ($srchby,$srchtype) =
449: map {&unescape($_);} (split(/\%\%/,$arg2));
450: $srchterm = &unescape($arg3);
451: } else {
452: ($srchby,$srchtype,$srchterm) =
453: map {&unescape($_);} ($arg1,$arg2,$arg3);
454: }
455: $result = &do_user_search($searchdomain,$srchby,
456: $srchtype,$srchterm);
457: } elsif ($query eq 'instdirsearch') {
458: $result = &do_inst_dir_search($searchdomain,$arg1,$arg2,$arg3);
459: } elsif ($query eq 'getinstuser') {
460: $result = &get_inst_user($searchdomain,$arg1,$arg2);
461: } elsif ($query eq 'getmultinstusers') {
462: $result = &get_multiple_instusers($searchdomain,$arg3);
463: } elsif ($query eq 'prepare activity log') {
464: my ($cid,$domain) = map {&unescape($_);} ($arg1,$arg2);
465: &logthis('preparing activity log tables for '.$cid);
466: my $command =
467: qq{$perlvar{'lonDaemons'}/parse_activity_log.pl -course=$cid -domain=$domain};
468: system($command);
469: &logthis($command);
470: my $returnvalue = $?>>8;
471: if ($returnvalue) {
472: $result = 'error: parse_activity_log.pl returned '.
473: $returnvalue;
474: } else {
475: $result = 'success';
476: }
477: } elsif (($query eq 'portfolio_metadata') ||
478: ($query eq 'portfolio_access')) {
479: $result = &portfolio_table_update($query,$arg1,$arg2,
480: $arg3);
481: } elsif ($query eq 'allusers') {
482: my ($uname,$udom) = map {&unescape($_);} ($arg1,$arg2);
483: my %userdata;
484: my (@data) = split(/\%\%/,$arg3);
485: foreach my $item (@data) {
486: my ($key,$value) = split(/=/,$item);
487: $userdata{$key} = &unescape($value);
488: }
489: $userdata{'username'} = $uname;
490: $userdata{'domain'} = $udom;
491: $result = &allusers_table_update($query,$uname,$udom,\%userdata);
492: } else {
493: # Do an sql query
494: $result = &do_sql_query($query,$arg1,$arg2,$arg3,$searchdomain);
495: }
496: # result does not need to be escaped because it has already been
497: # escaped.
498: #$result=&escape($result);
499: &Apache::lonnet::reply("queryreply:$queryid:$result",$conserver);
500: }
501: # tidy up gracefully and finish
502: #
503: # close the database handle
504: $dbh->disconnect
505: or &logthis("<font color='blue'>WARNING: Couldn't disconnect".
506: " from database $DBI::errstr : $@</font>");
507: # this exit is VERY important, otherwise the child will become
508: # a producer of more and more children, forking yourself into
509: # process death.
510: exit;
511: }
512: }
513:
514: sub do_user_search {
515: my ($domain,$srchby,$srchtype,$srchterm) = @_;
516: my $result;
517: my $quoted_dom = $dbh->quote( $domain );
518: my ($query,$quoted_srchterm,@fields);
519: my ($table_columns,$table_indices) =
520: &LONCAPA::lonmetadata::describe_metadata_storage('allusers');
521: foreach my $coldata (@{$table_columns}) {
522: push(@fields,$coldata->{'name'});
523: }
524: my $fieldlist = join(',',@fields);
525: $query = "SELECT $fieldlist FROM allusers WHERE (domain = $quoted_dom AND ";
526: if ($srchby eq 'lastfirst') {
527: my ($fraglast,$fragfirst) = split(/,/,$srchterm);
528: $fragfirst =~ s/^\s+//;
529: $fraglast =~ s/\s+$//;
530: if ($srchtype eq 'exact') {
531: $query .= 'lastname = '.$dbh->quote($fraglast).
532: ' AND firstname = '.$dbh->quote($fragfirst);
533: } elsif ($srchtype eq 'begins') {
534: $query .= 'lastname LIKE '.$dbh->quote($fraglast.'%').
535: ' AND firstname LIKE '.$dbh->quote($fragfirst.'%');
536: } else {
537: $query .= 'lastname LIKE '.$dbh->quote('%'.$fraglast.'%').
538: ' AND firstname LIKE '.$dbh->quote('%'.$fragfirst.'%');
539: }
540: } else {
541: my %srchfield = (
542: uname => 'username',
543: lastname => 'lastname',
544: );
545: if ($srchtype eq 'exact') {
546: $query .= $srchfield{$srchby}.' = '.$dbh->quote($srchterm);
547: } elsif ($srchtype eq 'begins') {
548: $query .= $srchfield{$srchby}.' LIKE '.$dbh->quote($srchterm.'%');
549: } else {
550: $query .= $srchfield{$srchby}.' LIKE '.$dbh->quote('%'.$srchterm.'%');
551: }
552: }
553: $query .= ") ORDER BY username ";
554: my $sth = $dbh->prepare($query);
555: if ($sth->execute()) {
556: my @results;
557: while (my @row = $sth->fetchrow_array) {
558: my @items;
559: for (my $i=0; $i<@row; $i++) {
560: push(@items,&escape($fields[$i]).'='.&escape($row[$i]));
561: }
562: my $userstr = join(':', @items);
563: push(@results,&escape($userstr));
564: }
565: $sth->finish;
566: $result = join('&',@results);
567: } else {
568: &logthis('<font color="blue">'.
569: 'WARNING: Could not retrieve from database:'.
570: $sth->errstr().'</font>');
571: }
572: return $result;
573: }
574:
575: sub do_inst_dir_search {
576: my ($domain,$srchby,$srchterm,$srchtype) = @_;
577: $srchby = &unescape($srchby);
578: $srchterm = &unescape($srchterm);
579: $srchtype = &unescape($srchtype);
580: my (%instusers,%instids,$result,$response);
581: eval {
582: local($SIG{__DIE__})='DEFAULT';
583: $result=&localenroll::get_userinfo($domain,undef,undef,\%instusers,
584: \%instids,undef,$srchby,$srchterm,
585: $srchtype);
586: };
587: if ($result eq 'ok') {
588: if (%instusers) {
589: foreach my $key (keys(%instusers)) {
590: my $usrstr = &Apache::lonnet::freeze_escape($instusers{$key});
591: $response .=&escape(&escape($key).'='.$usrstr).'&';
592: }
593: }
594: $response=~s/\&$//;
595: } else {
596: $response = 'unavailable';
597: }
598: return $response;
599: }
600:
601: sub get_inst_user {
602: my ($domain,$uname,$id) = @_;
603: $uname = &unescape($uname);
604: $id = &unescape($id);
605: my (%instusers,%instids,$result,$response);
606: eval {
607: local($SIG{__DIE__})='DEFAULT';
608: $result=&localenroll::get_userinfo($domain,$uname,$id,\%instusers,
609: \%instids);
610: };
611: if ($result eq 'ok') {
612: if (keys(%instusers) > 0) {
613: foreach my $key (keys(%instusers)) {
614: my $usrstr = &Apache::lonnet::freeze_escape($instusers{$key});
615: $response .= &escape(&escape($key).'='.$usrstr).'&';
616: }
617: }
618: $response=~s/\&$//;
619: } else {
620: $response = 'unavailable';
621: }
622: return $response;
623: }
624:
625: sub get_multiple_instusers {
626: my ($domain,$data) = @_;
627: my ($type,$users) = split(/=/,$data,2);
628: my $requested = &Apache::lonnet::thaw_unescape($users);
629: my $response;
630: if (ref($requested) eq 'HASH') {
631: my (%instusers,%instids,$result);
632: eval {
633: local($SIG{__DIE__})='DEFAULT';
634: $result=&localenroll::get_multusersinfo($domain,$type,$requested,\%instusers,
635: \%instids);
636: };
637: if ($@) {
638: $response = 'error';
639: } elsif ($result eq 'ok') {
640: if (keys(%instusers)) {
641: $response = $result.':'.&Apache::lonnet::freeze_escape(\%instusers);
642: }
643: } else {
644: $response = 'unavailable';
645: }
646: } else {
647: $response = 'invalid';
648: }
649: return $response;
650: }
651:
652: ########################################################
653: ########################################################
654:
655: =pod
656:
657: =item &do_sql_query
658:
659: Runs an sql metadata table query.
660:
661: Inputs: $query, $custom, $customshow
662:
663: Returns: A string containing escaped results.
664:
665: =cut
666:
667: ########################################################
668: ########################################################
669: {
670: my @metalist;
671:
672: sub process_file {
673: if ( -e $_ && # file exists
674: -f $_ && # and is a normal file
675: /\.meta$/ && # ends in meta
676: ! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version
677: ) {
678: push(@metalist,$File::Find::name);
679: }
680: }
681:
682: sub do_sql_query {
683: my ($query,$custom,$customshow,$domainstr,$searchdomain) = @_;
684:
685: #
686: # limit to searchdomain if given and table is metadata
687: #
688: if ($domainstr && ($query=~/FROM metadata/)) {
689: my $havingstr;
690: $domainstr = &unescape($domainstr);
691: if ($domainstr =~ /,/) {
692: foreach my $dom (split(/,/,$domainstr)) {
693: if ($dom =~ /^$LONCAPA::domain_re$/) {
694: $havingstr .= 'domain="'.$dom.'" OR ';
695: }
696: }
697: $havingstr =~ s/ OR $//;
698: } else {
699: if ($domainstr =~ /^$LONCAPA::domain_re$/) {
700: $havingstr = 'domain="'.$domainstr.'"';
701: }
702: }
703: if ($havingstr) {
704: $query.=' HAVING ('.$havingstr.')';
705: }
706: } elsif (($searchdomain) && ($query=~/FROM metadata/)) {
707: $query.=' HAVING (domain="'.$searchdomain.'")';
708: }
709: # &logthis('doing query ('.$searchdomain.')'.$query);
710:
711:
712:
713: $custom = &unescape($custom);
714: $customshow = &unescape($customshow);
715: #
716: @metalist = ();
717: #
718: my $result = '';
719: my @results = ();
720: my @files;
721: my $subsetflag=0;
722: #
723: if ($query) {
724: #prepare and execute the query
725: my $sth = $dbh->prepare($query);
726: unless ($sth->execute()) {
727: &logthis('<font color="blue">'.
728: 'WARNING: Could not retrieve from database:'.
729: $sth->errstr().'</font>');
730: } else {
731: my $aref=$sth->fetchall_arrayref;
732: foreach my $row (@$aref) {
733: push @files,@{$row}[3] if ($custom or $customshow);
734: my @b=map { &escape($_); } @$row;
735: push @results,join(",", @b);
736: # Build up the @files array with the LON-CAPA urls
737: # of the resources.
738: }
739: }
740: }
741: # do custom metadata searching here and build into result
742: return join("&",@results) if (! ($custom or $customshow));
743: # Only get here if there is a custom query or custom show request
744: &logthis("Doing custom query for $custom");
745: if ($query) {
746: @metalist=map {
747: $perlvar{'lonDocRoot'}.$_.'.meta';
748: } @files;
749: } else {
750: my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";
751: @metalist=();
752: opendir(RESOURCES,$dir);
753: my @homeusers=grep {
754: &ishome($dir.'/'.$_);
755: } grep {!/^\.\.?$/} readdir(RESOURCES);
756: closedir RESOURCES;
757: # Define the
758: foreach my $user (@homeusers) {
759: find (\&process_file,$dir.'/'.$user);
760: }
761: }
762: # if file is indicated in sql database and
763: # not part of sql-relevant query, do not pattern match.
764: #
765: # if file is not in sql database, output error.
766: #
767: # if file is indicated in sql database and is
768: # part of query result list, then do the pattern match.
769: my $customresult='';
770: my @results;
771: foreach my $metafile (@metalist) {
772: open(my $fh,$metafile);
773: my @lines=<$fh>;
774: my $stuff=join('',@lines);
775: if ($stuff=~/$custom/s) {
776: foreach my $f ('abstract','author','copyright',
777: 'creationdate','keywords','language',
778: 'lastrevisiondate','mime','notes',
779: 'owner','subject','title') {
780: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
781: }
782: my $mfile=$metafile;
783: my $docroot=$perlvar{'lonDocRoot'};
784: $mfile=~s/^$docroot//;
785: $mfile=~s/\.meta$//;
786: unless ($query) {
787: my $q2="SELECT * FROM metadata WHERE url ".
788: " LIKE BINARY '?'";
789: my $sth = $dbh->prepare($q2);
790: $sth->execute($mfile);
791: my $aref=$sth->fetchall_arrayref;
792: foreach my $a (@$aref) {
793: my @b=map { &escape($_)} @$a;
794: push @results,join(",", @b);
795: }
796: }
797: # &logthis("found: $stuff");
798: $customresult.='&custom='.&escape($mfile).','.
799: escape($stuff);
800: }
801: }
802: $result=join("&",@results) unless $query;
803: $result.=$customresult;
804: #
805: return $result;
806: } # End of &do_sql_query
807:
808: } # End of scoping curly braces for &process_file and &do_sql_query
809:
810: sub portfolio_table_update {
811: my ($query,$arg1,$arg2,$arg3) = @_;
812: my %tablenames = (
813: 'portfolio' => 'portfolio_metadata',
814: 'access' => 'portfolio_access',
815: 'addedfields' => 'portfolio_addedfields',
816: );
817: my $result = 'ok';
818: my $tablechk = &check_table($query);
819: if ($tablechk == 0) {
820: my $request =
821: &LONCAPA::lonmetadata::create_metadata_storage($query,$query);
822: $dbh->do($request);
823: if ($dbh->err) {
824: &logthis("create $query".
825: " ERROR: ".$dbh->errstr);
826: $result = 'error';
827: }
828: }
829: if ($result eq 'ok') {
830: my ($uname,$udom,$group) = split(/:/,&unescape($arg1));
831: my $file_name = &unescape($arg2);
832: my $action = $arg3;
833: my $is_course = 0;
834: if ($group ne '') {
835: $is_course = 1;
836: }
837: my $urlstart = '/uploaded/'.$udom.'/'.$uname;
838: my $pathstart = &propath($udom,$uname).'/userfiles';
839: my ($fullpath,$url);
840: if ($is_course) {
841: $fullpath = $pathstart.'/groups/'.$group.'/portfolio'.
842: $file_name;
843: $url = $urlstart.'/groups/'.$group.'/portfolio'.$file_name;
844: } else {
845: $fullpath = $pathstart.'/portfolio'.$file_name;
846: $url = $urlstart.'/portfolio'.$file_name;
847: }
848: if ($query eq 'portfolio_metadata') {
849: if ($action eq 'delete') {
850: my %loghash = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef,\%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group,'update');
851: } elsif (-e $fullpath.'.meta') {
852: my %loghash = &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef,\%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group,'update');
853: if (keys(%loghash) > 0) {
854: &portfolio_logging(%loghash);
855: }
856: }
857: } elsif ($query eq 'portfolio_access') {
858: my %access = &get_access_hash($uname,$udom,$group.$file_name);
859: my %loghash =
860: &LONCAPA::lonmetadata::process_portfolio_access_data($dbh,undef,
861: \%tablenames,$url,$fullpath,\%access,'update');
862: if (keys(%loghash) > 0) {
863: &portfolio_logging(%loghash);
864: } else {
865: my $available = 0;
866: foreach my $key (keys(%access)) {
867: my ($num,$scope,$end,$start) =
868: ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/);
869: if ($scope eq 'public' || $scope eq 'guest') {
870: $available = 1;
871: last;
872: }
873: }
874: if ($available) {
875: # Retrieve current values
876: my $condition = 'url='.$dbh->quote("$url");
877: my ($error,$row) =
878: &LONCAPA::lonmetadata::lookup_metadata($dbh,$condition,undef,
879: 'portfolio_metadata');
880: if (!$error) {
881: if (!(ref($row->[0]) eq 'ARRAY')) {
882: my %loghash =
883: &LONCAPA::lonmetadata::process_portfolio_metadata($dbh,undef,
884: \%tablenames,$url,$fullpath,$is_course,$udom,$uname,$group);
885: if (keys(%loghash) > 0) {
886: &portfolio_logging(%loghash);
887: }
888: }
889: }
890: }
891: }
892: }
893: }
894: return $result;
895: }
896:
897: sub get_access_hash {
898: my ($uname,$udom,$file) = @_;
899: my $hashref = &tie_user_hash($udom,$uname,'file_permissions',
900: &GDBM_READER());
901: my %curr_perms;
902: my %access;
903: if ($hashref) {
904: while (my ($key,$value) = each(%$hashref)) {
905: $key = &unescape($key);
906: next if ($key =~ /^error: 2 /);
907: $curr_perms{$key}=&Apache::lonnet::thaw_unescape($value);
908: }
909: if (!&untie_user_hash($hashref)) {
910: &logthis("error: ".($!+0)." untie (GDBM) Failed");
911: }
912: } else {
913: &logthis("error: ".($!+0)." tie (GDBM) Failed");
914: }
915: if (keys(%curr_perms) > 0) {
916: if (ref($curr_perms{$file."\0".'accesscontrol'}) eq 'HASH') {
917: foreach my $acl (keys(%{$curr_perms{$file."\0".'accesscontrol'}})) {
918: $access{$acl} = $curr_perms{$file."\0".$acl};
919: }
920: }
921: }
922: return %access;
923: }
924:
925: sub allusers_table_update {
926: my ($query,$uname,$udom,$userdata) = @_;
927: my %tablenames = (
928: 'allusers' => 'allusers',
929: );
930: my $result = 'ok';
931: my $tablechk = &check_table($query);
932: if ($tablechk == 0) {
933: my $request =
934: &LONCAPA::lonmetadata::create_metadata_storage($query,$query);
935: $dbh->do($request);
936: if ($dbh->err) {
937: &logthis("create $query".
938: " ERROR: ".$dbh->errstr);
939: $result = 'error';
940: }
941: }
942: if ($result eq 'ok') {
943: my %loghash =
944: &LONCAPA::lonmetadata::process_allusers_data($dbh,undef,
945: \%tablenames,$uname,$udom,$userdata,'update');
946: foreach my $key (keys(%loghash)) {
947: &logthis($loghash{$key});
948: }
949: }
950: return $result;
951: }
952:
953: ###########################################
954: sub check_table {
955: my ($table_id) = @_;
956: my $sth=$dbh->prepare('SHOW TABLES');
957: $sth->execute();
958: my $aref = $sth->fetchall_arrayref;
959: $sth->finish();
960: if ($sth->err()) {
961: &logthis("fetchall_arrayref after SHOW TABLES".
962: " ERROR: ".$sth->errstr);
963: return undef;
964: }
965: my $result = 0;
966: foreach my $table (@{$aref}) {
967: if ($table->[0] eq $table_id) {
968: $result = 1;
969: last;
970: }
971: }
972: return $result;
973: }
974:
975: ###########################################
976:
977: sub portfolio_logging {
978: my (%portlog) = @_;
979: foreach my $key (keys(%portlog)) {
980: if (ref($portlog{$key}) eq 'HASH') {
981: foreach my $item (keys(%{$portlog{$key}})) {
982: &logthis($portlog{$key}{$item});
983: }
984: }
985: }
986: }
987:
988:
989: ########################################################
990: ########################################################
991:
992: =pod
993:
994: =item &logthis
995:
996: Inputs: $message, the message to log
997:
998: Returns: nothing
999:
1000: Writes $message to the logfile.
1001:
1002: =cut
1003:
1004: ########################################################
1005: ########################################################
1006: sub logthis {
1007: my $message=shift;
1008: my $execdir=$perlvar{'lonDaemons'};
1009: open(my $fh,">>$execdir/logs/lonsql.log");
1010: my $now=time;
1011: my $local=localtime($now);
1012: print $fh "$local ($$): $message\n";
1013: }
1014:
1015: ########################################################
1016: ########################################################
1017:
1018: =pod
1019:
1020: =item &ishome
1021:
1022: Determine if the current machine is the home server for a user.
1023: The determination is made by checking the filesystem for the users information.
1024:
1025: Inputs: $author
1026:
1027: Returns: 0 - this is not the authors home server, 1 - this is.
1028:
1029: =cut
1030:
1031: ########################################################
1032: ########################################################
1033: sub ishome {
1034: my $author=shift;
1035: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
1036: my ($udom,$uname)=split(/\//,$author);
1037: my $proname=propath($udom,$uname);
1038: if (-e $proname) {
1039: return 1;
1040: } else {
1041: return 0;
1042: }
1043: }
1044:
1045: ########################################################
1046: ########################################################
1047:
1048: =pod
1049:
1050: =item &courselog
1051:
1052: Inputs: $path, $command
1053:
1054: Returns: unescaped string of values.
1055:
1056: =cut
1057:
1058: ########################################################
1059: ########################################################
1060: sub courselog {
1061: my ($path,$command)=@_;
1062: my %filters=();
1063: foreach (split(/\:/,&unescape($command))) {
1064: my ($name,$value)=split(/\=/,$_);
1065: $filters{$name}=$value;
1066: }
1067: my @results=();
1068: open(IN,$path.'/activity.log') or return ('file_error');
1069: while (my $line=<IN>) {
1070: chomp($line);
1071: my ($timestamp,$host,$log)=split(/\:/,$line);
1072: #
1073: # $log has the actual log entries; currently still escaped, and
1074: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
1075: # then additionally
1076: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
1077: # or
1078: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
1079: #
1080: # get delimiter between timestamped entries to be &&&
1081: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
1082: # now go over all log entries
1083: foreach (split(/\&\&\&/,&unescape($log))) {
1084: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
1085: my $values=&unescape(join(':',@values));
1086: $values=~s/\&/\:/g;
1087: $res=&unescape($res);
1088: my $include=1;
1089: if (($filters{'username'}) && ($uname ne $filters{'username'}))
1090: { $include=0; }
1091: if (($filters{'domain'}) && ($udom ne $filters{'domain'}))
1092: { $include=0; }
1093: if (($filters{'url'}) && ($res!~/$filters{'url'}/))
1094: { $include=0; }
1095: if (($filters{'start'}) && ($time<$filters{'start'}))
1096: { $include=0; }
1097: if (($filters{'end'}) && ($time>$filters{'end'}))
1098: { $include=0; }
1099: if (($filters{'action'} eq 'view') && ($action))
1100: { $include=0; }
1101: if (($filters{'action'} eq 'submit') && ($action ne 'POST'))
1102: { $include=0; }
1103: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE'))
1104: { $include=0; }
1105: if ($include) {
1106: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
1107: $uname.':'.$udom.':'.
1108: $action.':'.$values);
1109: }
1110: }
1111: }
1112: close IN;
1113: return join('&',sort(@results));
1114: }
1115:
1116: ########################################################
1117: ########################################################
1118:
1119: =pod
1120:
1121: =item &userlog
1122:
1123: Inputs: $path, $command
1124:
1125: Returns: unescaped string of values.
1126:
1127: =cut
1128:
1129: ########################################################
1130: ########################################################
1131: sub userlog {
1132: my ($path,$command)=@_;
1133: my %filters=();
1134: foreach (split(/\:/,&unescape($command))) {
1135: my ($name,$value)=split(/\=/,$_);
1136: $filters{$name}=$value;
1137: }
1138: my @results=();
1139: open(IN,$path.'/activity.log') or return ('file_error');
1140: while (my $line=<IN>) {
1141: chomp($line);
1142: my ($timestamp,$host,$log)=split(/\:/,$line);
1143: $log=&unescape($log);
1144: my $include=1;
1145: if (($filters{'start'}) && ($timestamp<$filters{'start'}))
1146: { $include=0; }
1147: if (($filters{'end'}) && ($timestamp>$filters{'end'}))
1148: { $include=0; }
1149: if (($filters{'action'} eq 'Role') && ($log !~/^Role/))
1150: { $include=0; }
1151: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
1152: if (($filters{'action'} eq 'check') && ($log!~/^Check/))
1153: { $include=0; }
1154: if ($include) {
1155: push(@results,$timestamp.':'.$host.':'.&escape($log));
1156: }
1157: }
1158: close IN;
1159: return join('&',sort(@results));
1160: }
1161:
1162: ########################################################
1163: ########################################################
1164:
1165: =pod
1166:
1167: =item Functions required for forking
1168:
1169: =over 4
1170:
1171: =item REAPER
1172:
1173: REAPER takes care of dead children.
1174:
1175: =item HUNTSMAN
1176:
1177: Signal handler for SIGINT.
1178:
1179: =item HUPSMAN
1180:
1181: Signal handler for SIGHUP
1182:
1183: =item DISCONNECT
1184:
1185: Disconnects from database.
1186:
1187: =back
1188:
1189: =cut
1190:
1191: ########################################################
1192: ########################################################
1193: sub REAPER { # takes care of dead children
1194: $SIG{CHLD} = \&REAPER;
1195: my $pid = wait;
1196: $children --;
1197: &logthis("Child $pid died");
1198: delete $children{$pid};
1199: }
1200:
1201: sub HUNTSMAN { # signal handler for SIGINT
1202: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1203: kill 'INT' => keys %children;
1204: my $execdir=$perlvar{'lonDaemons'};
1205: unlink("$execdir/logs/lonsql.pid");
1206: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
1207: $unixsock = "mysqlsock";
1208: my $port="$perlvar{'lonSockDir'}/$unixsock";
1209: unlink($port);
1210: exit; # clean up with dignity
1211: }
1212:
1213: sub HUPSMAN { # signal handler for SIGHUP
1214: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
1215: kill 'INT' => keys %children;
1216: close($server); # free up socket
1217: &logthis("<font color='red'>CRITICAL: Restarting</font>");
1218: my $execdir=$perlvar{'lonDaemons'};
1219: $unixsock = "mysqlsock";
1220: my $port="$perlvar{'lonSockDir'}/$unixsock";
1221: unlink($port);
1222: exec("$execdir/lonsql"); # here we go again
1223: }
1224:
1225: sub DISCONNECT {
1226: $dbh->disconnect or
1227: &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".
1228: " $DBI::errstr : $@</font>");
1229: exit;
1230: }
1231:
1232:
1233: =pod
1234:
1235: =back
1236:
1237: =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