Annotation of loncom/lonsql, revision 1.49

1.1       harris41    1: #!/usr/bin/perl
1.39      harris41    2: 
                      3: # The LearningOnline Network
1.40      harris41    4: # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
1.39      harris41    5: #
1.49    ! www         6: # $Id: lonsql,v 1.48 2002/06/18 21:14:23 www Exp $
1.41      harris41    7: #
                      8: # Copyright Michigan State University Board of Trustees
                      9: #
                     10: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                     11: #
                     12: # LON-CAPA is free software; you can redistribute it and/or modify
                     13: # it under the terms of the GNU General Public License as published by
                     14: # the Free Software Foundation; either version 2 of the License, or
                     15: # (at your option) any later version.
                     16: #
                     17: # LON-CAPA is distributed in the hope that it will be useful,
                     18: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     19: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     20: # GNU General Public License for more details.
                     21: #
                     22: # You should have received a copy of the GNU General Public License
                     23: # along with LON-CAPA; if not, write to the Free Software
                     24: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     25: #
                     26: # /home/httpd/html/adm/gpl.txt
                     27: #
                     28: # http://www.lon-capa.org/
                     29: #
1.39      harris41   30: # YEAR=2000
1.2       harris41   31: # lonsql-based on the preforker:harsha jagasia:date:5/10/00
1.4       www        32: # 7/25 Gerd Kortemeyer
1.6       harris41   33: # many different dates Scott Harrison
1.39      harris41   34: # YEAR=2001
                     35: # many different dates Scott Harrison
1.7       harris41   36: # 03/22/2001 Scott Harrison
1.36      www        37: # 8/30 Gerd Kortemeyer
1.41      harris41   38: # 10/17,11/28,11/29,12/20 Scott Harrison
1.42      harris41   39: # YEAR=2001
                     40: # 5/11 Scott Harrison
1.39      harris41   41: #
                     42: ###
                     43: 
1.40      harris41   44: ###############################################################################
                     45: ##                                                                           ##
                     46: ## ORGANIZATION OF THIS PERL SCRIPT                                          ##
                     47: ## 1. Modules used                                                           ##
                     48: ## 2. Enable find subroutine                                                 ##
1.43      matthew    49: ## 3. Read httpd config files and get variables                              ##
1.40      harris41   50: ## 4. Make sure that database can be accessed                                ##
                     51: ## 5. Make sure this process is running from user=www                        ##
                     52: ## 6. Check if other instance is running                                     ##
                     53: ## 7. POD (plain old documentation, CPAN style)                              ##
                     54: ##                                                                           ##
                     55: ###############################################################################
1.36      www        56: 
1.42      harris41   57: use lib '/home/httpd/lib/perl/';
                     58: use LONCAPA::Configuration;
                     59: 
1.2       harris41   60: use IO::Socket;
                     61: use Symbol;
1.1       harris41   62: use POSIX;
                     63: use IO::Select;
                     64: use IO::File;
                     65: use Socket;
                     66: use Fcntl;
                     67: use Tie::RefHash;
                     68: use DBI;
                     69: 
1.9       harris41   70: my @metalist;
                     71: # ----------------- Code to enable 'find' subroutine listing of the .meta files
                     72: require "find.pl";
                     73: sub wanted {
                     74:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
                     75:     -f _ &&
1.34      harris41   76:     /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
1.9       harris41   77:     push(@metalist,"$dir/$_");
                     78: }
                     79: 
1.1       harris41   80: $childmaxattempts=10;
1.2       harris41   81: $run =0;#running counter to generate the query-id
                     82: 
1.43      matthew    83: # -------------------------------- Read loncapa_apache.conf and loncapa.conf
                     84: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
                     85:                                                  'loncapa.conf');
