File:  [LON-CAPA] / loncom / lonsql
Revision 1.62: download - view: text, annotated - select for diffs
Tue Jun 8 22:09:44 2004 UTC (19 years, 9 months ago) by raeburn
Branches: MAIN
CVS tags: version_1_1_99_5, version_1_1_99_4, version_1_1_99_3, version_1_1_99_2, version_1_1_99_1, HEAD
Changes to support autoenroll calls from a remote server.

lond on the homeserver for the course(s) handles requests from the remote
server for institutional data (e.g., classlists, valid institutional courseIDs,
institutional section numbers for a course code, validation of course owners), by
calling the appropriate functions in the homeserver's localenroll.pm

All replies are made directly with the exception of fetch_enrollment_query, which
is shipped over to lonsql, in case retrieval of institutional classlists is a
protracted process.

lonsql on the homeserver for the course(s) calls localenroll::fetch_enrollment()
and writes XML files of enrollment data to /home/httpd/perl/tmp

Transfer of classlist data occurs later following an autoretrieve call from the
remote server. It is planned to generalize this function and add encryption to the transfer back to the client.

Autoenroll.pl called by cron on a library server, now only carries out updates for
courses in its domain, for which the library server is the course's homeserver. If a domain has multiple library servers Autoenroll.pl will need to be run on each library server.

    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.62 2004/06/08 22:09:44 raeburn 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: # Make sure that database can be accessed
  210: #
  211: my $dbh;
  212: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
  213:                             $perlvar{'lonSqlAccess'},
  214:                             { RaiseError =>0,PrintError=>0})) { 
  215:     print "Cannot connect to database!\n";
  216:     my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
  217:     my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
  218:     system("echo 'Cannot connect to MySQL database!' |".
  219:            " mailto $emailto -s '$subj' > /dev/null");
  220: 
  221:     open(SMP,'>/home/httpd/html/lon-status/mysql.txt');
  222:     print SMP 'time='.time.'&mysql=defunct'."\n";
  223:     close(SMP);
  224: 
  225:     exit 1;
  226: } else {
  227:     $dbh->disconnect;
  228: }
  229: 
  230: #
  231: # Check if other instance running
  232: #
  233: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
  234: if (-e $pidfile) {
  235:    my $lfh=IO::File->new("$pidfile");
  236:    my $pide=<$lfh>;
  237:    chomp($pide);
  238:    if (kill 0 => $pide) { die "already running"; }
  239: }
  240: 
  241: #
  242: # Read hosts file
  243: #
  244: my %hostip;
  245: my $thisserver;
  246: my $PREFORK=4; # number of children to maintain, at least four spare
  247: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
  248: while (my $configline=<CONFIG>) {
  249:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  250:     chomp($ip);
  251:     $hostip{$ip}=$id;
  252:     $thisserver=$name if ($id eq $perlvar{'lonHostID'});
  253:     $PREFORK++;
  254: }
  255: close(CONFIG);
  256: #
  257: $PREFORK=int($PREFORK/4);
  258: 
  259: #
  260: # Create a socket to talk to lond
  261: #
  262: my $unixsock = "mysqlsock";
  263: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
  264: my $server;
  265: unlink ($localfile);
  266: unless ($server=IO::Socket::UNIX->new(Local    =>"$localfile",
  267:                                       Type    => SOCK_STREAM,
  268:                                       Listen => 10)) {
  269:     print "in socket error:$@\n";
  270: }
  271: 
  272: #
  273: # Fork once and dissociate
  274: #
  275: my $fpid=fork;
  276: exit if $fpid;
  277: die "Couldn't fork: $!" unless defined ($fpid);
  278: POSIX::setsid() or die "Can't start new session: $!";
  279: 
  280: #
  281: # Write our PID on disk
  282: my $execdir=$perlvar{'lonDaemons'};
  283: open (PIDSAVE,">$execdir/logs/lonsql.pid");
  284: print PIDSAVE "$$\n";
  285: close(PIDSAVE);
  286: &logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
  287: 
  288: #
  289: # Ignore signals generated during initial startup
  290: $SIG{HUP}=$SIG{USR1}='IGNORE';
  291: # Now we are on our own    
  292: #    Fork off our children.
  293: for (1 .. $PREFORK) {
  294:     make_new_child();
  295: }
  296: 
  297: #
  298: # Install signal handlers.
  299: $SIG{CHLD} = \&REAPER;
  300: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
  301: $SIG{HUP}  = \&HUPSMAN;
  302: 
  303: #
  304: # And maintain the population.
  305: while (1) {
  306:     sleep;                          # wait for a signal (i.e., child's death)
  307:     for (my $i = $children; $i < $PREFORK; $i++) {
  308:         make_new_child();           # top up the child pool
  309:     }
  310: }
  311: 
  312: ########################################################
  313: ########################################################
  314: 
  315: =pod
  316: 
  317: =item &make_new_child
  318: 
  319: Inputs: None
  320: 
  321: Returns: None
  322: 
  323: =cut
  324: 
  325: ########################################################
  326: ########################################################
  327: sub make_new_child {
  328:     my $pid;
  329:     my $sigset;
  330:     #
  331:     # block signal for fork
  332:     $sigset = POSIX::SigSet->new(SIGINT);
  333:     sigprocmask(SIG_BLOCK, $sigset)
  334:         or die "Can't block SIGINT for fork: $!\n";
  335:     #
  336:     die "fork: $!" unless defined ($pid = fork);
  337:     #
  338:     if ($pid) {
  339:         # Parent records the child's birth and returns.
  340:         sigprocmask(SIG_UNBLOCK, $sigset)
  341:             or die "Can't unblock SIGINT for fork: $!\n";
  342:         $children{$pid} = 1;
  343:         $children++;
  344:         return;
  345:     } else {
  346:         # Child can *not* return from this subroutine.
  347:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
  348:         # unblock signals
  349:         sigprocmask(SIG_UNBLOCK, $sigset)
  350:             or die "Can't unblock SIGINT for fork: $!\n";
  351:         #open database handle
  352: 	# making dbh global to avoid garbage collector
  353: 	unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
  354:                                     $perlvar{'lonSqlAccess'},
  355:                                     { RaiseError =>0,PrintError=>0})) { 
  356:             sleep(10+int(rand(20)));
  357:             &logthis("<font color='blue'>WARNING: Couldn't connect to database".
  358:                      ": $@</font>");
  359:                      #  "($st secs): $@</font>");
  360:             print "database handle error\n";
  361:             exit;
  362:         }
  363: 	# make sure that a database disconnection occurs with 
  364:         # ending kill signals
  365: 	$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
  366:         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
  367:         for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
  368:             my $client = $server->accept() or last;
  369:             # do something with the connection
  370: 	    $run = $run+1;
  371: 	    my $userinput = <$client>;
  372: 	    chomp($userinput);
  373:             #
  374: 	    my ($conserver,$query,
  375: 		$arg1,$arg2,$arg3)=split(/&/,$userinput);
  376: 	    my $query=unescape($query);
  377:             #
  378:             #send query id which is pid_unixdatetime_runningcounter
  379: 	    my $queryid = $thisserver;
  380: 	    $queryid .="_".($$)."_";
  381: 	    $queryid .= time."_";
  382: 	    $queryid .= $run;
  383: 	    print $client "$queryid\n";
  384: 	    #
  385: 	    # &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
  386: 	    sleep 1;
  387:             #
  388:             my $result='';
  389:             #
  390:             # At this point, query is received, query-ID assigned and sent 
  391:             # back, $query eq 'logquery' will mean that this is a query 
  392:             # against log-files
  393:             if (($query eq 'userlog') || ($query eq 'courselog')) {
  394:                 # beginning of log query
  395:                 my $udom    = &unescape($arg1);
  396:                 my $uname   = &unescape($arg2);
  397:                 my $command = &unescape($arg3);
  398:                 my $path    = &propath($udom,$uname);
  399:                 if (-e "$path/activity.log") {
  400:                     if ($query eq 'userlog') {
  401:                         $result=&userlog($path,$command);
  402:                     } else {
  403:                         $result=&courselog($path,$command);
  404:                     }
  405:                 } else {
  406:                     &logthis('Unable to do log query: '.$uname.'@'.$udom);
  407:                     $result='no_such_file';
  408:                 }
  409:                 # end of log query
  410:             } elsif ($query eq 'fetchenrollment') {
  411:                 # retrieve institutional class lists
  412:                 my $dom = &unescape($arg1);
  413:                 my %affiliates = ();
  414:                 my %replies = ();
  415:                 my $locresult = '';
  416:                 my $querystr = &unescape($arg3);
  417:                 foreach (split/%%/,$querystr) {
  418:                     if (/^(\w+)=([^=]+)$/) {
  419:                         @{$affiliates{$1}} = split/,/,$2;
  420:                     }
  421:                 }
  422:                 $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);
  423:                 $result = &escape($locresult.':');
  424:                 if ($locresult) {
  425:                     $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));
  426:                 }
  427:             } else {
  428:                 # Do an sql query
  429:                 $result = &do_sql_query($query,$arg1,$arg2);
  430:             }
  431:             # result does not need to be escaped because it has already been
  432:             # escaped.
  433:             #$result=&escape($result);
  434:             &reply("queryreply:$queryid:$result",$conserver);
  435:         }
  436:         # tidy up gracefully and finish
  437:         #
  438:         # close the database handle
  439: 	$dbh->disconnect
  440:             or &logthis("<font color='blue'>WARNING: Couldn't disconnect".
  441:                         " from database  $DBI::errstr : $@</font>");
  442:         # this exit is VERY important, otherwise the child will become
  443:         # a producer of more and more children, forking yourself into
  444:         # process death.
  445:         exit;
  446:     }
  447: }
  448: 
  449: ########################################################
  450: ########################################################
  451: 
  452: =pod
  453: 
  454: =item &do_sql_query
  455: 
  456: Runs an sql metadata table query.
  457: 
  458: Inputs: $query, $custom, $customshow
  459: 
  460: Returns: A string containing escaped results.
  461: 
  462: =cut
  463: 
  464: ########################################################
  465: ########################################################
  466: {
  467:     my @metalist;
  468: 
  469: sub process_file {
  470:     if ( -e $_ &&  # file exists
  471:          -f $_ &&  # and is a normal file
  472:          /\.meta$/ &&  # ends in meta
  473:          ! /^.+\.\d+\.[^\.]+\.meta$/  # is not a previous version
  474:          ) {
  475:         push(@metalist,$File::Find::name);
  476:     }
  477: }
  478: 
  479: sub do_sql_query {
  480:     my ($query,$custom,$customshow) = @_;
  481:     $custom     = &unescape($custom);
  482:     $customshow = &unescape($customshow);
  483:     #
  484:     @metalist = ();
  485:     #
  486:     my $result = '';
  487:     my @results = ();
  488:     my @files;
  489:     my $subsetflag=0;
  490:     #
  491:     if ($query) {
  492:         #prepare and execute the query
  493:         my $sth = $dbh->prepare($query);
  494:         unless ($sth->execute()) {
  495:             &logthis('<font color="blue">'.
  496:                      'WARNING: Could not retrieve from database:'.
  497:                      $sth->errstr().'</font>');
  498:         } else {
  499:             my $aref=$sth->fetchall_arrayref;
  500:             foreach my $row (@$aref) {
  501:                 push @files,@{$row}[3] if ($custom or $customshow);
  502:                 my @b=map { &escape($_); } @$row;
  503:                 push @results,join(",", @b);
  504:                 # Build up the @files array with the LON-CAPA urls 
  505:                 # of the resources.
  506:             }
  507:         }
  508:     }
  509:     # do custom metadata searching here and build into result
  510:     return join("&",@results) if (! ($custom or $customshow));
  511:     # Only get here if there is a custom query or custom show request
  512:     &logthis("Doing custom query for $custom");
  513:     if ($query) {
  514:         @metalist=map {
  515:             $perlvar{'lonDocRoot'}.$_.'.meta';
  516:         } @files;
  517:     } else {
  518:         my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";
  519:         @metalist=(); 
  520:         opendir(RESOURCES,$dir);
  521:         my @homeusers=grep {
  522:             &ishome($dir.'/'.$_);
  523:         } grep {!/^\.\.?$/} readdir(RESOURCES);
  524:         closedir RESOURCES;
  525:         # Define the
  526:         foreach my $user (@homeusers) {
  527:             find (\&process_file,$dir.'/'.$user);
  528:         }
  529:     } 
  530:     # if file is indicated in sql database and
  531:     #     not part of sql-relevant query, do not pattern match.
  532:     #
  533:     # if file is not in sql database, output error.
  534:     #
  535:     # if file is indicated in sql database and is
  536:     #     part of query result list, then do the pattern match.
  537:     my $customresult='';
  538:     my @results;
  539:     foreach my $metafile (@metalist) {
  540:         my $fh=IO::File->new($metafile);
  541:         my @lines=<$fh>;
  542:         my $stuff=join('',@lines);
  543:         if ($stuff=~/$custom/s) {
  544:             foreach my $f ('abstract','author','copyright',
  545:                            'creationdate','keywords','language',
  546:                            'lastrevisiondate','mime','notes',
  547:                            'owner','subject','title') {
  548:                 $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
  549:             }
  550:             my $mfile=$metafile; 
  551:             my $docroot=$perlvar{'lonDocRoot'};
  552:             $mfile=~s/^$docroot//;
  553:             $mfile=~s/\.meta$//;
  554:             unless ($query) {
  555:                 my $q2="SELECT * FROM metadata WHERE url ".
  556:                     " LIKE BINARY '?'";
  557:                 my $sth = $dbh->prepare($q2);
  558:                 $sth->execute($mfile);
  559:                 my $aref=$sth->fetchall_arrayref;
  560:                 foreach my $a (@$aref) {
  561:                     my @b=map { &escape($_)} @$a;
  562:                     push @results,join(",", @b);
  563:                 }
  564:             }
  565:             # &logthis("found: $stuff");
  566:             $customresult.='&custom='.&escape($mfile).','.
  567:                 escape($stuff);
  568:         }
  569:     }
  570:     $result=join("&",@results) unless $query;
  571:     $result.=$customresult;
  572:     #
  573:     return $result;
  574: } # End of &do_sql_query
  575: 
  576: } # End of scoping curly braces for &process_file and &do_sql_query
  577: ########################################################
  578: ########################################################
  579: 
  580: =pod
  581: 
  582: =item &logthis
  583: 
  584: Inputs: $message, the message to log
  585: 
  586: Returns: nothing
  587: 
  588: Writes $message to the logfile.
  589: 
  590: =cut
  591: 
  592: ########################################################
  593: ########################################################
  594: sub logthis {
  595:     my $message=shift;
  596:     my $execdir=$perlvar{'lonDaemons'};
  597:     my $fh=IO::File->new(">>$execdir/logs/lonsql.log");
  598:     my $now=time;
  599:     my $local=localtime($now);
  600:     print $fh "$local ($$): $message\n";
  601: }
  602: 
  603: # -------------------------------------------------- Non-critical communication
  604: 
  605: ########################################################
  606: ########################################################
  607: 
  608: =pod
  609: 
  610: =item &subreply
  611: 
  612: Sends a command to a server.  Called only by &reply.
  613: 
  614: Inputs: $cmd,$server
  615: 
  616: Returns: The results of the message or 'con_lost' on error.
  617: 
  618: =cut
  619: 
  620: ########################################################
  621: ########################################################
  622: sub subreply {
  623:     my ($cmd,$server)=@_;
  624:     my $peerfile="$perlvar{'lonSockDir'}/$server";
  625:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  626:                                       Type    => SOCK_STREAM,
  627:                                       Timeout => 10)
  628:        or return "con_lost";
  629:     print $sclient "$cmd\n";
  630:     my $answer=<$sclient>;
  631:     chomp($answer);
  632:     $answer="con_lost" if (!$answer);
  633:     return $answer;
  634: }
  635: 
  636: ########################################################
  637: ########################################################
  638: 
  639: =pod
  640: 
  641: =item &reply
  642: 
  643: Sends a command to a server.
  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 reply {
  654:   my ($cmd,$server)=@_;
  655:   my $answer;
  656:   if ($server ne $perlvar{'lonHostID'}) { 
  657:     $answer=subreply($cmd,$server);
  658:     if ($answer eq 'con_lost') {
  659: 	$answer=subreply("ping",$server);
  660:         $answer=subreply($cmd,$server);
  661:     }
  662:   } else {
  663:     $answer='self_reply';
  664:     $answer=subreply($cmd,$server);
  665:   } 
  666:   return $answer;
  667: }
  668: 
  669: ########################################################
  670: ########################################################
  671: 
  672: =pod
  673: 
  674: =item &escape
  675: 
  676: Escape special characters in a string.
  677: 
  678: Inputs: string to escape
  679: 
  680: Returns: The input string with special characters escaped.
  681: 
  682: =cut
  683: 
  684: ########################################################
  685: ########################################################
  686: sub escape {
  687:     my $str=shift;
  688:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
  689:     return $str;
  690: }
  691: 
  692: ########################################################
  693: ########################################################
  694: 
  695: =pod
  696: 
  697: =item &unescape
  698: 
  699: Unescape special characters in a string.
  700: 
  701: Inputs: string to unescape
  702: 
  703: Returns: The input string with special characters unescaped.
  704: 
  705: =cut
  706: 
  707: ########################################################
  708: ########################################################
  709: sub unescape {
  710:     my $str=shift;
  711:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  712:     return $str;
  713: }
  714: 
  715: ########################################################
  716: ########################################################
  717: 
  718: =pod
  719: 
  720: =item &ishome
  721: 
  722: Determine if the current machine is the home server for a user.
  723: The determination is made by checking the filesystem for the users information.
  724: 
  725: Inputs: $author
  726: 
  727: Returns: 0 - this is not the authors home server, 1 - this is.
  728: 
  729: =cut
  730: 
  731: ########################################################
  732: ########################################################
  733: sub ishome {
  734:     my $author=shift;
  735:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
  736:     my ($udom,$uname)=split(/\//,$author);
  737:     my $proname=propath($udom,$uname);
  738:     if (-e $proname) {
  739: 	return 1;
  740:     } else {
  741:         return 0;
  742:     }
  743: }
  744: 
  745: ########################################################
  746: ########################################################
  747: 
  748: =pod
  749: 
  750: =item &propath
  751: 
  752: Inputs: user name, user domain
  753: 
  754: Returns: The full path to the users directory.
  755: 
  756: =cut
  757: 
  758: ########################################################
  759: ########################################################
  760: sub propath {
  761:     my ($udom,$uname)=@_;
  762:     $udom=~s/\W//g;
  763:     $uname=~s/\W//g;
  764:     my $subdir=$uname.'__';
  765:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  766:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  767:     return $proname;
  768: } 
  769: 
  770: ########################################################
  771: ########################################################
  772: 
  773: =pod
  774: 
  775: =item &courselog
  776: 
  777: Inputs: $path, $command
  778: 
  779: Returns: unescaped string of values.
  780: 
  781: =cut
  782: 
  783: ########################################################
  784: ########################################################
  785: sub courselog {
  786:     my ($path,$command)=@_;
  787:     my %filters=();
  788:     foreach (split(/\:/,&unescape($command))) {
  789: 	my ($name,$value)=split(/\=/,$_);
  790:         $filters{$name}=$value;
  791:     }
  792:     my @results=();
  793:     open(IN,$path.'/activity.log') or return ('file_error');
  794:     while (my $line=<IN>) {
  795:         chomp($line);
  796:         my ($timestamp,$host,$log)=split(/\:/,$line);
  797: #
  798: # $log has the actual log entries; currently still escaped, and
  799: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
  800: # then additionally
  801: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
  802: # or
  803: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
  804: #
  805: # get delimiter between timestamped entries to be &&&
  806:         $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
  807: # now go over all log entries 
  808:         foreach (split(/\&\&\&/,&unescape($log))) {
  809: 	    my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
  810:             my $values=&unescape(join(':',@values));
  811:             $values=~s/\&/\:/g;
  812:             $res=&unescape($res);
  813:             my $include=1;
  814:             if (($filters{'username'}) && ($uname ne $filters{'username'})) 
  815:                                                                { $include=0; }
  816:             if (($filters{'domain'}) && ($udom ne $filters{'domain'})) 
  817:                                                                { $include=0; }
  818:             if (($filters{'url'}) && ($res!~/$filters{'url'}/)) 
  819:                                                                { $include=0; }
  820:             if (($filters{'start'}) && ($time<$filters{'start'})) 
  821:                                                                { $include=0; }
  822:             if (($filters{'end'}) && ($time>$filters{'end'})) 
  823:                                                                { $include=0; }
  824:             if (($filters{'action'} eq 'view') && ($action)) 
  825:                                                                { $include=0; }
  826:             if (($filters{'action'} eq 'submit') && ($action ne 'POST')) 
  827:                                                                { $include=0; }
  828:             if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) 
  829:                                                                { $include=0; }
  830:             if ($include) {
  831: 	       push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
  832:                                             $uname.':'.$udom.':'.
  833:                                             $action.':'.$values);
  834:             }
  835:        }
  836:     }
  837:     close IN;
  838:     return join('&',sort(@results));
  839: }
  840: 
  841: ########################################################
  842: ########################################################
  843: 
  844: =pod
  845: 
  846: =item &userlog
  847: 
  848: Inputs: $path, $command
  849: 
  850: Returns: unescaped string of values.
  851: 
  852: =cut
  853: 
  854: ########################################################
  855: ########################################################
  856: sub userlog {
  857:     my ($path,$command)=@_;
  858:     my %filters=();
  859:     foreach (split(/\:/,&unescape($command))) {
  860: 	my ($name,$value)=split(/\=/,$_);
  861:         $filters{$name}=$value;
  862:     }
  863:     my @results=();
  864:     open(IN,$path.'/activity.log') or return ('file_error');
  865:     while (my $line=<IN>) {
  866:         chomp($line);
  867:         my ($timestamp,$host,$log)=split(/\:/,$line);
  868:         $log=&unescape($log);
  869:         my $include=1;
  870:         if (($filters{'start'}) && ($timestamp<$filters{'start'})) 
  871:                                                              { $include=0; }
  872:         if (($filters{'end'}) && ($timestamp>$filters{'end'})) 
  873:                                                              { $include=0; }
  874:         if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
  875:         if (($filters{'action'} eq 'check') && ($log!~/^Check/)) 
  876:                                                              { $include=0; }
  877:         if ($include) {
  878: 	   push(@results,$timestamp.':'.$log);
  879:         }
  880:     }
  881:     close IN;
  882:     return join('&',sort(@results));
  883: }
  884: 
  885: ########################################################
  886: ########################################################
  887: 
  888: =pod
  889: 
  890: =item Functions required for forking
  891: 
  892: =over 4
  893: 
  894: =item REAPER
  895: 
  896: REAPER takes care of dead children.
  897: 
  898: =item HUNTSMAN
  899: 
  900: Signal handler for SIGINT.
  901: 
  902: =item HUPSMAN
  903: 
  904: Signal handler for SIGHUP
  905: 
  906: =item DISCONNECT
  907: 
  908: Disconnects from database.
  909: 
  910: =back
  911: 
  912: =cut
  913: 
  914: ########################################################
  915: ########################################################
  916: sub REAPER {                   # takes care of dead children
  917:     $SIG{CHLD} = \&REAPER;
  918:     my $pid = wait;
  919:     $children --;
  920:     &logthis("Child $pid died");
  921:     delete $children{$pid};
  922: }
  923: 
  924: sub HUNTSMAN {                      # signal handler for SIGINT
  925:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
  926:     kill 'INT' => keys %children;
  927:     my $execdir=$perlvar{'lonDaemons'};
  928:     unlink("$execdir/logs/lonsql.pid");
  929:     &logthis("<font color='red'>CRITICAL: Shutting down</font>");
  930:     $unixsock = "mysqlsock";
  931:     my $port="$perlvar{'lonSockDir'}/$unixsock";
  932:     unlink($port);
  933:     exit;                           # clean up with dignity
  934: }
  935: 
  936: sub HUPSMAN {                      # signal handler for SIGHUP
  937:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
  938:     kill 'INT' => keys %children;
  939:     close($server);                # free up socket
  940:     &logthis("<font color='red'>CRITICAL: Restarting</font>");
  941:     my $execdir=$perlvar{'lonDaemons'};
  942:     $unixsock = "mysqlsock";
  943:     my $port="$perlvar{'lonSockDir'}/$unixsock";
  944:     unlink($port);
  945:     exec("$execdir/lonsql");         # here we go again
  946: }
  947: 
  948: sub DISCONNECT {
  949:     $dbh->disconnect or 
  950:     &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".
  951:              " $DBI::errstr : $@</font>");
  952:     exit;
  953: }
  954: 
  955: 
  956: =pod
  957: 
  958: =back
  959: 
  960: =cut

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>