loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.63: download - view: text, annotated - select for diffs
Wed Jul 28 20:46:28 2004 UTC (19 years, 9 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

Updates for activity log work.

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