File:  [LON-CAPA] / loncom / loncnew
Revision 1.15: download - view: text, annotated - select for diffs
Tue Jul 15 02:07:05 2003 UTC (20 years, 9 months ago) by foxr
Branches: MAIN
CVS tags: HEAD
Added code for lonc/lond transaction timeouts.  Who knows if it works right.
The intent is for a timeout to fail any transaction in progress and kill
off the sockt that timed out.

    1: #!/usr/bin/perl
    2: # The LearningOnline Network with CAPA
    3: # lonc maintains the connections to remote computers
    4: #
    5: # $Id: loncnew,v 1.15 2003/07/15 02:07:05 foxr Exp $
    6: #
    7: # Copyright Michigan State University Board of Trustees
    8: #
    9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   10: #
   11: # LON-CAPA is free software; you can redistribute it and/or modify
   12: # it under the terms of the GNU General Public License as published by
   13: # the Free Software Foundation; either version 2 of the License, or
   14: # (at your option) any later version.
   15: #
   16: # LON-CAPA is distributed in the hope that it will be useful,
   17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   19: # GNU General Public License for more details.
   20: #
   21: # You should have received a copy of the GNU General Public License
   22: # along with LON-CAPA; if not, write to the Free Software
   23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   24: #
   25: # /home/httpd/html/adm/gpl.txt
   26: #
   27: # http://www.lon-capa.org/
   28: #
   29: #
   30: # new lonc handles n request out bver m connections to londs.
   31: # This module is based on the Event class.
   32: #   Development iterations:
   33: #    - Setup basic event loop.   (done)
   34: #    - Add timer dispatch.       (done)
   35: #    - Add ability to accept lonc UNIX domain sockets.  (done)
   36: #    - Add ability to create/negotiate lond connections (done).
   37: #    - Add general logic for dispatching requests and timeouts. (done).
   38: #    - Add support for the lonc/lond requests.          (done).
   39: #    - Add logging/status monitoring.
   40: #    - Add Signal handling - HUP restarts. USR1 status report.
   41: #    - Add Configuration file I/O                       (done).
   42: #    - Add management/status request interface.
   43: #    - Add deferred request capability.                  (done)
   44: #    - Detect transmission timeouts.
   45: #
   46: 
   47: # Change log:
   48: #    $Log: loncnew,v $
   49: #    Revision 1.15  2003/07/15 02:07:05  foxr
   50: #    Added code for lonc/lond transaction timeouts.  Who knows if it works right.
   51: #    The intent is for a timeout to fail any transaction in progress and kill
   52: #    off the sockt that timed out.
   53: #
   54: #    Revision 1.14  2003/07/03 02:10:18  foxr
   55: #    Get all of the signals to work correctly.
   56: #
   57: #    Revision 1.13  2003/07/02 01:31:55  foxr
   58: #    Added kill -HUP logic (restart).
   59: #
   60: #    Revision 1.11  2003/06/25 01:54:44  foxr
   61: #    Fix more problems with transaction failure.
   62: #
   63: #    Revision 1.10  2003/06/24 02:46:04  foxr
   64: #    Put a limit on  the number of times we'll retry a connection.
   65: #    Start getting the signal stuff put in as well...note that need to get signals
   66: #    going or else 6the client will permanently give up on dead servers.
   67: #
   68: #    Revision 1.9  2003/06/13 02:38:43  foxr
   69: #    Add logging in 'expected format'
   70: #
   71: #    Revision 1.8  2003/06/11 02:04:35  foxr
   72: #    Support delayed transactions... this is done uniformly by encapsulating
   73: #    transactions in an object ... a LondTransaction that is implemented by
   74: #    LondTransaction.pm
   75: #
   76: #    Revision 1.7  2003/06/03 01:59:39  foxr
   77: #    complete coding to support deferred transactions.
   78: #
   79: #
   80: 
   81: use lib "/home/httpd/lib/perl/";
   82: use lib "/home/foxr/newloncapa/types";
   83: use Event qw(:DEFAULT );
   84: use POSIX qw(:signal_h);
   85: use POSIX;
   86: use IO::Socket;
   87: use IO::Socket::INET;
   88: use IO::Socket::UNIX;
   89: use IO::File;
   90: use IO::Handle;
   91: use Socket;
   92: use Crypt::IDEA;
   93: use LONCAPA::Queue;
   94: use LONCAPA::Stack;
   95: use LONCAPA::LondConnection;
   96: use LONCAPA::LondTransaction;
   97: use LONCAPA::Configuration;
   98: use LONCAPA::HashIterator;
   99: 
  100: 
  101: #
  102: #   Disable all signals we might receive from outside for now.
  103: #
  104: #$SIG{QUIT}  = IGNORE;
  105: #$SIG{HUP}   = IGNORE;
  106: #$SIG{USR1}  = IGNORE;
  107: #$SIG{INT}   = IGNORE;
  108: #$SIG{CHLD}  = IGNORE;
  109: #$SIG{__DIE__}  = IGNORE;
  110: 
  111: 
  112: # Read the httpd configuration file to get perl variables
  113: # normally set in apache modules:
  114: 
  115: my $perlvarref = LONCAPA::Configuration::read_conf('loncapa.conf');
  116: my %perlvar    = %{$perlvarref};
  117: 
  118: #
  119: #  parent and shared variables.
  120: 
  121: my %ChildHash;			# by pid -> host.
  122: 
  123: 
  124: my $MaxConnectionCount = 10;	# Will get from config later.
  125: my $ClientConnection = 0;	# Uniquifier for client events.
  126: 
  127: my $DebugLevel = 0;
  128: my $IdleTimeout= 3600;		# Wait an hour before pruning connections.
  129: 
  130: #
  131: #  The variables below are only used by the child processes.
  132: #
  133: my $RemoteHost;			# Name of host child is talking to.
  134: my $UnixSocketDir= "/home/httpd/sockets"; 
  135: my $IdleConnections = Stack->new(); # Set of idle connections
  136: my %ActiveConnections;		# Connections to the remote lond.
  137: my %ActiveTransactions;		# LondTransactions in flight.
  138: my %ActiveClients;		# Serial numbers of active clients by socket.
  139: my $WorkQueue       = Queue->new(); # Queue of pending transactions.
  140: my $ConnectionCount = 0;
  141: my $IdleSeconds     = 0;	# Number of seconds idle.
  142: my $Status          = "";	# Current status string.
  143: my $RecentLogEntry  = "";
  144: my $ConnectionRetries=5;	# Number of connection retries allowed.
  145: my $ConnectionRetriesLeft=5;	# Number of connection retries remaining.
  146: 
  147: #
  148: #   The hash below gives the HTML format for log messages
  149: #   given a severity.
  150: #    
  151: my %LogFormats;
  152: 
  153: $LogFormats{"CRITICAL"} = "<font color=red>CRITICAL: %s</font>";
  154: $LogFormats{"SUCCESS"}  = "<font color=green>SUCCESS: %s</font>";
  155: $LogFormats{"INFO"}     = "<font color=yellow>INFO: %s</font>";
  156: $LogFormats{"WARNING"}  = "<font color=blue>WARNING: %s</font>";
  157: $LogFormats{"DEFAULT"}  = " %s ";
  158: 
  159: 
  160: 
  161: =pod
  162: 
  163: =head2 LogPerm
  164: 
  165: Makes an entry into the permanent log file.
  166: 
  167: =cut
  168: sub LogPerm {
  169:     my $message=shift;
  170:     my $execdir=$perlvar{'lonDaemons'};
  171:     my $now=time;
  172:     my $local=localtime($now);
  173:     my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log");
  174:     print $fh "$now:$message:$local\n";
  175: }
  176: 
  177: =pod
  178: 
  179: =head2 Log
  180: 
  181: Logs a message to the log file.
  182: Parameters:
  183: 
  184: =item severity
  185: 
  186: One of CRITICAL, WARNING, INFO, SUCCESS used to select the
  187: format string used to format the message.  if the severity is
  188: not a defined severity the Default format string is used.
  189: 
  190: =item message
  191: 
  192: The base message.  In addtion to the format string, the message
  193: will be appended to a string containing the name of our remote
  194: host and the time will be formatted into the message.
  195: 
  196: =cut
  197: 
  198: sub Log {
  199:     my $severity = shift;
  200:     my $message  = shift;
  201:    
  202:     if(!$LogFormats{$severity}) {
  203: 	$severity = "DEFAULT";
  204:     }
  205: 
  206:     my $format = $LogFormats{$severity};
  207:     
  208:     #  Put the window dressing in in front of the message format:
  209: 
  210:     my $now   = time;
  211:     my $local = localtime($now);
  212:     my $finalformat = "$local ($$) [$RemoteHost] [$Status] ";
  213:     my $finalformat = $finalformat.$format."\n";
  214: 
  215:     # open the file and put the result.
  216: 
  217:     my $execdir = $perlvar{'lonDaemons'};
  218:     my $fh      = IO::File->new(">>$execdir/logs/lonc.log");
  219:     my $msg = sprintf($finalformat, $message);
  220:     $RecentLogEntry = $msg;
  221:     print $fh $msg;
  222:     
  223:     
  224: }
  225: 
  226: 
  227: =pod
  228: 
  229: =head2 GetPeerName
  230: 
  231: Returns the name of the host that a socket object is connected to.
  232: 
  233: =cut
  234: 
  235: sub GetPeername {
  236:     my $connection = shift;
  237:     my $AdrFamily  = shift;
  238:     my $peer       = $connection->peername();
  239:     my $peerport;
  240:     my $peerip;
  241:     if($AdrFamily == AF_INET) {
  242: 	($peerport, $peerip) = sockaddr_in($peer);
  243: 	my $peername    = gethostbyaddr($iaddr, $AdrFamily);
  244: 	return $peername;
  245:     } elsif ($AdrFamily == AF_UNIX) {
  246: 	my $peerfile;
  247: 	($peerfile) = sockaddr_un($peer);
  248: 	return $peerfile;
  249:     }
  250: }
  251: #----------------------------- Timer management ------------------------
  252: =pod
  253: 
  254: =head2 Debug
  255: 
  256: Invoked to issue a debug message.
  257: 
  258: =cut
  259: 
  260: sub Debug {
  261:     my $level   = shift;
  262:     my $message = shift;
  263:     if ($level <= $DebugLevel) {
  264: 	print $message." host = ".$RemoteHost."\n";
  265:     }
  266: }
  267: 
  268: sub SocketDump {
  269:     my $level = shift;
  270:     my $socket= shift;
  271:     if($level <= $DebugLevel) {
  272: 	$socket->Dump();
  273:     }
  274: }
  275: 
  276: =pod
  277: 
  278: =head2 ShowStatus
  279: 
  280:  Place some text as our pid status.
  281:  and as what we return in a SIGUSR1
  282: 
  283: =cut
  284: sub ShowStatus {
  285:     my $state = shift;
  286:     my $now = time;
  287:     my $local = localtime($now);
  288:     $Status   = $local.": ".$state;
  289:     $0='lonc: '.$state.' '.$local;
  290: }
  291: 
  292: =pod
  293: 
  294: =head 2 SocketTimeout
  295: 
  296:     Called when an action on the socket times out.  The socket is 
  297:    destroyed and any active transaction is failed.
  298: 
  299: 
  300: =cut
  301: sub SocketTimeout {
  302:     my $Socket = shift;
  303:     
  304:     KillSocket($Socket);
  305: }
  306: 
  307: =pod
  308: 
  309: =head2 Tick
  310: 
  311: Invoked  each timer tick.
  312: 
  313: =cut
  314: 
  315: 
  316: sub Tick {
  317:     my $client;
  318:     ShowStatus(GetServerHost()." Connection count: ".$ConnectionCount);
  319: 
  320:     # Is it time to prune connection count:
  321: 
  322: 
  323:     if($IdleConnections->Count()  && 
  324:        ($WorkQueue->Count() == 0)) { # Idle connections and nothing to do?
  325: 	$IdleSeconds++;
  326: 	if($IdleSeconds > $IdleTimeout) { # Prune a connection...
  327: 	    $Socket = $IdleConnections->pop();
  328: 	    KillSocket($Socket);
  329: 	}
  330:     } else {
  331: 	$IdleSeconds = 0;	# Reset idle count if not idle.
  332:     }
  333:     #
  334:     #  For each inflight transaction, tick down its timeout counter.
  335:     #
  336:     foreach $item (keys %ActiveTransactions) {
  337: 	my $Socket = $ActiveTransactions{$item}->getServer();
  338: 	$Socket->Tick();
  339:     }
  340:     # Do we have work in the queue, but no connections to service them?
  341:     # If so, try to make some new connections to get things going again.
  342:     #
  343:     
  344:     my $Requests = $WorkQueue->Count();
  345:     if (($ConnectionCount == 0)  && ($Requests > 0)) { 
  346: 	if ($ConnectionRetriesLeft > 0) {
  347: 	    my $Connections = ($Requests <= $MaxConnectionCount) ?
  348: 		$Requests : $MaxConnectionCount;
  349: 	    Debug(1,"Work but no connections, start ".$Connections." of them");
  350: 	    for ($i =0; $i < $Connections; $i++) {
  351: 		MakeLondConnection();
  352: 	    }
  353: 	} else {
  354: 	    Debug(1,"Work in queue, but gave up on connections..flushing\n");
  355: 	    EmptyQueue();	# Connections can't be established.
  356: 	}
  357:        
  358:     }
  359: }
  360: 
  361: =pod
  362: 
  363: =head2 SetupTimer
  364: 
  365: Sets up a 1 per sec recurring timer event.  The event handler is used to:
  366: 
  367: =item
  368: 
  369: Trigger timeouts on communications along active sockets.
  370: 
  371: =item
  372: 
  373: Trigger disconnections of idle sockets.
  374: 
  375: =cut
  376: 
  377: sub SetupTimer {
  378:     Debug(6, "SetupTimer");
  379:     Event->timer(interval => 1, debug => 1, cb => \&Tick );
  380: }
  381: 
  382: =pod
  383: 
  384: =head2 ServerToIdle
  385: 
  386: This function is called when a connection to the server is
  387: ready for more work.
  388: 
  389: If there is work in the Work queue the top element is dequeued
  390: and the connection will start to work on it.  If the work queue is
  391: empty, the connection is pushed on the idle connection stack where
  392: it will either get another work unit, or alternatively, if it sits there
  393: long enough, it will be shut down and released.
  394: 
  395: =cut
  396: 
  397: sub ServerToIdle {
  398:     my $Socket   = shift;	# Get the socket.
  399:     delete($ActiveTransactions{$Socket}); # Server has no transaction
  400: 
  401:     &Debug(6, "Server to idle");
  402: 
  403:     #  If there's work to do, start the transaction:
  404: 
  405:     $reqdata = $WorkQueue->dequeue(); # This is a LondTransaction
  406:     unless($reqdata eq undef)  {
  407: 	Debug(9, "Queue gave request data: ".$reqdata->getRequest());
  408: 	&StartRequest($Socket,  $reqdata);
  409: 
  410:     } else {
  411: 	
  412:     #  There's no work waiting, so push the server to idle list.
  413: 	&Debug(8, "No new work requests, server connection going idle");
  414: 	$IdleConnections->push($Socket);
  415:     }
  416: }
  417: 
  418: =pod
  419: 
  420: =head2 ClientWritable
  421: 
  422: Event callback for when a client socket is writable.
  423: 
  424: This callback is established when a transaction reponse is
  425: avaiable from lond.  The response is forwarded to the unix socket
  426: as it becomes writable in this sub.
  427: 
  428: Parameters:
  429: 
  430: =item Event
  431: 
  432: The event that has been triggered. Event->w->data is
  433: the data and Event->w->fd is the socket to write.
  434: 
  435: =cut
  436: 
  437: sub ClientWritable {
  438:     my $Event    = shift;
  439:     my $Watcher  = $Event->w;
  440:     my $Data     = $Watcher->data;
  441:     my $Socket   = $Watcher->fd;
  442: 
  443:     # Try to send the data:
  444: 
  445:     &Debug(6, "ClientWritable writing".$Data);
  446:     &Debug(9, "Socket is: ".$Socket);
  447: 
  448:     if($Socket->connected) {
  449: 	my $result = $Socket->send($Data, 0);
  450: 	
  451: 	# $result undefined: the write failed.
  452: 	# otherwise $result is the number of bytes written.
  453: 	# Remove that preceding string from the data.
  454: 	# If the resulting data is empty, destroy the watcher
  455: 	# and set up a read event handler to accept the next
  456: 	# request.
  457: 	
  458: 	&Debug(9,"Send result is ".$result." Defined: ".defined($result));
  459: 	if(defined($result)) {
  460: 	    &Debug(9, "send result was defined");
  461: 	    if($result == length($Data)) { # Entire string sent.
  462: 		&Debug(9, "ClientWritable data all written");
  463: 		$Watcher->cancel();
  464: 		#
  465: 		#  Set up to read next request from socket:
  466: 		
  467: 		my $descr     = sprintf("Connection to lonc client %d",
  468: 					$ActiveClients{$Socket});
  469: 		Event->io(cb    => \&ClientRequest,
  470: 			  poll  => 'r',
  471: 			  desc  => $descr,
  472: 			  data  => "",
  473: 			  fd    => $Socket);
  474: 		
  475: 	    } else {		# Partial string sent.
  476: 		$Watcher->data(substr($Data, $result));
  477: 		if($result == 0) {    # client hung up on us!!
  478: 		    Log("INFO", "lonc pipe client hung up on us!");
  479: 		    $Watcher->cancel;
  480: 		    $Socket->shutdown(2);
  481: 		    $Socket->close();
  482: 		}
  483: 	    }
  484: 	    
  485: 	} else {			# Error of some sort...
  486: 	    
  487: 	    # Some errnos are possible:
  488: 	    my $errno = $!;
  489: 	    if($errno == POSIX::EWOULDBLOCK   ||
  490: 	       $errno == POSIX::EAGAIN        ||
  491: 	       $errno == POSIX::EINTR) {
  492: 		# No action taken?
  493: 	    } else {		# Unanticipated errno.
  494: 		&Debug(5,"ClientWritable error or peer shutdown".$RemoteHost);
  495: 		$Watcher->cancel;	# Stop the watcher.
  496: 		$Socket->shutdown(2); # Kill connection
  497: 		$Socket->close();	# Close the socket.
  498: 	    }
  499: 	    
  500: 	}
  501:     } else {
  502: 	$Watcher->cancel();	# A delayed request...just cancel.
  503:     }
  504: }
  505: 
  506: =pod
  507: 
  508: =head2 CompleteTransaction
  509: 
  510: Called when the reply data has been received for a lond 
  511: transaction.   The reply data must now be sent to the
  512: ultimate client on the other end of the Unix socket.  This is
  513: done by setting up a writable event for the socket with the
  514: data the reply data.
  515: 
  516: Parameters:
  517: 
  518: =item Socket
  519: 
  520: Socket on which the lond transaction occured.  This is a
  521: LondConnection. The data received is in the TransactionReply member.
  522: 
  523: =item Transaction
  524: 
  525: The transaction that is being completed.
  526: 
  527: =cut
  528: 
  529: sub CompleteTransaction {
  530:     &Debug(6,"Complete transaction");
  531:     my $Socket = shift;
  532:     my $Transaction = shift;
  533: 
  534:     if (!$Transaction->isDeferred()) { # Normal transaction
  535: 	my $data   = $Socket->GetReply(); # Data to send.
  536: 	StartClientReply($Transaction, $data);
  537:     } else {			# Delete deferred transaction file.
  538: 	Log("SUCCESS", "A delayed transaction was completed");
  539: 	LogPerm("S:$Client:".$Transaction->getRequest());
  540: 	unlink $Transaction->getFile();
  541:     }
  542: }
  543: =pod
  544: =head1 StartClientReply
  545: 
  546:    Initiates a reply to a client where the reply data is a parameter.
  547: 
  548: =head2  parameters:
  549: 
  550: =item Transaction
  551: 
  552:     The transaction for which we are responding to the client.
  553: 
  554: =item data
  555: 
  556:     The data to send to apached client.
  557: 
  558: =cut
  559: sub StartClientReply {
  560:     my $Transaction   = shift;
  561:     my $data     = shift;
  562: 
  563: 
  564:     my $Client   = $Transaction->getClient();
  565: 
  566:     &Debug(8," Reply was: ".$data);
  567:     my $Serial         = $ActiveClients{$Client};
  568:     my $desc           = sprintf("Connection to lonc client %d",
  569: 
  570: 				 $Serial);
  571:     Event->io(fd       => $Client,
  572: 	      poll     => "w",
  573: 	      desc     => $desc,
  574: 	      cb       => \&ClientWritable,
  575: 	      data     => $data);
  576: }
  577: =pod
  578: =head2 FailTransaction
  579: 
  580:   Finishes a transaction with failure because the associated lond socket
  581:   disconnected.  There are two possibilities:
  582:   - The transaction is deferred: in which case we just quietly
  583:     delete the transaction since there is no client connection.
  584:   - The transaction is 'live' in which case we initiate the sending
  585:     of "con_lost" to the client.
  586: 
  587: Deleting the transaction means killing it from the 
  588: %ActiveTransactions hash.
  589: 
  590: Parameters:
  591: 
  592: =item client  
  593:  
  594:    The LondTransaction we are failing.
  595:  
  596: =cut
  597: 
  598: sub FailTransaction {
  599:     my $transaction = shift;
  600:     Debug(1, "Failing transaction: ".$transaction->getRequest());
  601:     if (!$transaction->isDeferred()) { # If the transaction is deferred we'll get to it.
  602: 	my $client  = $transaction->getClient();
  603: 	Debug(1," Replying con_lost to ".$transaction->getRequest());
  604: 	StartClientReply($transaction, "con_lost\n");
  605:     }
  606: 
  607: }
  608: 
  609: =pod
  610: =head1  EmptyQueue
  611: 
  612:   Fails all items in the work queue with con_lost.
  613:   Note that each item in the work queue is a transaction.
  614: 
  615: =cut
  616: sub EmptyQueue {
  617:     while($WorkQueue->Count()) {
  618: 	my $request = $WorkQueue->dequeue(); # This is a transaction
  619: 	FailTransaction($request);
  620:     }
  621: }
  622: 
  623: =pod
  624: 
  625: =head2 CloseAllLondConnections
  626: 
  627: Close all connections open on lond prior to exit e.g.
  628: 
  629: =cut
  630: sub CloseAllLondConnections {
  631:     foreach $Socket (keys %ActiveConnections) {
  632: 	KillSocket($Socket);
  633:     }
  634: }
  635: =cut
  636: 
  637: =pod
  638: 
  639: =head2 KillSocket
  640:  
  641: Destroys a socket.  This function can be called either when a socket
  642: has died of 'natural' causes or because a socket needs to be pruned due to
  643: idleness.  If the socket has died naturally, if there are no longer any 
  644: live connections a new connection is created (in case there are transactions
  645: in the queue).  If the socket has been pruned, it is never re-created.
  646: 
  647: Parameters:
  648: 
  649: =item Socket
  650:  
  651:   The socket to kill off.
  652: 
  653: =item Restart
  654: 
  655: nonzero if we are allowed to create a new connection.
  656: 
  657: 
  658: =cut
  659: sub KillSocket {
  660:     my $Socket = shift;
  661: 
  662:     $Socket->Shutdown();
  663: 
  664:     #  If the socket came from the active connection set,
  665:     #  delete its transaction... note that FailTransaction should
  666:     #  already have been called!!!
  667:     #  otherwise it came from the idle set.
  668:     #  
  669:     
  670:     if(exists($ActiveTransactions{$Socket})) {
  671: 	delete ($ActiveTransactions{$Socket});
  672:     }
  673:     if(exists($ActiveConnections{$Socket})) {
  674: 	delete($ActiveConnections{$Socket});
  675:     }
  676:     $ConnectionCount--;
  677: 
  678:     #  If the connection count has gone to zero and there is work in the
  679:     #  work queue, the work all gets failed with con_lost.
  680:     #
  681:     if($ConnectionCount == 0) {
  682: 	EmptyQueue;
  683:     }
  684: }
  685: 
  686: =pod
  687: 
  688: =head2 LondReadable
  689: 
  690: This function is called whenever a lond connection
  691: is readable.  The action is state dependent:
  692: 
  693: =head3 State=Initialized
  694: 
  695: We''re waiting for the challenge, this is a no-op until the
  696: state changes.
  697: 
  698: =head3 State=Challenged 
  699: 
  700: The challenge has arrived we need to transition to Writable.
  701: The connection must echo the challenge back.
  702: 
  703: =head3 State=ChallengeReplied
  704: 
  705: The challenge has been replied to.  The we are receiveing the 
  706: 'ok' from the partner.
  707: 
  708: =head3 State=RequestingKey
  709: 
  710: The ok has been received and we need to send the request for
  711: an encryption key.  Transition to writable for that.
  712: 
  713: =head3 State=ReceivingKey
  714: 
  715: The the key has been requested, now we are reading the new key.
  716: 
  717: =head3 State=Idle 
  718: 
  719: The encryption key has been negotiated or we have finished 
  720: reading data from the a transaction.   If the callback data has
  721: a client as well as the socket iformation, then we are 
  722: doing a transaction and the data received is relayed to the client
  723: before the socket is put on the idle list.
  724: 
  725: =head3 State=SendingRequest
  726: 
  727: I do not think this state can be received here, but if it is,
  728: the appropriate thing to do is to transition to writable, and send
  729: the request.
  730: 
  731: =head3 State=ReceivingReply
  732: 
  733: We finished sending the request to the server and now transition
  734: to readable to receive the reply. 
  735: 
  736: The parameter to this function are:
  737: 
  738: The event. Implicit in this is the watcher and its data.  The data 
  739: contains at least the lond connection object and, if a 
  740: transaction is in progress, the socket attached to the local client.
  741: 
  742: =cut
  743: 
  744: sub LondReadable {
  745: 
  746:     my $Event      = shift;
  747:     my $Watcher    = $Event->w;
  748:     my $Socket     = $Watcher->data;
  749:     my $client     = undef;
  750: 
  751:     &Debug(6,"LondReadable called state = ".$State);
  752: 
  753: 
  754:     my $State = $Socket->GetState(); # All action depends on the state.
  755: 
  756:     SocketDump(6, $Socket);
  757:     my $status = $Socket->Readable();
  758:     &Debug(2, "Socket->Readable returned: $status");
  759: 
  760:     if($status != 0) {
  761: 	 # bad return from socket read. Currently this means that
  762: 	# The socket has become disconnected. We fail the transaction.
  763: 
  764: 	if(exists($ActiveTransactions{$Socket})) {
  765: 	    Debug(3,"Lond connection lost failing transaction");
  766: 	    FailTransaction($ActiveTransactions{$Socket});
  767: 	}
  768: 	$Watcher->cancel();
  769: 	KillSocket($Socket);
  770: 	return;
  771:     }
  772:     SocketDump(6,$Socket);
  773: 
  774:     $State = $Socket->GetState(); # Update in case of transition.
  775:     &Debug(6, "After read, state is ".$State);
  776: 
  777:    if($State eq "Initialized") {
  778: 
  779: 
  780:     } elsif ($State eq "ChallengeReceived") {
  781: 	#  The challenge must be echoed back;  The state machine
  782: 	# in the connection takes care of setting that up.  Just
  783: 	# need to transition to writable:
  784: 
  785: 	$Watcher->cb(\&LondWritable);
  786: 	$Watcher->poll("w");
  787: 
  788:     } elsif ($State eq "ChallengeReplied") {
  789: 
  790: 
  791:     } elsif ($State eq "RequestingKey") {
  792: 	#  The ok was received.  Now we need to request the key
  793: 	#  That requires us to be writable:
  794: 
  795: 	$Watcher->cb(\&LondWritable);
  796: 	$Watcher->poll("w");
  797: 
  798:     } elsif ($State eq "ReceivingKey") {
  799: 
  800:     } elsif ($State eq "Idle") {
  801: 	# If necessary, complete a transaction and then go into the
  802: 	# idle queue.
  803: 	$Watcher->cancel();
  804: 	if(exists($ActiveTransactions{$Socket})) {
  805: 	    Debug(8,"Completing transaction!!");
  806: 	    CompleteTransaction($Socket, 
  807: 				$ActiveTransactions{$Socket});
  808: 	} else {
  809: 	    Log("SUCCESS", "Connection ".$ConnectionCount." to "
  810: 		.$RemoteHost." now ready for action");
  811: 	}
  812: 	ServerToIdle($Socket);	# Next work unit or idle.
  813: 	
  814:     } elsif ($State eq "SendingRequest") {
  815: 	#  We need to be writable for this and probably don't belong
  816: 	#  here inthe first place.
  817: 
  818: 	Deubg(6, "SendingRequest state encountered in readable");
  819: 	$Watcher->poll("w");
  820: 	$Watcher->cb(\&LondWritable);
  821: 
  822:     } elsif ($State eq "ReceivingReply") {
  823: 
  824: 
  825:     } else {
  826: 	 # Invalid state.
  827: 	Debug(4, "Invalid state in LondReadable");
  828:     }
  829: }
  830: 
  831: =pod
  832: 
  833: =head2 LondWritable
  834: 
  835: This function is called whenever a lond connection
  836: becomes writable while there is a writeable monitoring
  837: event.  The action taken is very state dependent:
  838: 
  839: =head3 State = Connected 
  840: 
  841: The connection is in the process of sending the 'init' hailing to the
  842: lond on the remote end.  The connection object''s Writable member is
  843: called.  On error, ConnectionError is called to destroy the connection
  844: and remove it from the ActiveConnections hash
  845: 
  846: =head3 Initialized
  847: 
  848: 'init' has been sent, writability monitoring is removed and
  849: readability monitoring is started with LondReadable as the callback.
  850: 
  851: =head3 ChallengeReceived
  852: 
  853: The connection has received the who are you challenge from the remote
  854: system, and is in the process of sending the challenge
  855: response. Writable is called.
  856: 
  857: =head3 ChallengeReplied
  858: 
  859: The connection has replied to the initial challenge The we switch to
  860: monitoring readability looking for the server to reply with 'ok'.
  861: 
  862: =head3 RequestingKey
  863: 
  864: The connection is in the process of requesting its encryption key.
  865: Writable is called.
  866: 
  867: =head3 ReceivingKey
  868: 
  869: The connection has sent the request for a key.  Switch to readability
  870: monitoring to accept the key
  871: 
  872: =head3 SendingRequest
  873: 
  874: The connection is in the process of sending a request to the server.
  875: This request is part of a client transaction.  All the states until
  876: now represent the client setup protocol. Writable is called.
  877: 
  878: =head3 ReceivingReply
  879: 
  880: The connection has sent a request.  Now it must receive a reply.
  881: Readability monitoring is requested.
  882: 
  883: This function is an event handler and therefore receives as
  884: a parameter the event that has fired.  The data for the watcher
  885: of this event is a reference to a list of one or two elements,
  886: depending on state. The first (and possibly only) element is the
  887: socket.  The second (present only if a request is in progress)
  888: is the socket on which to return a reply to the caller.
  889: 
  890: =cut
  891: 
  892: sub LondWritable {
  893:     my $Event   = shift;
  894:     my $Watcher = $Event->w;
  895:     my $Socket  = $Watcher->data;
  896:     my $State   = $Socket->GetState();
  897: 
  898:     Debug(6,"LondWritable State = ".$State."\n");
  899: 
  900:  
  901:     #  Figure out what to do depending on the state of the socket:
  902:     
  903: 
  904: 
  905: 
  906:     SocketDump(6,$Socket);
  907: 
  908:     if      ($State eq "Connected")         {
  909: 
  910: 	if ($Socket->Writable() != 0) {
  911: 	    #  The write resulted in an error.
  912: 	    # We'll treat this as if the socket got disconnected:
  913: 	    Log("WARNING", "Connection to ".$RemoteHost.
  914: 		" has been disconnected");
  915: 	    $Watcher->cancel();
  916: 	    KillSocket($Socket);
  917: 	    return;
  918: 	}
  919: 	#  "init" is being sent...
  920: 
  921: 	
  922:     } elsif ($State eq "Initialized")       {
  923: 
  924: 	# Now that init was sent, we switch 
  925: 	# to watching for readability:
  926: 
  927: 	$Watcher->cb(\&LondReadable);
  928: 	$Watcher->poll("r");
  929: 
  930:     } elsif ($State eq "ChallengeReceived") {
  931: 	# We received the challenge, now we 
  932: 	# are echoing it back. This is a no-op,
  933: 	# we're waiting for the state to change
  934: 	
  935: 	if($Socket->Writable() != 0) {
  936: 
  937: 	    $Watcher->cancel();
  938: 	    KillSocket($Socket);
  939: 	    return;
  940: 	}
  941: 	
  942:     } elsif ($State eq "ChallengeReplied")  {
  943: 	# The echo was sent back, so we switch
  944: 	# to watching readability.
  945: 
  946: 	$Watcher->cb(\&LondReadable);
  947: 	$Watcher->poll("r");
  948: 
  949:     } elsif ($State eq "RequestingKey")     {
  950: 	# At this time we're requesting the key.
  951: 	# again, this is essentially a no-op.
  952: 	# we'll write the next chunk until the
  953: 	# state changes.
  954: 
  955: 	if($Socket->Writable() != 0) {
  956: 	    # Write resulted in an error.
  957: 
  958: 	    $Watcher->cancel();
  959: 	    KillSocket($Socket);
  960: 	    return;
  961: 
  962: 	}
  963:     } elsif ($State eq "ReceivingKey")      {
  964: 	# Now we need to wait for the key
  965: 	# to come back from the peer:
  966: 
  967: 	$Watcher->cb(\&LondReadable);
  968: 	$Watcher->poll("r");
  969: 
  970:     } elsif ($State eq "SendingRequest")    {
  971: 	# At this time we are sending a request to the
  972: 	# peer... write the next chunk:
  973: 
  974: 	if($Socket->Writable() != 0) {
  975: 
  976: 	    if(exists($ActiveTransactions{$Socket})) {
  977: 		Debug(3, "Lond connection lost, failing transactions");
  978: 		FailTransaction($ActiveTransactions{$Socket});
  979: 	    }
  980: 	    $Watcher->cancel();
  981: 	    KillSocket($Socket);
  982: 	    return;
  983: 	    
  984: 	}
  985: 
  986:     } elsif ($State eq "ReceivingReply")    {
  987: 	# The send has completed.  Wait for the
  988: 	# data to come in for a reply.
  989: 	Debug(8,"Writable sent request/receiving reply");
  990: 	$Watcher->cb(\&LondReadable);
  991: 	$Watcher->poll("r");
  992: 
  993:     } else {
  994: 	#  Control only passes here on an error: 
  995: 	#  the socket state does not match any
  996: 	#  of the known states... so an error
  997: 	#  must be logged.
  998: 
  999: 	&Debug(4, "Invalid socket state ".$State."\n");
 1000:     }
 1001:     
 1002: }
 1003: =pod
 1004:     
 1005: =cut
 1006: sub QueueDelayed {
 1007:     Debug(3,"QueueDelayed called");
 1008: 
 1009:     my $path = "$perlvar{'lonSockDir'}/delayed";
 1010: 
 1011:     Debug(4, "Delayed path: ".$path);
 1012:     opendir(DIRHANDLE, $path);
 1013:     
 1014:     @alldelayed = grep /\.$RemoteHost$/, readdir DIRHANDLE;
 1015:     Debug(4, "Got ".$alldelayed." delayed files");
 1016:     closedir(DIRHANDLE);
 1017:     my $dfname;
 1018:     my $reqfile;
 1019:     foreach $dfname (sort  @alldelayed) {
 1020: 	$reqfile = "$path/$dfname";
 1021: 	Debug(4, "queueing ".$reqfile);
 1022: 	my $Handle = IO::File->new($reqfile);
 1023: 	my $cmd    = <$Handle>;
 1024: 	chomp $cmd;		# There may or may not be a newline...
 1025: 	$cmd = $cmd."\n";	# now for sure there's exactly one newline.
 1026: 	my $Transaction = LondTransaction->new($cmd);
 1027: 	$Transaction->SetDeferred($reqfile);
 1028: 	QueueTransaction($Transaction);
 1029:     }
 1030:     
 1031: }
 1032: 
 1033: =pod
 1034: 
 1035: =head2 MakeLondConnection
 1036: 
 1037: Create a new lond connection object, and start it towards its initial
 1038: idleness.  Once idle, it becomes elligible to receive transactions
 1039: from the work queue.  If the work queue is not empty when the
 1040: connection is completed and becomes idle, it will dequeue an entry and
 1041: start off on it.
 1042: 
 1043: =cut
 1044: 
 1045: sub MakeLondConnection {     
 1046:     Debug(4,"MakeLondConnection to ".GetServerHost()." on port "
 1047: 	  .GetServerPort());
 1048: 
 1049:     my $Connection = LondConnection->new(&GetServerHost(),
 1050: 					 &GetServerPort());
 1051: 
 1052:     if($Connection == undef) {	# Needs to be more robust later.
 1053: 	Log("CRITICAL","Failed to make a connection with lond.");
 1054: 	$ConnectionRetriesLeft--;
 1055: 	return 0;		# Failure.
 1056:     }  else {
 1057: 	$ConnectionRetriesLeft = $ConnectionRetries; # success resets the count
 1058: 	# The connection needs to have writability 
 1059: 	# monitored in order to send the init sequence
 1060: 	# that starts the whole authentication/key
 1061: 	# exchange underway.
 1062: 	#
 1063: 	my $Socket = $Connection->GetSocket();
 1064: 	if($Socket == undef) {
 1065: 	    die "did not get a socket from the connection";
 1066: 	} else {
 1067: 	    &Debug(9,"MakeLondConnection got socket: ".$Socket);
 1068: 	}
 1069: 	
 1070: 	
 1071: 	$event = Event->io(fd       => $Socket,
 1072: 			   poll     => 'w',
 1073: 			   cb       => \&LondWritable,
 1074: 			   data     => $Connection,
 1075: 			   desc => 'Connection to lond server');
 1076: 	$ActiveConnections{$Connection} = $event;
 1077: 	
 1078: 	$ConnectionCount++;
 1079: 	Debug(4, "Connection count = ".$ConnectionCount);
 1080: 	if($ConnectionCount == 1) { # First Connection:
 1081: 	    QueueDelayed;
 1082: 	}
 1083: 	Log("SUCESS", "Created connection ".$ConnectionCount
 1084: 	    ." to host ".GetServerHost());
 1085: 	return 1;		# Return success.
 1086:     }
 1087:     
 1088: }
 1089: 
 1090: =pod
 1091: 
 1092: =head2 StartRequest
 1093: 
 1094: Starts a lond request going on a specified lond connection.
 1095: parameters are:
 1096: 
 1097: =item $Lond
 1098: 
 1099: Connection to the lond that will send the transaction and receive the
 1100: reply.
 1101: 
 1102: =item $Client
 1103: 
 1104: Connection to the client that is making this request We got the
 1105: request from this socket, and when the request has been relayed to
 1106: lond and we get a reply back from lond it will get sent to this
 1107: socket.
 1108: 
 1109: =item $Request
 1110: 
 1111: The text of the request to send.
 1112: 
 1113: =cut
 1114: 
 1115: sub StartRequest {
 1116:     my $Lond     = shift;
 1117:     my $Request  = shift;	# This is a LondTransaction.
 1118:     
 1119:     Debug(6, "StartRequest: ".$Request->getRequest());
 1120: 
 1121:     my $Socket = $Lond->GetSocket();
 1122:     
 1123:     $Request->Activate($Lond);
 1124:     $ActiveTransactions{$Lond} = $Request;
 1125: 
 1126:     $Lond->InitiateTransaction($Request->getRequest());
 1127:     $event = Event->io(fd      => $Socket,
 1128: 		       poll    => "w",
 1129: 		       cb      => \&LondWritable,
 1130: 		       data    => $Lond,
 1131: 		       desc    => "lond transaction connection");
 1132:     $ActiveConnections{$Lond} = $event;
 1133:     Debug(8," Start Request made watcher data with ".$event->data."\n");
 1134: }
 1135: 
 1136: =pod
 1137: 
 1138: =head2 QueueTransaction
 1139: 
 1140: If there is an idle lond connection, it is put to work doing this
 1141: transaction.  Otherwise, the transaction is placed in the work queue.
 1142: If placed in the work queue and the maximum number of connections has
 1143: not yet been created, a new connection will be started.  Our goal is
 1144: to eventually have a sufficient number of connections that the work
 1145: queue will typically be empty.  parameters are:
 1146: 
 1147: =item Socket
 1148: 
 1149: open on the lonc client.
 1150: 
 1151: =item Request
 1152: 
 1153: data to send to the lond.
 1154: 
 1155: =cut
 1156: 
 1157: sub QueueTransaction {
 1158: 
 1159:     my $requestData   = shift;	# This is a LondTransaction.
 1160:     my $cmd           = $requestData->getRequest();
 1161: 
 1162:     Debug(6,"QueueTransaction: ".$cmd);
 1163: 
 1164:     my $LondSocket    = $IdleConnections->pop();
 1165:     if(!defined $LondSocket) {	# Need to queue request.
 1166: 	Debug(8,"Must queue...");
 1167: 	$WorkQueue->enqueue($requestData);
 1168: 	if($ConnectionCount < $MaxConnectionCount) {
 1169: 	    Debug(4,"Starting additional lond connection");
 1170: 	    MakeLondConnection();
 1171: 	}
 1172:     } else {			# Can start the request:
 1173: 	Debug(8,"Can start...");
 1174: 	StartRequest($LondSocket,  $requestData);
 1175:     }
 1176: }
 1177: 
 1178: #-------------------------- Lonc UNIX socket handling ---------------------
 1179: 
 1180: =pod
 1181: 
 1182: =head2 ClientRequest
 1183: Callback that is called when data can be read from the UNIX domain
 1184: socket connecting us with an apache server process.
 1185: 
 1186: =cut
 1187: 
 1188: sub ClientRequest {
 1189:     Debug(6, "ClientRequest");
 1190:     my $event   = shift;
 1191:     my $watcher = $event->w;
 1192:     my $socket  = $watcher->fd;
 1193:     my $data    = $watcher->data;
 1194:     my $thisread;
 1195: 
 1196:     Debug(9, "  Watcher named: ".$watcher->desc);
 1197: 
 1198:     my $rv = $socket->recv($thisread, POSIX::BUFSIZ, 0);
 1199:     Debug(8, "rcv:  data length = ".length($thisread)
 1200: 	  ." read =".$thisread);
 1201:     unless (defined $rv && length($thisread)) {
 1202: 	 # Likely eof on socket.
 1203: 	Debug(5,"Client Socket closed on lonc for ".$RemoteHost);
 1204: 	close($socket);
 1205: 	$watcher->cancel();
 1206: 	delete($ActiveClients{$socket});
 1207: 	return;
 1208:     }
 1209:     Debug(8,"Data: ".$data." this read: ".$thisread);
 1210:     $data = $data.$thisread;	# Append new data.
 1211:     $watcher->data($data);
 1212:     if($data =~ /(.*\n)/) {	# Request entirely read.
 1213: 	if($data eq "close_connection_exit\n") {
 1214: 	    Log("CRITICAL",
 1215: 		"Request Close Connection ... exiting");
 1216: 	    CloseAllLondConnections();
 1217: 	    exit;
 1218: 	}
 1219: 	Debug(8, "Complete transaction received: ".$data);
 1220: 	my $Transaction = LondTransaction->new($data);
 1221: 	$Transaction->SetClient($socket);
 1222: 	QueueTransaction($Transaction);
 1223: 	$watcher->cancel();	# Done looking for input data.
 1224:     }
 1225: 
 1226: }
 1227: 
 1228: 
 1229: =pod
 1230: 
 1231: =head2  NewClient
 1232: 
 1233: Callback that is called when a connection is received on the unix
 1234: socket for a new client of lonc.  The callback is parameterized by the
 1235: event.. which is a-priori assumed to be an io event, and therefore has
 1236: an fd member that is the Listener socket.  We Accept the connection
 1237: and register a new event on the readability of that socket:
 1238: 
 1239: =cut
 1240: 
 1241: sub NewClient {
 1242:     Debug(6, "NewClient");
 1243:     my $event      = shift;		# Get the event parameters.
 1244:     my $watcher    = $event->w; 
 1245:     my $socket     = $watcher->fd;	# Get the event' socket.
 1246:     my $connection = $socket->accept();	# Accept the client connection.
 1247:     Debug(8,"Connection request accepted from "
 1248: 	  .GetPeername($connection, AF_UNIX));
 1249: 
 1250: 
 1251:     my $description = sprintf("Connection to lonc client %d",
 1252: 			      $ClientConnection);
 1253:     Debug(9, "Creating event named: ".$description);
 1254:     Event->io(cb      => \&ClientRequest,
 1255: 	      poll    => 'r',
 1256: 	      desc    => $description,
 1257: 	      data    => "",
 1258: 	      fd      => $connection);
 1259:     $ActiveClients{$connection} = $ClientConnection;
 1260:     $ClientConnection++;
 1261: }
 1262: 
 1263: =pod
 1264: 
 1265: =head2 GetLoncSocketPath
 1266: 
 1267: Returns the name of the UNIX socket on which to listen for client
 1268: connections.
 1269: 
 1270: =cut
 1271: 
 1272: sub GetLoncSocketPath {
 1273:     return $UnixSocketDir."/".GetServerHost();
 1274: }
 1275: 
 1276: =pod
 1277: 
 1278: =head2 GetServerHost
 1279: 
 1280: Returns the host whose lond we talk with.
 1281: 
 1282: =cut
 1283: 
 1284: sub GetServerHost {
 1285:     return $RemoteHost;		# Setup by the fork.
 1286: }
 1287: 
 1288: =pod
 1289: 
 1290: =head2 GetServerPort
 1291: 
 1292: Returns the lond port number.
 1293: 
 1294: =cut
 1295: 
 1296: sub GetServerPort {
 1297:     return $perlvar{londPort};
 1298: }
 1299: 
 1300: =pod
 1301: 
 1302: =head2 SetupLoncListener
 1303: 
 1304: Setup a lonc listener event.  The event is called when the socket
 1305: becomes readable.. that corresponds to the receipt of a new
 1306: connection.  The event handler established will accept the connection
 1307: (creating a communcations channel), that int turn will establish
 1308: another event handler to subess requests.
 1309: 
 1310: =cut
 1311: 
 1312: sub SetupLoncListener {
 1313: 
 1314:     my $socket;
 1315:     my $SocketName = GetLoncSocketPath();
 1316:     unlink($SocketName);
 1317:     unless ($socket =IO::Socket::UNIX->new(Local  => $SocketName,
 1318: 					    Listen => 10, 
 1319: 					    Type   => SOCK_STREAM)) {
 1320: 	die "Failed to create a lonc listner socket";
 1321:     }
 1322:     Event->io(cb     => \&NewClient,
 1323: 	      poll   => 'r',
 1324: 	      desc   => 'Lonc listener Unix Socket',
 1325: 	      fd     => $socket);
 1326: }
 1327: 
 1328: =pod 
 1329: 
 1330: =head2 ChildStatus
 1331:  
 1332: Child USR1 signal handler to report the most recent status
 1333: into the status file.
 1334: 
 1335: =cut
 1336: sub ChildStatus {
 1337:     my $event = shift;
 1338:     my $watcher = $event->w;
 1339: 
 1340:     Debug(2, "Reporting child status because : ".$watcher->data);
 1341:     my $docdir = $perlvar{'lonDocRoot'};
 1342:     my $fh = IO::File->new(">>$docdir/lon-status/loncstatus.txt");
 1343:     print $fh $$."\t".$RemoteHost."\t".$Status."\t".
 1344: 	$RecentLogEntry."\n";
 1345: }
 1346: 
 1347: =pod
 1348: 
 1349: =head2 SignalledToDeath
 1350: 
 1351: Called in response to a signal that causes a chid process to die.
 1352: 
 1353: =cut
 1354: 
 1355: 
 1356: sub SignalledToDeath {
 1357:     my $event  = shift;
 1358:     my $watcher= $event->w;
 1359: 
 1360:     Debug(2,"Signalled to death! via ".$watcher->data);
 1361:     my ($signal) = @_;
 1362:     chomp($signal);
 1363:     Log("CRITICAL", "Abnormal exit.  Child $$ for $RemoteHost "
 1364: 	."died through "."\"$signal\"");
 1365:     LogPerm("F:lonc: $$ on $RemoteHost signalled to death: "
 1366: 	    ."\"$signal\"");
 1367:     die("Signal abnormal end");
 1368:     exit 0;
 1369: 
 1370: }
 1371: =head2 ChildProcess
 1372: 
 1373: This sub implements a child process for a single lonc daemon.
 1374: 
 1375: =cut
 1376: 
 1377: sub ChildProcess {
 1378: 
 1379: 
 1380:     #
 1381:     #  Signals must be handled by the Event framework...
 1382: #
 1383: #    $SIG{QUIT}  = \&SignalledToDeath;
 1384: #    $SIG{HUP}   = \&ChildStatus;
 1385: #    $SIG{USR1}  = IGNORE;
 1386: #    $SIG{INT}   = DEFAULT;
 1387: #    $SIG{CHLD}  = IGNORE;
 1388: #    $SIG{__DIE__}  = \&SignalledToDeath;
 1389: 
 1390:     Event->signal(signal   => "QUIT",
 1391: 		  cb       => \&SignalledToDeath,
 1392: 		  data     => "QUIT");
 1393:     Event->signal(signal   => "HUP",
 1394: 		  cb       => \&ChildStatus,
 1395: 		  data     => "HUP");
 1396:     Event->signal(signal   => "USR1",
 1397: 		  cb       => \&ChildStatus,
 1398: 		  data     => "USR1");
 1399: 
 1400:     SetupTimer();
 1401:     
 1402:     SetupLoncListener();
 1403:     
 1404:     $Event::Debuglevel = $DebugLevel;
 1405:     
 1406:     Debug(9, "Making initial lond connection for ".$RemoteHost);
 1407: 
 1408: # Setup the initial server connection:
 1409:     
 1410:      # &MakeLondConnection(); // let first work requirest do it.
 1411: 
 1412: 
 1413:     Debug(9,"Entering event loop");
 1414:     my $ret = Event::loop();		#  Start the main event loop.
 1415:     
 1416:     
 1417:     die "Main event loop exited!!!";
 1418: }
 1419: 
 1420: #  Create a new child for host passed in:
 1421: 
 1422: sub CreateChild {
 1423:     my $sigset = POSIX::SigSet->new(SIGINT);
 1424:     sigprocmask(SIG_BLOCK, $sigset);
 1425:     my $host = shift;
 1426:     $RemoteHost = $host;
 1427:     Log("CRITICAL", "Forking server for ".$host);
 1428:     $pid          = fork;
 1429:     if($pid) {			# Parent
 1430: 	$ChildHash{$pid} = $RemoteHost;
 1431: 	sigprocmask(SIG_UNBLOCK, $sigset);
 1432: 
 1433:     } else {			# child.
 1434: 	ShowStatus("Connected to ".$RemoteHost);
 1435: 	$SIG{INT} = DEFAULT;
 1436: 	sigprocmask(SIG_UNBLOCK, $sigset);
 1437: 	ChildProcess;		# Does not return.
 1438:     }
 1439: 
 1440: }
 1441: #
 1442: #  Parent process logic pass 1:
 1443: #   For each entry in the hosts table, we will
 1444: #  fork off an instance of ChildProcess to service the transactions
 1445: #  to that host.  Each pid will be entered in a global hash
 1446: #  with the value of the key, the host.
 1447: #  The parent will then enter a loop to wait for process exits.
 1448: #  Each exit gets logged and the child gets restarted.
 1449: #
 1450: 
 1451: #
 1452: #   Fork and start in new session so hang-up isn't going to 
 1453: #   happen without intent.
 1454: #
 1455: 
 1456: 
 1457: 
 1458: 
 1459: 
 1460: 
 1461: ShowStatus("Forming new session");
 1462: my $childpid = fork;
 1463: if ($childpid != 0) {
 1464:     sleep 4;			# Give child a chacne to break to
 1465:     exit 0;			# a new sesion.
 1466: }
 1467: #
 1468: #   Write my pid into the pid file so I can be located
 1469: #
 1470: 
 1471: ShowStatus("Parent writing pid file:");
 1472: $execdir = $perlvar{'lonDaemons'};
 1473: open (PIDSAVE, ">$execdir/logs/lonc.pid");
 1474: print PIDSAVE "$$\n";
 1475: close(PIDSAVE);
 1476: 
 1477: if (POSIX::setsid() < 0) {
 1478:     print "Could not create new session\n";
 1479:     exit -1;
 1480: }
 1481: 
 1482: ShowStatus("Forking node servers");
 1483: 
 1484: Log("CRITICAL", "--------------- Starting children ---------------");
 1485: 
 1486: my $HostIterator = LondConnection::GetHostIterator;
 1487: while (! $HostIterator->end()) {
 1488: 
 1489:     $hostentryref = $HostIterator->get();
 1490:     CreateChild($hostentryref->[0]);
 1491:     $HostIterator->next();
 1492: }
 1493: $RemoteHost = "Parent Server";
 1494: 
 1495: # Maintain the population:
 1496: 
 1497: ShowStatus("Parent keeping the flock");
 1498: 
 1499: #
 1500: #   Set up parent signals:
 1501: #
 1502: 
 1503: $SIG{INT}  = \&Terminate;
 1504: $SIG{TERM} = \&Terminate; 
 1505: $SIG{HUP}  = \&Restart;
 1506: $SIG{USR1} = \&CheckKids; 
 1507: 
 1508: while(1) {
 1509:     $deadchild = wait();
 1510:     if(exists $ChildHash{$deadchild}) {	# need to restart.
 1511: 	$deadhost = $ChildHash{$deadchild};
 1512: 	delete($ChildHash{$deadchild});
 1513: 	Log("WARNING","Lost child pid= ".$deadchild.
 1514: 	      "Connected to host ".$deadhost);
 1515: 	Log("INFO", "Restarting child procesing ".$deadhost);
 1516: 	CreateChild($deadhost);
 1517:     }
 1518: }
 1519: 
 1520: 
 1521: 
 1522: =pod
 1523: 
 1524: =head1 CheckKids
 1525: 
 1526:   Since kids do not die as easily in this implementation
 1527: as the previous one, there  is no need to restart the
 1528: dead ones (all dead kids get restarted when they die!!)
 1529: The only thing this function does is to pass USR1 to the
 1530: kids so that they report their status.
 1531: 
 1532: =cut
 1533: 
 1534: sub CheckKids {
 1535:     Debug(2, "Checking status of children");
 1536:     my $docdir = $perlvar{'lonDocRoot'};
 1537:     my $fh = IO::File->new(">$docdir/lon-status/loncstatus.txt");
 1538:     my $now=time;
 1539:     my $local=localtime($now);
 1540:     print $fh "LONC status $local - parent $$ \n\n";
 1541:     foreach $pid (keys %ChildHash) {
 1542: 	Debug(2, "Sending USR1 -> $pid");
 1543: 	kill 'USR1' => $pid;	# Tell Child to report status.
 1544: 	sleep 1;		# Wait so file doesn't intermix.
 1545:     }
 1546: }
 1547: 
 1548: =pod
 1549: 
 1550: =head1 Restart
 1551: 
 1552: Signal handler for HUP... all children are killed and
 1553: we self restart.  This is an el-cheapo way to re read
 1554: the config file.
 1555: 
 1556: =cut
 1557: 
 1558: sub Restart {
 1559:     KillThemAll;		# First kill all the children.
 1560:     Log("CRITICAL", "Restarting");
 1561:     my $execdir = $perlvar{'lonDaemons'};
 1562:     unlink("$execdir/logs/lonc.pid");
 1563:     exec("$execdir/lonc");
 1564: }
 1565: 
 1566: =pod
 1567: 
 1568: =head1 KillThemAll
 1569: 
 1570: Signal handler that kills all children by sending them a 
 1571: SIGINT.  Responds to sigint and sigterm.
 1572: 
 1573: =cut
 1574: 
 1575: sub KillThemAll {
 1576:     Debug(2, "Kill them all!!");
 1577:     local($SIG{CHLD}) = 'IGNORE';      # Our children >will< die.
 1578:     foreach $pid (keys %ChildHash) {
 1579: 	my $serving = $ChildHash{$pid};
 1580: 	Debug(2, "Killing lonc for $serving pid = $pid");
 1581: 	ShowStatus("Killing lonc for $serving pid = $pid");
 1582: 	Log("CRITICAL", "Killing lonc for $serving pid = $pid");
 1583: 	kill('INT', $pid);
 1584: 	delete($ChildeHash{$pid});
 1585:     }
 1586:     my $execdir = $perlvar{'lonDaemons'};
 1587:     unlink("$execdir/logs/lonc.pid");
 1588:     ShowStatus("Killing the master process");
 1589:     Log("CRITICAL", "Killing the master process.");
 1590: }
 1591: 
 1592: =pod
 1593: 
 1594: =head1 Terminate
 1595:  
 1596: Terminate the system.
 1597: 
 1598: =cut
 1599: 
 1600: sub Terminate {
 1601:     KillThemAll;
 1602:     exit;
 1603: 
 1604: }
 1605: =pod
 1606: 
 1607: =head1 Theory
 1608: 
 1609: The event class is used to build this as a single process with an
 1610: event driven model.  The following events are handled:
 1611: 
 1612: =item UNIX Socket connection Received
 1613: 
 1614: =item Request data arrives on UNIX data transfer socket.
 1615: 
 1616: =item lond connection becomes writable.
 1617: 
 1618: =item timer fires at 1 second intervals.
 1619: 
 1620: All sockets are run in non-blocking mode.  Timeouts managed by the timer
 1621: handler prevents hung connections.
 1622: 
 1623: Key data structures:
 1624: 
 1625: =item RequestQueue
 1626: 
 1627: A queue of requests received from UNIX sockets that are
 1628: waiting for a chance to be forwarded on a lond connection socket.
 1629: 
 1630: =item ActiveConnections
 1631: 
 1632: A hash of lond connections that have transactions in process that are
 1633: available to be timed out.
 1634: 
 1635: =item ActiveTransactions
 1636: 
 1637: A hash indexed by lond connections that contain the client reply
 1638: socket for each connection that has an active transaction on it.
 1639: 
 1640: =item IdleConnections
 1641: 
 1642: A hash of lond connections that have no work to do.  These connections
 1643: can be closed if they are idle for a long enough time.
 1644: 
 1645: =cut

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