Annotation of nsdl/lonsql, revision 1.1
1.1 ! www 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.67 2005/04/13 18:39:13 albertel 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("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
! 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("<font color='blue'>WARNING: Couldn't connect to database".
! 374: ": $@</font>");
! 375: # "($st secs): $@</font>");
! 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: # retrieve institutional class lists
! 428: my $dom = &unescape($arg1);
! 429: my %affiliates = ();
! 430: my %replies = ();
! 431: my $locresult = '';
! 432: my $querystr = &unescape($arg3);
! 433: foreach (split/%%/,$querystr) {
! 434: if (/^(\w+)=([^=]+)$/) {
! 435: @{$affiliates{$1}} = split/,/,$2;
! 436: }
! 437: }
! 438: $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);
! 439: $result = &escape($locresult.':');
! 440: if ($locresult) {
! 441: $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));
! 442: }
! 443: } elsif ($query eq 'prepare activity log') {
! 444: my ($cid,$domain) = map {&unescape($_);} ($arg1,$arg2);
! 445: &logthis('preparing activity log tables for '.$cid);
! 446: my $command =
! 447: qq{$perlvar{'lonDaemons'}/parse_activity_log.pl -course=$cid -domain=$domain};
! 448: system($command);
! 449: &logthis($command);
! 450: my $returnvalue = $?>>8;
! 451: if ($returnvalue) {
! 452: $result = 'error: parse_activity_log.pl returned '.
! 453: $returnvalue;
! 454: } else {
! 455: $result = 'success';
! 456: }
! 457: } else {
! 458: # Do an sql query
! 459: $result = &do_sql_query($query,$arg1,$arg2);
! 460: }
! 461: # result does not need to be escaped because it has already been
! 462: # escaped.
! 463: #$result=&escape($result);
! 464: &reply("queryreply:$queryid:$result",$conserver);
! 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".
! 471: " from database $DBI::errstr : $@</font>");
! 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: ########################################################
! 480: ########################################################
! 481:
! 482: =pod
! 483:
! 484: =item &do_sql_query
! 485:
! 486: Runs an sql metadata table query.
! 487:
! 488: Inputs: $query, $custom, $customshow
! 489:
! 490: Returns: A string containing escaped results.
! 491:
! 492: =cut
! 493:
! 494: ########################################################
! 495: ########################################################
! 496: {
! 497: my @metalist;
! 498:
! 499: sub process_file {
! 500: if ( -e $_ && # file exists
! 501: -f $_ && # and is a normal file
! 502: /\.meta$/ && # ends in meta
! 503: ! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version
! 504: ) {
! 505: push(@metalist,$File::Find::name);
! 506: }
! 507: }
! 508:
! 509: sub do_sql_query {
! 510: my ($query,$custom,$customshow) = @_;
! 511: &logthis('doing query '.$query);
! 512: $custom = &unescape($custom);
! 513: $customshow = &unescape($customshow);
! 514: #
! 515: @metalist = ();
! 516: #
! 517: my $result = '';
! 518: my @results = ();
! 519: my @files;
! 520: my $subsetflag=0;
! 521: #
! 522: if ($query) {
! 523: #prepare and execute the query
! 524: my $sth = $dbh->prepare($query);
! 525: unless ($sth->execute()) {
! 526: &logthis('<font color="blue">'.
! 527: 'WARNING: Could not retrieve from database:'.
! 528: $sth->errstr().'</font>');
! 529: } else {
! 530: my $aref=$sth->fetchall_arrayref;
! 531: foreach my $row (@$aref) {
! 532: push @files,@{$row}[3] if ($custom or $customshow);
! 533: my @b=map { &escape($_); } @$row;
! 534: push @results,join(",", @b);
! 535: # Build up the @files array with the LON-CAPA urls
! 536: # of the resources.
! 537: }
! 538: }
! 539: }
! 540: # do custom metadata searching here and build into result
! 541: return join("&",@results) if (! ($custom or $customshow));
! 542: # Only get here if there is a custom query or custom show request
! 543: &logthis("Doing custom query for $custom");
! 544: if ($query) {
! 545: @metalist=map {
! 546: $perlvar{'lonDocRoot'}.$_.'.meta';
! 547: } @files;
! 548: } else {
! 549: my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";
! 550: @metalist=();
! 551: opendir(RESOURCES,$dir);
! 552: my @homeusers=grep {
! 553: &ishome($dir.'/'.$_);
! 554: } grep {!/^\.\.?$/} readdir(RESOURCES);
! 555: closedir RESOURCES;
! 556: # Define the
! 557: foreach my $user (@homeusers) {
! 558: find (\&process_file,$dir.'/'.$user);
! 559: }
! 560: }
! 561: # if file is indicated in sql database and
! 562: # not part of sql-relevant query, do not pattern match.
! 563: #
! 564: # if file is not in sql database, output error.
! 565: #
! 566: # if file is indicated in sql database and is
! 567: # part of query result list, then do the pattern match.
! 568: my $customresult='';
! 569: my @results;
! 570: foreach my $metafile (@metalist) {
! 571: my $fh=IO::File->new($metafile);
! 572: my @lines=<$fh>;
! 573: my $stuff=join('',@lines);
! 574: if ($stuff=~/$custom/s) {
! 575: foreach my $f ('abstract','author','copyright',
! 576: 'creationdate','keywords','language',
! 577: 'lastrevisiondate','mime','notes',
! 578: 'owner','subject','title') {
! 579: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
! 580: }
! 581: my $mfile=$metafile;
! 582: my $docroot=$perlvar{'lonDocRoot'};
! 583: $mfile=~s/^$docroot//;
! 584: $mfile=~s/\.meta$//;
! 585: unless ($query) {
! 586: my $q2="SELECT * FROM metadata WHERE url ".
! 587: " LIKE BINARY '?'";
! 588: my $sth = $dbh->prepare($q2);
! 589: $sth->execute($mfile);
! 590: my $aref=$sth->fetchall_arrayref;
! 591: foreach my $a (@$aref) {
! 592: my @b=map { &escape($_)} @$a;
! 593: push @results,join(",", @b);
! 594: }
! 595: }
! 596: # &logthis("found: $stuff");
! 597: $customresult.='&custom='.&escape($mfile).','.
! 598: escape($stuff);
! 599: }
! 600: }
! 601: $result=join("&",@results) unless $query;
! 602: $result.=$customresult;
! 603: #
! 604: return $result;
! 605: } # End of &do_sql_query
! 606:
! 607: } # End of scoping curly braces for &process_file and &do_sql_query
! 608: ########################################################
! 609: ########################################################
! 610:
! 611: =pod
! 612:
! 613: =item &logthis
! 614:
! 615: Inputs: $message, the message to log
! 616:
! 617: Returns: nothing
! 618:
! 619: Writes $message to the logfile.
! 620:
! 621: =cut
! 622:
! 623: ########################################################
! 624: ########################################################
! 625: sub logthis {
! 626: my $message=shift;
! 627: my $execdir=$perlvar{'lonDaemons'};
! 628: my $fh=IO::File->new(">>$execdir/logs/lonsql.log");
! 629: my $now=time;
! 630: my $local=localtime($now);
! 631: print $fh "$local ($$): $message\n";
! 632: }
! 633:
! 634: # -------------------------------------------------- Non-critical communication
! 635:
! 636: ########################################################
! 637: ########################################################
! 638:
! 639: =pod
! 640:
! 641: =item &subreply
! 642:
! 643: Sends a command to a server. Called only by &reply.
! 644:
! 645: Inputs: $cmd,$server
! 646:
! 647: Returns: The results of the message or 'con_lost' on error.
! 648:
! 649: =cut
! 650:
! 651: ########################################################
! 652: ########################################################
! 653: sub subreply {
! 654: my ($cmd,$server)=@_;
! 655: my $peerfile="$perlvar{'lonSockDir'}/$server";
! 656: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
! 657: Type => SOCK_STREAM,
! 658: Timeout => 10)
! 659: or return "con_lost";
! 660: print $sclient "$cmd\n";
! 661: my $answer=<$sclient>;
! 662: chomp($answer);
! 663: $answer="con_lost" if (!$answer);
! 664: return $answer;
! 665: }
! 666:
! 667: ########################################################
! 668: ########################################################
! 669:
! 670: =pod
! 671:
! 672: =item &reply
! 673:
! 674: Sends a command to a server.
! 675:
! 676: Inputs: $cmd,$server
! 677:
! 678: Returns: The results of the message or 'con_lost' on error.
! 679:
! 680: =cut
! 681:
! 682: ########################################################
! 683: ########################################################
! 684: sub reply {
! 685: my ($cmd,$server)=@_;
! 686: my $answer;
! 687: if ($server ne $perlvar{'lonHostID'}) {
! 688: $answer=subreply($cmd,$server);
! 689: if ($answer eq 'con_lost') {
! 690: $answer=subreply("ping",$server);
! 691: $answer=subreply($cmd,$server);
! 692: }
! 693: } else {
! 694: $answer='self_reply';
! 695: $answer=subreply($cmd,$server);
! 696: }
! 697: return $answer;
! 698: }
! 699:
! 700: ########################################################
! 701: ########################################################
! 702:
! 703: =pod
! 704:
! 705: =item &escape
! 706:
! 707: Escape special characters in a string.
! 708:
! 709: Inputs: string to escape
! 710:
! 711: Returns: The input string with special characters escaped.
! 712:
! 713: =cut
! 714:
! 715: ########################################################
! 716: ########################################################
! 717: sub escape {
! 718: my $str=shift;
! 719: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
! 720: return $str;
! 721: }
! 722:
! 723: ########################################################
! 724: ########################################################
! 725:
! 726: =pod
! 727:
! 728: =item &unescape
! 729:
! 730: Unescape special characters in a string.
! 731:
! 732: Inputs: string to unescape
! 733:
! 734: Returns: The input string with special characters unescaped.
! 735:
! 736: =cut
! 737:
! 738: ########################################################
! 739: ########################################################
! 740: sub unescape {
! 741: my $str=shift;
! 742: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
! 743: return $str;
! 744: }
! 745:
! 746: ########################################################
! 747: ########################################################
! 748:
! 749: =pod
! 750:
! 751: =item &ishome
! 752:
! 753: Determine if the current machine is the home server for a user.
! 754: The determination is made by checking the filesystem for the users information.
! 755:
! 756: Inputs: $author
! 757:
! 758: Returns: 0 - this is not the authors home server, 1 - this is.
! 759:
! 760: =cut
! 761:
! 762: ########################################################
! 763: ########################################################
! 764: sub ishome {
! 765: my $author=shift;
! 766: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
! 767: my ($udom,$uname)=split(/\//,$author);
! 768: my $proname=propath($udom,$uname);
! 769: if (-e $proname) {
! 770: return 1;
! 771: } else {
! 772: return 0;
! 773: }
! 774: }
! 775:
! 776: ########################################################
! 777: ########################################################
! 778:
! 779: =pod
! 780:
! 781: =item &propath
! 782:
! 783: Inputs: user name, user domain
! 784:
! 785: Returns: The full path to the users directory.
! 786:
! 787: =cut
! 788:
! 789: ########################################################
! 790: ########################################################
! 791: sub propath {
! 792: my ($udom,$uname)=@_;
! 793: $udom=~s/\W//g;
! 794: $uname=~s/\W//g;
! 795: my $subdir=$uname.'__';
! 796: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
! 797: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
! 798: return $proname;
! 799: }
! 800:
! 801: ########################################################
! 802: ########################################################
! 803:
! 804: =pod
! 805:
! 806: =item &courselog
! 807:
! 808: Inputs: $path, $command
! 809:
! 810: Returns: unescaped string of values.
! 811:
! 812: =cut
! 813:
! 814: ########################################################
! 815: ########################################################
! 816: sub courselog {
! 817: my ($path,$command)=@_;
! 818: my %filters=();
! 819: foreach (split(/\:/,&unescape($command))) {
! 820: my ($name,$value)=split(/\=/,$_);
! 821: $filters{$name}=$value;
! 822: }
! 823: my @results=();
! 824: open(IN,$path.'/activity.log') or return ('file_error');
! 825: while (my $line=<IN>) {
! 826: chomp($line);
! 827: my ($timestamp,$host,$log)=split(/\:/,$line);
! 828: #
! 829: # $log has the actual log entries; currently still escaped, and
! 830: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
! 831: # then additionally
! 832: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
! 833: # or
! 834: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
! 835: #
! 836: # get delimiter between timestamped entries to be &&&
! 837: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
! 838: # now go over all log entries
! 839: foreach (split(/\&\&\&/,&unescape($log))) {
! 840: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
! 841: my $values=&unescape(join(':',@values));
! 842: $values=~s/\&/\:/g;
! 843: $res=&unescape($res);
! 844: my $include=1;
! 845: if (($filters{'username'}) && ($uname ne $filters{'username'}))
! 846: { $include=0; }
! 847: if (($filters{'domain'}) && ($udom ne $filters{'domain'}))
! 848: { $include=0; }
! 849: if (($filters{'url'}) && ($res!~/$filters{'url'}/))
! 850: { $include=0; }
! 851: if (($filters{'start'}) && ($time<$filters{'start'}))
! 852: { $include=0; }
! 853: if (($filters{'end'}) && ($time>$filters{'end'}))
! 854: { $include=0; }
! 855: if (($filters{'action'} eq 'view') && ($action))
! 856: { $include=0; }
! 857: if (($filters{'action'} eq 'submit') && ($action ne 'POST'))
! 858: { $include=0; }
! 859: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE'))
! 860: { $include=0; }
! 861: if ($include) {
! 862: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
! 863: $uname.':'.$udom.':'.
! 864: $action.':'.$values);
! 865: }
! 866: }
! 867: }
! 868: close IN;
! 869: return join('&',sort(@results));
! 870: }
! 871:
! 872: ########################################################
! 873: ########################################################
! 874:
! 875: =pod
! 876:
! 877: =item &userlog
! 878:
! 879: Inputs: $path, $command
! 880:
! 881: Returns: unescaped string of values.
! 882:
! 883: =cut
! 884:
! 885: ########################################################
! 886: ########################################################
! 887: sub userlog {
! 888: my ($path,$command)=@_;
! 889: my %filters=();
! 890: foreach (split(/\:/,&unescape($command))) {
! 891: my ($name,$value)=split(/\=/,$_);
! 892: $filters{$name}=$value;
! 893: }
! 894: my @results=();
! 895: open(IN,$path.'/activity.log') or return ('file_error');
! 896: while (my $line=<IN>) {
! 897: chomp($line);
! 898: my ($timestamp,$host,$log)=split(/\:/,$line);
! 899: $log=&unescape($log);
! 900: my $include=1;
! 901: if (($filters{'start'}) && ($timestamp<$filters{'start'}))
! 902: { $include=0; }
! 903: if (($filters{'end'}) && ($timestamp>$filters{'end'}))
! 904: { $include=0; }
! 905: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
! 906: if (($filters{'action'} eq 'check') && ($log!~/^Check/))
! 907: { $include=0; }
! 908: if ($include) {
! 909: push(@results,$timestamp.':'.$log);
! 910: }
! 911: }
! 912: close IN;
! 913: return join('&',sort(@results));
! 914: }
! 915:
! 916: ########################################################
! 917: ########################################################
! 918:
! 919: =pod
! 920:
! 921: =item Functions required for forking
! 922:
! 923: =over 4
! 924:
! 925: =item REAPER
! 926:
! 927: REAPER takes care of dead children.
! 928:
! 929: =item HUNTSMAN
! 930:
! 931: Signal handler for SIGINT.
! 932:
! 933: =item HUPSMAN
! 934:
! 935: Signal handler for SIGHUP
! 936:
! 937: =item DISCONNECT
! 938:
! 939: Disconnects from database.
! 940:
! 941: =back
! 942:
! 943: =cut
! 944:
! 945: ########################################################
! 946: ########################################################
! 947: sub REAPER { # takes care of dead children
! 948: $SIG{CHLD} = \&REAPER;
! 949: my $pid = wait;
! 950: $children --;
! 951: &logthis("Child $pid died");
! 952: delete $children{$pid};
! 953: }
! 954:
! 955: sub HUNTSMAN { # signal handler for SIGINT
! 956: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
! 957: kill 'INT' => keys %children;
! 958: my $execdir=$perlvar{'lonDaemons'};
! 959: unlink("$execdir/logs/lonsql.pid");
! 960: &logthis("<font color='red'>CRITICAL: Shutting down</font>");
! 961: $unixsock = "mysqlsock";
! 962: my $port="$perlvar{'lonSockDir'}/$unixsock";
! 963: unlink($port);
! 964: exit; # clean up with dignity
! 965: }
! 966:
! 967: sub HUPSMAN { # signal handler for SIGHUP
! 968: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
! 969: kill 'INT' => keys %children;
! 970: close($server); # free up socket
! 971: &logthis("<font color='red'>CRITICAL: Restarting</font>");
! 972: my $execdir=$perlvar{'lonDaemons'};
! 973: $unixsock = "mysqlsock";
! 974: my $port="$perlvar{'lonSockDir'}/$unixsock";
! 975: unlink($port);
! 976: exec("$execdir/lonsql"); # here we go again
! 977: }
! 978:
! 979: sub DISCONNECT {
! 980: $dbh->disconnect or
! 981: &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".
! 982: " $DBI::errstr : $@</font>");
! 983: exit;
! 984: }
! 985:
! 986:
! 987: =pod
! 988:
! 989: =back
! 990:
! 991: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonsql CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / nsdl