Annotation of loncom/lonsql, revision 1.3

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

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