1.42      harris41   86: my %perlvar=%{$perlvarref};
1.4       www        87: 
1.31      harris41   88: # ------------------------------------- Make sure that database can be accessed
                     89: {
                     90:     my $dbh;
                     91:     unless (
                     92: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
                     93: 	    ) { 
                     94: 	print "Cannot connect to database!\n";
1.38      harris41   95: 	$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
                     96: 	$subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
                     97: 	system("echo 'Cannot connect to MySQL database!' |\
                     98:  mailto $emailto -s '$subj' > /dev/null");
                     99: 	exit 1;
1.31      harris41  100:     }
                    101:     else {
                    102: 	$dbh->disconnect;
                    103:     }
                    104: }
                    105: 
1.4       www       106: # --------------------------------------------- Check if other instance running
                    107: 
                    108: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
                    109: 
                    110: if (-e $pidfile) {
                    111:    my $lfh=IO::File->new("$pidfile");
                    112:    my $pide=<$lfh>;
                    113:    chomp($pide);
                    114:    if (kill 0 => $pide) { die "already running"; }
                    115: }
1.1       harris41  116: 
                    117: # ------------------------------------------------------------- Read hosts file
1.2       harris41  118: $PREFORK=4; # number of children to maintain, at least four spare
1.1       harris41  119: 
                    120: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
                    121: 
                    122: while ($configline=<CONFIG>) {
                    123:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
                    124:     chomp($ip);
                    125: 
1.2       harris41  126:     $hostip{$ip}=$id;
1.1       harris41  127:     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
                    128: 
1.2       harris41  129:     $PREFORK++;
1.1       harris41  130: }
                    131: close(CONFIG);
1.36      www       132: 
                    133: $PREFORK=int($PREFORK/4);
1.1       harris41  134: 
1.2       harris41  135: $unixsock = "mysqlsock";
                    136: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
                    137: my $server;
                    138: unlink ($localfile);
                    139: unless ($server=IO::Socket::UNIX->new(Local    =>"$localfile",
                    140: 				  Type    => SOCK_STREAM,
                    141: 				  Listen => 10))
                    142: {
                    143:     print "in socket error:$@\n";
                    144: }
1.1       harris41  145: 
                    146: # -------------------------------------------------------- Routines for forking
                    147: # global variables
1.2       harris41  148: $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
1.1       harris41  149: %children               = ();       # keys are current child process IDs
1.2       harris41  150: $children               = 0;        # current number of children
1.1       harris41  151: 
                    152: sub REAPER {                        # takes care of dead children
                    153:     $SIG{CHLD} = \&REAPER;
                    154:     my $pid = wait;
1.2       harris41  155:     $children --;
                    156:     &logthis("Child $pid died");
1.1       harris41  157:     delete $children{$pid};
                    158: }
                    159: 
                    160: sub HUNTSMAN {                      # signal handler for SIGINT
                    161:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
                    162:     kill 'INT' => keys %children;
                    163:     my $execdir=$perlvar{'lonDaemons'};
                    164:     unlink("$execdir/logs/lonsql.pid");
                    165:     &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.2       harris41  166:     $unixsock = "mysqlsock";
                    167:     my $port="$perlvar{'lonSockDir'}/$unixsock";
                    168:     unlink(port);
1.1       harris41  169:     exit;                           # clean up with dignity
                    170: }
                    171: 
                    172: sub HUPSMAN {                      # signal handler for SIGHUP
                    173:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
                    174:     kill 'INT' => keys %children;
                    175:     close($server);                # free up socket
                    176:     &logthis("<font color=red>CRITICAL: Restarting</font>");
                    177:     my $execdir=$perlvar{'lonDaemons'};
1.2       harris41  178:     $unixsock = "mysqlsock";
                    179:     my $port="$perlvar{'lonSockDir'}/$unixsock";
                    180:     unlink(port);
1.1       harris41  181:     exec("$execdir/lonsql");         # here we go again
                    182: }
                    183: 
                    184: sub logthis {
                    185:     my $message=shift;
                    186:     my $execdir=$perlvar{'lonDaemons'};
1.2       harris41  187:     my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
1.1       harris41  188:     my $now=time;
                    189:     my $local=localtime($now);
                    190:     print $fh "$local ($$): $message\n";
                    191: }
