Annotation of loncom/lonsql, revision 1.37

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

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