loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.44: download - view: text, annotated - select for diffs
Mon Jun 17 14:00:09 2002 UTC (21 years, 10 months ago) by www
Branches: MAIN
CVS tags: HEAD

Towards bug 121

If the query command is 'logquery' instead of an SQL command, lonsql will
go into another program block. Functionality to query logs should be
implemented there.

Also bugfix: a query-reply must ALWAYS have an "\n" in the end, or the
remote end will wait forever. Previous statement "append if $result" might
lead to lengthy timeout results if database is offline.

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