1.45      www       192: 
                    193: # ------------------------------------------------------------------ Course log
                    194: 
                    195: sub courselog {
                    196:     my ($path,$command)=@_;
1.46      www       197:     my %filters=();
1.47      www       198:     foreach (split(/\:/,&unescape($command))) {
1.46      www       199: 	my ($name,$value)=split(/\=/,$_);
                    200:         $filters{$name}=$value;
                    201:     }
                    202:     my @results=();
                    203:     open(IN,$path.'/activity.log') or return ('file_error');
                    204:     while ($line=<IN>) {
                    205:         chomp($line);
                    206:         my ($timestamp,$host,$log)=split(/\:/,$line);
1.49    ! www       207: #
        !           208: # $log has the actual log entries; currently still escaped, and
        !           209: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
        !           210: # then additionally
        !           211: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
        !           212: # or
        !           213: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
        !           214: #
        !           215: # get delimiter between timestamped entries to be &&&
        !           216:         $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
        !           217: # now go over all log entries 
        !           218:         foreach (split(/\&\&\&/,&unescape($log))) {
        !           219: 	    my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
        !           220:             my $values=&unescape(join(':',@values));
        !           221:             $values=~s/\&/\:/g;
1.48      www       222:             $res=&unescape($res);
1.46      www       223:             my $include=1;
1.47      www       224:             if (($filters{'username'}) && ($uname ne $filters{'username'})) 
                    225:                                                                { $include=0; }
                    226:             if (($filters{'domain'}) && ($udom ne $filters{'domain'})) 
                    227:                                                                { $include=0; }
                    228:             if (($filters{'url'}) && ($res!~/$filters{'url'}/)) 
                    229:                                                                { $include=0; }
                    230:             if (($filters{'start'}) && ($time<$filters{'start'})) 
                    231:                                                                { $include=0; }
                    232:             if (($filters{'end'}) && ($time>$filters{'end'})) 
                    233:                                                                { $include=0; }
                    234:             if (($filters{'action'} eq 'view') && ($action)) 
                    235:                                                                { $include=0; }
                    236:             if (($filters{'action'} eq 'submit') && ($action ne 'POST')) 
                    237:                                                                { $include=0; }
                    238:             if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) 
                    239:                                                                { $include=0; }
                    240:             if ($include) {
1.49    ! www       241: 	       push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
        !           242:                                             $uname.':'.$udom.':'.
1.47      www       243:                                             $action.':'.$values);
                    244:             }
                    245:        }
1.46      www       246:     }
                    247:     close IN;
                    248:     return join('&',sort(@results));
1.45      www       249: }
                    250: 
                    251: # -------------------------------------------------------------------- User log
                    252: 
                    253: sub userlog {
                    254:     my ($path,$command)=@_;
1.46      www       255:     my %filters=();
1.47      www       256:     foreach (split(/\:/,&unescape($command))) {
1.46      www       257: 	my ($name,$value)=split(/\=/,$_);
                    258:         $filters{$name}=$value;
                    259:     }
                    260:     my @results=();
                    261:     open(IN,$path.'/activity.log') or return ('file_error');
                    262:     while ($line=<IN>) {
                    263:         chomp($line);
                    264:         my ($timestamp,$host,$log)=split(/\:/,$line);
                    265:         $log=&unescape($log);
                    266:         my $include=1;
1.49    ! www       267:         if (($filters{'start'}) && ($timestamp<$filters{'start'})) 
        !           268:                                                              { $include=0; }
        !           269:         if (($filters{'end'}) && ($timestamp>$filters{'end'})) 
        !           270:                                                              { $include=0; }
1.46      www       271:         if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
1.49    ! www       272:         if (($filters{'action'} eq 'check') && ($log!~/^Check/)) 
        !           273:                                                              { $include=0; }
1.46      www       274:         if ($include) {
                    275: 	   push(@results,$timestamp.':'.$log);
                    276:         }
                    277:     }
                    278:     close IN;
                    279:     return join('&',sort(@results));
1.45      www       280: }
                    281: 
                    282: 
