[BACK]Return to lonsql CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lonsql between versions 1.1 and 1.56

version 1.1, 2000/05/08 15:14:27 version 1.56, 2003/07/25 17:07:06
Line 1 Line 1
 #!/usr/bin/perl  #!/usr/bin/perl
   
 # The LearningOnline Network  # The LearningOnline Network
 # lonsql  # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
 # provides unix domain sockets to receive queries from lond and send replies to lonc  #
   # $Id$
   #
   # Copyright Michigan State University Board of Trustees
   #
   # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   #
   # LON-CAPA is free software; you can redistribute it and/or modify
   # it under the terms of the GNU General Public License as published by
   # the Free Software Foundation; either version 2 of the License, or
   # (at your option) any later version.
   #
   # LON-CAPA is distributed in the hope that it will be useful,
   # but WITHOUT ANY WARRANTY; without even the implied warranty of
   # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   # GNU General Public License for more details.
   #
   # You should have received a copy of the GNU General Public License
   # along with LON-CAPA; if not, write to the Free Software
   # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   #
   # /home/httpd/html/adm/gpl.txt
   #
   # http://www.lon-capa.org/
 #  #
 # PID in subdir logs/lonc.pid  
 # kill kills  
 # HUP restarts  
 # USR1 tries to open connections again  
   
 # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,  
 # 10/8,10/9,10/15,11/18,12/22,  
 # 2/8 Gerd Kortemeyer   
 # based on nonforker from Perl Cookbook  
 # - server who multiplexes without forking  
   
 use POSIX;  =pod
   
   =head1 NAME
   
   lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
   
   =head1 SYNOPSIS
   
   This script should be run as user=www.  
   Note that a lonsql.pid file contains the pid of the parent process.
   
   =head1 OVERVIEW
   
   The SQL database in LON-CAPA is used for catalog searches against
   resource metadata only. The authoritative version of the resource
   metadata is an XML-file on the normal file system (same file name as
   resource plus ".meta"). The SQL-database is a cache of these files,
   and can be reconstructed from the XML files at any time.
   
   The current database is implemented assuming a non-adjustable
   architecture involving these data fields (specific to each version of
   a resource).
   
   =over 4
   
   =item * title
   
   =item * author
   
   =item * subject
   
   =item * notes
   
   =item * abstract
   
   =item * mime
   
   =item * language
   
   =item * creationdate
   
   =item * lastrevisiondate
   
   =item * owner
   
   =item * copyright 
   
   =back 
   
   =head2 Purpose within LON-CAPA
   
   LON-CAPA is meant to distribute A LOT of educational content to A LOT
   of people. It is ineffective to directly rely on contents within the
   ext2 filesystem to be speedily scanned for on-the-fly searches of
   content descriptions. (Simply put, it takes a cumbersome amount of
   time to open, read, analyze, and close thousands of files.)
   
   The solution is to index various data fields that are descriptive of
   the educational resources on a LON-CAPA server machine in a
   database. Descriptive data fields are referred to as "metadata". The
   question then arises as to how this metadata is handled in terms of
   the rest of the LON-CAPA network without burdening client and daemon
   processes.
   
   The obvious solution, using lonc to send a query to a lond process,
   doesn't work so well in general as you can see in the following
   example:
   
       lonc= loncapa client process    A-lonc= a lonc process on Server A
       lond= loncapa daemon process
   
                    database command
       A-lonc  --------TCP/IP----------------> B-lond
   
   The problem emerges that A-lonc and B-lond are kept waiting for the
   MySQL server to "do its stuff", or in other words, perform the
   conceivably sophisticated, data-intensive, time-sucking database
   transaction.  By tying up a lonc and lond process, this significantly
   cripples the capabilities of LON-CAPA servers.
   
   The solution is to offload the work onto another process, and use
   lonc and lond just for requests and notifications of completed
   processing:
   
                   database command
   
     A-lonc  ---------TCP/IP-----------------> B-lond =====> B-lonsql
            <---------------------------------/                |
              "ok, I'll get back to you..."                    |
                                                               |
                                                               /
     A-lond  <-------------------------------  B-lonc   <======
              "Guess what? I have the result!"
   
   Of course, depending on success or failure, the messages may vary, but
   the principle remains the same where a separate pool of children
   processes (lonsql's) handle the MySQL database manipulations.
   
   Thus, lonc and lond spend effectively no time waiting on results from
   the database.
   
   =head1 Internals
   
   =over 4
   
   =cut
   
   use strict;
   
   use lib '/home/httpd/lib/perl/';
   use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
   use Symbol;
   use POSIX;
 use IO::Select;  use IO::Select;
 use IO::File;  use IO::File;
 use Socket;  use Socket;
 use Fcntl;  use Fcntl;
 use Tie::RefHash;  use Tie::RefHash;
 use Crypt::IDEA;  
 use DBI;  use DBI;
   use File::Find;
   
   ########################################################
   ########################################################
   
 $childmaxattempts=10;  =pod
 $run =0;  
 # ------------------------------------ Read httpd access.conf and get variables  =item Global Variables
   
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  =over 4
   
 while ($configline=<CONFIG>) {  =item dbh
     if ($configline =~ /PerlSetVar/) {  
  my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  =back
         chomp($varvalue);  
         $perlvar{$varname}=$varvalue;  =cut
     }  
   ########################################################
   ########################################################
   my $dbh;
   
   ########################################################
   ########################################################
   
   =pod 
   
   =item Variables required for forking
   
   =over 4
   
   =item $MAX_CLIENTS_PER_CHILD
   
   The number of clients each child should process.
   
   =item %children 
   
   The keys to %children  are the current child process IDs
   
   =item $children
   
   The current number of children
   
   =back
   
   =cut 
   
   ########################################################
   ########################################################
   my $MAX_CLIENTS_PER_CHILD  = 5;   # number of clients each child should process
   my %children               = ();  # keys are current child process IDs
   my $children               = 0;   # current number of children
                                  
   ###################################################################
   ###################################################################
   
   =pod
   
   =item Main body of code.
   
   =over 4
   
   =item Read data from loncapa_apache.conf and loncapa.conf.
   
   =item Ensure we can access the database.
   
   =item Determine if there are other instances of lonsql running.
   
   =item Read the hosts file.
   
   =item Create a socket for lonsql.
   
   =item Fork once and dissociate from parent.
   
   =item Write PID to disk.
   
   =item Prefork children and maintain the population of children.
   
   =back
   
   =cut
   
   ###################################################################
   ###################################################################
   my $childmaxattempts=10;
   my $run =0;              # running counter to generate the query-id
   #
   # Read loncapa_apache.conf and loncapa.conf
   #
   my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
   my %perlvar=%{$perlvarref};
   #
   # Make sure that database can be accessed
   #
   my $dbh;
   unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
                               $perlvar{'lonSqlAccess'},
                               { RaiseError =>0,PrintError=>0})) { 
       print "Cannot connect to database!\n";
       my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
       my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
       system("echo 'Cannot connect to MySQL database!' |".
              " mailto $emailto -s '$subj' > /dev/null");
       exit 1;
   } else {
       $dbh->disconnect;
 }  }
 close(CONFIG);  
   
 # ------------------------------------------------------------- Read hosts file  #
 #$PREFORK=4; # number of children to maintain, at least four spare  # Check if other instance running
   #
   my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
   if (-e $pidfile) {
      my $lfh=IO::File->new("$pidfile");
      my $pide=<$lfh>;
      chomp($pide);
      if (kill 0 => $pide) { die "already running"; }
   }
   
   #
   # Read hosts file
   #
   my %hostip;
   my $thisserver;
   my $PREFORK=4; # number of children to maintain, at least four spare
 open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
   while (my $configline=<CONFIG>) {
 while ($configline=<CONFIG>) {  
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
     chomp($ip);      chomp($ip);
       $hostip{$ip}=$id;
       $thisserver=$name if ($id eq $perlvar{'lonHostID'});
       $PREFORK++;
   }
   close(CONFIG);
   #
   $PREFORK=int($PREFORK/4);
   
     #$hostip{$ip}=$id;  #
     $hostip{$id}=$ip;  # Create a socket to talk to lond
   #
   my $unixsock = "mysqlsock";
   my $localfile="$perlvar{'lonSockDir'}/$unixsock";
   my $server;
   unlink ($localfile);
   unless ($server=IO::Socket::UNIX->new(Local    =>"$localfile",
                                         Type    => SOCK_STREAM,
                                         Listen => 10)) {
       print "in socket error:$@\n";
   }
   
     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }  #
   # Fork once and dissociate
   #
   my $fpid=fork;
   exit if $fpid;
   die "Couldn't fork: $!" unless defined ($fpid);
   POSIX::setsid() or die "Can't start new session: $!";
   
     #$PREFORK++;  #
   # Write our PID on disk
   my $execdir=$perlvar{'lonDaemons'};
   open (PIDSAVE,">$execdir/logs/lonsql.pid");
   print PIDSAVE "$$\n";
   close(PIDSAVE);
   &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
   
   #
   # Ignore signals generated during initial startup
   $SIG{HUP}=$SIG{USR1}='IGNORE';
   # Now we are on our own    
   #    Fork off our children.
   for (1 .. $PREFORK) {
       make_new_child();
 }  }
 close(CONFIG);  
   
   #
   # Install signal handlers.
   $SIG{CHLD} = \&REAPER;
   $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
   $SIG{HUP}  = \&HUPSMAN;
   
 # -------------------------------------------------------- Routines for forking  #
 # global variables  # And maintain the population.
 #$MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process  while (1) {
 %children               = ();       # keys are current child process IDs      sleep;                          # wait for a signal (i.e., child's death)
 #$children               = 0;        # current number of children      for (my $i = $children; $i < $PREFORK; $i++) {
 %childpid               = ();       # the other way around          make_new_child();           # top up the child pool
       }
   }
   
 %childatt               = ();       # number of attempts to start server  ########################################################
                                     # for ID  ########################################################
   
   =pod
   
 sub REAPER {                        # takes care of dead children  =item &make_new_child
     $SIG{CHLD} = \&REAPER;  
     my $pid = wait;  
   
     #$children --;  Inputs: None
     #&logthis("Child $pid died");  
     #delete $children{$pid};  
       
     my $wasserver=$children{$pid};  
     &logthis("<font color=red>CRITICAL: "  
      ."Child $pid for server $wasserver died ($childatt{$wasserver})</font>");  
     delete $children{$pid};  
     delete $childpid{$wasserver};  
     my $port = "$perlvar{'lonSockDir'}/$wasserver";  
     unlink($port);  
   
   Returns: None
   
 }  =cut
   
 sub HUNTSMAN {                      # signal handler for SIGINT  ########################################################
     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children  ########################################################
     kill 'INT' => keys %children;  sub make_new_child {
     my $execdir=$perlvar{'lonDaemons'};      my $pid;
     unlink("$execdir/logs/lonsql.pid");      my $sigset;
     &logthis("<font color=red>CRITICAL: Shutting down</font>");      #
     exit;                           # clean up with dignity      # block signal for fork
       $sigset = POSIX::SigSet->new(SIGINT);
       sigprocmask(SIG_BLOCK, $sigset)
           or die "Can't block SIGINT for fork: $!\n";
       #
       die "fork: $!" unless defined ($pid = fork);
       #
       if ($pid) {
           # Parent records the child's birth and returns.
           sigprocmask(SIG_UNBLOCK, $sigset)
               or die "Can't unblock SIGINT for fork: $!\n";
           $children{$pid} = 1;
           $children++;
           return;
       } else {
           # Child can *not* return from this subroutine.
           $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
           # unblock signals
           sigprocmask(SIG_UNBLOCK, $sigset)
               or die "Can't unblock SIGINT for fork: $!\n";
           #open database handle
    # making dbh global to avoid garbage collector
    unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
                                       $perlvar{'lonSqlAccess'},
                                       { RaiseError =>0,PrintError=>0})) { 
               sleep(10+int(rand(20)));
               &logthis("<font color=blue>WARNING: Couldn't connect to database".
                        ": $@</font>");
                        #  "($st secs): $@</font>");
               print "database handle error\n";
               exit;
           }
    # make sure that a database disconnection occurs with 
           # ending kill signals
    $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
           # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
           for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
               my $client = $server->accept() or last;
               # do something with the connection
       $run = $run+1;
       my $userinput = <$client>;
       chomp($userinput);
               #
       my ($conserver,$query,
    $arg1,$arg2,$arg3)=split(/&/,$userinput);
       my $query=unescape($query);
               #
               #send query id which is pid_unixdatetime_runningcounter
       my $queryid = $thisserver;
       $queryid .="_".($$)."_";
       $queryid .= time."_";
       $queryid .= $run;
       print $client "$queryid\n";
       #
       &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
       sleep 1;
               #
               my $result='';
               #
               # At this point, query is received, query-ID assigned and sent 
               # back, $query eq 'logquery' will mean that this is a query 
               # against log-files
               if (($query eq 'userlog') || ($query eq 'courselog')) {
                   # beginning of log query
                   my $udom    = &unescape($arg1);
                   my $uname   = &unescape($arg2);
                   my $command = &unescape($arg3);
                   my $path    = &propath($udom,$uname);
                   if (-e "$path/activity.log") {
                       if ($query eq 'userlog') {
                           $result=&userlog($path,$command);
                       } else {
                           $result=&courselog($path,$command);
                       }
                   } else {
                       &logthis('Unable to do log query: '.$uname.'@'.$udom);
                       $result='no_such_file';
                   }
                   # end of log query
               } else {
                   # Do an sql query
                   $result = &do_sql_query($query,$arg1,$arg2);
               }
               # result does not need to be escaped because it has already been
               # escaped.
               #$result=&escape($result);
               # reply with result, append \n unless already there
       $result.="\n" unless ($result=~/\n$/);
               &reply("queryreply:$queryid:$result",$conserver);
           }
           # tidy up gracefully and finish
           #
           # close the database handle
    $dbh->disconnect
               or &logthis("<font color=blue>WARNING: Couldn't disconnect".
                           " from database  $DBI::errstr : $@</font>");
           # this exit is VERY important, otherwise the child will become
           # a producer of more and more children, forking yourself into
           # process death.
           exit;
       }
 }  }
   
 sub HUPSMAN {                      # signal handler for SIGHUP  ########################################################
     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children  ########################################################
     kill 'INT' => keys %children;  
     close($server);                # free up socket  =pod
     &logthis("<font color=red>CRITICAL: Restarting</font>");  
     my $execdir=$perlvar{'lonDaemons'};  =item &do_sql_query
     exec("$execdir/lonsql");         # here we go again  
   Runs an sql metadata table query.
   
   Inputs: $query, $custom, $customshow
   
   Returns: A string containing escaped results.
   
   =cut
   
   ########################################################
   ########################################################
   {
       my @metalist;
   
   sub process_file {
       if ( -e $_ &&  # file exists
            -f $_ &&  # and is a normal file
            /\.meta$/ &&  # ends in meta
            ! /^.+\.\d+\.[^\.]+\.meta$/  # is not a previous version
            ) {
           push(@metalist,$File::Find::name);
       }
 }  }
   
   sub do_sql_query {
       my ($query,$custom,$customshow) = @_;
       $custom     = &unescape($custom);
       $customshow = &unescape($customshow);
       #
       @metalist = ();
       #
       my $result = '';
       my @results = ();
       my @files;
       my $subsetflag=0;
       #
       if ($query) {
           #prepare and execute the query
           my $sth = $dbh->prepare($query);
           unless ($sth->execute()) {
               &logthis("<font color=blue>WARNING: ".
                        "Could not retrieve from database: $@</font>");
           } else {
               my $aref=$sth->fetchall_arrayref;
               foreach my $row (@$aref) {
                   push @files,@{$row}[3] if ($custom or $customshow);
                   my @b=map { &escape($_); } @$row;
                   push @results,join(",", @b);
                   # Build up the @files array with the LON-CAPA urls 
                   # of the resources.
               }
           }
       }
       # do custom metadata searching here and build into result
       return join("&",@results) if (! ($custom or $customshow));
       # Only get here if there is a custom query or custom show request
       &logthis("Doing custom query for $custom");
       if ($query) {
           @metalist=map {
               $perlvar{'lonDocRoot'}.$_.'.meta';
           } @files;
       } else {
           my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";
           @metalist=(); 
           opendir(RESOURCES,$dir);
           my @homeusers=grep {
               &ishome($dir.'/'.$_);
           } grep {!/^\.\.?$/} readdir(RESOURCES);
           closedir RESOURCES;
           # Define the
           foreach my $user (@homeusers) {
               find (\&process_file,$dir.'/'.$user);
           }
       } 
       # if file is indicated in sql database and
       #     not part of sql-relevant query, do not pattern match.
       #
       # if file is not in sql database, output error.
       #
       # if file is indicated in sql database and is
       #     part of query result list, then do the pattern match.
       my $customresult='';
       my @results;
       foreach my $metafile (@metalist) {
           my $fh=IO::File->new($metafile);
           my @lines=<$fh>;
           my $stuff=join('',@lines);
           if ($stuff=~/$custom/s) {
               foreach my $f ('abstract','author','copyright',
                              'creationdate','keywords','language',
                              'lastrevisiondate','mime','notes',
                              'owner','subject','title') {
                   $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
               }
               my $mfile=$metafile; 
               my $docroot=$perlvar{'lonDocRoot'};
               $mfile=~s/^$docroot//;
               $mfile=~s/\.meta$//;
               unless ($query) {
                   my $q2="SELECT * FROM metadata WHERE url ".
                       " LIKE BINARY '?'";
                   my $sth = $dbh->prepare($q2);
                   $sth->execute($mfile);
                   my $aref=$sth->fetchall_arrayref;
                   foreach my $a (@$aref) {
                       my @b=map { &escape($_)} @$a;
                       push @results,join(",", @b);
                   }
               }
               # &logthis("found: $stuff");
               $customresult.='&custom='.&escape($mfile).','.
                   escape($stuff);
           }
       }
       $result=join("&",@results) unless $query;
       $result.=$customresult;
       #
       return $result;
   } # End of &do_sql_query
   
   } # End of scoping curly braces for &process_file and &do_sql_query
   ########################################################
   ########################################################
   
   =pod
   
   =item &logthis
   
   Inputs: $message, the message to log
   
   Returns: nothing
   
   Writes $message to the logfile.
   
   =cut
   
   ########################################################
   ########################################################
 sub logthis {  sub logthis {
     my $message=shift;      my $message=shift;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
Line 117  sub logthis { Line 613  sub logthis {
     print $fh "$local ($$): $message\n";      print $fh "$local ($$): $message\n";
 }  }
   
 # ----------------------------------------------------------- Send USR1 to lonc  
 sub reconlonc {  
     my $peerfile=shift;  
     &logthis("Trying to reconnect for $peerfile");  
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";  
     if (my $fh=IO::File->new("$loncfile")) {  
  my $loncpid=<$fh>;  
         chomp($loncpid);  
         if (kill 0 => $loncpid) {  
     &logthis("lonc at pid $loncpid responding, sending USR1");  
             kill USR1 => $loncpid;  
             sleep 1;  
             if (-e "$peerfile") { return; }  
             &logthis("$peerfile still not there, give it another try");  
             sleep 5;  
             if (-e "$peerfile") { return; }  
             &logthis(  
  "<font color=blue>WARNING: $peerfile still not there, giving up</font>");  
         } else {  
     &logthis(  
               "<font color=red>CRITICAL: "  
              ."lonc at pid $loncpid not responding, giving up</font>");  
         }  
     } else {  
       &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');  
     }  
 }  
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
   
   ########################################################
   ########################################################
   
   =pod
   
   =item &subreply
   
   Sends a command to a server.  Called only by &reply.
   
   Inputs: $cmd,$server
   
   Returns: The results of the message or 'con_lost' on error.
   
   =cut
   
   ########################################################
   ########################################################
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/$server";
Line 156  sub subreply { Line 642  sub subreply {
     print $sclient "$cmd\n";      print $sclient "$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      $answer="con_lost" if (!$answer);
     return $answer;      return $answer;
 }  }
   
   ########################################################
   ########################################################
   
   =pod
   
   =item &reply
   
   Sends a command to a server.
   
   Inputs: $cmd,$server
   
   Returns: The results of the message or 'con_lost' on error.
   
   =cut
   
   ########################################################
   ########################################################
 sub reply {  sub reply {
   my ($cmd,$server)=@_;    my ($cmd,$server)=@_;
   my $answer;    my $answer;
Line 167  sub reply { Line 670  sub reply {
     $answer=subreply($cmd,$server);      $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {      if ($answer eq 'con_lost') {
  $answer=subreply("ping",$server);   $answer=subreply("ping",$server);
         if ($answer ne $server) {  
            &reconlonc("$perlvar{'lonSockDir'}/$server");  
         }  
         $answer=subreply($cmd,$server);          $answer=subreply($cmd,$server);
     }      }
   } else {    } else {
     $answer='self_reply';      $answer='self_reply';
       $answer=subreply($cmd,$server);
   }     } 
   return $answer;    return $answer;
 }  }
   
 $unixsock = "msua1_sql";  ########################################################
 my $localfile="$perlvar{'lonSockDir'}/$unixsock";  ########################################################
 my $server=IO::Socket::UNIX->new(LocalAddr    =>"$localfile",  
   Type    => SOCK_STREAM,  
   Timeout => 10);  
   
 # ---------------------------------------------------- Fork once and dissociate  =pod
 $fpid=fork;  
 exit if $fpid;  
 die "Couldn't fork: $!" unless defined ($fpid);  
   
 POSIX::setsid() or die "Can't start new session: $!";  =item &escape
   
 # ------------------------------------------------------- Write our PID on disk  Escape special characters in a string.
   
 $execdir=$perlvar{'lonDaemons'};  Inputs: string to escape
 open (PIDSAVE,">$execdir/logs/lonsql.pid");  
 print PIDSAVE "$$\n";  
 close(PIDSAVE);  
 &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");  
   
 # ----------------------------- Ignore signals generated during initial startup  Returns: The input string with special characters escaped.
 $SIG{HUP}=$SIG{USR1}='IGNORE';  
   =cut
   
   ########################################################
   ########################################################
   sub escape {
       my $str=shift;
       $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
       return $str;
   }
   
   ########################################################
   ########################################################
   
   =pod
   
   =item &unescape
   
   Unescape special characters in a string.
   
 # ------------------------------------------------------- Now we are on our own  Inputs: string to unescape
 #Fork of children one for every server  
   
 #for (1 .. $PREFORK) {  Returns: The input string with special characters unescaped.
 #    make_new_child($thisserver);  
 #}  
   
 foreach $thisserver (keys %hostip) {   =cut
     make_new_child($thisserver);  
   ########################################################
   ########################################################
   sub unescape {
       my $str=shift;
       $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       return $str;
 }  }
   
 &logthis("Done starting initial servers");  ########################################################
 # ----------------------------------------------------- Install signal handlers  ########################################################
   
 $SIG{CHLD} = \&REAPER;  =pod
 $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;  
 $SIG{HUP}  = \&HUPSMAN;  
   
 # And maintain the population.  =item &ishome
 while (1) {  
     sleep;                          # wait for a signal (i.e., child's death)  Determine if the current machine is the home server for a user.
   The determination is made by checking the filesystem for the users information.
   
   Inputs: $author
   
   Returns: 0 - this is not the authors home server, 1 - this is.
   
   =cut
   
     #for ($i = $children; $i < $PREFORK; $i++) {  ########################################################
     #   make_new_child();           # top up the child pool  ########################################################
     #}  sub ishome {
           my $author=shift;
     foreach $thisserver (keys %hostip) {      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
         if (!$childpid{$thisserver}) {      my ($udom,$uname)=split(/\//,$author);
     if ($childatt{$thisserver}<=$childmaxattempts) {      my $proname=propath($udom,$uname);
        $childatt{$thisserver}++;      if (-e $proname) {
                &logthis(   return 1;
    "<font color=yellow>INFO: Trying to reconnect for $thisserver "      } else {
   ."($childatt{$thisserver} of $childmaxattempts attempts)</font>");           return 0;
                make_new_child($thisserver);  
     }  
         }         
     }      }
 }  }
   
 sub make_new_child {  ########################################################
     my $conserver=shift;  ########################################################
     my $pid;  
     my $sigset;  
     my $queryid;  
   
     &logthis("Attempting to start child");      =pod
     # block signal for fork  
     $sigset = POSIX::SigSet->new(SIGINT);  
     sigprocmask(SIG_BLOCK, $sigset)  
         or die "Can't block SIGINT for fork: $!\n";  
       
     die "fork: $!" unless defined ($pid = fork);#do the forking of children  
   
     if ($pid) {  
         # Parent records the child's birth and returns.  
         sigprocmask(SIG_UNBLOCK, $sigset)  
             or die "Can't unblock SIGINT for fork: $!\n";  
         $children{$pid} = 1;  
         $children++;  
         return;  
     } else {  
        # Child can *not* return from this subroutine.  
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before  
       
         # unblock signals  
         sigprocmask(SIG_UNBLOCK, $sigset)  
             or die "Can't unblock SIGINT for fork: $!\n";  
   
         #connect to the database  =item &propath
  unless (  
  my $dbh = DBI->connect("DBI:mysql:loncapa","root","mysql",{ RaiseError =>1,})  Inputs: user name, user domain
  ) {   
             my $st=120+int(rand(240));  Returns: The full path to the users directory.
     &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");  
     sleep($st);  =cut
     exit;#do I need to cleanup before exit if can't connect to database   
  };  ########################################################
   ########################################################
         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD  sub propath {
         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {      my ($udom,$uname)=@_;
             $client = $server->accept()     or last;      $udom=~s/\W//g;
     $run = $run+1;      $uname=~s/\W//g;
 # =============================================================================      my $subdir=$uname.'__';
             # do something with the connection      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
 # -----------------------------------------------------------------------------      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
     my $userinput = "1";      return $proname;
     #while (my $userinput=<$client>) {  } 
     while (my $userinput="1") {  
     print ("here we go\n");  ########################################################
  chomp($userinput);  ########################################################
     
  #send query id which is pid_unixdatetime_runningcounter  =pod
  $queryid = $conserver;   
  $queryid .=($$)."_";  =item &courselog
  $queryid .= time."_";  
  $queryid .= run;  Inputs: $path, $command
  print $client "$queryid\n";  
   Returns: unescaped string of values.
  #prepare and execute the query  
     =cut
  my $sth = $dbh->prepare("select * into outfile \"$queryid\" from resource");#can't use $userinput directly since we the query to write to a file which depends on the query id generated   
     ########################################################
  $sth->execute();  ########################################################
  if (-e "$queryid") { print "Oops ,file is already there!\n";}  sub courselog {
  else      my ($path,$command)=@_;
  {      my %filters=();
      print "error reading into file\n";      foreach (split(/\:/,&unescape($command))) {
  }   my ($name,$value)=split(/\=/,$_);
             $filters{$name}=$value;
                  #connect to lonc and send the query results      }
  $reply = reply($queryid,$conserver);      my @results=();
         open(IN,$path.'/activity.log') or return ('file_error');
      }      while (my $line=<IN>) {
 # =============================================================================          chomp($line);
           my ($timestamp,$host,$log)=split(/\:/,$line);
   #
   # $log has the actual log entries; currently still escaped, and
   # %26(timestamp)%3a(url)%3a(user)%3a(domain)
   # then additionally
   # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
   # or
   # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
   #
   # get delimiter between timestamped entries to be &&&
           $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
   # now go over all log entries 
           foreach (split(/\&\&\&/,&unescape($log))) {
       my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
               my $values=&unescape(join(':',@values));
               $values=~s/\&/\:/g;
               $res=&unescape($res);
               my $include=1;
               if (($filters{'username'}) && ($uname ne $filters{'username'})) 
                                                                  { $include=0; }
               if (($filters{'domain'}) && ($udom ne $filters{'domain'})) 
                                                                  { $include=0; }
               if (($filters{'url'}) && ($res!~/$filters{'url'}/)) 
                                                                  { $include=0; }
               if (($filters{'start'}) && ($time<$filters{'start'})) 
                                                                  { $include=0; }
               if (($filters{'end'}) && ($time>$filters{'end'})) 
                                                                  { $include=0; }
               if (($filters{'action'} eq 'view') && ($action)) 
                                                                  { $include=0; }
               if (($filters{'action'} eq 'submit') && ($action ne 'POST')) 
                                                                  { $include=0; }
               if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) 
                                                                  { $include=0; }
               if ($include) {
          push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
                                               $uname.':'.$udom.':'.
                                               $action.':'.$values);
               }
          }
       }
       close IN;
       return join('&',sort(@results));
   }
   
   ########################################################
   ########################################################
   
   =pod
   
   =item &userlog
   
   Inputs: $path, $command
   
   Returns: unescaped string of values.
   
   =cut
   
   ########################################################
   ########################################################
   sub userlog {
       my ($path,$command)=@_;
       my %filters=();
       foreach (split(/\:/,&unescape($command))) {
    my ($name,$value)=split(/\=/,$_);
           $filters{$name}=$value;
       }
       my @results=();
       open(IN,$path.'/activity.log') or return ('file_error');
       while (my $line=<IN>) {
           chomp($line);
           my ($timestamp,$host,$log)=split(/\:/,$line);
           $log=&unescape($log);
           my $include=1;
           if (($filters{'start'}) && ($timestamp<$filters{'start'})) 
                                                                { $include=0; }
           if (($filters{'end'}) && ($timestamp>$filters{'end'})) 
                                                                { $include=0; }
           if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
           if (($filters{'action'} eq 'check') && ($log!~/^Check/)) 
                                                                { $include=0; }
           if ($include) {
      push(@results,$timestamp.':'.$log);
         }          }
       
         # tidy up gracefully and finish  
       
         # this exit is VERY important, otherwise the child will become  
         # a producer of more and more children, forking yourself into  
         # process death.  
         exit;  
     }      }
 }         close IN;
           return join('&',sort(@results));
   }
   
   ########################################################
   ########################################################
   
   =pod
   
   =item Functions required for forking
   
   =over 4
   
   =item REAPER
   
   REAPER takes care of dead children.
   
   =item HUNTSMAN
   
   Signal handler for SIGINT.
   
   =item HUPSMAN
   
   Signal handler for SIGHUP
   
   =item DISCONNECT
   
   Disconnects from database.
   
   =back
   
   =cut
   
   ########################################################
   ########################################################
   sub REAPER {                   # takes care of dead children
       $SIG{CHLD} = \&REAPER;
       my $pid = wait;
       $children --;
       &logthis("Child $pid died");
       delete $children{$pid};
   }
   
   sub HUNTSMAN {                      # signal handler for SIGINT
       local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
       kill 'INT' => keys %children;
       my $execdir=$perlvar{'lonDaemons'};
       unlink("$execdir/logs/lonsql.pid");
       &logthis("<font color=red>CRITICAL: Shutting down</font>");
       $unixsock = "mysqlsock";
       my $port="$perlvar{'lonSockDir'}/$unixsock";
       unlink($port);
       exit;                           # clean up with dignity
   }
   
   sub HUPSMAN {                      # signal handler for SIGHUP
       local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
       kill 'INT' => keys %children;
       close($server);                # free up socket
       &logthis("<font color=red>CRITICAL: Restarting</font>");
       my $execdir=$perlvar{'lonDaemons'};
       $unixsock = "mysqlsock";
       my $port="$perlvar{'lonSockDir'}/$unixsock";
       unlink($port);
       exec("$execdir/lonsql");         # here we go again
   }
   
   sub DISCONNECT {
       $dbh->disconnect or 
       &logthis("<font color=blue>WARNING: Couldn't disconnect from database ".
                " $DBI::errstr : $@</font>");
       exit;
   }
   
   
   
       
   
   
   
Line 337  sub make_new_child { Line 975  sub make_new_child {
   
   
   
   # ----------------------------------- POD (plain old documentation, CPAN style)
   
   =pod
   
   =back
   
   =cut
Removed from v.1.1  
changed lines
  Added in v.1.56

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.