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

Diff for /loncom/lonsql between versions 1.1 and 1.29

version 1.1, 2000/05/08 15:14:27 version 1.29, 2001/04/02 20:10:09
Line 1 Line 1
 #!/usr/bin/perl  #!/usr/bin/perl
   # lonsql-based on the preforker:harsha jagasia:date:5/10/00
 # The LearningOnline Network  # 7/25 Gerd Kortemeyer
 # lonsql  # many different dates Scott Harrison
 # provides unix domain sockets to receive queries from lond and send replies to lonc  # 03/22/2001 Scott Harrison
 #  
 # 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;  
 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;
   
   my @metalist;
   # ----------------- Code to enable 'find' subroutine listing of the .meta files
   require "find.pl";
   sub wanted {
       (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
       -f _ &&
       /^.*\.meta$/ &&
       push(@metalist,"$dir/$_");
   }
   
   
 $childmaxattempts=10;  $childmaxattempts=10;
 $run =0;  $run =0;#running counter to generate the query-id
 # ------------------------------------ Read httpd access.conf and get variables  
   
   # ------------------------------------ Read httpd access.conf and get variables
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
   
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
Line 41  while ($configline=<CONFIG>) { Line 39  while ($configline=<CONFIG>) {
 }  }
 close(CONFIG);  close(CONFIG);
   
   # --------------------------------------------- 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  # ------------------------------------------------------------- Read hosts file
 #$PREFORK=4; # number of children to maintain, at least four spare  $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";
   
Line 50  while ($configline=<CONFIG>) { Line 59  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;      $hostip{$ip}=$id;
     $hostip{$id}=$ip;  
   
     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
   
     #$PREFORK++;      $PREFORK++;
 }  }
 close(CONFIG);  close(CONFIG);
   
   $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";
   }
   
 # -------------------------------------------------------- Routines for forking  # -------------------------------------------------------- Routines for forking
 # global variables  # global variables
 #$MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process  $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
 %children               = ();       # keys are current child process IDs  %children               = ();       # keys are current child process IDs
 #$children               = 0;        # current number of children  $children               = 0;        # current number of children
 %childpid               = ();       # the other way around  
   
 %childatt               = ();       # number of attempts to start server  
                                     # for ID  
   
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
     my $pid = wait;      my $pid = wait;
       $children --;
     #$children --;      &logthis("Child $pid died");
     #&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 $children{$pid};
     delete $childpid{$wasserver};  
     my $port = "$perlvar{'lonSockDir'}/$wasserver";  
     unlink($port);  
   
   
 }  }
   
 sub HUNTSMAN {                      # signal handler for SIGINT  sub HUNTSMAN {                      # signal handler for SIGINT
Line 96  sub HUNTSMAN {                      # si Line 98  sub HUNTSMAN {                      # si
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lonsql.pid");      unlink("$execdir/logs/lonsql.pid");
     &logthis("<font color=red>CRITICAL: Shutting down</font>");      &logthis("<font color=red>CRITICAL: Shutting down</font>");
       $unixsock = "mysqlsock";
       my $port="$perlvar{'lonSockDir'}/$unixsock";
       unlink(port);
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
   
Line 105  sub HUPSMAN {                      # sig Line 110  sub HUPSMAN {                      # sig
     close($server);                # free up socket      close($server);                # free up socket
     &logthis("<font color=red>CRITICAL: Restarting</font>");      &logthis("<font color=red>CRITICAL: Restarting</font>");
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
       $unixsock = "mysqlsock";
       my $port="$perlvar{'lonSockDir'}/$unixsock";
       unlink(port);
     exec("$execdir/lonsql");         # here we go again      exec("$execdir/lonsql");         # here we go again
 }  }
   
 sub logthis {  sub logthis {
     my $message=shift;      my $message=shift;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $fh=IO::File->new(">>$execdir/logs/lonsql.log");      my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     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  
 sub subreply {  
     my ($cmd,$server)=@_;  
     my $peerfile="$perlvar{'lonSockDir'}/$server";  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
     print $sclient "$cmd\n";  
     my $answer=<$sclient>;  
     chomp($answer);  
     if (!$answer) { $answer="con_lost"; }  
     return $answer;  
 }  
   
 sub reply {  
   my ($cmd,$server)=@_;  
   my $answer;  
   if ($server ne $perlvar{'lonHostID'}) {   
     $answer=subreply($cmd,$server);  
     if ($answer eq 'con_lost') {  
  $answer=subreply("ping",$server);  
         if ($answer ne $server) {  
            &reconlonc("$perlvar{'lonSockDir'}/$server");  
         }  
         $answer=subreply($cmd,$server);  
     }  
   } else {  
     $answer='self_reply';  
   }   
   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  # ---------------------------------------------------- Fork once and dissociate
 $fpid=fork;  $fpid=fork;
 exit if $fpid;  exit if $fpid;
Line 201  close(PIDSAVE); Line 141  close(PIDSAVE);
   
 # ----------------------------- Ignore signals generated during initial startup  # ----------------------------- Ignore signals generated during initial startup
 $SIG{HUP}=$SIG{USR1}='IGNORE';  $SIG{HUP}=$SIG{USR1}='IGNORE';
   # ------------------------------------------------------- Now we are on our own    
 # ------------------------------------------------------- Now we are on our own  # Fork off our children.
 #Fork of children one for every server  for (1 .. $PREFORK) {
       make_new_child();
 #for (1 .. $PREFORK) {  
 #    make_new_child($thisserver);  
 #}  
   
 foreach $thisserver (keys %hostip) {   
     make_new_child($thisserver);  
 }  }
   
 &logthis("Done starting initial servers");  # Install signal handlers.
 # ----------------------------------------------------- Install signal handlers  
   
 $SIG{CHLD} = \&REAPER;  $SIG{CHLD} = \&REAPER;
 $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 $SIG{HUP}  = \&HUPSMAN;  $SIG{HUP}  = \&HUPSMAN;
Line 223  $SIG{HUP}  = \&HUPSMAN; Line 155  $SIG{HUP}  = \&HUPSMAN;
 # And maintain the population.  # And maintain the population.
 while (1) {  while (1) {
     sleep;                          # wait for a signal (i.e., child's death)      sleep;                          # wait for a signal (i.e., child's death)
       for ($i = $children; $i < $PREFORK; $i++) {
     #for ($i = $children; $i < $PREFORK; $i++) {          make_new_child();           # top up the child pool
     #   make_new_child();           # top up the child pool  
     #}  
       
     foreach $thisserver (keys %hostip) {  
         if (!$childpid{$thisserver}) {  
     if ($childatt{$thisserver}<=$childmaxattempts) {  
        $childatt{$thisserver}++;  
                &logthis(  
    "<font color=yellow>INFO: Trying to reconnect for $thisserver "  
   ."($childatt{$thisserver} of $childmaxattempts attempts)</font>");   
                make_new_child($thisserver);  
     }  
         }         
     }      }
 }  }
   
   
 sub make_new_child {  sub make_new_child {
     my $conserver=shift;  
     my $pid;      my $pid;
     my $sigset;      my $sigset;
     my $queryid;      
   
     &logthis("Attempting to start child");      
     # block signal for fork      # block signal for fork
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)      sigprocmask(SIG_BLOCK, $sigset)
         or die "Can't block SIGINT for fork: $!\n";          or die "Can't block SIGINT for fork: $!\n";
           
     die "fork: $!" unless defined ($pid = fork);#do the forking of children      die "fork: $!" unless defined ($pid = fork);
       
     if ($pid) {      if ($pid) {
         # Parent records the child's birth and returns.          # Parent records the child's birth and returns.
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
Line 263  sub make_new_child { Line 180  sub make_new_child {
         $children++;          $children++;
         return;          return;
     } else {      } else {
        # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before          $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
           
         # unblock signals          # unblock signals
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
   
         #connect to the database  
           #open database handle
    # making dbh global to avoid garbage collector
  unless (   unless (
  my $dbh = DBI->connect("DBI:mysql:loncapa","root","mysql",{ RaiseError =>1,})   $dbh = DBI->connect("DBI:mysql:loncapa","www","123",{ RaiseError =>0,PrintError=>0})
  ) {    ) { 
             my $st=120+int(rand(240));  
     &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");      &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
     sleep($st);      print "database handle error\n";
     exit;#do I need to cleanup before exit if can't connect to database       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          # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {          for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
             $client = $server->accept()     or last;              $client = $server->accept()     or last;
     $run = $run+1;              
 # =============================================================================  
             # do something with the connection              # do something with the connection
 # -----------------------------------------------------------------------------      $run = $run+1;
     my $userinput = "1";      my $userinput = <$client>;
     #while (my $userinput=<$client>) {      chomp($userinput);
     while (my $userinput="1") {          
     print ("here we go\n");      my ($conserver,$querytmp,
  chomp($userinput);   $customtmp,$customshowtmp)=split(/&/,$userinput);
         my $query=unescape($querytmp);
  #send query id which is pid_unixdatetime_runningcounter      my $custom=unescape($customtmp);
  $queryid = $conserver;       my $customshow=unescape($customshowtmp);
  $queryid .=($$)."_";  
  $queryid .= time."_";              #send query id which is pid_unixdatetime_runningcounter
  $queryid .= run;      $queryid = $thisserver;
  print $client "$queryid\n";      $queryid .="_".($$)."_";
       $queryid .= time."_";
  #prepare and execute the query      $queryid .= $run;
         print $client "$queryid\n";
  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       
         &logthis("QUERY: $query");
  $sth->execute();      &logthis("QUERY: $query");
  if (-e "$queryid") { print "Oops ,file is already there!\n";}      sleep 1;
  else              #prepare and execute the query
  {      my $sth = $dbh->prepare($query);
      print "error reading into file\n";      my $result;
  }      my @files;
         my $subsetflag=0;
                  #connect to lonc and send the query results      if ($query) {
  $reply = reply($queryid,$conserver);   unless ($sth->execute())
      {
      }      &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
 # =============================================================================      $result="";
    }
    else {
       my $r1=$sth->fetchall_arrayref;
       my @r2;
       map {my $a=$_; 
    my @b=map {escape($_)} @$a;
    push @files,@{$a}[3];
    push @r2,join(",", @b)
    } (@$r1);
       $result=join("&",@r2);
    }
       }
       # do custom metadata searching here and build into result
       if ($custom or $customshow) {
    &logthis("am going to do custom query for $custom");
    if ($query) {
       @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
    }
    else {
       @metalist=(); pop @metalist;
       &find("$perlvar{'lonDocRoot'}/res");
    }
   # &logthis("FILELIST:" . join(":::",@metalist));
    # 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 @r2;
    foreach my $m (@metalist) {
       my $fh=IO::File->new($m);
       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?//;
    }
    my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
    $m2=~s/^$docroot//;
    $m2=~s/\.meta$//;
    unless ($query) {
       my $q2="select * from metadata where url like '$m2'";
       my $sth = $dbh->prepare($q2);
       $sth->execute();
       my $r1=$sth->fetchall_arrayref;
       map {my $a=$_; 
    my @b=map {escape($_)} @$a;
    push @files,@{$a}[3];
    push @r2,join(",", @b)
    } (@$r1);
    }
   # &logthis("found: $stuff");
    $customresult.='&custom='.escape($m2).','.escape($stuff);
       }
    }
    $result=join("&",@r2) unless $query;
    $result.=$customresult;
       }
       # reply with result
       $result.="\n" if $result;
               &reply("queryreply:$queryid:$result",$conserver);
   
         }          }
           
         # tidy up gracefully and finish          # tidy up gracefully and finish
   
           #close the database handle
    $dbh->disconnect
      or &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
           
         # this exit is VERY important, otherwise the child will become          # this exit is VERY important, otherwise the child will become
         # a producer of more and more children, forking yourself into          # a producer of more and more children, forking yourself into
         # process death.          # process death.
         exit;          exit;
     }      }
 }     }
       
   
       
   
   
   
   
   sub DISCONNECT {
       $dbh->disconnect or 
       &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
       exit;
   }
   
   # -------------------------------------------------- Non-critical communication
   
   sub subreply {
       my ($cmd,$server)=@_;
       my $peerfile="$perlvar{'lonSockDir'}/$server";
       my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                         Type    => SOCK_STREAM,
                                         Timeout => 10)
          or return "con_lost";
       print $sclient "$cmd\n";
       my $answer=<$sclient>;
       chomp($answer);
       if (!$answer) { $answer="con_lost"; }
       return $answer;
   }
   
   sub reply {
     my ($cmd,$server)=@_;
     my $answer;
     if ($server ne $perlvar{'lonHostID'}) { 
       $answer=subreply($cmd,$server);
       if ($answer eq 'con_lost') {
    $answer=subreply("ping",$server);
           $answer=subreply($cmd,$server);
       }
     } else {
       $answer='self_reply';
     } 
     return $answer;
   }
   
   # -------------------------------------------------------- Escape Special Chars
   
   sub escape {
       my $str=shift;
       $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
       return $str;
   }
   
   # ----------------------------------------------------- Un-Escape Special Chars
   
   sub unescape {
       my $str=shift;
       $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       return $str;
   }
Removed from v.1.1  
changed lines
  Added in v.1.29

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.