Annotation of loncom/lonsql, revision 1.20

1.1       harris41    1: #!/usr/bin/perl
1.2       harris41    2: # lonsql-based on the preforker:harsha jagasia:date:5/10/00
1.4       www         3: # 7/25 Gerd Kortemeyer
1.6       harris41    4: # many different dates Scott Harrison
1.7       harris41    5: # 03/22/2001 Scott Harrison
1.2       harris41    6: use IO::Socket;
                      7: use Symbol;
1.1       harris41    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: 
1.9       harris41   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: 
1.1       harris41   26: 
                     27: $childmaxattempts=10;
1.2       harris41   28: $run =0;#running counter to generate the query-id
                     29: 
1.1       harris41   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);
1.4       www        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: }
1.1       harris41   52: 
                     53: # ------------------------------------------------------------- Read hosts file
1.2       harris41   54: $PREFORK=4; # number of children to maintain, at least four spare
1.1       harris41   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: 
1.2       harris41   62:     $hostip{$ip}=$id;
1.1       harris41   63: 
                     64:     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
                     65: 
1.2       harris41   66:     $PREFORK++;
1.1       harris41   67: }
                     68: close(CONFIG);
                     69: 
1.2       harris41   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: }
1.1       harris41   80: 
                     81: # -------------------------------------------------------- Routines for forking
                     82: # global variables
1.2       harris41   83: $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
1.1       harris41   84: %children               = ();       # keys are current child process IDs
1.2       harris41   85: $children               = 0;        # current number of children
1.1       harris41   86: 
                     87: sub REAPER {                        # takes care of dead children
                     88:     $SIG{CHLD} = \&REAPER;
                     89:     my $pid = wait;
1.2       harris41   90:     $children --;
                     91:     &logthis("Child $pid died");
1.1       harris41   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>");
1.2       harris41  101:     $unixsock = "mysqlsock";
                    102:     my $port="$perlvar{'lonSockDir'}/$unixsock";
                    103:     unlink(port);
1.1       harris41  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'};
1.2       harris41  113:     $unixsock = "mysqlsock";
                    114:     my $port="$perlvar{'lonSockDir'}/$unixsock";
                    115:     unlink(port);
1.1       harris41  116:     exec("$execdir/lonsql");         # here we go again
                    117: }
                    118: 
                    119: sub logthis {
                    120:     my $message=shift;
                    121:     my $execdir=$perlvar{'lonDaemons'};
1.2       harris41  122:     my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
1.1       harris41  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';
1.2       harris41  144: # ------------------------------------------------------- Now we are on our own    
                    145: # Fork off our children.
                    146: for (1 .. $PREFORK) {
                    147:     make_new_child();
1.1       harris41  148: }
                    149: 
1.2       harris41  150: # Install signal handlers.
1.1       harris41  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)
1.2       harris41  158:     for ($i = $children; $i < $PREFORK; $i++) {
                    159:         make_new_child();           # top up the child pool
1.1       harris41  160:     }
                    161: }
                    162: 