1.1       harris41  283: # ---------------------------------------------------- Fork once and dissociate
                    284: $fpid=fork;
                    285: exit if $fpid;
                    286: die "Couldn't fork: $!" unless defined ($fpid);
                    287: 
                    288: POSIX::setsid() or die "Can't start new session: $!";
                    289: 
                    290: # ------------------------------------------------------- Write our PID on disk
                    291: 
                    292: $execdir=$perlvar{'lonDaemons'};
                    293: open (PIDSAVE,">$execdir/logs/lonsql.pid");
                    294: print PIDSAVE "$$\n";
                    295: close(PIDSAVE);
                    296: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
                    297: 
                    298: # ----------------------------- Ignore signals generated during initial startup
                    299: $SIG{HUP}=$SIG{USR1}='IGNORE';
1.2       harris41  300: # ------------------------------------------------------- Now we are on our own    
                    301: # Fork off our children.
                    302: for (1 .. $PREFORK) {
                    303:     make_new_child();
1.1       harris41  304: }
                    305: 
1.2       harris41  306: # Install signal handlers.
1.1       harris41  307: $SIG{CHLD} = \&REAPER;
                    308: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
                    309: $SIG{HUP}  = \&HUPSMAN;
                    310: 
                    311: # And maintain the population.
                    312: while (1) {
                    313:     sleep;                          # wait for a signal (i.e., child's death)
1.2       harris41  314:     for ($i = $children; $i < $PREFORK; $i++) {
                    315:         make_new_child();           # top up the child pool
1.1       harris41  316:     }
                    317: }
                    318: 
