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

Diff for /loncom/lonsql between versions 1.1 and 1.35

version 1.1, 2000/05/08 15:14:27 version 1.35, 2001/04/17 15:47:19
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$/ && !/^.+\.\d+\.[^\.]+\.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 38  while ($configline=<CONFIG>) {
 }  }
 close(CONFIG);  close(CONFIG);
   
   # ------------------------------------- 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";
    exit;
       }
       else {
    $dbh->disconnect;
       }
   }
   
   # --------------------------------------------- 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 72  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 110  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 122  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 153  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 167  $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 192  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",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
  ) {    ) { 
             my $st=120+int(rand(240));               sleep(10+int(rand(20)));
     &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;
       opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
       my @homeusers=grep
             {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
             grep {!/^\.\.?$/} readdir(RESOURCES);
       closedir RESOURCES;
       foreach my $user (@homeusers) {
    &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
       }
    }
   # &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 binary '$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';
       $answer=subreply($cmd,$server);
     } 
     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;
   }
   
   # --------------------------------------- Is this the home server of an author?
   # (copied from lond, modification of the return value)
   sub ishome {
       my $author=shift;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $proname=propath($udom,$uname);
       if (-e $proname) {
    return 1;
       } else {
           return 0;
       }
   }
   
   # -------------------------------------------- Return path to profile directory
   # (copied from lond)
   sub propath {
       my ($udom,$uname)=@_;
       $udom=~s/\W//g;
       $uname=~s/\W//g;
       my $subdir=$uname.'__';
       $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
       my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
       return $proname;
   } 
Removed from v.1.1  
changed lines
  Added in v.1.35

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