1.2       harris41  163: 
1.1       harris41  164: sub make_new_child {
                    165:     my $pid;
                    166:     my $sigset;
1.2       harris41  167:     
1.1       harris41  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:     
1.2       harris41  173:     die "fork: $!" unless defined ($pid = fork);
                    174:     
1.1       harris41  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 {
1.2       harris41  183:         # Child can *not* return from this subroutine.
1.1       harris41  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";
1.2       harris41  189: 	
                    190: 	
                    191:         #open database handle
                    192: 	# making dbh global to avoid garbage collector
1.1       harris41  193: 	unless (
1.5       harris41  194: 		$dbh = DBI->connect("DBI:mysql:loncapa","www","123",{ RaiseError =>0,PrintError=>0})
1.1       harris41  195: 		) { 
                    196: 	            my $st=120+int(rand(240));
                    197: 		    &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
1.2       harris41  198: 		    print "database handle error\n";
1.1       harris41  199: 		    sleep($st);
1.2       harris41  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: 
1.1       harris41  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;
1.2       harris41  209:             
                    210:             # do something with the connection
1.1       harris41  211: 	    $run = $run+1;
1.2       harris41  212: 	    my $userinput = <$client>;
                    213: 	    chomp($userinput);
                    214: 	    	    
1.7       harris41  215: 	    my ($conserver,$querytmp,$customtmp)=split(/&/,$userinput);
1.3       harris41  216: 	    my $query=unescape($querytmp);
1.7       harris41  217: 	    my $custom=unescape($customtmp);
1.2       harris41  218: 
                    219:             #send query id which is pid_unixdatetime_runningcounter
                    220: 	    $queryid = $thisserver;
                    221: 	    $queryid .="_".($$)."_";
                    222: 	    $queryid .= time."_";
                    223: 	    $queryid .= $run;
                    224: 	    print $client "$queryid\n";
                    225: 	    
                    226:             #prepare and execute the query
1.3       harris41  227: 	    my $sth = $dbh->prepare($query);
                    228: 	    my $result;
1.20    ! harris41  229: 	    my @files;
1.3       harris41  230: 	    unless ($sth->execute())
                    231: 	    {
                    232: 		&logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
                    233: 		$result="";
                    234: 	    }
                    235: 	    else {
                    236: 		my $r1=$sth->fetchall_arrayref;
1.20    ! harris41  237: 		my @r2;
        !           238: 		map {my $a=$_; 
        !           239: 		     my @b=map {escape($_)} @$a;
        !           240: 		     push @files,@{$a}[3];
        !           241: 		     push @r2,join(",", @b)
        !           242: 		     } (@$r1);
1.17      harris41  243: 		$result=join("&",@r2);
1.3       harris41  244: 	    }
1.7       harris41  245: 
                    246: 	    # do custom metadata searching here and build into result
1.9       harris41  247: 	    if ($custom) {
                    248: 		&logthis("am going to do custom query for $custom");
1.20    ! harris41  249: 		if (@files) {
        !           250: 		    @metalist=map {$perlvar{'lonDocRoot'}.$_.'meta'} @files;
        !           251: 		}
        !           252: 		else {
        !           253: 		    @metalist=(); pop @metalist;
        !           254: 		    &find("$perlvar{'lonDocRoot'}/res");
        !           255: 		}
        !           256: #		&logthis("FILELIST:" . join(":::",@metalist));
1.10      harris41  257: 		# if file is indicated in sql database and
                    258: 		# not part of sql-relevant query, do not pattern match.
                    259: 		# if file is not in sql database, output error.
                    260: 		# if file is indicated in sql database and is
                    261: 		# part of query result list, then do the pattern match.
1.12      harris41  262: 		my $customresult='';
1.11      harris41  263: 		foreach my $m (@metalist) {
                    264: 		    my $fh=IO::File->new($m);
                    265: 		    my @lines=<$fh>;
                    266: 		    my $stuff=join('',@lines);
                    267: 		    if ($stuff=~/$custom/s) {
1.18      harris41  268: 			foreach my $f ('abstract','author','copyright',
                    269: 				       'creationdate','keywords','language',
                    270: 				       'lastrevisiondate','mime','notes',
                    271: 				       'owner','subject','title') {
1.19      harris41  272: 			    $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//;
1.18      harris41  273: 			}
1.19      harris41  274: 			my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
1.20    ! harris41  275: 			$m2=~s/^$docroot//; $m2=~s/\.meta$//;
        !           276: #			&logthis("found: $stuff");
1.19      harris41  277: 			$customresult.='&custom='.escape($m2).','.escape($stuff);
1.11      harris41  278: 		    }
                    279: 		}
1.17      harris41  280: 		$result.=$customresult;
1.9       harris41  281: 	    }
1.8       harris41  282: 	    # reply with result
1.17      harris41  283: 	    $result.="\n" if $result;
                    284:             &reply("queryreply:$queryid:$result",$conserver);
1.2       harris41  285: 
1.1       harris41  286:         }
                    287:     
                    288:         # tidy up gracefully and finish
1.2       harris41  289: 	
                    290:         #close the database handle
                    291: 	$dbh->disconnect
                    292: 	   or &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
1.1       harris41  293:     
                    294:         # this exit is VERY important, otherwise the child will become
                    295:         # a producer of more and more children, forking yourself into
                    296:         # process death.
                    297:         exit;
                    298:     }
1.2       harris41  299: }
1.1       harris41  300: 
1.2       harris41  301: sub DISCONNECT {
                    302:     $dbh->disconnect or 
                    303:     &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
                    304:     exit;
                    305: }
1.1       harris41  306: 
1.2       harris41  307: # -------------------------------------------------- Non-critical communication
1.1       harris41  308: 
1.2       harris41  309: sub subreply {
                    310:     my ($cmd,$server)=@_;
                    311:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    312:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    313:                                       Type    => SOCK_STREAM,
                    314:                                       Timeout => 10)
                    315:        or return "con_lost";
                    316:     print $sclient "$cmd\n";
                    317:     my $answer=<$sclient>;
                    318:     chomp($answer);
                    319:     if (!$answer) { $answer="con_lost"; }
                    320:     return $answer;
                    321: }
1.1       harris41  322: 
1.2       harris41  323: sub reply {
                    324:   my ($cmd,$server)=@_;
                    325:   my $answer;
                    326:   if ($server ne $perlvar{'lonHostID'}) { 
                    327:     $answer=subreply($cmd,$server);
                    328:     if ($answer eq 'con_lost') {
                    329: 	$answer=subreply("ping",$server);
                    330:         $answer=subreply($cmd,$server);
                    331:     }
                    332:   } else {
                    333:     $answer='self_reply';
                    334:   } 
                    335:   return $answer;
                    336: }
1.1       harris41  337: 
1.3       harris41  338: # -------------------------------------------------------- Escape Special Chars
                    339: 
                    340: sub escape {
                    341:     my $str=shift;
                    342:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                    343:     return $str;
                    344: }
                    345: 
                    346: # ----------------------------------------------------- Un-Escape Special Chars
                    347: 
                    348: sub unescape {
                    349:     my $str=shift;
                    350:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    351:     return $str;
                    352: }

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