1.2       harris41  319: 
1.1       harris41  320: sub make_new_child {
                    321:     my $pid;
                    322:     my $sigset;
1.2       harris41  323:     
1.1       harris41  324:     # block signal for fork
                    325:     $sigset = POSIX::SigSet->new(SIGINT);
                    326:     sigprocmask(SIG_BLOCK, $sigset)
                    327:         or die "Can't block SIGINT for fork: $!\n";
                    328:     
1.2       harris41  329:     die "fork: $!" unless defined ($pid = fork);
                    330:     
1.1       harris41  331:     if ($pid) {
                    332:         # Parent records the child's birth and returns.
                    333:         sigprocmask(SIG_UNBLOCK, $sigset)
                    334:             or die "Can't unblock SIGINT for fork: $!\n";
                    335:         $children{$pid} = 1;
                    336:         $children++;
                    337:         return;
                    338:     } else {
1.2       harris41  339:         # Child can *not* return from this subroutine.
1.1       harris41  340:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
                    341:     
                    342:         # unblock signals
                    343:         sigprocmask(SIG_UNBLOCK, $sigset)
                    344:             or die "Can't unblock SIGINT for fork: $!\n";
1.2       harris41  345: 	
                    346: 	
                    347:         #open database handle
                    348: 	# making dbh global to avoid garbage collector
1.1       harris41  349: 	unless (
1.31      harris41  350: 		$dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
1.1       harris41  351: 		) { 
1.30      harris41  352:   	            sleep(10+int(rand(20)));
1.1       harris41  353: 		    &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
1.2       harris41  354: 		    print "database handle error\n";
                    355: 		    exit;
                    356: 
                    357: 	  };
                    358: 	# make sure that a database disconnection occurs with ending kill signals
                    359: 	$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
                    360: 
1.1       harris41  361:         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
                    362:         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
                    363:             $client = $server->accept()     or last;
1.2       harris41  364:             
                    365:             # do something with the connection
1.1       harris41  366: 	    $run = $run+1;
1.2       harris41  367: 	    my $userinput = <$client>;
                    368: 	    chomp($userinput);
                    369: 	    	    
1.45      www       370: 	    my ($conserver,$query,
                    371: 		$arg1,$arg2,$arg3)=split(/&/,$userinput);
                    372: 	    my $query=unescape($query);
1.2       harris41  373: 
                    374:             #send query id which is pid_unixdatetime_runningcounter
                    375: 	    $queryid = $thisserver;
                    376: 	    $queryid .="_".($$)."_";
                    377: 	    $queryid .= time."_";
                    378: 	    $queryid .= $run;
                    379: 	    print $client "$queryid\n";
                    380: 	    
1.47      www       381: 	    &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
1.25      harris41  382: 	    sleep 1;
1.44      www       383: 
1.45      www       384:             my $result='';
                    385: 
1.44      www       386: # ---------- At this point, query is received, query-ID assigned and sent back 
                    387: # $query eq 'logquery' will mean that this is a query against log-files
                    388: 
1.45      www       389: 
                    390: 	   if (($query eq 'userlog') || ($query eq 'courselog')) {
                    391: # ----------------------------------------------------- beginning of log query
                    392: #
                    393: # this goes against a user's log file
                    394: #
                    395: 	       my $udom=&unescape($arg1);
                    396: 	       my $uname=&unescape($arg2);
                    397:                my $command=&unescape($arg3);
                    398:                my $path=&propath($udom,$uname);
                    399:                if (-e "$path/activity.log") {
                    400: 		   if ($query eq 'userlog') {
                    401:                        $result=&userlog($path,$command);
                    402:                    } else {
                    403:                        $result=&courselog($path,$command);
                    404:                    }
                    405:                } else {
                    406: 		   &logthis('Unable to do log query: '.$uname.'@'.$udom);
                    407: 	           $result='no_such_file';
                    408: 	       }
                    409: # ------------------------------------------------------------ end of log query
                    410:           } else {
1.44      www       411: # -------------------------------------------------------- This is an sql query
1.45      www       412: 	    my $custom=unescape($arg1);
                    413: 	    my $customshow=unescape($arg2);
1.2       harris41  414:             #prepare and execute the query
1.3       harris41  415: 	    my $sth = $dbh->prepare($query);
1.45      www       416: 
1.20      harris41  417: 	    my @files;
1.24      harris41  418: 	    my $subsetflag=0;
1.26      harris41  419: 	    if ($query) {
                    420: 		unless ($sth->execute())
                    421: 		{
                    422: 		    &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
                    423: 		    $result="";
                    424: 		}
                    425: 		else {
                    426: 		    my $r1=$sth->fetchall_arrayref;
                    427: 		    my @r2;
1.41      harris41  428: 		    foreach (@$r1) {my $a=$_; 
1.26      harris41  429: 			 my @b=map {escape($_)} @$a;
                    430: 			 push @files,@{$a}[3];
                    431: 			 push @r2,join(",", @b)
1.41      harris41  432: 			 }
1.26      harris41  433: 		    $result=join("&",@r2);
                    434: 		}
1.3       harris41  435: 	    }
1.7       harris41  436: 	    # do custom metadata searching here and build into result
1.28      harris41  437: 	    if ($custom or $customshow) {
1.9       harris41  438: 		&logthis("am going to do custom query for $custom");
1.26      harris41  439: 		if ($query) {
1.23      harris41  440: 		    @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
1.20      harris41  441: 		}
                    442: 		else {
                    443: 		    @metalist=(); pop @metalist;
1.34      harris41  444: 		    opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
                    445: 		    my @homeusers=grep
                    446: 		          {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
                    447: 		          grep {!/^\.\.?$/} readdir(RESOURCES);
                    448: 		    closedir RESOURCES;
                    449: 		    foreach my $user (@homeusers) {
                    450: 			&find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
                    451: 		    }
1.20      harris41  452: 		}
1.23      harris41  453: #		&logthis("FILELIST:" . join(":::",@metalist));
1.10      harris41  454: 		# if file is indicated in sql database and
                    455: 		# not part of sql-relevant query, do not pattern match.
                    456: 		# if file is not in sql database, output error.
                    457: 		# if file is indicated in sql database and is
                    458: 		# part of query result list, then do the pattern match.
1.12      harris41  459: 		my $customresult='';
1.26      harris41  460: 		my @r2;
1.11      harris41  461: 		foreach my $m (@metalist) {
                    462: 		    my $fh=IO::File->new($m);
                    463: 		    my @lines=<$fh>;
                    464: 		    my $stuff=join('',@lines);
                    465: 		    if ($stuff=~/$custom/s) {
1.18      harris41  466: 			foreach my $f ('abstract','author','copyright',
                    467: 				       'creationdate','keywords','language',
                    468: 				       'lastrevisiondate','mime','notes',
                    469: 				       'owner','subject','title') {
1.37      harris41  470: 			    $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
1.18      harris41  471: 			}
1.19      harris41  472: 			my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
1.26      harris41  473: 			$m2=~s/^$docroot//;
                    474: 			$m2=~s/\.meta$//;
                    475: 			unless ($query) {
1.35      harris41  476: 			    my $q2="select * from metadata where url like binary '$m2'";
1.27      harris41  477: 			    my $sth = $dbh->prepare($q2);
1.26      harris41  478: 			    $sth->execute();
                    479: 			    my $r1=$sth->fetchall_arrayref;
1.41      harris41  480: 			    foreach (@$r1) {my $a=$_; 
1.26      harris41  481: 				 my @b=map {escape($_)} @$a;
                    482: 				 push @files,@{$a}[3];
                    483: 				 push @r2,join(",", @b)
1.41      harris41  484: 				 }
1.26      harris41  485: 			}
1.20      harris41  486: #			&logthis("found: $stuff");
1.19      harris41  487: 			$customresult.='&custom='.escape($m2).','.escape($stuff);
1.11      harris41  488: 		    }
                    489: 		}
1.26      harris41  490: 		$result=join("&",@r2) unless $query;
1.17      harris41  491: 		$result.=$customresult;
1.9       harris41  492: 	    }
1.44      www       493: # ------------------------------------------------------------ end of sql query
1.46      www       494: 	   }
                    495: 
                    496:             # result does need to be escaped
                    497: 
                    498:             $result=&escape($result);
                    499: 
1.44      www       500: 	    # reply with result, append \n unless already there
1.45      www       501: 
1.44      www       502: 	    $result.="\n" unless ($result=~/\n$/);
1.17      harris41  503:             &reply("queryreply:$queryid:$result",$conserver);
1.2       harris41  504: 
1.1       harris41  505:         }
                    506:     
                    507:         # tidy up gracefully and finish
1.2       harris41  508: 	
                    509:         #close the database handle
                    510: 	$dbh->disconnect
                    511: 	   or &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
1.1       harris41  512:     
                    513:         # this exit is VERY important, otherwise the child will become
                    514:         # a producer of more and more children, forking yourself into
                    515:         # process death.
                    516:         exit;
                    517:     }
1.2       harris41  518: }
1.1       harris41  519: 
1.2       harris41  520: sub DISCONNECT {
                    521:     $dbh->disconnect or 
                    522:     &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
                    523:     exit;
                    524: }
