loncom/lonc - view

File: [LON-CAPA] / loncom / Attic / lonc
Revision 1.32: download - view: text, annotated - select for diffs
Fri Mar 8 03:56:19 2002 UTC (22 years, 11 months ago) by foxr
Branches: MAIN
CVS tags: HEAD

Corrected and simplified child management logic:
1. Removed SIGCHLD handler, made parent main loop
   just be a wait, rather than sleep.
2. Corrected book-keeping error in lonc's make_child_process
   which caused single child death to trigger attempts to
   restart all children...whether actually dead or not.

#!/usr/bin/perl # The LearningOnline Network # lonc - LON TCP-Client Domain-Socket-Server # provides persistent TCP connections to the other servers in the network # through multiplexed domain sockets # # $Id: lonc,v 1.32 2002/03/08 03:56:19 foxr Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # # PID in subdir logs/lonc.pid # kill kills # HUP restarts # USR1 tries to open connections again # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19, # 10/8,10/9,10/15,11/18,12/22, # 2/8,7/25 Gerd Kortemeyer # 12/05 Scott Harrison # 12/05 Gerd Kortemeyer # YEAR=2001 # 01/10/01 Scott Harrison # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer # 12/20 Scott Harrison # YEAR=2002 # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer # # based on nonforker from Perl Cookbook # - server who multiplexes without forking use POSIX; use IO::Socket; use IO::Select; use IO::File; use Socket; use Fcntl; use Tie::RefHash; use Crypt::IDEA; #use Net::Ping; use LWP::UserAgent(); $status=''; $lastlog=''; $conserver='SHELL'; $DEBUG = 0; # Set to 1 for annoyingly complete logs. # -------------------------------- Set signal handlers to record abnormal exits &status("Init exception handlers"); $SIG{QUIT}=\&catchexception; $SIG{__DIE__}=\&catchexception; # ------------------------------------ Read httpd access.conf and get variables &status("Read access.conf"); open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; while ($configline=<CONFIG>) { if ($configline =~ /PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); chomp($varvalue); $perlvar{$varname}=$varvalue; } } close(CONFIG); # ----------------------------- Make sure this process is running from user=www &status("Check user ID"); my $wwwid=getpwnam('www'); if ($wwwid!=$<) { $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; $subj="LON: $perlvar{'lonHostID'} User ID mismatch"; system("echo 'User ID mismatch. lonc must be run as user www.' |\ mailto $emailto -s '$subj' > /dev/null"); exit 1; } # --------------------------------------------- Check if other instance running my $pidfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; if (-e $pidfile) { my $lfh=IO::File->new("$pidfile"); my $pide=<$lfh>; chomp($pide); if (kill 0 => $pide) { die "already running"; } } # ------------------------------------------------------------- Read hosts file open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; while ($configline=<CONFIG>) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); chomp($ip); if ($ip) { $hostip{$id}=$ip; $hostname{$id}=$name; } } close(CONFIG); # -------------------------------------------------------- Routines for forking %children = (); # keys are current child process IDs, # values are hosts %childpid = (); # the other way around %childatt = (); # number of attempts to start server # for ID $childmaxattempts=5; # ---------------------------------------------------- Fork once and dissociate &status("Fork and dissociate"); $fpid=fork; exit if $fpid; die "Couldn't fork: $!" unless defined ($fpid); POSIX::setsid() or die "Can't start new session: $!"; $conserver='PARENT'; # ------------------------------------------------------- Write our PID on disk &status("Write PID"); $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lonc.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); &logthis("CRITICAL: ---------- Starting ----------"); # ----------------------------- Ignore signals generated during initial startup $SIG{HUP}=$SIG{USR1}='IGNORE'; # ------------------------------------------------------- Now we are on our own # Fork off our children, one for every server &status("Forking ..."); foreach $thisserver (keys %hostip) { #if (&online($hostname{$thisserver})) { make_new_child($thisserver); #} } &logthis("Done starting initial servers"); # ----------------------------------------------------- Install signal handlers $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; $SIG{USR1} = \&USRMAN; # And maintain the population. while (1) { my $deadpid = wait; # Wait for the next child to die. # See who died and start new one &status("Woke up"); my $skipping=''; if(exists($children{$deadpid})) { $thisserver = $children{$deadpid}; # Look name of dead guy's peer. delete($children{$deadpid}); # Get rid of dead hash entry. if($childatt{$thisserver} < $childmaxattempts) { $childatt{$thisserver}++; &logthis( "INFO: Trying to reconnect for $thisserver " ."($childatt{$thisserver} of $childmaxattempts attempts)"); make_new_child($thisserver); } else { $skipping .= $thisserver.' '; } if($skipping) { &logthis("WARNING: Skipped $skipping"); } } } sub make_new_child { $newserver=shift; my $pid; my $sigset; &logthis("Attempting to start child for server $newserver"); # block signal for fork $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!\n"; die "fork: $!" unless defined ($pid = fork); if ($pid) { # Parent records the child's birth and returns. sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = $newserver; $childpid{$newserver} = $pid; return; } else { $conserver=$newserver; # Child can *not* return from this subroutine. $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before $SIG{USR1}= \&logstatus; # unblock signals sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; # ----------------------------- This is the modified main program of non-forker $port = "$perlvar{'lonSockDir'}/$conserver"; unlink($port); # -------------------------------------------------------------- Open other end &openremote($conserver); &logthis(" Connection to $conserver open "); # ----------------------------------------- We're online, send delayed messages &status("Checking for delayed messages"); my @allbuffered; my $path="$perlvar{'lonSockDir'}/delayed"; opendir(DIRHANDLE,$path); @allbuffered=grep /\.$conserver$/, readdir DIRHANDLE; closedir(DIRHANDLE); my $dfname; foreach (@allbuffered) { &status("Sending delayed: $_"); $dfname="$path/$_"; if($DEBUG) { &logthis('Sending '.$dfname); } my $wcmd; { my $dfh=IO::File->new($dfname); $cmd=<$dfh>; } chomp($cmd); my $bcmd=$cmd; if ($cmd =~ /^encrypt\:/) { my $rcmd=$cmd; $rcmd =~ s/^encrypt\://; chomp($rcmd); my $cmdlength=length($rcmd); $rcmd.=" "; my $encrequest=''; for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { $encrequest.= unpack("H16",$cipher->encrypt(substr($rcmd,$encidx,8))); } $cmd="enc:$cmdlength:$encrequest\n"; } $SIG{ALRM}=sub { die "timeout" }; $SIG{__DIE__}='DEFAULT'; eval { alarm(60); print $remotesock "$cmd\n"; $answer=<$remotesock>; chomp($answer); alarm(0); }; $SIG{ALRM}='DEFAULT'; $SIG{__DIE__}=\&catchexception; if (($answer ne '') && ($@!~/timeout/)) { unlink("$dfname"); &logthis("Delayed $cmd: >$answer<"); &logperm("S:$conserver:$bcmd"); } } if($DEBUG) { &logthis(" Delayed transactions sent"); } # ------------------------------------------------------- Listen to UNIX socket &status("Opening socket"); unless ( $server = IO::Socket::UNIX->new(Local => $port, Type => SOCK_STREAM, Listen => 10 ) ) { my $st=120+int(rand(240)); &logthis( "WARNING: ". "Can't make server socket ($st secs): $@ .. exiting"); sleep($st); exit; }; # ----------------------------------------------------------------------------- &logthis("$conserver online"); # ----------------------------------------------------------------------------- # begin with empty buffers %inbuffer = (); %outbuffer = (); %ready = (); tie %ready, 'Tie::RefHash'; nonblock($server); $select = IO::Select->new($server); # Main loop: check reads/accepts, check writes, check ready to process while (1) { my $client; my $rv; my $data; # check for new information on the connections we have # anything to read or accept? foreach $client ($select->can_read(100.0)) { if ($client == $server) { # accept a new connection &status("Accept new connection: $conserver"); $client = $server->accept(); $select->add($client); nonblock($client); } else { # read data $data = ''; $rv = $client->recv($data, POSIX::BUFSIZ, 0); unless (defined($rv) && length $data) { # This would be the end of file, so close the client delete $inbuffer{$client}; delete $outbuffer{$client}; delete $ready{$client}; &status("Idle"); $select->remove($client); close $client; next; } $inbuffer{$client} .= $data; # test whether the data in the buffer or the data we # just read means there is a complete request waiting # to be fulfilled. If there is, set $ready{$client} # to the requests waiting to be fulfilled. while ($inbuffer{$client} =~ s/(.*\n)//) { push( @{$ready{$client}}, $1 ); } } } # Any complete requests to process? foreach $client (keys %ready) { handle($client); } # Buffers to flush? foreach $client ($select->can_write(1)) { # Skip this client if we have nothing to say next unless exists $outbuffer{$client}; $rv = $client->send($outbuffer{$client}, 0); unless ($outbuffer{$client} eq "con_lost\n") { unless (defined $rv) { # Whine, but move on. &logthis("I was told I could write, but I can't.\n"); next; } $errno=$!; if (($rv == length $outbuffer{$client}) || ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) { substr($outbuffer{$client}, 0, $rv) = ''; delete $outbuffer{$client} unless length $outbuffer{$client}; } else { # Couldn't write all the data, and it wasn't because # it would have blocked. Shutdown and move on. &logthis("Dropping data with ".$errno.": ". length($outbuffer{$client}).", $rv"); delete $inbuffer{$client}; delete $outbuffer{$client}; delete $ready{$client}; $select->remove($client); close($client); next; } } else { # -------------------------------------------------------- Wow, connection lost &logthis( "CRITICAL: Closing connection"); &status("Connection lost"); $remotesock->shutdown(2); &logthis("Attempting to open new connection"); &openremote($conserver); } } } } # ------------------------------------------------------- End of make_new_child # handle($socket) deals with all pending requests for $client sub handle { # requests are in $ready{$client} # send output to $outbuffer{$client} my $client = shift; my $request; foreach $request (@{$ready{$client}}) { # ============================================================= Process request # $request is the text of the request # put text of reply into $outbuffer{$client} # ------------------------------------------------------------ Is this the end? if($DEBUG) { &logthis(" Request $request processing starts"); } if ($request eq "close_connection_exit\n") { &status("Request close connection"); &logthis( "CRITICAL: Request Close Connection ... exiting"); $remotesock->shutdown(2); $server->close(); exit; } # ----------------------------------------------------------------------------- if ($request =~ /^encrypt\:/) { my $cmd=$request; $cmd =~ s/^encrypt\://; chomp($cmd); my $cmdlength=length($cmd); $cmd.=" "; my $encrequest=''; for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { $encrequest.= unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8))); } $request="enc:$cmdlength:$encrequest\n"; } # --------------------------------------------------------------- Main exchange $SIG{ALRM}=sub { die "timeout" }; $SIG{__DIE__}='DEFAULT'; eval { alarm(300); &status("Sending: $request"); print $remotesock "$request"; &status("Waiting for reply from $conserver: $request"); $answer=<$remotesock>; &status("Received reply: $request"); alarm(0); }; if($DEBUG) { &logthis(" Request data exchange complete"); } if ($@=~/timeout/) { $answer=''; &logthis( "CRITICAL: Timeout: $request"); } $SIG{ALRM}='DEFAULT'; $SIG{__DIE__}=\&catchexception; if ($answer) { if ($answer =~ /^enc/) { my ($cmd,$cmdlength,$encinput)=split(/:/,$answer); chomp($encinput); $answer=''; for (my $encidx=0;$encidx<length($encinput);$encidx+=16) { $answer.=$cipher->decrypt( pack("H16",substr($encinput,$encidx,16)) ); } $answer=substr($answer,0,$cmdlength); $answer.="\n"; } $outbuffer{$client} .= $answer; } else { $outbuffer{$client} .= "con_lost\n"; } &status("Completed: $request"); if($DEBUG) { &logthis(" Request processing complete"); } # ===================================================== Done processing request } delete $ready{$client}; # -------------------------------------------------------------- End non-forker if($DEBUG) { &logthis(" requests for child handled"); } } # ---------------------------------------------------------- End make_new_child } # nonblock($socket) puts socket into nonblocking mode sub nonblock { my $socket = shift; my $flags; $flags = fcntl($socket, F_GETFL, 0) or die "Can't get flags for socket: $!\n"; fcntl($socket, F_SETFL, $flags | O_NONBLOCK) or die "Can't make socket nonblocking: $!\n"; } sub openremote { # ---------------------------------------------------- Client to network server my $conserver=shift; &status("Opening TCP"); my $st=120+int(rand(240)); # Sleep before opening: unless ( $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver}, PeerPort => $perlvar{'londPort'}, Proto => "tcp", Type => SOCK_STREAM) ) { &logthis( "WARNING: Couldn't connect to $conserver ($st secs): $@"); sleep($st); exit; }; # ----------------------------------------------------------------- Init dialog &logthis("INFO Connected to $conserver, initing "); &status("Init dialogue: $conserver"); $SIG{ALRM}=sub { die "timeout" }; $SIG{__DIE__}='DEFAULT'; eval { alarm(60); print $remotesock "init\n"; $answer=<$remotesock>; print $remotesock "$answer"; $answer=<$remotesock>; chomp($answer); alarm(0); }; $SIG{ALRM}='DEFAULT'; $SIG{__DIE__}=\&catchexception; if ($@=~/timeout/) { &logthis("Timed out during init.. exiting"); exit; } if ($answer ne 'ok') { &logthis("Init reply: >$answer<"); my $st=120+int(rand(240)); &logthis( "WARNING: Init failed ($st secs)"); sleep($st); exit; } sleep 5; &status("Ponging"); print $remotesock "pong\n"; $answer=<$remotesock>; chomp($answer); if ($answer!~/^$conserver/) { &logthis("Pong reply: >$answer<"); } # ----------------------------------------------------------- Initialize cipher &status("Initialize cipher"); print $remotesock "ekey\n"; my $buildkey=<$remotesock>; my $key=$conserver.$perlvar{'lonHostID'}; $key=~tr/a-z/A-Z/; $key=~tr/G-P/0-9/; $key=~tr/Q-Z/0-9/; $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; $key=substr($key,0,32); my $cipherkey=pack("H32",$key); if ($cipher=new IDEA $cipherkey) { &logthis("Secure connection initialized"); } else { my $st=120+int(rand(240)); &logthis( "WARNING: ". "Could not establish secure connection ($st secs)!"); sleep($st); exit; } &logthis(" Remote open success "); } # grabs exception and records it to log before exiting sub catchexception { my ($signal)=@_; $SIG{QUIT}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; chomp($signal); &logthis("CRITICAL: " ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through " ."\"$signal\" with parameter [$@]"); die($@); } # -------------------------------------- Routines to see if other box available #sub online { # my $host=shift; # &status("Pinging ".$host); # my $p=Net::Ping->new("tcp",20); # my $online=$p->ping("$host"); # $p->close(); # undef ($p); # return $online; #} sub connected { my ($local,$remote)=@_; &status("Checking connection $local to $remote"); $local=~s/\W//g; $remote=~s/\W//g; unless ($hostname{$local}) { return 'local_unknown'; } unless ($hostname{$remote}) { return 'remote_unknown'; } #unless (&online($hostname{$local})) { return 'local_offline'; } my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET', "http://".$hostname{$local}.'/cgi-bin/ping.pl?'.$remote); my $response=$ua->request($request); unless ($response->is_success) { return 'local_error'; } my $reply=$response->content; $reply=(split("\n",$reply))[0]; $reply=~s/\W//g; if ($reply ne $remote) { return $reply; } return 'ok'; } sub hangup { foreach (keys %children) { $wasserver=$children{$_}; &status("Closing $wasserver"); &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver)); &status("Kill PID $_ for $wasserver"); kill ('INT',$_); } } sub HUNTSMAN { # signal handler for SIGINT local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children &hangup(); my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lonc.pid"); &logthis("CRITICAL: Shutting down"); exit; # clean up with dignity } sub HUPSMAN { # signal handler for SIGHUP local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children &hangup(); &logthis("CRITICAL: Restarting"); unlink("$execdir/logs/lonc.pid"); my $execdir=$perlvar{'lonDaemons'}; exec("$execdir/lonc"); # here we go again } sub checkchildren { &initnewstatus(); &logstatus(); &logthis('Going to check on the children'); foreach (sort keys %children) { sleep 1; unless (kill 'USR1' => $_) { &logthis ('CRITICAL: Child '.$_.' is dead'); &logstatus($$.' is dead'); } } } sub USRMAN { &logthis("USR1: Trying to establish connections again"); %childatt=(); &checkchildren(); } # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; my $answer=''; if ($server ne $perlvar{'lonHostID'}) { my $peerfile="$perlvar{'lonSockDir'}/$server"; my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", Type => SOCK_STREAM, Timeout => 10) or return "con_lost"; $SIG{ALRM}=sub { die "timeout" }; $SIG{__DIE__}='DEFAULT'; eval { alarm(10); print $sclient "$cmd\n"; $answer=<$sclient>; chomp($answer); alarm(0); }; if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; } $SIG{ALRM}='DEFAULT'; $SIG{__DIE__}=\&catchexception; } else { $answer='self_reply'; } return $answer; } # --------------------------------------------------------------------- Logging sub logthis { my $message=shift; my $execdir=$perlvar{'lonDaemons'}; my $fh=IO::File->new(">>$execdir/logs/lonc.log"); my $now=time; my $local=localtime($now); $lastlog=$local.': '.$message; print $fh "$local ($$) [$conserver] [$status]: $message\n"; } sub logperm { my $message=shift; my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log"); print $fh "$now:$message:$local\n"; } # ------------------------------------------------------------------ Log status sub logstatus { my $docdir=$perlvar{'lonDocRoot'}; my $fh=IO::File->new(">>$docdir/lon-status/loncstatus.txt"); print $fh $$."\t".$conserver."\t".$status."\t".$lastlog."\n"; } sub initnewstatus { my $docdir=$perlvar{'lonDocRoot'}; my $fh=IO::File->new(">$docdir/lon-status/loncstatus.txt"); my $now=time; my $local=localtime($now); print $fh "LONC status $local - parent $$\n\n"; } # -------------------------------------------------------------- Status setting sub status { my $what=shift; my $now=time; my $local=localtime($now); $status=$local.': '.$what; } # ----------------------------------- POD (plain old documentation, CPAN style) =head1 NAME lonc - LON TCP-MySQL-Server Daemon for handling database requests. =head1 SYNOPSIS Usage: B<lonc> Should only be run as user=www. This is a command-line script which is invoked by B<loncron>. There is no expectation that a typical user will manually start B<lonc> from the command-line. (In other words, DO NOT START B<lonc> YOURSELF.) =head1 DESCRIPTION Provides persistent TCP connections to the other servers in the network through multiplexed domain sockets B<lonc> forks off children processes that correspond to the other servers in the network. Management of these processes can be done at the parent process level or the child process level. B<logs/lonc.log> is the location of log messages. The process management is now explained in terms of linux shell commands, subroutines internal to this code, and signal assignments: =over 4 =item * PID is stored in B<logs/lonc.pid> This is the process id number of the parent B<lonc> process. =item * SIGTERM and SIGINT Parent signal assignment: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; Child signal assignment: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) (The child dies and a SIGALRM is sent to parent, awaking parent from slumber to restart a new child.) Command-line invocations: B<kill> B<-s> SIGTERM I<PID> B<kill> B<-s> SIGINT I<PID> Subroutine B<HUNTSMAN>: This is only invoked for the B<lonc> parent I<PID>. This kills all the children, and then the parent. The B<lonc.pid> file is cleared. =item * SIGHUP Current bug: This signal can only be processed the first time on the parent process. Subsequent SIGHUP signals have no effect. Parent signal assignment: $SIG{HUP} = \&HUPSMAN; Child signal assignment: none (nothing happens) Command-line invocations: B<kill> B<-s> SIGHUP I<PID> Subroutine B<HUPSMAN>: This is only invoked for the B<lonc> parent I<PID>, This kills all the children, and then the parent. The B<lonc.pid> file is cleared. =item * SIGUSR1 Parent signal assignment: $SIG{USR1} = \&USRMAN; Child signal assignment: $SIG{USR1}= \&logstatus; Command-line invocations: B<kill> B<-s> SIGUSR1 I<PID> Subroutine B<USRMAN>: When invoked for the B<lonc> parent I<PID>, SIGUSR1 is sent to all the children, and the status of each connection is logged. =item * SIGCHLD Child signal assignment: none Command-line invocations: B<kill> B<-s> SIGCHLD I<PID> Subroutine B<REAPER>: This is only invoked for the B<lonc> parent I<PID>. Information pertaining to the child is removed. The socket port is cleaned up. =back =head1 PREREQUISITES POSIX IO::Socket IO::Select IO::File Socket Fcntl Tie::RefHash Crypt::IDEA =head1 COREQUISITES =head1 OSNAMES linux =head1 SCRIPT CATEGORIES Server/Process =cut