loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.45: download - view: text, annotated - select for diffs
Mon Jun 17 20:25:51 2002 UTC (22 years ago) by www
Branches: MAIN
CVS tags: HEAD

New routines for userlog and courselog queries.

BUGFIX: $result had the wrong scope.

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.45 2002/06/17 20:25:51 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: 194: 195: # -------------------------------------------- Return path to profile directory 196: 197: sub propath { 198: my ($udom,$uname)=@_; 199: $udom=~s/\W//g; 200: $uname=~s/\W//g; 201: my $subdir=$uname.'__'; 202: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 203: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 204: return $proname; 205: } 206: 207: # ------------------------------------------------------------------ Course log 208: 209: sub courselog { 210: my ($path,$command)=@_; 211: return 'not_yet_implemented'; 212: } 213: 214: # -------------------------------------------------------------------- User log 215: 216: sub userlog { 217: my ($path,$command)=@_; 218: return 'not_yet_implemented'; 219: } 220: 221: 222: # ---------------------------------------------------- Fork once and dissociate 223: $fpid=fork; 224: exit if $fpid; 225: die "Couldn't fork: $!" unless defined ($fpid); 226: 227: POSIX::setsid() or die "Can't start new session: $!"; 228: 229: # ------------------------------------------------------- Write our PID on disk 230: 231: $execdir=$perlvar{'lonDaemons'}; 232: open (PIDSAVE,">$execdir/logs/lonsql.pid"); 233: print PIDSAVE "$$\n"; 234: close(PIDSAVE); 235: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); 236: 237: # ----------------------------- Ignore signals generated during initial startup 238: $SIG{HUP}=$SIG{USR1}='IGNORE'; 239: # ------------------------------------------------------- Now we are on our own 240: # Fork off our children. 241: for (1 .. $PREFORK) { 242: make_new_child(); 243: } 244: 245: # Install signal handlers. 246: $SIG{CHLD} = \&REAPER; 247: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 248: $SIG{HUP} = \&HUPSMAN; 249: 250: # And maintain the population. 251: while (1) { 252: sleep; # wait for a signal (i.e., child's death) 253: for ($i = $children; $i < $PREFORK; $i++) { 254: make_new_child(); # top up the child pool 255: } 256: } 257: 258: 259: sub make_new_child { 260: my $pid; 261: my $sigset; 262: 263: # block signal for fork 264: $sigset = POSIX::SigSet->new(SIGINT); 265: sigprocmask(SIG_BLOCK, $sigset) 266: or die "Can't block SIGINT for fork: $!\n"; 267: 268: die "fork: $!" unless defined ($pid = fork); 269: 270: if ($pid) { 271: # Parent records the child's birth and returns. 272: sigprocmask(SIG_UNBLOCK, $sigset) 273: or die "Can't unblock SIGINT for fork: $!\n"; 274: $children{$pid} = 1; 275: $children++; 276: return; 277: } else { 278: # Child can *not* return from this subroutine. 279: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before 280: 281: # unblock signals 282: sigprocmask(SIG_UNBLOCK, $sigset) 283: or die "Can't unblock SIGINT for fork: $!\n"; 284: 285: 286: #open database handle 287: # making dbh global to avoid garbage collector 288: unless ( 289: $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) 290: ) { 291: sleep(10+int(rand(20))); 292: &logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>"); 293: print "database handle error\n"; 294: exit; 295: 296: }; 297: # make sure that a database disconnection occurs with ending kill signals 298: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; 299: 300: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD 301: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { 302: $client = $server->accept() or last; 303: 304: # do something with the connection 305: $run = $run+1; 306: my $userinput = <$client>; 307: chomp($userinput); 308: 309: my ($conserver,$query, 310: $arg1,$arg2,$arg3)=split(/&/,$userinput); 311: my $query=unescape($query); 312: 313: #send query id which is pid_unixdatetime_runningcounter 314: $queryid = $thisserver; 315: $queryid .="_".($$)."_"; 316: $queryid .= time."_"; 317: $queryid .= $run; 318: print $client "$queryid\n"; 319: 320: &logthis("QUERY: $query"); 321: sleep 1; 322: 323: my $result=''; 324: 325: # ---------- At this point, query is received, query-ID assigned and sent back 326: # $query eq 'logquery' will mean that this is a query against log-files 327: 328: 329: if (($query eq 'userlog') || ($query eq 'courselog')) { 330: # ----------------------------------------------------- beginning of log query 331: # 332: # this goes against a user's log file 333: # 334: my $udom=&unescape($arg1); 335: my $uname=&unescape($arg2); 336: my $command=&unescape($arg3); 337: my $path=&propath($udom,$uname); 338: if (-e "$path/activity.log") { 339: if ($query eq 'userlog') { 340: $result=&userlog($path,$command); 341: } else { 342: $result=&courselog($path,$command); 343: } 344: } else { 345: &logthis('Unable to do log query: '.$uname.'@'.$udom); 346: $result='no_such_file'; 347: } 348: # ------------------------------------------------------------ end of log query 349: } else { 350: # -------------------------------------------------------- This is an sql query 351: my $custom=unescape($arg1); 352: my $customshow=unescape($arg2); 353: #prepare and execute the query 354: my $sth = $dbh->prepare($query); 355: 356: my @files; 357: my $subsetflag=0; 358: if ($query) { 359: unless ($sth->execute()) 360: { 361: &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>"); 362: $result=""; 363: } 364: else { 365: my $r1=$sth->fetchall_arrayref; 366: my @r2; 367: foreach (@$r1) {my $a=$_; 368: my @b=map {escape($_)} @$a; 369: push @files,@{$a}[3]; 370: push @r2,join(",", @b) 371: } 372: $result=join("&",@r2); 373: } 374: } 375: # do custom metadata searching here and build into result 376: if ($custom or $customshow) { 377: &logthis("am going to do custom query for $custom"); 378: if ($query) { 379: @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files; 380: } 381: else { 382: @metalist=(); pop @metalist; 383: opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}"); 384: my @homeusers=grep 385: {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")} 386: grep {!/^\.\.?$/} readdir(RESOURCES); 387: closedir RESOURCES; 388: foreach my $user (@homeusers) { 389: &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user"); 390: } 391: } 392: # &logthis("FILELIST:" . join(":::",@metalist)); 393: # if file is indicated in sql database and 394: # not part of sql-relevant query, do not pattern match. 395: # if file is not in sql database, output error. 396: # if file is indicated in sql database and is 397: # part of query result list, then do the pattern match. 398: my $customresult=''; 399: my @r2; 400: foreach my $m (@metalist) { 401: my $fh=IO::File->new($m); 402: my @lines=<$fh>; 403: my $stuff=join('',@lines); 404: if ($stuff=~/$custom/s) { 405: foreach my $f ('abstract','author','copyright', 406: 'creationdate','keywords','language', 407: 'lastrevisiondate','mime','notes', 408: 'owner','subject','title') { 409: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s; 410: } 411: my $m2=$m; my $docroot=$perlvar{'lonDocRoot'}; 412: $m2=~s/^$docroot//; 413: $m2=~s/\.meta$//; 414: unless ($query) { 415: my $q2="select * from metadata where url like binary '$m2'"; 416: my $sth = $dbh->prepare($q2); 417: $sth->execute(); 418: my $r1=$sth->fetchall_arrayref; 419: foreach (@$r1) {my $a=$_; 420: my @b=map {escape($_)} @$a; 421: push @files,@{$a}[3]; 422: push @r2,join(",", @b) 423: } 424: } 425: # &logthis("found: $stuff"); 426: $customresult.='&custom='.escape($m2).','.escape($stuff); 427: } 428: } 429: $result=join("&",@r2) unless $query; 430: $result.=$customresult; 431: } 432: # ------------------------------------------------------------ end of sql query 433: } 434: # reply with result, append \n unless already there 435: 436: $result.="\n" unless ($result=~/\n$/); 437: &reply("queryreply:$queryid:$result",$conserver); 438: 439: } 440: 441: # tidy up gracefully and finish 442: 443: #close the database handle 444: $dbh->disconnect 445: or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>"); 446: 447: # this exit is VERY important, otherwise the child will become 448: # a producer of more and more children, forking yourself into 449: # process death. 450: exit; 451: } 452: } 453: 454: sub DISCONNECT { 455: $dbh->disconnect or 456: &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>"); 457: exit; 458: } 459: 460: # -------------------------------------------------- Non-critical communication 461: 462: sub subreply { 463: my ($cmd,$server)=@_; 464: my $peerfile="$perlvar{'lonSockDir'}/$server"; 465: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 466: Type => SOCK_STREAM, 467: Timeout => 10) 468: or return "con_lost"; 469: print $sclient "$cmd\n"; 470: my $answer=<$sclient>; 471: chomp($answer); 472: if (!$answer) { $answer="con_lost"; } 473: return $answer; 474: } 475: 476: sub reply { 477: my ($cmd,$server)=@_; 478: my $answer; 479: if ($server ne $perlvar{'lonHostID'}) { 480: $answer=subreply($cmd,$server); 481: if ($answer eq 'con_lost') { 482: $answer=subreply("ping",$server); 483: $answer=subreply($cmd,$server); 484: } 485: } else { 486: $answer='self_reply'; 487: $answer=subreply($cmd,$server); 488: } 489: return $answer; 490: } 491: 492: # -------------------------------------------------------- Escape Special Chars 493: 494: sub escape { 495: my $str=shift; 496: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 497: return $str; 498: } 499: 500: # ----------------------------------------------------- Un-Escape Special Chars 501: 502: sub unescape { 503: my $str=shift; 504: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 505: return $str; 506: } 507: 508: # --------------------------------------- Is this the home server of an author? 509: # (copied from lond, modification of the return value) 510: sub ishome { 511: my $author=shift; 512: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; 513: my ($udom,$uname)=split(/\//,$author); 514: my $proname=propath($udom,$uname); 515: if (-e $proname) { 516: return 1; 517: } else { 518: return 0; 519: } 520: } 521: 522: # -------------------------------------------- Return path to profile directory 523: # (copied from lond) 524: sub propath { 525: my ($udom,$uname)=@_; 526: $udom=~s/\W//g; 527: $uname=~s/\W//g; 528: my $subdir=$uname.'__'; 529: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; 530: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; 531: return $proname; 532: } 533: 534: # ----------------------------------- POD (plain old documentation, CPAN style) 535: 536: =head1 NAME 537: 538: lonsql - LON TCP-MySQL-Server Daemon for handling database requests. 539: 540: =head1 SYNOPSIS 541: 542: This script should be run as user=www. The following is an example invocation 543: from the loncron script. Note that a lonsql.pid file contains the pid of 544: the parent process. 545: 546: if (-e $lonsqlfile) { 547: my $lfh=IO::File->new("$lonsqlfile"); 548: my $lonsqlpid=<$lfh>; 549: chomp($lonsqlpid); 550: if (kill 0 => $lonsqlpid) { 551: print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>"; 552: $restartflag=0; 553: } else { 554: $errors++; $errors++; 555: print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>"; 556: $restartflag=1; 557: print $fh 558: "<h3>Decided to clean up stale .pid file and restart lonsql</h3>"; 559: } 560: } 561: if ($restartflag==1) { 562: $errors++; 563: print $fh '<br><font color="red">Killall lonsql: '. 564: system('killall lonsql').' - '; 565: sleep 60; 566: print $fh unlink($lonsqlfile).' - '. 567: system('killall -9 lonsql'). 568: '</font><br>'; 569: print $fh "<h3>lonsql not running, trying to start</h3>"; 570: system( 571: "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors"); 572: sleep 10; 573: 574: =head1 DESCRIPTION 575: 576: Not yet written. 577: 578: =head1 README 579: 580: Not yet written. 581: 582: =head1 PREREQUISITES 583: 584: IO::Socket 585: Symbol 586: POSIX 587: IO::Select 588: IO::File 589: Socket 590: Fcntl 591: Tie::RefHash 592: DBI 593: 594: =head1 COREQUISITES 595: 596: =head1 OSNAMES 597: 598: linux 599: 600: =head1 SCRIPT CATEGORIES 601: 602: Server/Process 603: 604: =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.