1.1       harris41  525: 
1.2       harris41  526: # -------------------------------------------------- Non-critical communication
1.1       harris41  527: 
1.2       harris41  528: sub subreply {
                    529:     my ($cmd,$server)=@_;
                    530:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    531:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    532:                                       Type    => SOCK_STREAM,
                    533:                                       Timeout => 10)
                    534:        or return "con_lost";
                    535:     print $sclient "$cmd\n";
                    536:     my $answer=<$sclient>;
                    537:     chomp($answer);
                    538:     if (!$answer) { $answer="con_lost"; }
                    539:     return $answer;
                    540: }
1.1       harris41  541: 
1.2       harris41  542: sub reply {
                    543:   my ($cmd,$server)=@_;
                    544:   my $answer;
                    545:   if ($server ne $perlvar{'lonHostID'}) { 
                    546:     $answer=subreply($cmd,$server);
                    547:     if ($answer eq 'con_lost') {
                    548: 	$answer=subreply("ping",$server);
                    549:         $answer=subreply($cmd,$server);
                    550:     }
                    551:   } else {
                    552:     $answer='self_reply';
1.33      harris41  553:     $answer=subreply($cmd,$server);
1.2       harris41  554:   } 
                    555:   return $answer;
                    556: }
1.1       harris41  557: 
1.3       harris41  558: # -------------------------------------------------------- Escape Special Chars
                    559: 
                    560: sub escape {
                    561:     my $str=shift;
                    562:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                    563:     return $str;
                    564: }
                    565: 
                    566: # ----------------------------------------------------- Un-Escape Special Chars
                    567: 
                    568: sub unescape {
                    569:     my $str=shift;
                    570:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    571:     return $str;
                    572: }
