loncom/lonsql - view

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, 2 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("CRITICAL: ---------- Starting ----------"); 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("WARNING: Couldn't connect to database". 374: ": $@"); 375: # "($st secs): $@"); 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("WARNING: Couldn't disconnect". 477: " from database $DBI::errstr : $@"); 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(''. 533: 'WARNING: Could not retrieve from database:'. 534: $sth->errstr().''); 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("CRITICAL: Shutting down"); 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("CRITICAL: Restarting"); 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("WARNING: Couldn't disconnect from database ". 988: " $DBI::errstr : $@"); 989: exit; 990: } 991: 992: 993: =pod 994: 995: =back 996: 997: =cut