File:  [LON-CAPA] / loncom / lonsql
Revision 1.21: download - view: text, annotated - select for diffs
Tue Mar 27 13:35:35 2001 UTC (23 years, 1 month ago) by harris41
Branches: MAIN
CVS tags: HEAD
more changes to support bleeping custom metadata -Scott

    1: #!/usr/bin/perl
    2: # lonsql-based on the preforker:harsha jagasia:date:5/10/00
    3: # 7/25 Gerd Kortemeyer
    4: # many different dates Scott Harrison
    5: # 03/22/2001 Scott Harrison
    6: use IO::Socket;
    7: use Symbol;
    8: use POSIX;
    9: use IO::Select;
   10: use IO::File;
   11: use Socket;
   12: use Fcntl;
   13: use Tie::RefHash;
   14: use DBI;
   15: 
   16: my @metalist;
   17: # ----------------- Code to enable 'find' subroutine listing of the .meta files
   18: require "find.pl";
   19: sub wanted {
   20:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
   21:     -f _ &&
   22:     /^.*\.meta$/ &&
   23:     push(@metalist,"$dir/$_");
   24: }
   25: 
   26: 
   27: $childmaxattempts=10;
   28: $run =0;#running counter to generate the query-id
   29: 
   30: # ------------------------------------ Read httpd access.conf and get variables
   31: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
   32: 
   33: while ($configline=<CONFIG>) {
   34:     if ($configline =~ /PerlSetVar/) {
   35: 	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
   36:         chomp($varvalue);
   37:         $perlvar{$varname}=$varvalue;
   38:     }
   39: }
   40: close(CONFIG);
   41: 
   42: # --------------------------------------------- Check if other instance running
   43: 
   44: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
   45: 
   46: if (-e $pidfile) {
   47:    my $lfh=IO::File->new("$pidfile");
   48:    my $pide=<$lfh>;
   49:    chomp($pide);
   50:    if (kill 0 => $pide) { die "already running"; }
   51: }
   52: 
   53: # ------------------------------------------------------------- Read hosts file
   54: $PREFORK=4; # number of children to maintain, at least four spare
   55: 
   56: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
   57: 
   58: while ($configline=<CONFIG>) {
   59:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
   60:     chomp($ip);
   61: 
   62:     $hostip{$ip}=$id;
   63: 
   64:     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
   65: 
   66:     $PREFORK++;
   67: }
   68: close(CONFIG);
   69: 
   70: $unixsock = "mysqlsock";
   71: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
   72: my $server;
   73: unlink ($localfile);
   74: unless ($server=IO::Socket::UNIX->new(Local    =>"$localfile",
   75: 				  Type    => SOCK_STREAM,
   76: 				  Listen => 10))
   77: {
   78:     print "in socket error:$@\n";
   79: }
   80: 
   81: # -------------------------------------------------------- Routines for forking
   82: # global variables
   83: $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
   84: %children               = ();       # keys are current child process IDs
   85: $children               = 0;        # current number of children
   86: 
   87: sub REAPER {                        # takes care of dead children
   88:     $SIG{CHLD} = \&REAPER;
   89:     my $pid = wait;
   90:     $children --;
   91:     &logthis("Child $pid died");
   92:     delete $children{$pid};
   93: }
   94: 
   95: sub HUNTSMAN {                      # signal handler for SIGINT
   96:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
   97:     kill 'INT' => keys %children;
   98:     my $execdir=$perlvar{'lonDaemons'};
   99:     unlink("$execdir/logs/lonsql.pid");
  100:     &logthis("<font color=red>CRITICAL: Shutting down</font>");
  101:     $unixsock = "mysqlsock";
  102:     my $port="$perlvar{'lonSockDir'}/$unixsock";
  103:     unlink(port);
  104:     exit;                           # clean up with dignity
  105: }
  106: 
  107: sub HUPSMAN {                      # signal handler for SIGHUP
  108:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
  109:     kill 'INT' => keys %children;
  110:     close($server);                # free up socket
  111:     &logthis("<font color=red>CRITICAL: Restarting</font>");
  112:     my $execdir=$perlvar{'lonDaemons'};
  113:     $unixsock = "mysqlsock";
  114:     my $port="$perlvar{'lonSockDir'}/$unixsock";
  115:     unlink(port);
  116:     exec("$execdir/lonsql");         # here we go again
  117: }
  118: 
  119: sub logthis {
  120:     my $message=shift;
  121:     my $execdir=$perlvar{'lonDaemons'};
  122:     my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
  123:     my $now=time;
  124:     my $local=localtime($now);
  125:     print $fh "$local ($$): $message\n";
  126: }
  127: # ---------------------------------------------------- Fork once and dissociate
  128: $fpid=fork;
  129: exit if $fpid;
  130: die "Couldn't fork: $!" unless defined ($fpid);
  131: 
  132: POSIX::setsid() or die "Can't start new session: $!";
  133: 
  134: # ------------------------------------------------------- Write our PID on disk
  135: 
  136: $execdir=$perlvar{'lonDaemons'};
  137: open (PIDSAVE,">$execdir/logs/lonsql.pid");
  138: print PIDSAVE "$$\n";
  139: close(PIDSAVE);
  140: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
  141: 
  142: # ----------------------------- Ignore signals generated during initial startup
  143: $SIG{HUP}=$SIG{USR1}='IGNORE';
  144: # ------------------------------------------------------- Now we are on our own    
  145: # Fork off our children.
  146: for (1 .. $PREFORK) {
  147:     make_new_child();
  148: }
  149: 
  150: # Install signal handlers.
  151: $SIG{CHLD} = \&REAPER;
  152: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
  153: $SIG{HUP}  = \&HUPSMAN;
  154: 
  155: # And maintain the population.
  156: while (1) {
  157:     sleep;                          # wait for a signal (i.e., child's death)
  158:     for ($i = $children; $i < $PREFORK; $i++) {
  159:         make_new_child();           # top up the child pool
  160:     }
  161: }
  162: 
  163: 
  164: sub make_new_child {
  165:     my $pid;
  166:     my $sigset;
  167:     
  168:     # block signal for fork
  169:     $sigset = POSIX::SigSet->new(SIGINT);
  170:     sigprocmask(SIG_BLOCK, $sigset)
  171:         or die "Can't block SIGINT for fork: $!\n";
  172:     
  173:     die "fork: $!" unless defined ($pid = fork);
  174:     
  175:     if ($pid) {
  176:         # Parent records the child's birth and returns.
  177:         sigprocmask(SIG_UNBLOCK, $sigset)
  178:             or die "Can't unblock SIGINT for fork: $!\n";
  179:         $children{$pid} = 1;
  180:         $children++;
  181:         return;
  182:     } else {
  183:         # Child can *not* return from this subroutine.
  184:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
  185:     
  186:         # unblock signals
  187:         sigprocmask(SIG_UNBLOCK, $sigset)
  188:             or die "Can't unblock SIGINT for fork: $!\n";
  189: 	
  190: 	
  191:         #open database handle
  192: 	# making dbh global to avoid garbage collector
  193: 	unless (
  194: 		$dbh = DBI->connect("DBI:mysql:loncapa","www","123",{ RaiseError =>0,PrintError=>0})
  195: 		) { 
  196: 	            my $st=120+int(rand(240));
  197: 		    &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
  198: 		    print "database handle error\n";
  199: 		    sleep($st);
  200: 		    exit;
  201: 
  202: 	  };
  203: 	# make sure that a database disconnection occurs with ending kill signals
  204: 	$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
  205: 
  206:         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
  207:         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
  208:             $client = $server->accept()     or last;
  209:             
  210:             # do something with the connection
  211: 	    $run = $run+1;
  212: 	    my $userinput = <$client>;
  213: 	    chomp($userinput);
  214: 	    	    
  215: 	    my ($conserver,$querytmp,
  216: 		$customtmp,$customshowtmp)=split(/&/,$userinput);
  217: 	    my $query=unescape($querytmp);
  218: 	    my $custom=unescape($customtmp);
  219: 	    my $customshow=unescape($customshowtmp);
  220: 
  221:             #send query id which is pid_unixdatetime_runningcounter
  222: 	    $queryid = $thisserver;
  223: 	    $queryid .="_".($$)."_";
  224: 	    $queryid .= time."_";
  225: 	    $queryid .= $run;
  226: 	    print $client "$queryid\n";
  227: 	    
  228:             #prepare and execute the query
  229: 	    my $sth = $dbh->prepare($query);
  230: 	    my $result;
  231: 	    my @files;
  232: 	    unless ($sth->execute())
  233: 	    {
  234: 		&logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
  235: 		$result="";
  236: 	    }
  237: 	    else {
  238: 		my $r1=$sth->fetchall_arrayref;
  239: 		my @r2;
  240: 		map {my $a=$_; 
  241: 		     my @b=map {escape($_)} @$a;
  242: 		     push @files,@{$a}[3];
  243: 		     push @r2,join(",", @b)
  244: 		     } (@$r1);
  245: 		$result=join("&",@r2);
  246: 	    }
  247: 
  248: 	    # do custom metadata searching here and build into result
  249: 	    if ($custom) {
  250: 		&logthis("am going to do custom query for $custom");
  251: 		if (@files) {
  252: 		    @metalist=map {$perlvar{'lonDocRoot'}.$_.'meta'} @files;
  253: 		}
  254: 		else {
  255: 		    @metalist=(); pop @metalist;
  256: 		    &find("$perlvar{'lonDocRoot'}/res");
  257: 		}
  258: #		&logthis("FILELIST:" . join(":::",@metalist));
  259: 		# if file is indicated in sql database and
  260: 		# not part of sql-relevant query, do not pattern match.
  261: 		# if file is not in sql database, output error.
  262: 		# if file is indicated in sql database and is
  263: 		# part of query result list, then do the pattern match.
  264: 		my $customresult='';
  265: 		foreach my $m (@metalist) {
  266: 		    my $fh=IO::File->new($m);
  267: 		    my @lines=<$fh>;
  268: 		    my $stuff=join('',@lines);
  269: 		    if ($stuff=~/$custom/s) {
  270: 			foreach my $f ('abstract','author','copyright',
  271: 				       'creationdate','keywords','language',
  272: 				       'lastrevisiondate','mime','notes',
  273: 				       'owner','subject','title') {
  274: 			    $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//;
  275: 			}
  276: 			my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
  277: 			$m2=~s/^$docroot//; $m2=~s/\.meta$//;
  278: #			&logthis("found: $stuff");
  279: 			$customresult.='&custom='.escape($m2).','.escape($stuff);
  280: 		    }
  281: 		}
  282: 		$result.=$customresult;
  283: 	    }
  284: 	    # reply with result
  285: 	    $result.="\n" if $result;
  286:             &reply("queryreply:$queryid:$result",$conserver);
  287: 
  288:         }
  289:     
  290:         # tidy up gracefully and finish
  291: 	
  292:         #close the database handle
  293: 	$dbh->disconnect
  294: 	   or &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
  295:     
  296:         # this exit is VERY important, otherwise the child will become
  297:         # a producer of more and more children, forking yourself into
  298:         # process death.
  299:         exit;
  300:     }
  301: }
  302: 
  303: sub DISCONNECT {
  304:     $dbh->disconnect or 
  305:     &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
  306:     exit;
  307: }
  308: 
  309: # -------------------------------------------------- Non-critical communication
  310: 
  311: sub subreply {
  312:     my ($cmd,$server)=@_;
  313:     my $peerfile="$perlvar{'lonSockDir'}/$server";
  314:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  315:                                       Type    => SOCK_STREAM,
  316:                                       Timeout => 10)
  317:        or return "con_lost";
  318:     print $sclient "$cmd\n";
  319:     my $answer=<$sclient>;
  320:     chomp($answer);
  321:     if (!$answer) { $answer="con_lost"; }
  322:     return $answer;
  323: }
  324: 
  325: sub reply {
  326:   my ($cmd,$server)=@_;
  327:   my $answer;
  328:   if ($server ne $perlvar{'lonHostID'}) { 
  329:     $answer=subreply($cmd,$server);
  330:     if ($answer eq 'con_lost') {
  331: 	$answer=subreply("ping",$server);
  332:         $answer=subreply($cmd,$server);
  333:     }
  334:   } else {
  335:     $answer='self_reply';
  336:   } 
  337:   return $answer;
  338: }
  339: 
  340: # -------------------------------------------------------- Escape Special Chars
  341: 
  342: sub escape {
  343:     my $str=shift;
  344:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
  345:     return $str;
  346: }
  347: 
  348: # ----------------------------------------------------- Un-Escape Special Chars
  349: 
  350: sub unescape {
  351:     my $str=shift;
  352:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  353:     return $str;
  354: }

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