1.34      harris41  573: 
                    574: # --------------------------------------- Is this the home server of an author?
                    575: # (copied from lond, modification of the return value)
                    576: sub ishome {
                    577:     my $author=shift;
                    578:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    579:     my ($udom,$uname)=split(/\//,$author);
                    580:     my $proname=propath($udom,$uname);
                    581:     if (-e $proname) {
                    582: 	return 1;
                    583:     } else {
                    584:         return 0;
                    585:     }
                    586: }
                    587: 
                    588: # -------------------------------------------- Return path to profile directory
                    589: # (copied from lond)
                    590: sub propath {
                    591:     my ($udom,$uname)=@_;
                    592:     $udom=~s/\W//g;
                    593:     $uname=~s/\W//g;
                    594:     my $subdir=$uname.'__';
                    595:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                    596:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
                    597:     return $proname;
                    598: } 
1.40      harris41  599: 
                    600: # ----------------------------------- POD (plain old documentation, CPAN style)
                    601: 
                    602: =head1 NAME
                    603: 
                    604: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
                    605: 
                    606: =head1 SYNOPSIS
                    607: 
                    608: This script should be run as user=www.  The following is an example invocation
                    609: from the loncron script.  Note that a lonsql.pid file contains the pid of
                    610: the parent process.
                    611: 
                    612:     if (-e $lonsqlfile) {
                    613: 	my $lfh=IO::File->new("$lonsqlfile");
                    614: 	my $lonsqlpid=<$lfh>;
                    615: 	chomp($lonsqlpid);
                    616: 	if (kill 0 => $lonsqlpid) {
                    617: 	    print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>";
                    618: 	    $restartflag=0;
                    619: 	} else {
                    620: 	    $errors++; $errors++;
                    621: 	    print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>";
                    622: 		$restartflag=1;
                    623: 	print $fh 
                    624: 	    "<h3>Decided to clean up stale .pid file and restart lonsql</h3>";
                    625: 	}
                    626:     }
                    627:     if ($restartflag==1) {
                    628: 	$errors++;
                    629: 	         print $fh '<br><font color="red">Killall lonsql: '.
                    630:                     system('killall lonsql').' - ';
                    631:                     sleep 60;
                    632:                     print $fh unlink($lonsqlfile).' - '.
                    633:                               system('killall -9 lonsql').
                    634:                     '</font><br>';
                    635: 	print $fh "<h3>lonsql not running, trying to start</h3>";
                    636: 	system(
                    637:  "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors");
                    638: 	sleep 10;
                    639: 
                    640: =head1 DESCRIPTION
                    641: 
1.41      harris41  642: Not yet written.
1.40      harris41  643: 
                    644: =head1 README
                    645: 
1.41      harris41  646: Not yet written.
1.40      harris41  647: 
                    648: =head1 PREREQUISITES
                    649: 
                    650: IO::Socket
                    651: Symbol
                    652: POSIX
                    653: IO::Select
                    654: IO::File
                    655: Socket
                    656: Fcntl
                    657: Tie::RefHash
                    658: DBI
                    659: 
                    660: =head1 COREQUISITES
                    661: 
                    662: =head1 OSNAMES
                    663: 
                    664: linux
                    665: 
                    666: =head1 SCRIPT CATEGORIES
                    667: 
                    668: Server/Process
                    669: 
                    670: =cut

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