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>