loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.46: download - view: text, annotated - select for diffs
Tue Jun 18 15:04:05 2002 UTC (22 years ago) by www
Branches: MAIN
CVS tags: HEAD

Toward bug 121.
lonnet now has routines to query course and user activity logs.
lonsql userlog already does some stuff.
Left to do: implement filters!
BUGFIX: lonsql was not escaping the query result. A ":" in any of the fields
would truncate the reply. lonsearchcat likely has to be adapted to unescape.

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.46 2002/06/18 15:04:05 www 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: # YEAR=2000 31: # lonsql-based on the preforker:harsha jagasia:date:5/10/00 32: # 7/25 Gerd Kortemeyer 33: # many different dates Scott Harrison 34: # YEAR=2001 35: # many different dates Scott Harrison 36: # 03/22/2001 Scott Harrison 37: # 8/30 Gerd Kortemeyer 38: # 10/17,11/28,11/29,12/20 Scott Harrison 39: # YEAR=2001 40: # 5/11 Scott Harrison 41: # 42: ### 43: 44: ############################################################################### 45: ## ## 46: ## ORGANIZATION OF THIS PERL SCRIPT ## 47: ## 1. Modules used ## 48: ## 2. Enable find subroutine ## 49: ## 3. Read httpd config files and get variables ## 50: ## 4. Make sure that database can be accessed ## 51: ## 5. Make sure this process is running from user=www ## 52: ## 6. Check if other instance is running ## 53: ## 7. POD (plain old documentation, CPAN style) ## 54: ## ## 55: ############################################################################### 56: 57: use lib '/home/httpd/lib/perl/'; 58: use LONCAPA::Configuration; 59: 60: use IO::Socket; 61: use Symbol; 62: use POSIX; 63: use IO::Select; 64: use IO::File; 65: use Socket; 66: use Fcntl; 67: use Tie::RefHash; 68: use DBI; 69: 70: my @metalist; 71: # ----------------- Code to enable 'find' subroutine listing of the .meta files 72: require "find.pl"; 73: sub wanted { 74: (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && 75: -f _ && 76: /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ && 77: push(@metalist,"$dir/$_"); 78: } 79: 80: $childmaxattempts=10; 81: $run =0;#running counter to generate the query-id 82: 83: # -------------------------------- Read loncapa_apache.conf and loncapa.conf 84: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf', 85: 'loncapa.conf'); 86: my %perlvar=%{$perlvarref}; 87: 88: # ------------------------------------- Make sure that database can be accessed 89: { 90: my $dbh; 91: unless ( 92: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) 93: ) { 94: print "Cannot connect to database!\n"; 95: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 96: $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!"; 97: system("echo 'Cannot connect to MySQL database!' |\ 98: mailto $emailto -s '$subj' > /dev/null"); 99: exit 1; 100: } 101: else { 102: $dbh->disconnect; 103: } 104: } 105: 106: # --------------------------------------------- Check if other instance running 107: 108: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid"; 109: 110: if (-e $pidfile) { 111: my $lfh=IO::File->new("$pidfile"); 112: my $pide=<$lfh>; 113: chomp($pide); 114: if (kill 0 => $pide) { die "already running"; } 115: } 116: 117: # ------------------------------------------------------------- Read hosts file 118: $PREFORK=4; # number of children to maintain, at least four spare 119: 120: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 121: 122: while ($configline=<CONFIG>) { 123: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 124: chomp($ip); 125: 126: $hostip{$ip}=$id; 127: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } 128: 129: $PREFORK++; 130: } 131: close(CONFIG); 132: 133: $PREFORK=int($PREFORK/4); 134: 135: $unixsock = "mysqlsock"; 136: my $localfile="$perlvar{'lonSockDir'}/$unixsock"; 137: my $server; 138: unlink ($localfile); 139: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile", 140: Type => SOCK_STREAM, 141: Listen => 10)) 142: { 143: print "in socket error:$@\n"; 144: } 145: 146: # -------------------------------------------------------- Routines for forking 147: # global variables 148: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process 149: %children = (); # keys are current child process IDs 150: $children = 0; # current number of children 151: 152: sub REAPER { # takes care of dead children 153: $SIG{CHLD} = \&REAPER; 154: my $pid = wait; 155: $children --; 156: &logthis("Child $pid died"); 157: delete $children{$pid}; 158: } 159: 160: sub HUNTSMAN { # signal handler for SIGINT 161: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 162: kill 'INT' => keys %children; 163: my $execdir=$perlvar{'lonDaemons'}; 164: unlink("$execdir/logs/lonsql.pid"); 165: &logthis("<font color=red>CRITICAL: Shutting down</font>"); 166: $unixsock = "mysqlsock"; 167: my $port="$perlvar{'lonSockDir'}/$unixsock"; 168: unlink(port); 169: exit; # clean up with dignity 170: } 171: 172: sub HUPSMAN { # signal handler for SIGHUP 173: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 174: kill 'INT' => keys %children; 175: close($server); # free up socket 176: &logthis("<font color=red>CRITICAL: Restarting</font>"); 177: my $execdir=$perlvar{'lonDaemons'}; 178: $unixsock = "mysqlsock"; 179: my $port="$perlvar{'lonSockDir'}/$unixsock"; 180: unlink(port); 181: exec("$execdir/lonsql"); # here we go again 182: } 183: 184: sub logthis { 185: my $message=shift; 186: my $execdir=$perlvar{'lonDaemons'}; 187: my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log"); 188: my $now=time; 189: my $local=localtime($now); 190: print $fh "$local ($$): $message\n"; 191: } 192: 193: # ------------------------------------------------------------------ Course log 194: 195: sub courselog { 196: my ($path,$command)=@_; 197: my %filters=(); 198: foreach (split(/\=/,&unescape($command))) { 199: my ($name,$value)=split(/\=/,$_); 200: $filters{$name}=$value; 201: } 202: my @results=(); 203: open(IN,$path.'/activity.log') or return ('file_error'); 204: while ($line=<IN>) { 205: chomp($line); 206: my ($timestamp,$host,$log)=split(/\:/,$line); 207: foreach (split(/\&/,&unescape($log))) { 208: my ($res,$uname,$udom,$action,$values)=split(/\:/,$_); 209: my $include=1; 210: } 211: } 212: close IN; 213: return join('&',sort(@results)); 214: } 215: 216: # -------------------------------------------------------------------- User log 217: 218: sub userlog { 219: my ($path,$command)=@_; 220: my %filters=(); 221: foreach (split(/\=/,&unescape($command))) { 222: my ($name,$value)=split(/\=/,$_); 223: $filters{$name}=$value; 224: } 225: my @results=(); 226: open(IN,$path.'/activity.log') or return ('file_error'); 227: while ($line=<IN>) { 228: chomp($line); 229: my ($timestamp,$host,$log)=split(/\:/,$line); 230: $log=&unescape($log); 231: my $include=1; 232: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; } 233: if ($include) { 234: push(@results,$timestamp.':'.$log); 235: } 236: } 237: close IN; 238: return join('&',sort(@results)); 239: } 240: 241: 242: # ---------------------------------------------------- Fork once and dissociate 243: $fpid=fork; 244: exit if $fpid; 245: die "Couldn't fork: $!" unless defined ($fpid); 246: 247: POSIX::setsid() or die "Can't start new session: $!"; 248: 249: # ------------------------------------------------------- Write our PID on disk 250: 251: $execdir=$perlvar{'lonDaemons'}; 252: open (PIDSAVE,">$execdir/logs/lonsql.pid"); 253: print PIDSAVE "$$\n"; 254: close(PIDSAVE); 255: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); 256: 257: # ----------------------------- Ignore signals generated during initial startup 258: $SIG{HUP}=$SIG{USR1}='IGNORE'; 259: # ------------------------------------------------------- Now we are on our own 260: # Fork off our children. 261: for (1 .. $PREFORK) { 262: make_new_child(); 263: } 264: 265: # Install signal handlers. 266: $SIG{CHLD} = \&REAPER; 267: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 268: $SIG{HUP} = \&HUPSMAN; 269: 270: # And maintain the population. 271: while (1) { 272: sleep; # wait for a signal (i.e., child's death) 273: for ($i = $children; $i < $PREFORK; $i++) { 274: make_new_child(); # top up the child pool 275: } 276: } 277: 278: 279: sub make_new_child { 280: my $pid; 281: my $sigset; 282: 283: # block signal for fork 284: $sigset = POSIX::SigSet->new(SIGINT); 285: sigprocmask(SIG_BLOCK, $sigset) 286: or die "Can't block SIGINT for fork: $!\n"; 287: 288: die "fork: $!" unless defined ($pid = fork); 289: 290: if ($pid) { 291: # Parent records the child's birth and returns. 292: sigprocmask(SIG_UNBLOCK, $sigset) 293: or die "Can't unblock SIGINT for fork: $!\n"; 294: $children{$pid} = 1; 295: $children++; 296: return; 297: } else { 298: # Child can *not* return from this subroutine. 299: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 300: 301: # unblock signals 302: sigprocmask(SIG_UNBLOCK, $sigset) 303: or die "Can't unblock SIGINT for fork: $!\n"; 304: 305: 306: #open database handle 307: # making dbh global to avoid garbage collector 308: unless ( 309: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) 310: ) { 311: sleep(10+int(rand(20))); 312: &logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>"); 313: print "database handle error\n"; 314: exit; 315: 316: }; 317: # make sure that a database disconnection occurs with ending kill signals 318: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; 319: 320: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD 321: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { 322: $client = $server->accept() or last; 323: 324: # do something with the connection 325: $run = $run+1; 326: my $userinput = <$client>; 327: chomp($userinput); 328: 329: my ($conserver,$query, 330: $arg1,$arg2,$arg3)=split(/&/,$userinput); 331: my $query=unescape($query); 332: 333: #send query id which is pid_unixdatetime_runningcounter 334: $queryid = $thisserver; 335: $queryid .="_".($$)."_"; 336: $queryid .= time."_"; 337: $queryid .= $run; 338: print $client "$queryid\n"; 339: 340: &logthis("QUERY: $query"); 341: sleep 1; 342: 343: my $result=''; 344: 345: # ---------- At this point, query is received, query-ID assigned and sent back 346: # $query eq 'logquery' will mean that this is a query against log-files 347: 348: 349: if (($query eq 'userlog') || ($query eq 'courselog')) { 350: # ----------------------------------------------------- beginning of log query 351: # 352: # this goes against a user's log file 353: # 354: my $udom=&unescape($arg1); 355: my $uname=&unescape($arg2); 356: my $command=&unescape($arg3); 357: my $path=&propath($udom,$uname); 358: if (-e "$path/activity.log") { 359: if ($query eq 'userlog') { 360: $result=&userlog($path,$command); 361: } else { 362: $result=&courselog($path,$command); 363: } 364: } else { 365: &logthis('Unable to do log query: '.$uname.'@'.$udom); 366: $result='no_such_file'; 367: } 368: # ------------------------------------------------------------ end of log query 369: } else { 370: # -------------------------------------------------------- This is an sql query 371: my $custom=unescape($arg1); 372: my $customshow=unescape($arg2); 373: #prepare and execute the query 374: my $sth = $dbh->prepare($query); 375: 376: my @files; 377: my $subsetflag=0; 378: if ($query) { 379: unless ($sth->execute()) 380: { 381: &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>"); 382: $result=""; 383: } 384: else { 385: my $r1=$sth->fetchall_arrayref; 386: my @r2; 387: foreach (@$r1) {my $a=$_; 388: my @b=map {escape($_)} @$a; 389: push @files,@{$a}[3]; 390: push @r2,join(",", @b) 391: } 392: $result=join("&",@r2); 393: } 394: } 395: # do custom metadata searching here and build into result 396: if ($custom or $customshow) { 397: &logthis("am going to do custom query for $custom"); 398: if ($query) { 399: @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files; 400: } 401: else { 402: @metalist=(); pop @metalist; 403: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"); 404: my @homeusers=grep 405: {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")} 406: grep {!/^\.\.?$/} readdir(RESOURCES); 407: closedir RESOURCES; 408: foreach my $user (@homeusers) { 409: &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user"); 410: } 411: } 412: # &logthis("FILELIST:" . join(":::",@metalist)); 413: # if file is indicated in sql database and 414: # not part of sql-relevant query, do not pattern match. 415: # if file is not in sql database, output error. 416: # if file is indicated in sql database and is 417: # part of query result list, then do the pattern match. 418: my $customresult=''; 419: my @r2; 420: foreach my $m (@metalist) { 421: my $fh=IO::File->new($m); 422: my @lines=<$fh>; 423: my $stuff=join('',@lines); 424: if ($stuff=~/$custom/s) { 425: foreach my $f ('abstract','author','copyright', 426: 'creationdate','keywords','language', 427: 'lastrevisiondate','mime','notes', 428: 'owner','subject','title') { 429: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s; 430: } 431: my $m2=$m; my $docroot=$perlvar{'lonDocRoot'}; 432: $m2=~s/^$docroot//; 433: $m2=~s/\.meta$//; 434: unless ($query) { 435: my $q2="select * from metadata where url like binary '$m2'"; 436: my $sth = $dbh->prepare($q2); 437: $sth->execute(); 438: my $r1=$sth->fetchall_arrayref; 439: foreach (@$r1) {my $a=$_; 440: my @b=map {escape($_)} @$a; 441: push @files,@{$a}[3]; 442: push @r2,join(",", @b) 443: } 444: } 445: # &logthis("found: $stuff"); 446: $customresult.='&custom='.escape($m2).','.escape($stuff); 447: } 448: } 449: $result=join("&",@r2) unless $query; 450: $result.=$customresult; 451: } 452: # ------------------------------------------------------------ end of sql query 453: } 454: 455: # result does need to be escaped 456: 457: $result=&escape($result); 458: 459: # reply with result, append \n unless already there 460: 461: $result.="\n" unless ($result=~/\n$/); 462: &reply("queryreply:$queryid:$result",$conserver); 463: 464: } 465: 466: # tidy up gracefully and finish 467: 468: #close the database handle 469: $dbh->disconnect 470: or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>"); 471: 472: # this exit is VERY important, otherwise the child will become 473: # a producer of more and more children, forking yourself into 474: # process death. 475: exit; 476: } 477: } 478: 479: sub DISCONNECT { 480: $dbh->disconnect or 481: &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>"); 482: exit; 483: } 484: 485: # -------------------------------------------------- Non-critical communication 486: 487: sub subreply { 488: my ($cmd,$server)=@_; 489: my $peerfile="$perlvar{'lonSockDir'}/$server"; 490: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 491: Type => SOCK_STREAM, 492: Timeout => 10) 493: or return "con_lost"; 494: print $sclient "$cmd\n"; 495: my $answer=<$sclient>; 496: chomp($answer); 497: if (!$answer) { $answer="con_lost"; } 498: return $answer; 499: } 500: 501: sub reply { 502: my ($cmd,$server)=@_; 503: my $answer; 504: if ($server ne $perlvar{'lonHostID'}) { 505: $answer=subreply($cmd,$server); 506: if ($answer eq 'con_lost') { 507: $answer=subreply("ping",$server); 508: $answer=subreply($cmd,$server); 509: } 510: } else { 511: $answer='self_reply'; 512: $answer=subreply($cmd,$server); 513: } 514: return $answer; 515: } 516: 517: # -------------------------------------------------------- Escape Special Chars 518: 519: sub escape { 520: my $str=shift; 521: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 522: return $str; 523: } 524: 525: # ----------------------------------------------------- Un-Escape Special Chars 526: 527: sub unescape { 528: my $str=shift; 529: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 530: return $str; 531: } 532: 533: # --------------------------------------- Is this the home server of an author? 534: # (copied from lond, modification of the return value) 535: sub ishome { 536: my $author=shift; 537: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 538: my ($udom,$uname)=split(/\//,$author); 539: my $proname=propath($udom,$uname); 540: if (-e $proname) { 541: return 1; 542: } else { 543: return 0; 544: } 545: } 546: 547: # -------------------------------------------- Return path to profile directory 548: # (copied from lond) 549: sub propath { 550: my ($udom,$uname)=@_; 551: $udom=~s/\W//g; 552: $uname=~s/\W//g; 553: my $subdir=$uname.'__'; 554: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 555: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 556: return $proname; 557: } 558: 559: # ----------------------------------- POD (plain old documentation, CPAN style) 560: 561: =head1 NAME 562: 563: lonsql - LON TCP-MySQL-Server Daemon for handling database requests. 564: 565: =head1 SYNOPSIS 566: 567: This script should be run as user=www. The following is an example invocation 568: from the loncron script. Note that a lonsql.pid file contains the pid of 569: the parent process. 570: 571: if (-e $lonsqlfile) { 572: my $lfh=IO::File->new("$lonsqlfile"); 573: my $lonsqlpid=<$lfh>; 574: chomp($lonsqlpid); 575: if (kill 0 => $lonsqlpid) { 576: print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>"; 577: $restartflag=0; 578: } else { 579: $errors++; $errors++; 580: print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>"; 581: $restartflag=1; 582: print $fh 583: "<h3>Decided to clean up stale .pid file and restart lonsql</h3>"; 584: } 585: } 586: if ($restartflag==1) { 587: $errors++; 588: print $fh '<br><font color="red">Killall lonsql: '. 589: system('killall lonsql').' - '; 590: sleep 60; 591: print $fh unlink($lonsqlfile).' - '. 592: system('killall -9 lonsql'). 593: '</font><br>'; 594: print $fh "<h3>lonsql not running, trying to start</h3>"; 595: system( 596: "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors"); 597: sleep 10; 598: 599: =head1 DESCRIPTION 600: 601: Not yet written. 602: 603: =head1 README 604: 605: Not yet written. 606: 607: =head1 PREREQUISITES 608: 609: IO::Socket 610: Symbol 611: POSIX 612: IO::Select 613: IO::File 614: Socket 615: Fcntl 616: Tie::RefHash 617: DBI 618: 619: =head1 COREQUISITES 620: 621: =head1 OSNAMES 622: 623: linux 624: 625: =head1 SCRIPT CATEGORIES 626: 627: Server/Process 628: 629: =cut

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.