Annotation of loncom/loncnew, revision 1.77

1.1       foxr        1: #!/usr/bin/perl
1.2       albertel    2: # The LearningOnline Network with CAPA
                      3: # lonc maintains the connections to remote computers
                      4: #
1.77    ! albertel    5: # $Id: loncnew,v 1.76 2006/08/25 21:12:19 albertel Exp $
1.2       albertel    6: #
                      7: # Copyright Michigan State University Board of Trustees
                      8: #
                      9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
1.17      foxr       10: ## LON-CAPA is free software; you can redistribute it and/or modify
1.2       albertel   11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
1.1       foxr       28: #
1.15      foxr       29: # new lonc handles n request out bver m connections to londs.
1.1       foxr       30: # This module is based on the Event class.
                     31: #   Development iterations:
                     32: #    - Setup basic event loop.   (done)
                     33: #    - Add timer dispatch.       (done)
                     34: #    - Add ability to accept lonc UNIX domain sockets.  (done)
                     35: #    - Add ability to create/negotiate lond connections (done).
1.7       foxr       36: #    - Add general logic for dispatching requests and timeouts. (done).
                     37: #    - Add support for the lonc/lond requests.          (done).
1.38      foxr       38: #    - Add logging/status monitoring.                    (done)
                     39: #    - Add Signal handling - HUP restarts. USR1 status report. (done)
1.7       foxr       40: #    - Add Configuration file I/O                       (done).
1.38      foxr       41: #    - Add management/status request interface.         (done)
1.8       foxr       42: #    - Add deferred request capability.                  (done)
1.38      foxr       43: #    - Detect transmission timeouts.                     (done)
1.7       foxr       44: #
                     45: 
1.23      foxr       46: use strict;
1.1       foxr       47: use lib "/home/httpd/lib/perl/";
                     48: use Event qw(:DEFAULT );
                     49: use POSIX qw(:signal_h);
1.12      foxr       50: use POSIX;
1.1       foxr       51: use IO::Socket;
                     52: use IO::Socket::INET;
                     53: use IO::Socket::UNIX;
1.9       foxr       54: use IO::File;
1.6       foxr       55: use IO::Handle;
1.1       foxr       56: use Socket;
                     57: use Crypt::IDEA;
                     58: use LONCAPA::Queue;
                     59: use LONCAPA::Stack;
                     60: use LONCAPA::LondConnection;
1.7       foxr       61: use LONCAPA::LondTransaction;
1.1       foxr       62: use LONCAPA::Configuration;
                     63: use LONCAPA::HashIterator;
1.67      albertel   64: use Fcntl qw(:flock);
1.1       foxr       65: 
                     66: 
                     67: # Read the httpd configuration file to get perl variables
                     68: # normally set in apache modules:
                     69: 
                     70: my $perlvarref = LONCAPA::Configuration::read_conf('loncapa.conf');
                     71: my %perlvar    = %{$perlvarref};
                     72: 
                     73: #
                     74: #  parent and shared variables.
                     75: 
                     76: my %ChildHash;			# by pid -> host.
1.26      foxr       77: my %HostToPid;			# By host -> pid.
                     78: my %HostHash;			# by loncapaname -> IP.
1.62      foxr       79: my %listening_to;		# Socket->host table for who the parent
                     80:                                 # is listening to.
                     81: my %parent_dispatchers;         # host-> listener watcher events. 
1.1       foxr       82: 
1.65      foxr       83: my %parent_handlers;		# Parent signal handlers...
                     84: 
1.9       foxr       85: my $MaxConnectionCount = 10;	# Will get from config later.
1.1       foxr       86: my $ClientConnection = 0;	# Uniquifier for client events.
                     87: 
1.9       foxr       88: my $DebugLevel = 0;
1.29      foxr       89: my $NextDebugLevel= 2;		# So Sigint can toggle this.
1.50      albertel   90: my $IdleTimeout= 600;		# Wait 10 minutes before pruning connections.
1.1       foxr       91: 
1.39      foxr       92: my $LogTransactions = 0;	# When True, all transactions/replies get logged.
1.65      foxr       93: my $executable      = $0;	# Get the full path to me.
1.39      foxr       94: 
1.1       foxr       95: #
                     96: #  The variables below are only used by the child processes.
                     97: #
                     98: my $RemoteHost;			# Name of host child is talking to.
1.20      albertel   99: my $UnixSocketDir= $perlvar{'lonSockDir'};
1.1       foxr      100: my $IdleConnections = Stack->new(); # Set of idle connections
                    101: my %ActiveConnections;		# Connections to the remote lond.
1.7       foxr      102: my %ActiveTransactions;		# LondTransactions in flight.
1.1       foxr      103: my %ActiveClients;		# Serial numbers of active clients by socket.
                    104: my $WorkQueue       = Queue->new(); # Queue of pending transactions.
                    105: my $ConnectionCount = 0;
1.4       foxr      106: my $IdleSeconds     = 0;	# Number of seconds idle.
1.9       foxr      107: my $Status          = "";	# Current status string.
1.14      foxr      108: my $RecentLogEntry  = "";
1.72      albertel  109: my $ConnectionRetries=5;	# Number of connection retries allowed.
                    110: my $ConnectionRetriesLeft=5;	# Number of connection retries remaining.
1.40      foxr      111: my $LondVersion     = "unknown"; # Version of lond we talk with.
1.49      foxr      112: my $KeyMode         = "";       # e.g. ssl, local, insecure from last connect.
1.54      foxr      113: my $LondConnecting  = 0;       # True when a connection is being built.
1.1       foxr      114: 
1.60      foxr      115: 
                    116: 
1.65      foxr      117: my $DieWhenIdle     = 1;	# When true children die when trimmed -> 0.
1.77    ! albertel  118: my $hosts_tab       = 1;        # True if we are using a static hosts.tab
1.62      foxr      119: my $I_am_child      = 0;	# True if this is the child process.
1.57      foxr      120: 
1.1       foxr      121: #
1.9       foxr      122: #   The hash below gives the HTML format for log messages
                    123: #   given a severity.
                    124: #    
                    125: my %LogFormats;
                    126: 
1.45      albertel  127: $LogFormats{"CRITICAL"} = "<font color='red'>CRITICAL: %s</font>";
                    128: $LogFormats{"SUCCESS"}  = "<font color='green'>SUCCESS: %s</font>";
                    129: $LogFormats{"INFO"}     = "<font color='yellow'>INFO: %s</font>";
                    130: $LogFormats{"WARNING"}  = "<font color='blue'>WARNING: %s</font>";
1.9       foxr      131: $LogFormats{"DEFAULT"}  = " %s ";
                    132: 
1.10      foxr      133: 
1.57      foxr      134: #  UpdateStatus;
                    135: #    Update the idle status display to show how many connections
                    136: #    are left, retries and other stuff.
                    137: #
                    138: sub UpdateStatus {
                    139:     if ($ConnectionRetriesLeft > 0) {
                    140: 	ShowStatus(GetServerHost()." Connection count: ".$ConnectionCount
                    141: 		   ." Retries remaining: ".$ConnectionRetriesLeft
                    142: 		   ." ($KeyMode)");
                    143:     } else {
                    144: 	ShowStatus(GetServerHost()." >> DEAD <<");
                    145:     }
                    146: }
                    147: 
1.10      foxr      148: 
                    149: =pod
                    150: 
                    151: =head2 LogPerm
                    152: 
                    153: Makes an entry into the permanent log file.
                    154: 
                    155: =cut
1.69      matthew   156: 
1.10      foxr      157: sub LogPerm {
                    158:     my $message=shift;
                    159:     my $execdir=$perlvar{'lonDaemons'};
                    160:     my $now=time;
                    161:     my $local=localtime($now);
                    162:     my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log");
                    163:     print $fh "$now:$message:$local\n";
                    164: }
1.9       foxr      165: 
                    166: =pod
                    167: 
                    168: =head2 Log
                    169: 
                    170: Logs a message to the log file.
                    171: Parameters:
                    172: 
                    173: =item severity
                    174: 
                    175: One of CRITICAL, WARNING, INFO, SUCCESS used to select the
                    176: format string used to format the message.  if the severity is
                    177: not a defined severity the Default format string is used.
                    178: 
                    179: =item message
                    180: 
                    181: The base message.  In addtion to the format string, the message
                    182: will be appended to a string containing the name of our remote
                    183: host and the time will be formatted into the message.
                    184: 
                    185: =cut
                    186: 
                    187: sub Log {
1.47      foxr      188: 
                    189:     my ($severity, $message) = @_;
                    190: 
1.9       foxr      191:     if(!$LogFormats{$severity}) {
                    192: 	$severity = "DEFAULT";
                    193:     }
                    194: 
                    195:     my $format = $LogFormats{$severity};
                    196:     
                    197:     #  Put the window dressing in in front of the message format:
                    198: 
                    199:     my $now   = time;
                    200:     my $local = localtime($now);
                    201:     my $finalformat = "$local ($$) [$RemoteHost] [$Status] ";
1.76      albertel  202:     $finalformat = $finalformat.$format."\n";
1.9       foxr      203: 
                    204:     # open the file and put the result.
                    205: 
                    206:     my $execdir = $perlvar{'lonDaemons'};
                    207:     my $fh      = IO::File->new(">>$execdir/logs/lonc.log");
                    208:     my $msg = sprintf($finalformat, $message);
1.14      foxr      209:     $RecentLogEntry = $msg;
1.9       foxr      210:     print $fh $msg;
                    211:     
1.10      foxr      212:     
1.9       foxr      213: }
1.6       foxr      214: 
1.3       albertel  215: 
1.1       foxr      216: =pod
1.3       albertel  217: 
                    218: =head2 GetPeerName
                    219: 
                    220: Returns the name of the host that a socket object is connected to.
                    221: 
1.1       foxr      222: =cut
                    223: 
                    224: sub GetPeername {
1.47      foxr      225: 
                    226: 
                    227:     my ($connection, $AdrFamily) = @_;
                    228: 
1.1       foxr      229:     my $peer       = $connection->peername();
                    230:     my $peerport;
                    231:     my $peerip;
                    232:     if($AdrFamily == AF_INET) {
                    233: 	($peerport, $peerip) = sockaddr_in($peer);
1.23      foxr      234: 	my $peername    = gethostbyaddr($peerip, $AdrFamily);
1.1       foxr      235: 	return $peername;
                    236:     } elsif ($AdrFamily == AF_UNIX) {
                    237: 	my $peerfile;
                    238: 	($peerfile) = sockaddr_un($peer);
                    239: 	return $peerfile;
                    240:     }
                    241: }
                    242: =pod
1.3       albertel  243: 
1.1       foxr      244: =head2 Debug
1.3       albertel  245: 
                    246: Invoked to issue a debug message.
                    247: 
1.1       foxr      248: =cut
1.3       albertel  249: 
1.1       foxr      250: sub Debug {
1.47      foxr      251: 
                    252:     my ($level, $message) = @_;
                    253: 
1.1       foxr      254:     if ($level <= $DebugLevel) {
1.23      foxr      255: 	Log("INFO", "-Debug- $message host = $RemoteHost");
1.1       foxr      256:     }
                    257: }
                    258: 
                    259: sub SocketDump {
1.47      foxr      260: 
                    261:     my ($level, $socket) = @_;
                    262: 
1.1       foxr      263:     if($level <= $DebugLevel) {
1.48      foxr      264: 	$socket->Dump(-1);	# Ensure it will get dumped.
1.1       foxr      265:     }
                    266: }
1.3       albertel  267: 
1.1       foxr      268: =pod
1.3       albertel  269: 
1.5       foxr      270: =head2 ShowStatus
                    271: 
                    272:  Place some text as our pid status.
1.10      foxr      273:  and as what we return in a SIGUSR1
1.5       foxr      274: 
                    275: =cut
1.69      matthew   276: 
1.5       foxr      277: sub ShowStatus {
1.10      foxr      278:     my $state = shift;
                    279:     my $now = time;
                    280:     my $local = localtime($now);
                    281:     $Status   = $local.": ".$state;
                    282:     $0='lonc: '.$state.' '.$local;
1.5       foxr      283: }
                    284: 
                    285: =pod
                    286: 
1.69      matthew   287: =head2 SocketTimeout
1.15      foxr      288: 
                    289:     Called when an action on the socket times out.  The socket is 
                    290:    destroyed and any active transaction is failed.
                    291: 
                    292: 
                    293: =cut
1.69      matthew   294: 
1.15      foxr      295: sub SocketTimeout {
                    296:     my $Socket = shift;
1.38      foxr      297:     Log("WARNING", "A socket timeout was detected");
1.52      foxr      298:     Debug(5, " SocketTimeout called: ");
1.48      foxr      299:     $Socket->Dump(0);
1.42      foxr      300:     if(exists($ActiveTransactions{$Socket})) {
1.43      albertel  301: 	FailTransaction($ActiveTransactions{$Socket});
1.42      foxr      302:     }
1.22      foxr      303:     KillSocket($Socket);	# A transaction timeout also counts as
                    304:                                 # a connection failure:
                    305:     $ConnectionRetriesLeft--;
1.42      foxr      306:     if($ConnectionRetriesLeft <= 0) {
1.52      foxr      307: 	Log("CRITICAL", "Host marked DEAD: ".GetServerHost());
1.56      foxr      308: 	$LondConnecting = 0;
1.42      foxr      309:     }
                    310: 
1.15      foxr      311: }
1.64      foxr      312: #
                    313: #   This function should be called by the child in all cases where it must
                    314: #   exit.  If the child process is running with the DieWhenIdle turned on
                    315: #   it must create a lock file for the AF_UNIX socket in order to prevent
                    316: #   connection requests from lonnet in the time between process exit
                    317: #   and the parent picking up the listen again.
                    318: # Parameters:
                    319: #     exit_code           - Exit status value, however see the next parameter.
                    320: #     message             - If this optional parameter is supplied, the exit
                    321: #                           is via a die with this message.
                    322: #
                    323: sub child_exit {
                    324:     my ($exit_code, $message) = @_;
                    325: 
                    326:     # Regardless of how we exit, we may need to do the lock thing:
                    327: 
                    328:     if($DieWhenIdle) {
                    329: 	#
                    330: 	#  Create a lock file since there will be a time window
                    331: 	#  between our exit and the parent's picking up the listen
                    332: 	#  during which no listens will be done on the
                    333: 	#  lonnet client socket.
                    334: 	#
1.77    ! albertel  335: 	my $lock_file = &GetLoncSocketPath().".lock";
1.64      foxr      336: 	open(LOCK,">$lock_file");
                    337: 	print LOCK "Contents not important";
                    338: 	close(LOCK);
1.77    ! albertel  339: 	if ($hosts_tab) {
        !           340: 	    unlink(&GetLoncSocketPath());
        !           341: 	}
1.64      foxr      342: 	exit(0);
                    343:     }
                    344:     #  Now figure out how we exit:
                    345: 
                    346:     if($message) {
                    347: 	die $message;
                    348:     } else {
                    349: 	exit($exit_code);
                    350:     }
                    351: }
1.35      foxr      352: #----------------------------- Timer management ------------------------
1.15      foxr      353: 
                    354: =pod
                    355: 
1.1       foxr      356: =head2 Tick
1.3       albertel  357: 
                    358: Invoked  each timer tick.
                    359: 
1.1       foxr      360: =cut
                    361: 
1.5       foxr      362: 
1.1       foxr      363: sub Tick {
1.52      foxr      364:     my ($Event)       = @_;
                    365:     my $clock_watcher = $Event->w;
                    366: 
1.1       foxr      367:     my $client;
1.57      foxr      368:     UpdateStatus();
                    369: 
1.4       foxr      370:     # Is it time to prune connection count:
                    371: 
                    372: 
                    373:     if($IdleConnections->Count()  && 
                    374:        ($WorkQueue->Count() == 0)) { # Idle connections and nothing to do?
1.52      foxr      375: 	$IdleSeconds++;
1.4       foxr      376: 	if($IdleSeconds > $IdleTimeout) { # Prune a connection...
1.23      foxr      377: 	    my $Socket = $IdleConnections->pop();
1.6       foxr      378: 	    KillSocket($Socket);
1.54      foxr      379: 	    $IdleSeconds = 0;	# Otherwise all connections get trimmed to fast.
1.57      foxr      380: 	    UpdateStatus();
                    381: 	    if(($ConnectionCount == 0) && $DieWhenIdle) {
1.64      foxr      382: 		&child_exit(0);
                    383: 
1.57      foxr      384: 	    }
1.4       foxr      385: 	}
                    386:     } else {
                    387: 	$IdleSeconds = 0;	# Reset idle count if not idle.
                    388:     }
1.15      foxr      389:     #
                    390:     #  For each inflight transaction, tick down its timeout counter.
                    391:     #
1.35      foxr      392: 
1.34      albertel  393:     foreach my $item (keys %ActiveConnections) {
                    394: 	my $State = $ActiveConnections{$item}->data->GetState();
1.35      foxr      395: 	if ($State ne 'Idle') {
1.34      albertel  396: 	    Debug(5,"Ticking Socket $State $item");
                    397: 	    $ActiveConnections{$item}->data->Tick();
                    398: 	}
1.15      foxr      399:     }
1.5       foxr      400:     # Do we have work in the queue, but no connections to service them?
                    401:     # If so, try to make some new connections to get things going again.
                    402:     #
1.57      foxr      403:     #   Note this code is dead now...
                    404:     #
1.5       foxr      405:     my $Requests = $WorkQueue->Count();
1.56      foxr      406:     if (($ConnectionCount == 0)  && ($Requests > 0) && (!$LondConnecting)) { 
1.10      foxr      407: 	if ($ConnectionRetriesLeft > 0) {
1.56      foxr      408: 	    Debug(5,"Work but no connections, Make a new one");
                    409: 	    my $success;
                    410: 	    $success    = &MakeLondConnection;
                    411: 	    if($success == 0) { # All connections failed:
1.29      foxr      412: 		Debug(5,"Work in queue failed to make any connectiouns\n");
1.22      foxr      413: 		EmptyQueue();	# Fail pending transactions with con_lost.
1.42      foxr      414: 		CloseAllLondConnections(); # Should all be closed but....
1.10      foxr      415: 	    }
                    416: 	} else {
1.56      foxr      417: 	    $LondConnecting = 0;
1.22      foxr      418: 	    ShowStatus(GetServerHost()." >>> DEAD!!! <<<");
1.29      foxr      419: 	    Debug(5,"Work in queue, but gave up on connections..flushing\n");
1.10      foxr      420: 	    EmptyQueue();	# Connections can't be established.
1.42      foxr      421: 	    CloseAllLondConnections(); # Should all already be closed but...
1.5       foxr      422: 	}
                    423:        
                    424:     }
1.49      foxr      425:     if ($ConnectionCount == 0) {
                    426: 	$KeyMode = ""; 
1.52      foxr      427: 	$clock_watcher->cancel();
1.49      foxr      428:     }
1.66      albertel  429:     &UpdateStatus();
1.1       foxr      430: }
                    431: 
                    432: =pod
1.3       albertel  433: 
1.1       foxr      434: =head2 SetupTimer
                    435: 
1.3       albertel  436: Sets up a 1 per sec recurring timer event.  The event handler is used to:
1.1       foxr      437: 
1.3       albertel  438: =item
                    439: 
                    440: Trigger timeouts on communications along active sockets.
                    441: 
                    442: =item
                    443: 
                    444: Trigger disconnections of idle sockets.
1.1       foxr      445: 
                    446: =cut
                    447: 
                    448: sub SetupTimer {
1.52      foxr      449:     Debug(6, "SetupTimer");
                    450:     Event->timer(interval => 1, cb => \&Tick );
1.1       foxr      451: }
1.3       albertel  452: 
1.1       foxr      453: =pod
1.3       albertel  454: 
1.1       foxr      455: =head2 ServerToIdle
1.3       albertel  456: 
                    457: This function is called when a connection to the server is
                    458: ready for more work.
                    459: 
                    460: If there is work in the Work queue the top element is dequeued
1.1       foxr      461: and the connection will start to work on it.  If the work queue is
                    462: empty, the connection is pushed on the idle connection stack where
                    463: it will either get another work unit, or alternatively, if it sits there
                    464: long enough, it will be shut down and released.
                    465: 
1.3       albertel  466: =cut
1.1       foxr      467: 
                    468: sub ServerToIdle {
                    469:     my $Socket   = shift;	# Get the socket.
1.49      foxr      470:     $KeyMode = $Socket->{AuthenticationMode};
1.7       foxr      471:     delete($ActiveTransactions{$Socket}); # Server has no transaction
1.1       foxr      472: 
1.29      foxr      473:     &Debug(5, "Server to idle");
1.1       foxr      474: 
                    475:     #  If there's work to do, start the transaction:
                    476: 
1.23      foxr      477:     my $reqdata = $WorkQueue->dequeue(); # This is a LondTransaction
1.29      foxr      478:     if ($reqdata ne undef)  {
                    479: 	Debug(5, "Queue gave request data: ".$reqdata->getRequest());
1.7       foxr      480: 	&StartRequest($Socket,  $reqdata);
1.8       foxr      481: 
1.1       foxr      482:     } else {
                    483: 	
                    484:     #  There's no work waiting, so push the server to idle list.
1.29      foxr      485: 	&Debug(5, "No new work requests, server connection going idle");
1.1       foxr      486: 	$IdleConnections->push($Socket);
                    487:     }
                    488: }
1.3       albertel  489: 
1.1       foxr      490: =pod
1.3       albertel  491: 
1.1       foxr      492: =head2 ClientWritable
1.3       albertel  493: 
                    494: Event callback for when a client socket is writable.
                    495: 
                    496: This callback is established when a transaction reponse is
                    497: avaiable from lond.  The response is forwarded to the unix socket
                    498: as it becomes writable in this sub.
                    499: 
1.1       foxr      500: Parameters:
                    501: 
1.3       albertel  502: =item Event
                    503: 
                    504: The event that has been triggered. Event->w->data is
                    505: the data and Event->w->fd is the socket to write.
1.1       foxr      506: 
                    507: =cut
1.3       albertel  508: 
1.1       foxr      509: sub ClientWritable {
                    510:     my $Event    = shift;
                    511:     my $Watcher  = $Event->w;
                    512:     my $Data     = $Watcher->data;
                    513:     my $Socket   = $Watcher->fd;
                    514: 
                    515:     # Try to send the data:
                    516: 
                    517:     &Debug(6, "ClientWritable writing".$Data);
                    518:     &Debug(9, "Socket is: ".$Socket);
                    519: 
1.6       foxr      520:     if($Socket->connected) {
                    521: 	my $result = $Socket->send($Data, 0);
                    522: 	
                    523: 	# $result undefined: the write failed.
                    524: 	# otherwise $result is the number of bytes written.
                    525: 	# Remove that preceding string from the data.
                    526: 	# If the resulting data is empty, destroy the watcher
                    527: 	# and set up a read event handler to accept the next
                    528: 	# request.
                    529: 	
                    530: 	&Debug(9,"Send result is ".$result." Defined: ".defined($result));
1.29      foxr      531: 	if($result ne undef) {
1.6       foxr      532: 	    &Debug(9, "send result was defined");
                    533: 	    if($result == length($Data)) { # Entire string sent.
                    534: 		&Debug(9, "ClientWritable data all written");
                    535: 		$Watcher->cancel();
                    536: 		#
                    537: 		#  Set up to read next request from socket:
                    538: 		
                    539: 		my $descr     = sprintf("Connection to lonc client %d",
                    540: 					$ActiveClients{$Socket});
                    541: 		Event->io(cb    => \&ClientRequest,
                    542: 			  poll  => 'r',
                    543: 			  desc  => $descr,
                    544: 			  data  => "",
                    545: 			  fd    => $Socket);
                    546: 		
                    547: 	    } else {		# Partial string sent.
                    548: 		$Watcher->data(substr($Data, $result));
1.15      foxr      549: 		if($result == 0) {    # client hung up on us!!
1.52      foxr      550: 		    # Log("INFO", "lonc pipe client hung up on us!");
1.15      foxr      551: 		    $Watcher->cancel;
                    552: 		    $Socket->shutdown(2);
                    553: 		    $Socket->close();
                    554: 		}
1.6       foxr      555: 	    }
                    556: 	    
                    557: 	} else {			# Error of some sort...
                    558: 	    
                    559: 	    # Some errnos are possible:
                    560: 	    my $errno = $!;
                    561: 	    if($errno == POSIX::EWOULDBLOCK   ||
                    562: 	       $errno == POSIX::EAGAIN        ||
                    563: 	       $errno == POSIX::EINTR) {
                    564: 		# No action taken?
                    565: 	    } else {		# Unanticipated errno.
                    566: 		&Debug(5,"ClientWritable error or peer shutdown".$RemoteHost);
                    567: 		$Watcher->cancel;	# Stop the watcher.
                    568: 		$Socket->shutdown(2); # Kill connection
                    569: 		$Socket->close();	# Close the socket.
                    570: 	    }
1.1       foxr      571: 	    
                    572: 	}
1.6       foxr      573:     } else {
                    574: 	$Watcher->cancel();	# A delayed request...just cancel.
1.1       foxr      575:     }
                    576: }
                    577: 
                    578: =pod
1.3       albertel  579: 
1.1       foxr      580: =head2 CompleteTransaction
1.3       albertel  581: 
                    582: Called when the reply data has been received for a lond 
1.1       foxr      583: transaction.   The reply data must now be sent to the
                    584: ultimate client on the other end of the Unix socket.  This is
                    585: done by setting up a writable event for the socket with the
                    586: data the reply data.
1.3       albertel  587: 
1.1       foxr      588: Parameters:
1.3       albertel  589: 
                    590: =item Socket
                    591: 
                    592: Socket on which the lond transaction occured.  This is a
                    593: LondConnection. The data received is in the TransactionReply member.
                    594: 
1.7       foxr      595: =item Transaction
1.3       albertel  596: 
1.7       foxr      597: The transaction that is being completed.
1.1       foxr      598: 
                    599: =cut
1.3       albertel  600: 
1.1       foxr      601: sub CompleteTransaction {
1.29      foxr      602:     &Debug(5,"Complete transaction");
1.47      foxr      603: 
                    604:     my ($Socket, $Transaction) = @_;
1.1       foxr      605: 
1.7       foxr      606:     if (!$Transaction->isDeferred()) { # Normal transaction
                    607: 	my $data   = $Socket->GetReply(); # Data to send.
1.39      foxr      608: 	if($LogTransactions) {
                    609: 	    Log("SUCCESS", "Reply from lond: '$data'");
                    610: 	}
1.7       foxr      611: 	StartClientReply($Transaction, $data);
                    612:     } else {			# Delete deferred transaction file.
1.9       foxr      613: 	Log("SUCCESS", "A delayed transaction was completed");
1.23      foxr      614: 	LogPerm("S:$Transaction->getClient() :".$Transaction->getRequest());
1.7       foxr      615: 	unlink $Transaction->getFile();
                    616:     }
1.6       foxr      617: }
1.42      foxr      618: 
1.6       foxr      619: =pod
1.42      foxr      620: 
1.6       foxr      621: =head1 StartClientReply
                    622: 
                    623:    Initiates a reply to a client where the reply data is a parameter.
                    624: 
1.7       foxr      625: =head2  parameters:
                    626: 
                    627: =item Transaction
                    628: 
                    629:     The transaction for which we are responding to the client.
                    630: 
                    631: =item data
                    632: 
                    633:     The data to send to apached client.
                    634: 
1.6       foxr      635: =cut
1.42      foxr      636: 
1.6       foxr      637: sub StartClientReply {
1.1       foxr      638: 
1.47      foxr      639:     my ($Transaction, $data) = @_;
1.12      foxr      640: 
1.7       foxr      641:     my $Client   = $Transaction->getClient();
                    642: 
1.1       foxr      643:     &Debug(8," Reply was: ".$data);
                    644:     my $Serial         = $ActiveClients{$Client};
                    645:     my $desc           = sprintf("Connection to lonc client %d",
                    646: 				 $Serial);
                    647:     Event->io(fd       => $Client,
                    648: 	      poll     => "w",
                    649: 	      desc     => $desc,
                    650: 	      cb       => \&ClientWritable,
                    651: 	      data     => $data);
                    652: }
1.42      foxr      653: 
1.4       foxr      654: =pod
1.42      foxr      655: 
1.4       foxr      656: =head2 FailTransaction
                    657: 
                    658:   Finishes a transaction with failure because the associated lond socket
1.7       foxr      659:   disconnected.  There are two possibilities:
                    660:   - The transaction is deferred: in which case we just quietly
                    661:     delete the transaction since there is no client connection.
                    662:   - The transaction is 'live' in which case we initiate the sending
                    663:     of "con_lost" to the client.
                    664: 
1.42      foxr      665: Deleting the transaction means killing it from the %ActiveTransactions hash.
1.4       foxr      666: 
                    667: Parameters:
                    668: 
                    669: =item client  
                    670:  
1.7       foxr      671:    The LondTransaction we are failing.
                    672:  
1.42      foxr      673: 
1.4       foxr      674: =cut
                    675: 
                    676: sub FailTransaction {
1.7       foxr      677:     my $transaction = shift;
1.52      foxr      678:     
                    679:     #  If the socket is dead, that's already logged.
                    680: 
                    681:     if ($ConnectionRetriesLeft > 0) {
                    682: 	Log("WARNING", "Failing transaction "
1.71      albertel  683: 	    .$transaction->getLoggableRequest());
1.52      foxr      684:     }
1.71      albertel  685:     Debug(1, "Failing transaction: ".$transaction->getLoggableRequest());
1.10      foxr      686:     if (!$transaction->isDeferred()) { # If the transaction is deferred we'll get to it.
1.11      foxr      687: 	my $client  = $transaction->getClient();
1.30      foxr      688: 	Debug(1," Replying con_lost to ".$transaction->getRequest());
1.11      foxr      689: 	StartClientReply($transaction, "con_lost\n");
1.7       foxr      690:     }
1.4       foxr      691: 
                    692: }
                    693: 
                    694: =pod
1.69      matthew   695: 
1.6       foxr      696: =head1  EmptyQueue
1.7       foxr      697: 
1.6       foxr      698:   Fails all items in the work queue with con_lost.
1.7       foxr      699:   Note that each item in the work queue is a transaction.
                    700: 
1.6       foxr      701: =cut
1.69      matthew   702: 
1.6       foxr      703: sub EmptyQueue {
1.22      foxr      704:     $ConnectionRetriesLeft--;	# Counts as connection failure too.
1.6       foxr      705:     while($WorkQueue->Count()) {
1.10      foxr      706: 	my $request = $WorkQueue->dequeue(); # This is a transaction
1.7       foxr      707: 	FailTransaction($request);
1.6       foxr      708:     }
                    709: }
                    710: 
                    711: =pod
1.4       foxr      712: 
1.9       foxr      713: =head2 CloseAllLondConnections
                    714: 
                    715: Close all connections open on lond prior to exit e.g.
                    716: 
                    717: =cut
1.69      matthew   718: 
1.9       foxr      719: sub CloseAllLondConnections {
1.23      foxr      720:     foreach my $Socket (keys %ActiveConnections) {
1.42      foxr      721:       if(exists($ActiveTransactions{$Socket})) {
                    722: 	FailTransaction($ActiveTransactions{$Socket});
                    723:       }
                    724:       KillSocket($Socket);
1.9       foxr      725:     }
                    726: }
                    727: 
                    728: =pod
                    729: 
1.4       foxr      730: =head2 KillSocket
                    731:  
                    732: Destroys a socket.  This function can be called either when a socket
                    733: has died of 'natural' causes or because a socket needs to be pruned due to
                    734: idleness.  If the socket has died naturally, if there are no longer any 
                    735: live connections a new connection is created (in case there are transactions
                    736: in the queue).  If the socket has been pruned, it is never re-created.
                    737: 
                    738: Parameters:
1.1       foxr      739: 
1.4       foxr      740: =item Socket
                    741:  
                    742:   The socket to kill off.
                    743: 
                    744: =item Restart
                    745: 
                    746: nonzero if we are allowed to create a new connection.
                    747: 
1.69      matthew   748: =cut
1.4       foxr      749: 
                    750: sub KillSocket {
                    751:     my $Socket = shift;
                    752: 
1.17      foxr      753:     Log("WARNING", "Shutting down a socket");
1.9       foxr      754:     $Socket->Shutdown();
                    755: 
1.7       foxr      756:     #  If the socket came from the active connection set,
                    757:     #  delete its transaction... note that FailTransaction should
                    758:     #  already have been called!!!
                    759:     #  otherwise it came from the idle set.
                    760:     #  
1.4       foxr      761:     
                    762:     if(exists($ActiveTransactions{$Socket})) {
                    763: 	delete ($ActiveTransactions{$Socket});
                    764:     }
                    765:     if(exists($ActiveConnections{$Socket})) {
                    766: 	delete($ActiveConnections{$Socket});
1.37      albertel  767: 	$ConnectionCount--;
                    768: 	if ($ConnectionCount < 0) { $ConnectionCount = 0; }
1.4       foxr      769:     }
1.6       foxr      770:     #  If the connection count has gone to zero and there is work in the
                    771:     #  work queue, the work all gets failed with con_lost.
                    772:     #
                    773:     if($ConnectionCount == 0) {
1.22      foxr      774: 	EmptyQueue();
1.42      foxr      775: 	CloseAllLondConnections; # Should all already be closed but...
1.4       foxr      776:     }
                    777: }
1.1       foxr      778: 
                    779: =pod
1.3       albertel  780: 
1.1       foxr      781: =head2 LondReadable
1.3       albertel  782: 
1.1       foxr      783: This function is called whenever a lond connection
                    784: is readable.  The action is state dependent:
                    785: 
1.3       albertel  786: =head3 State=Initialized
                    787: 
                    788: We''re waiting for the challenge, this is a no-op until the
1.1       foxr      789: state changes.
1.3       albertel  790: 
1.1       foxr      791: =head3 State=Challenged 
1.3       albertel  792: 
                    793: The challenge has arrived we need to transition to Writable.
1.1       foxr      794: The connection must echo the challenge back.
1.3       albertel  795: 
1.1       foxr      796: =head3 State=ChallengeReplied
1.3       albertel  797: 
                    798: The challenge has been replied to.  The we are receiveing the 
1.1       foxr      799: 'ok' from the partner.
1.3       albertel  800: 
1.40      foxr      801: =head3  State=ReadingVersionString
                    802: 
                    803: We have requested the lond version and are reading the
                    804: version back.  Upon completion, we'll store the version away
                    805: for future use(?).
                    806: 
                    807: =head3 State=HostSet
                    808: 
                    809: We have selected the domain name of our peer (multhomed hosts)
                    810: and are getting the reply (presumably ok) back.
                    811: 
1.1       foxr      812: =head3 State=RequestingKey
1.3       albertel  813: 
                    814: The ok has been received and we need to send the request for
1.1       foxr      815: an encryption key.  Transition to writable for that.
1.3       albertel  816: 
1.1       foxr      817: =head3 State=ReceivingKey
1.3       albertel  818: 
                    819: The the key has been requested, now we are reading the new key.
                    820: 
1.1       foxr      821: =head3 State=Idle 
1.3       albertel  822: 
                    823: The encryption key has been negotiated or we have finished 
1.1       foxr      824: reading data from the a transaction.   If the callback data has
                    825: a client as well as the socket iformation, then we are 
                    826: doing a transaction and the data received is relayed to the client
                    827: before the socket is put on the idle list.
1.3       albertel  828: 
1.1       foxr      829: =head3 State=SendingRequest
1.3       albertel  830: 
                    831: I do not think this state can be received here, but if it is,
1.1       foxr      832: the appropriate thing to do is to transition to writable, and send
                    833: the request.
1.3       albertel  834: 
1.1       foxr      835: =head3 State=ReceivingReply
1.3       albertel  836: 
                    837: We finished sending the request to the server and now transition
1.1       foxr      838: to readable to receive the reply. 
                    839: 
                    840: The parameter to this function are:
1.3       albertel  841: 
1.1       foxr      842: The event. Implicit in this is the watcher and its data.  The data 
                    843: contains at least the lond connection object and, if a 
                    844: transaction is in progress, the socket attached to the local client.
                    845: 
1.3       albertel  846: =cut
1.1       foxr      847: 
                    848: sub LondReadable {
1.8       foxr      849: 
1.41      albertel  850:     my $Event      = shift;
                    851:     my $Watcher    = $Event->w;
                    852:     my $Socket     = $Watcher->data;
                    853:     my $client     = undef;
1.40      foxr      854: 
1.41      albertel  855:     &Debug(6,"LondReadable called state = ".$Socket->GetState());
1.40      foxr      856: 
                    857: 
1.41      albertel  858:     my $State = $Socket->GetState(); # All action depends on the state.
1.40      foxr      859: 
1.41      albertel  860:     SocketDump(6, $Socket);
                    861:     my $status = $Socket->Readable();
1.40      foxr      862: 
1.41      albertel  863:     &Debug(2, "Socket->Readable returned: $status");
1.40      foxr      864: 
1.41      albertel  865:     if($status != 0) {
                    866: 	# bad return from socket read. Currently this means that
                    867: 	# The socket has become disconnected. We fail the transaction.
1.40      foxr      868: 
1.41      albertel  869: 	Log("WARNING",
                    870: 	    "Lond connection lost.");
                    871: 	if(exists($ActiveTransactions{$Socket})) {
                    872: 	    FailTransaction($ActiveTransactions{$Socket});
1.56      foxr      873: 	} else {
                    874: 	    #  Socket is connecting and failed... need to mark
                    875: 	    #  no longer connecting.
                    876: 	   
                    877: 	    $LondConnecting = 0;
1.41      albertel  878: 	}
                    879: 	$Watcher->cancel();
                    880: 	KillSocket($Socket);
                    881: 	$ConnectionRetriesLeft--;       # Counts as connection failure
                    882: 	return;
                    883:     }
                    884:     SocketDump(6,$Socket);
1.17      foxr      885: 
1.41      albertel  886:     $State = $Socket->GetState(); # Update in case of transition.
                    887:     &Debug(6, "After read, state is ".$State);
1.1       foxr      888: 
1.41      albertel  889:     if($State eq "Initialized") {
1.1       foxr      890: 
                    891: 
1.41      albertel  892:     } elsif ($State eq "ChallengeReceived") {
1.1       foxr      893: 	#  The challenge must be echoed back;  The state machine
                    894: 	# in the connection takes care of setting that up.  Just
                    895: 	# need to transition to writable:
1.41      albertel  896: 	
                    897: 	$Watcher->cb(\&LondWritable);
                    898: 	$Watcher->poll("w");
1.1       foxr      899: 
1.41      albertel  900:     } elsif ($State eq "ChallengeReplied") {
1.1       foxr      901: 
1.41      albertel  902:     } elsif ($State eq "RequestingVersion") {
                    903: 	# Need to ask for the version... that is writiability:
1.1       foxr      904: 
1.41      albertel  905: 	$Watcher->cb(\&LondWritable);
                    906: 	$Watcher->poll("w");
                    907: 
                    908:     } elsif ($State eq "ReadingVersionString") {
                    909: 	# Read the rest of the version string... 
                    910:     } elsif ($State eq "SetHost") {
                    911: 	# Need to request the actual domain get set...
                    912: 
                    913: 	$Watcher->cb(\&LondWritable);
                    914: 	$Watcher->poll("w");
                    915:     } elsif ($State eq "HostSet") {
                    916: 	# Reading the 'ok' from the peer.
                    917: 
                    918:     } elsif ($State eq "RequestingKey") {
1.1       foxr      919: 	#  The ok was received.  Now we need to request the key
                    920: 	#  That requires us to be writable:
                    921: 
1.41      albertel  922: 	$Watcher->cb(\&LondWritable);
                    923: 	$Watcher->poll("w");
1.1       foxr      924: 
1.41      albertel  925:     } elsif ($State eq "ReceivingKey") {
1.1       foxr      926: 
1.41      albertel  927:     } elsif ($State eq "Idle") {
1.40      foxr      928:    
1.41      albertel  929: 	# This is as good a spot as any to get the peer version
                    930: 	# string:
1.40      foxr      931:    
1.41      albertel  932: 	if($LondVersion eq "unknown") {
                    933: 	    $LondVersion = $Socket->PeerVersion();
                    934: 	    Log("INFO", "Connected to lond version: $LondVersion");
                    935: 	}
1.1       foxr      936: 	# If necessary, complete a transaction and then go into the
                    937: 	# idle queue.
1.22      foxr      938: 	#  Note that a trasition to idle indicates a live lond
                    939: 	# on the other end so reset the connection retries.
                    940: 	#
1.41      albertel  941: 	$ConnectionRetriesLeft = $ConnectionRetries; # success resets the count
                    942: 	$Watcher->cancel();
                    943: 	if(exists($ActiveTransactions{$Socket})) {
                    944: 	    Debug(5,"Completing transaction!!");
                    945: 	    CompleteTransaction($Socket, 
                    946: 				$ActiveTransactions{$Socket});
                    947: 	} else {
                    948: 	    Log("SUCCESS", "Connection ".$ConnectionCount." to "
                    949: 		.$RemoteHost." now ready for action");
                    950: 	}
                    951: 	ServerToIdle($Socket);	# Next work unit or idle.
1.54      foxr      952: 
                    953: 	#
                    954: 	$LondConnecting = 0;	# Best spot I can think of for this.
                    955: 	# 
1.6       foxr      956: 	
1.41      albertel  957:     } elsif ($State eq "SendingRequest") {
1.1       foxr      958: 	#  We need to be writable for this and probably don't belong
                    959: 	#  here inthe first place.
                    960: 
1.73      albertel  961: 	Debug(6, "SendingRequest state encountered in readable");
1.41      albertel  962: 	$Watcher->poll("w");
                    963: 	$Watcher->cb(\&LondWritable);
1.1       foxr      964: 
1.41      albertel  965:     } elsif ($State eq "ReceivingReply") {
1.1       foxr      966: 
                    967: 
1.41      albertel  968:     } else {
                    969: 	# Invalid state.
                    970: 	Debug(4, "Invalid state in LondReadable");
                    971:     }
1.1       foxr      972: }
1.3       albertel  973: 
1.1       foxr      974: =pod
1.3       albertel  975: 
1.1       foxr      976: =head2 LondWritable
1.3       albertel  977: 
1.1       foxr      978: This function is called whenever a lond connection
                    979: becomes writable while there is a writeable monitoring
                    980: event.  The action taken is very state dependent:
1.3       albertel  981: 
1.1       foxr      982: =head3 State = Connected 
1.3       albertel  983: 
                    984: The connection is in the process of sending the 'init' hailing to the
                    985: lond on the remote end.  The connection object''s Writable member is
                    986: called.  On error, ConnectionError is called to destroy the connection
                    987: and remove it from the ActiveConnections hash
                    988: 
1.1       foxr      989: =head3 Initialized
1.3       albertel  990: 
                    991: 'init' has been sent, writability monitoring is removed and
                    992: readability monitoring is started with LondReadable as the callback.
                    993: 
1.1       foxr      994: =head3 ChallengeReceived
1.3       albertel  995: 
                    996: The connection has received the who are you challenge from the remote
                    997: system, and is in the process of sending the challenge
                    998: response. Writable is called.
                    999: 
1.1       foxr     1000: =head3 ChallengeReplied
1.3       albertel 1001: 
                   1002: The connection has replied to the initial challenge The we switch to
                   1003: monitoring readability looking for the server to reply with 'ok'.
                   1004: 
1.1       foxr     1005: =head3 RequestingKey
1.3       albertel 1006: 
                   1007: The connection is in the process of requesting its encryption key.
                   1008: Writable is called.
                   1009: 
1.1       foxr     1010: =head3 ReceivingKey
1.3       albertel 1011: 
                   1012: The connection has sent the request for a key.  Switch to readability
                   1013: monitoring to accept the key
                   1014: 
1.1       foxr     1015: =head3 SendingRequest
1.3       albertel 1016: 
                   1017: The connection is in the process of sending a request to the server.
                   1018: This request is part of a client transaction.  All the states until
                   1019: now represent the client setup protocol. Writable is called.
                   1020: 
1.1       foxr     1021: =head3 ReceivingReply
                   1022: 
1.3       albertel 1023: The connection has sent a request.  Now it must receive a reply.
                   1024: Readability monitoring is requested.
                   1025: 
                   1026: This function is an event handler and therefore receives as
1.1       foxr     1027: a parameter the event that has fired.  The data for the watcher
                   1028: of this event is a reference to a list of one or two elements,
                   1029: depending on state. The first (and possibly only) element is the
                   1030: socket.  The second (present only if a request is in progress)
                   1031: is the socket on which to return a reply to the caller.
                   1032: 
                   1033: =cut
1.3       albertel 1034: 
1.1       foxr     1035: sub LondWritable {
                   1036:     my $Event   = shift;
                   1037:     my $Watcher = $Event->w;
1.8       foxr     1038:     my $Socket  = $Watcher->data;
                   1039:     my $State   = $Socket->GetState();
1.1       foxr     1040: 
1.8       foxr     1041:     Debug(6,"LondWritable State = ".$State."\n");
1.1       foxr     1042: 
1.8       foxr     1043:  
1.1       foxr     1044:     #  Figure out what to do depending on the state of the socket:
                   1045:     
                   1046: 
                   1047: 
                   1048: 
                   1049:     SocketDump(6,$Socket);
                   1050: 
1.42      foxr     1051:     #  If the socket is writable, we must always write.
                   1052:     # Only by writing will we undergo state transitions.
                   1053:     # Old logic wrote in state specific code below, however
                   1054:     # That forces us at least through another invocation of
                   1055:     # this function after writability is possible again.
                   1056:     # This logic also factors out common code for handling
                   1057:     # write failures... in all cases, write failures 
                   1058:     # Kill the socket.
                   1059:     #  This logic makes the branches of the >big< if below
                   1060:     # so that the writing states are actually NO-OPs.
                   1061: 
                   1062:     if ($Socket->Writable() != 0) {
1.43      albertel 1063: 	#  The write resulted in an error.
                   1064: 	# We'll treat this as if the socket got disconnected:
                   1065: 	Log("WARNING", "Connection to ".$RemoteHost.
                   1066: 	    " has been disconnected");
                   1067: 	if(exists($ActiveTransactions{$Socket})) {
                   1068: 	    FailTransaction($ActiveTransactions{$Socket});
1.56      foxr     1069: 	} else {
                   1070: 	    #  In the process of conneting, so need to turn that off.
                   1071: 	    
                   1072: 	    $LondConnecting = 0;
1.43      albertel 1073: 	}
                   1074: 	$Watcher->cancel();
                   1075: 	KillSocket($Socket);
                   1076: 	return;
1.42      foxr     1077:     }
                   1078: 
                   1079: 
                   1080: 
1.41      albertel 1081:     if      ($State eq "Connected")         {
1.1       foxr     1082: 
1.41      albertel 1083: 	#  "init" is being sent...
1.42      foxr     1084:  
1.41      albertel 1085:     } elsif ($State eq "Initialized")       {
1.4       foxr     1086: 
1.41      albertel 1087: 	# Now that init was sent, we switch 
                   1088: 	# to watching for readability:
1.1       foxr     1089: 
1.41      albertel 1090: 	$Watcher->cb(\&LondReadable);
                   1091: 	$Watcher->poll("r");
                   1092: 	
                   1093:     } elsif ($State eq "ChallengeReceived") {
                   1094: 	# We received the challenge, now we 
                   1095: 	# are echoing it back. This is a no-op,
                   1096: 	# we're waiting for the state to change
1.1       foxr     1097: 	
1.41      albertel 1098:     } elsif ($State eq "ChallengeReplied")  {
                   1099: 	# The echo was sent back, so we switch
                   1100: 	# to watching readability.
                   1101: 
                   1102: 	$Watcher->cb(\&LondReadable);
                   1103: 	$Watcher->poll("r");
                   1104:     } elsif ($State eq "RequestingVersion") {
                   1105: 	# Sending the peer a version request...
1.42      foxr     1106: 
1.41      albertel 1107:     } elsif ($State eq "ReadingVersionString") {
                   1108: 	# Transition to read since we have sent the
                   1109: 	# version command and now just need to read the
                   1110: 	# version string from the peer:
1.40      foxr     1111:       
1.41      albertel 1112: 	$Watcher->cb(\&LondReadable);
                   1113: 	$Watcher->poll("r");
1.40      foxr     1114:       
1.41      albertel 1115:     } elsif ($State eq "SetHost") {
                   1116: 	#  Setting the remote domain...
1.42      foxr     1117: 
1.41      albertel 1118:     } elsif ($State eq "HostSet") {
                   1119: 	# Back to readable to get the ok.
1.40      foxr     1120:       
1.41      albertel 1121: 	$Watcher->cb(\&LondReadable);
                   1122: 	$Watcher->poll("r");
1.40      foxr     1123:       
                   1124: 
1.41      albertel 1125:     } elsif ($State eq "RequestingKey")     {
                   1126: 	# At this time we're requesting the key.
                   1127: 	# again, this is essentially a no-op.
                   1128: 
                   1129:     } elsif ($State eq "ReceivingKey")      {
                   1130: 	# Now we need to wait for the key
                   1131: 	# to come back from the peer:
                   1132: 
                   1133: 	$Watcher->cb(\&LondReadable);
                   1134: 	$Watcher->poll("r");
                   1135: 
                   1136:     } elsif ($State eq "SendingRequest")    {
1.40      foxr     1137:  
1.41      albertel 1138: 	# At this time we are sending a request to the
1.1       foxr     1139: 	# peer... write the next chunk:
                   1140: 
1.41      albertel 1141: 
                   1142:     } elsif ($State eq "ReceivingReply")    {
                   1143: 	# The send has completed.  Wait for the
                   1144: 	# data to come in for a reply.
                   1145: 	Debug(8,"Writable sent request/receiving reply");
                   1146: 	$Watcher->cb(\&LondReadable);
                   1147: 	$Watcher->poll("r");
1.1       foxr     1148: 
1.41      albertel 1149:     } else {
                   1150: 	#  Control only passes here on an error: 
                   1151: 	#  the socket state does not match any
                   1152: 	#  of the known states... so an error
                   1153: 	#  must be logged.
1.1       foxr     1154: 
1.41      albertel 1155: 	&Debug(4, "Invalid socket state ".$State."\n");
                   1156:     }
1.1       foxr     1157:     
                   1158: }
1.6       foxr     1159: =pod
                   1160:     
                   1161: =cut
1.69      matthew  1162: 
1.6       foxr     1163: sub QueueDelayed {
1.8       foxr     1164:     Debug(3,"QueueDelayed called");
                   1165: 
1.6       foxr     1166:     my $path = "$perlvar{'lonSockDir'}/delayed";
1.8       foxr     1167: 
                   1168:     Debug(4, "Delayed path: ".$path);
1.6       foxr     1169:     opendir(DIRHANDLE, $path);
1.75      albertel 1170: 
                   1171:     my @all_host_ids;
                   1172:     my $host_iterator =   &LondConnection::GetHostIterator();
                   1173:     while (!$host_iterator->end()) {
                   1174: 	my ($host_id,$host_name) = @{$host_iterator->get()}[0,3];
                   1175: 	if ($host_name eq $RemoteHost) {
                   1176: 	    push(@all_host_ids, $host_id);
                   1177: 	}
                   1178: 	$host_iterator->next();
                   1179:     }
                   1180:     my $host_id_re = '(?:'.join('|',@all_host_ids).')';
                   1181:     my @alldelayed = grep(/\.$host_id_re$/, readdir(DIRHANDLE));
1.6       foxr     1182:     closedir(DIRHANDLE);
1.75      albertel 1183:     foreach my $dfname (sort(@alldelayed)) {
                   1184: 	my $reqfile = "$path/$dfname";
                   1185: 	my ($host_id) = ($dfname =~ /\.([^.]*)$/);
                   1186: 	Debug(4, "queueing ".$reqfile." for $host_id");
1.6       foxr     1187: 	my $Handle = IO::File->new($reqfile);
                   1188: 	my $cmd    = <$Handle>;
1.8       foxr     1189: 	chomp $cmd;		# There may or may not be a newline...
1.12      foxr     1190: 	$cmd = $cmd."\n";	# now for sure there's exactly one newline.
1.75      albertel 1191: 	my $Transaction = LondTransaction->new("sethost:$host_id:$cmd");
1.7       foxr     1192: 	$Transaction->SetDeferred($reqfile);
                   1193: 	QueueTransaction($Transaction);
1.6       foxr     1194:     }
                   1195:     
                   1196: }
1.1       foxr     1197: 
                   1198: =pod
1.3       albertel 1199: 
1.1       foxr     1200: =head2 MakeLondConnection
1.3       albertel 1201: 
                   1202: Create a new lond connection object, and start it towards its initial
                   1203: idleness.  Once idle, it becomes elligible to receive transactions
                   1204: from the work queue.  If the work queue is not empty when the
                   1205: connection is completed and becomes idle, it will dequeue an entry and
                   1206: start off on it.
                   1207: 
1.1       foxr     1208: =cut
1.3       albertel 1209: 
1.1       foxr     1210: sub MakeLondConnection {     
                   1211:     Debug(4,"MakeLondConnection to ".GetServerHost()." on port "
                   1212: 	  .GetServerPort());
                   1213: 
                   1214:     my $Connection = LondConnection->new(&GetServerHost(),
                   1215: 					 &GetServerPort());
                   1216: 
1.30      foxr     1217:     if($Connection eq undef) {	# Needs to be more robust later.
1.9       foxr     1218: 	Log("CRITICAL","Failed to make a connection with lond.");
1.10      foxr     1219: 	$ConnectionRetriesLeft--;
                   1220: 	return 0;		# Failure.
1.5       foxr     1221:     }  else {
1.22      foxr     1222: 
1.5       foxr     1223: 	# The connection needs to have writability 
                   1224: 	# monitored in order to send the init sequence
                   1225: 	# that starts the whole authentication/key
                   1226: 	# exchange underway.
                   1227: 	#
                   1228: 	my $Socket = $Connection->GetSocket();
1.30      foxr     1229: 	if($Socket eq undef) {
1.64      foxr     1230: 	    &child_exit(-1, "did not get a socket from the connection");
1.5       foxr     1231: 	} else {
                   1232: 	    &Debug(9,"MakeLondConnection got socket: ".$Socket);
                   1233: 	}
1.1       foxr     1234: 	
1.21      foxr     1235: 	$Connection->SetTimeoutCallback(\&SocketTimeout);
                   1236: 
1.23      foxr     1237: 	my $event = Event->io(fd       => $Socket,
1.5       foxr     1238: 			   poll     => 'w',
                   1239: 			   cb       => \&LondWritable,
1.8       foxr     1240: 			   data     => $Connection,
1.5       foxr     1241: 			   desc => 'Connection to lond server');
                   1242: 	$ActiveConnections{$Connection} = $event;
1.52      foxr     1243: 	if ($ConnectionCount == 0) {
                   1244: 	    &SetupTimer;	# Need to handle timeouts with connections...
                   1245: 	}
1.5       foxr     1246: 	$ConnectionCount++;
1.8       foxr     1247: 	Debug(4, "Connection count = ".$ConnectionCount);
1.6       foxr     1248: 	if($ConnectionCount == 1) { # First Connection:
                   1249: 	    QueueDelayed;
                   1250: 	}
1.9       foxr     1251: 	Log("SUCESS", "Created connection ".$ConnectionCount
                   1252: 	    ." to host ".GetServerHost());
1.54      foxr     1253: 	$LondConnecting = 1;	# Connection in progress.
1.10      foxr     1254: 	return 1;		# Return success.
1.1       foxr     1255:     }
                   1256:     
                   1257: }
1.3       albertel 1258: 
1.1       foxr     1259: =pod
1.3       albertel 1260: 
1.1       foxr     1261: =head2 StartRequest
1.3       albertel 1262: 
                   1263: Starts a lond request going on a specified lond connection.
                   1264: parameters are:
                   1265: 
                   1266: =item $Lond
                   1267: 
                   1268: Connection to the lond that will send the transaction and receive the
                   1269: reply.
                   1270: 
                   1271: =item $Client
                   1272: 
                   1273: Connection to the client that is making this request We got the
                   1274: request from this socket, and when the request has been relayed to
                   1275: lond and we get a reply back from lond it will get sent to this
                   1276: socket.
                   1277: 
                   1278: =item $Request
                   1279: 
                   1280: The text of the request to send.
                   1281: 
1.1       foxr     1282: =cut
                   1283: 
                   1284: sub StartRequest {
1.47      foxr     1285: 
                   1286:     my ($Lond, $Request) = @_;
1.1       foxr     1287:     
1.7       foxr     1288:     Debug(6, "StartRequest: ".$Request->getRequest());
1.1       foxr     1289: 
                   1290:     my $Socket = $Lond->GetSocket();
                   1291:     
1.7       foxr     1292:     $Request->Activate($Lond);
                   1293:     $ActiveTransactions{$Lond} = $Request;
1.1       foxr     1294: 
1.7       foxr     1295:     $Lond->InitiateTransaction($Request->getRequest());
1.23      foxr     1296:     my $event = Event->io(fd      => $Socket,
1.1       foxr     1297: 		       poll    => "w",
                   1298: 		       cb      => \&LondWritable,
                   1299: 		       data    => $Lond,
                   1300: 		       desc    => "lond transaction connection");
                   1301:     $ActiveConnections{$Lond} = $event;
                   1302:     Debug(8," Start Request made watcher data with ".$event->data."\n");
                   1303: }
                   1304: 
                   1305: =pod
1.3       albertel 1306: 
1.1       foxr     1307: =head2 QueueTransaction
1.3       albertel 1308: 
                   1309: If there is an idle lond connection, it is put to work doing this
                   1310: transaction.  Otherwise, the transaction is placed in the work queue.
                   1311: If placed in the work queue and the maximum number of connections has
                   1312: not yet been created, a new connection will be started.  Our goal is
                   1313: to eventually have a sufficient number of connections that the work
                   1314: queue will typically be empty.  parameters are:
                   1315: 
                   1316: =item Socket
                   1317: 
                   1318: open on the lonc client.
                   1319: 
                   1320: =item Request
                   1321: 
                   1322: data to send to the lond.
1.1       foxr     1323: 
                   1324: =cut
1.3       albertel 1325: 
1.1       foxr     1326: sub QueueTransaction {
                   1327: 
1.7       foxr     1328:     my $requestData   = shift;	# This is a LondTransaction.
                   1329:     my $cmd           = $requestData->getRequest();
                   1330: 
                   1331:     Debug(6,"QueueTransaction: ".$cmd);
1.1       foxr     1332: 
                   1333:     my $LondSocket    = $IdleConnections->pop();
                   1334:     if(!defined $LondSocket) {	# Need to queue request.
1.29      foxr     1335: 	Debug(5,"Must queue...");
1.1       foxr     1336: 	$WorkQueue->enqueue($requestData);
1.56      foxr     1337: 	Debug(5, "Queue Transaction startnew $ConnectionCount $LondConnecting");
                   1338: 	if(($ConnectionCount < $MaxConnectionCount)   && (! $LondConnecting)) {
                   1339: 
1.22      foxr     1340: 	    if($ConnectionRetriesLeft > 0) {
1.29      foxr     1341: 		Debug(5,"Starting additional lond connection");
1.56      foxr     1342: 		if(&MakeLondConnection() == 0) {
1.22      foxr     1343: 		    EmptyQueue();	# Fail transactions, can't make connection.
1.42      foxr     1344: 		    CloseAllLondConnections; # Should all be closed but...
1.22      foxr     1345: 		}
                   1346: 	    } else {
                   1347: 		ShowStatus(GetServerHost()." >>> DEAD !!!! <<<");
1.56      foxr     1348: 		$LondConnecting = 0;
1.22      foxr     1349: 		EmptyQueue();	# It's worse than that ... he's dead Jim.
1.42      foxr     1350: 		CloseAllLondConnections; # Should all be closed but..
1.17      foxr     1351: 	    }
1.1       foxr     1352: 	}
                   1353:     } else {			# Can start the request:
                   1354: 	Debug(8,"Can start...");
1.7       foxr     1355: 	StartRequest($LondSocket,  $requestData);
1.1       foxr     1356:     }
                   1357: }
                   1358: 
                   1359: #-------------------------- Lonc UNIX socket handling ---------------------
1.3       albertel 1360: 
1.1       foxr     1361: =pod
1.3       albertel 1362: 
1.1       foxr     1363: =head2 ClientRequest
1.3       albertel 1364: Callback that is called when data can be read from the UNIX domain
                   1365: socket connecting us with an apache server process.
1.1       foxr     1366: 
                   1367: =cut
                   1368: 
                   1369: sub ClientRequest {
                   1370:     Debug(6, "ClientRequest");
                   1371:     my $event   = shift;
                   1372:     my $watcher = $event->w;
                   1373:     my $socket  = $watcher->fd;
                   1374:     my $data    = $watcher->data;
                   1375:     my $thisread;
                   1376: 
                   1377:     Debug(9, "  Watcher named: ".$watcher->desc);
                   1378: 
                   1379:     my $rv = $socket->recv($thisread, POSIX::BUFSIZ, 0);
                   1380:     Debug(8, "rcv:  data length = ".length($thisread)
                   1381: 	  ." read =".$thisread);
1.29      foxr     1382:     unless (defined $rv  && length($thisread)) {
1.1       foxr     1383: 	 # Likely eof on socket.
                   1384: 	Debug(5,"Client Socket closed on lonc for ".$RemoteHost);
                   1385: 	close($socket);
                   1386: 	$watcher->cancel();
                   1387: 	delete($ActiveClients{$socket});
1.10      foxr     1388: 	return;
1.1       foxr     1389:     }
                   1390:     Debug(8,"Data: ".$data." this read: ".$thisread);
                   1391:     $data = $data.$thisread;	# Append new data.
                   1392:     $watcher->data($data);
1.44      albertel 1393:     if($data =~ /\n$/) {	# Request entirely read.
1.10      foxr     1394: 	if($data eq "close_connection_exit\n") {
1.9       foxr     1395: 	    Log("CRITICAL",
                   1396: 		"Request Close Connection ... exiting");
                   1397: 	    CloseAllLondConnections();
                   1398: 	    exit;
                   1399: 	}
1.1       foxr     1400: 	Debug(8, "Complete transaction received: ".$data);
1.39      foxr     1401: 	if($LogTransactions) {
                   1402: 	    Log("SUCCESS", "Transaction: '$data'"); # Transaction has \n.
                   1403: 	}
1.8       foxr     1404: 	my $Transaction = LondTransaction->new($data);
1.7       foxr     1405: 	$Transaction->SetClient($socket);
                   1406: 	QueueTransaction($Transaction);
1.1       foxr     1407: 	$watcher->cancel();	# Done looking for input data.
                   1408:     }
                   1409: 
                   1410: }
                   1411: 
1.62      foxr     1412: #
                   1413: #     Accept a connection request for a client (lonc child) and
                   1414: #    start up an event watcher to keep an eye on input from that 
                   1415: #    Event.  This can be called both from NewClient and from
                   1416: #    ChildProcess if we are started in DieWhenIdle mode.
                   1417: # Parameters:
                   1418: #    $socket       - The listener socket.
                   1419: # Returns:
                   1420: #   NONE
                   1421: # Side Effects:
                   1422: #    An event is made to watch the accepted connection.
                   1423: #    Active clients hash is updated to reflect the new connection.
                   1424: #    The client connection count is incremented.
                   1425: #
                   1426: sub accept_client {
                   1427:     my ($socket) = @_;
                   1428: 
                   1429:     Debug(8, "Entering accept for lonc UNIX socket\n");
                   1430:     my $connection = $socket->accept();	# Accept the client connection.
                   1431:     Debug(8,"Connection request accepted from "
                   1432: 	  .GetPeername($connection, AF_UNIX));
                   1433: 
                   1434: 
                   1435:     my $description = sprintf("Connection to lonc client %d",
                   1436: 			      $ClientConnection);
                   1437:     Debug(9, "Creating event named: ".$description);
                   1438:     Event->io(cb      => \&ClientRequest,
                   1439: 	      poll    => 'r',
                   1440: 	      desc    => $description,
                   1441: 	      data    => "",
                   1442: 	      fd      => $connection);
                   1443:     $ActiveClients{$connection} = $ClientConnection;
                   1444:     $ClientConnection++;
                   1445: }
1.1       foxr     1446: 
                   1447: =pod
1.3       albertel 1448: 
1.1       foxr     1449: =head2  NewClient
1.3       albertel 1450: 
                   1451: Callback that is called when a connection is received on the unix
                   1452: socket for a new client of lonc.  The callback is parameterized by the
                   1453: event.. which is a-priori assumed to be an io event, and therefore has
                   1454: an fd member that is the Listener socket.  We Accept the connection
                   1455: and register a new event on the readability of that socket:
                   1456: 
1.1       foxr     1457: =cut
1.3       albertel 1458: 
1.1       foxr     1459: sub NewClient {
                   1460:     Debug(6, "NewClient");
                   1461:     my $event      = shift;		# Get the event parameters.
                   1462:     my $watcher    = $event->w; 
                   1463:     my $socket     = $watcher->fd;	# Get the event' socket.
                   1464: 
1.62      foxr     1465:     &accept_client($socket);
1.1       foxr     1466: }
1.3       albertel 1467: 
                   1468: =pod
                   1469: 
                   1470: =head2 GetLoncSocketPath
                   1471: 
                   1472: Returns the name of the UNIX socket on which to listen for client
                   1473: connections.
1.1       foxr     1474: 
1.58      foxr     1475: =head2 Parameters:
                   1476: 
                   1477:     host (optional)  - Name of the host socket to return.. defaults to
                   1478:                        the return from GetServerHost().
                   1479: 
1.1       foxr     1480: =cut
1.3       albertel 1481: 
1.1       foxr     1482: sub GetLoncSocketPath {
1.58      foxr     1483: 
                   1484:     my $host = GetServerHost();	# Default host.
                   1485:     if (@_) {
                   1486: 	($host)  = @_;		# Override if supplied.
                   1487:     }
                   1488:     return $UnixSocketDir."/".$host;
1.1       foxr     1489: }
                   1490: 
1.3       albertel 1491: =pod
                   1492: 
                   1493: =head2 GetServerHost
                   1494: 
                   1495: Returns the host whose lond we talk with.
                   1496: 
1.1       foxr     1497: =cut
1.3       albertel 1498: 
1.7       foxr     1499: sub GetServerHost {
1.1       foxr     1500:     return $RemoteHost;		# Setup by the fork.
                   1501: }
1.3       albertel 1502: 
                   1503: =pod
                   1504: 
                   1505: =head2 GetServerPort
                   1506: 
                   1507: Returns the lond port number.
                   1508: 
1.1       foxr     1509: =cut
1.3       albertel 1510: 
1.7       foxr     1511: sub GetServerPort {
1.1       foxr     1512:     return $perlvar{londPort};
                   1513: }
1.3       albertel 1514: 
                   1515: =pod
                   1516: 
                   1517: =head2 SetupLoncListener
                   1518: 
                   1519: Setup a lonc listener event.  The event is called when the socket
                   1520: becomes readable.. that corresponds to the receipt of a new
                   1521: connection.  The event handler established will accept the connection
                   1522: (creating a communcations channel), that int turn will establish
                   1523: another event handler to subess requests.
1.1       foxr     1524: 
1.58      foxr     1525: =head2  Parameters:
                   1526: 
                   1527:    host (optional)   Name of the host to set up a unix socket to.
                   1528: 
1.1       foxr     1529: =cut
1.3       albertel 1530: 
1.1       foxr     1531: sub SetupLoncListener {
                   1532: 
1.58      foxr     1533:     my $host       = GetServerHost(); # Default host.
                   1534:     if (@_) {
                   1535: 	($host)    = @_		# Override host with parameter.
                   1536:     }
                   1537: 
1.1       foxr     1538:     my $socket;
1.58      foxr     1539:     my $SocketName = GetLoncSocketPath($host);
1.1       foxr     1540:     unlink($SocketName);
1.7       foxr     1541:     unless ($socket =IO::Socket::UNIX->new(Local  => $SocketName,
1.55      albertel 1542: 					    Listen => 250, 
1.1       foxr     1543: 					    Type   => SOCK_STREAM)) {
1.64      foxr     1544: 	if($I_am_child) {
                   1545: 	    &child_exit(-1, "Failed to create a lonc listener socket");
                   1546: 	} else {
                   1547: 	    die "Failed to create a lonc listner socket";
                   1548: 	}
1.1       foxr     1549:     }
1.59      foxr     1550:     return $socket;
1.1       foxr     1551: }
                   1552: 
1.39      foxr     1553: #
                   1554: #   Toggle transaction logging.
                   1555: #  Implicit inputs:  
                   1556: #     LogTransactions
                   1557: #  Implicit Outputs:
                   1558: #     LogTransactions
                   1559: sub ToggleTransactionLogging {
                   1560:     print STDERR "Toggle transaction logging...\n";
                   1561:     if(!$LogTransactions) {
                   1562: 	$LogTransactions = 1;
                   1563:     } else {
                   1564: 	$LogTransactions = 0;
                   1565:     }
                   1566: 
                   1567: 
                   1568:     Log("SUCCESS", "Toggled transaction logging: $LogTransactions \n");
                   1569: }
                   1570: 
1.14      foxr     1571: =pod 
                   1572: 
                   1573: =head2 ChildStatus
                   1574:  
                   1575: Child USR1 signal handler to report the most recent status
                   1576: into the status file.
                   1577: 
1.22      foxr     1578: We also use this to reset the retries count in order to allow the
                   1579: client to retry connections with a previously dead server.
1.69      matthew  1580: 
1.14      foxr     1581: =cut
1.46      albertel 1582: 
1.14      foxr     1583: sub ChildStatus {
                   1584:     my $event = shift;
                   1585:     my $watcher = $event->w;
                   1586: 
                   1587:     Debug(2, "Reporting child status because : ".$watcher->data);
                   1588:     my $docdir = $perlvar{'lonDocRoot'};
1.67      albertel 1589:     
                   1590:     open(LOG,">>$docdir/lon-status/loncstatus.txt");
                   1591:     flock(LOG,LOCK_EX);
                   1592:     print LOG $$."\t".$RemoteHost."\t".$Status."\t".
1.14      foxr     1593: 	$RecentLogEntry."\n";
1.38      foxr     1594:     #
                   1595:     #  Write out information about each of the connections:
                   1596:     #
1.46      albertel 1597:     if ($DebugLevel > 2) {
1.67      albertel 1598: 	print LOG "Active connection statuses: \n";
1.46      albertel 1599: 	my $i = 1;
                   1600: 	print STDERR  "================================= Socket Status Dump:\n";
                   1601: 	foreach my $item (keys %ActiveConnections) {
                   1602: 	    my $Socket = $ActiveConnections{$item}->data;
                   1603: 	    my $state  = $Socket->GetState();
1.67      albertel 1604: 	    print LOG "Connection $i State: $state\n";
1.46      albertel 1605: 	    print STDERR "---------------------- Connection $i \n";
1.48      foxr     1606: 	    $Socket->Dump(-1);	# Ensure it gets dumped..
1.46      albertel 1607: 	    $i++;	
                   1608: 	}
1.38      foxr     1609:     }
1.67      albertel 1610:     flock(LOG,LOCK_UN);
                   1611:     close(LOG);
1.22      foxr     1612:     $ConnectionRetriesLeft = $ConnectionRetries;
1.70      albertel 1613:     UpdateStatus();
1.14      foxr     1614: }
                   1615: 
1.1       foxr     1616: =pod
1.3       albertel 1617: 
1.10      foxr     1618: =head2 SignalledToDeath
                   1619: 
                   1620: Called in response to a signal that causes a chid process to die.
                   1621: 
                   1622: =cut
                   1623: 
                   1624: 
                   1625: sub SignalledToDeath {
1.14      foxr     1626:     my $event  = shift;
                   1627:     my $watcher= $event->w;
                   1628: 
                   1629:     Debug(2,"Signalled to death! via ".$watcher->data);
1.17      foxr     1630:     my ($signal) = $watcher->data;
1.10      foxr     1631:     chomp($signal);
                   1632:     Log("CRITICAL", "Abnormal exit.  Child $$ for $RemoteHost "
                   1633: 	."died through "."\"$signal\"");
1.68      albertel 1634:     #LogPerm("F:lonc: $$ on $RemoteHost signalled to death: "
                   1635: #	    ."\"$signal\"");
1.12      foxr     1636:     exit 0;
1.10      foxr     1637: 
                   1638: }
1.16      foxr     1639: 
1.69      matthew  1640: =pod
                   1641: 
1.16      foxr     1642: =head2 ToggleDebug
                   1643: 
                   1644: This sub toggles trace debugging on and off.
                   1645: 
                   1646: =cut
                   1647: 
                   1648: sub ToggleDebug {
                   1649:     my $Current    = $DebugLevel;
                   1650:        $DebugLevel = $NextDebugLevel;
                   1651:        $NextDebugLevel = $Current;
                   1652: 
                   1653:     Log("SUCCESS", "New debugging level for $RemoteHost now $DebugLevel");
                   1654: 
                   1655: }
                   1656: 
1.69      matthew  1657: =pod
                   1658: 
1.1       foxr     1659: =head2 ChildProcess
                   1660: 
                   1661: This sub implements a child process for a single lonc daemon.
1.61      foxr     1662: Optional parameter:
                   1663:    $socket  - if provided, this is a socket already open for listen
                   1664:               on the client socket. Otherwise, a new listen is set up.
1.1       foxr     1665: 
                   1666: =cut
                   1667: 
                   1668: sub ChildProcess {
1.62      foxr     1669:     #  If we are in DieWhenIdle mode, we've inherited all the
                   1670:     #  events of our parent and those have to be cancelled or else
                   1671:     #  all holy bloody chaos will result.. trust me, I already made
                   1672:     #  >that< mistake.
                   1673: 
                   1674:     my $host = GetServerHost();
                   1675:     foreach my $listener (keys %parent_dispatchers) {
                   1676: 	my $watcher = $parent_dispatchers{$listener};
                   1677: 	my $s       = $watcher->fd;
                   1678: 	if ($listener ne $host) { # Close everyone but me.
                   1679: 	    Debug(5, "Closing listen socket for $listener");
                   1680: 	    $s->close();
                   1681: 	}
                   1682: 	Debug(5, "Killing watcher for $listener");
                   1683: 
                   1684: 	$watcher->cancel();
1.65      foxr     1685: 	delete($parent_dispatchers{$listener});
1.62      foxr     1686: 
                   1687:     }
1.65      foxr     1688: 
                   1689:     #  kill off the parent's signal handlers too!  
                   1690:     #
                   1691: 
                   1692:     for my $handler (keys %parent_handlers) {
                   1693: 	my $watcher = $parent_handlers{$handler};
                   1694: 	$watcher->cancel();
                   1695: 	delete($parent_handlers{$handler});
                   1696:     }
                   1697: 
1.64      foxr     1698:     $I_am_child    = 1;		# Seems like in spite of it all I may still getting
                   1699:                                 # parent event dispatches.. flag I'm a child.
1.1       foxr     1700: 
                   1701: 
1.14      foxr     1702:     #
                   1703:     #  Signals must be handled by the Event framework...
1.61      foxr     1704:     #
1.14      foxr     1705: 
                   1706:     Event->signal(signal   => "QUIT",
                   1707: 		  cb       => \&SignalledToDeath,
                   1708: 		  data     => "QUIT");
                   1709:     Event->signal(signal   => "HUP",
                   1710: 		  cb       => \&ChildStatus,
                   1711: 		  data     => "HUP");
                   1712:     Event->signal(signal   => "USR1",
                   1713: 		  cb       => \&ChildStatus,
                   1714: 		  data     => "USR1");
1.39      foxr     1715:     Event->signal(signal   => "USR2",
                   1716: 		  cb       => \&ToggleTransactionLogging);
1.16      foxr     1717:     Event->signal(signal   => "INT",
                   1718: 		  cb       => \&ToggleDebug,
                   1719: 		  data     => "INT");
1.1       foxr     1720: 
1.62      foxr     1721:     #  Figure out if we got passed a socket or need to open one to listen for
                   1722:     #  client requests.
                   1723: 
1.61      foxr     1724:     my ($socket) = @_;
                   1725:     if (!$socket) {
                   1726: 
                   1727: 	$socket =  SetupLoncListener();
                   1728:     }
1.62      foxr     1729:     #  Establish an event to listen for client connection requests.
                   1730: 
                   1731: 
1.59      foxr     1732:     Event->io(cb   => \&NewClient,
                   1733: 	      poll => 'r',
                   1734: 	      desc => 'Lonc Listener Unix Socket',
                   1735: 	      fd   => $socket);
1.1       foxr     1736:     
1.76      albertel 1737:     $Event::DebugLevel = $DebugLevel;
1.1       foxr     1738:     
                   1739:     Debug(9, "Making initial lond connection for ".$RemoteHost);
                   1740: 
                   1741: # Setup the initial server connection:
                   1742:     
1.62      foxr     1743:      # &MakeLondConnection(); // let first work request do it.
1.10      foxr     1744: 
1.62      foxr     1745:     #  If We are in diwhenidle, need to accept the connection since the
                   1746:     #  event may  not fire.
                   1747: 
                   1748:     if ($DieWhenIdle) {
                   1749: 	&accept_client($socket);
                   1750:     }
1.5       foxr     1751: 
1.1       foxr     1752:     Debug(9,"Entering event loop");
                   1753:     my $ret = Event::loop();		#  Start the main event loop.
                   1754:     
                   1755:     
1.64      foxr     1756:     &child_exit (-1,"Main event loop exited!!!");
1.1       foxr     1757: }
                   1758: 
                   1759: #  Create a new child for host passed in:
                   1760: 
                   1761: sub CreateChild {
1.62      foxr     1762:     my ($host, $socket) = @_;
1.52      foxr     1763: 
1.12      foxr     1764:     my $sigset = POSIX::SigSet->new(SIGINT);
                   1765:     sigprocmask(SIG_BLOCK, $sigset);
1.1       foxr     1766:     $RemoteHost = $host;
1.9       foxr     1767:     Log("CRITICAL", "Forking server for ".$host);
1.23      foxr     1768:     my $pid          = fork;
1.1       foxr     1769:     if($pid) {			# Parent
1.17      foxr     1770: 	$RemoteHost = "Parent";
1.27      foxr     1771: 	$ChildHash{$pid} = $host;
1.26      foxr     1772: 	$HostToPid{$host}= $pid;
1.12      foxr     1773: 	sigprocmask(SIG_UNBLOCK, $sigset);
                   1774: 
1.1       foxr     1775:     } else {			# child.
1.5       foxr     1776: 	ShowStatus("Connected to ".$RemoteHost);
1.23      foxr     1777: 	$SIG{INT} = 'DEFAULT';
1.12      foxr     1778: 	sigprocmask(SIG_UNBLOCK, $sigset);
1.62      foxr     1779: 	if(defined $socket) {
                   1780: 	    &ChildProcess($socket);
                   1781: 	} else {
                   1782: 	    ChildProcess;		# Does not return.
                   1783: 	}
1.1       foxr     1784:     }
1.61      foxr     1785: }
1.1       foxr     1786: 
1.61      foxr     1787: # parent_client_connection:
                   1788: #    Event handler that processes client connections for the parent process.
                   1789: #    This sub is called when the parent is listening on a socket and
                   1790: #    a connection request arrives.  We must:
                   1791: #     Start a child process to accept the connection request.
                   1792: #     Kill our listen on the socket.
                   1793: # Parameter:
                   1794: #    event       - The event object that was created to monitor this socket.
                   1795: #                  event->w->fd is the socket.
                   1796: # Returns:
                   1797: #    NONE
                   1798: #
                   1799: sub parent_client_connection {
1.62      foxr     1800:     if ($I_am_child) {
                   1801: 	#  Should not get here, but seem to anyway:
                   1802: 	&Debug(5," Child caught parent client connection event!!");
                   1803: 	my ($event) = @_;
                   1804: 	my $watcher = $event->w;
                   1805: 	$watcher->cancel();	# Try to kill it off again!!
                   1806:     } else {
                   1807: 	&Debug(9, "parent_client_connection");
                   1808: 	my ($event)   = @_;
                   1809: 	my $watcher   = $event->w;
                   1810: 	my $socket    = $watcher->fd;
1.77    ! albertel 1811: 	if ($hosts_tab) {
1.62      foxr     1812: 	
1.77    ! albertel 1813: 	    # Lookup the host associated with this socket:
        !          1814: 
        !          1815: 	    my $host = $listening_to{$socket};
1.62      foxr     1816: 	
1.77    ! albertel 1817: 	    # Start the child:
        !          1818: 
        !          1819: 
        !          1820: 
        !          1821: 	    &Debug(9,"Creating child for $host (parent_client_connection)");
        !          1822: 	    &CreateChild($host, $socket);
        !          1823: 	    	
        !          1824: 	    # Clean up the listen since now the child takes over until it exits.
1.62      foxr     1825: 	
1.77    ! albertel 1826: 	    $watcher->cancel();		# Nolonger listening to this event
        !          1827: 	    delete($listening_to{$socket});
        !          1828: 	    delete($parent_dispatchers{$host});
        !          1829: 	    $socket->close();
        !          1830: 
        !          1831: 	} else {
        !          1832: 	    my $connection = $socket->accept();	# Accept the client connection.
        !          1833: 	    Event->io(cb      => \&get_remote_hostname,
        !          1834: 		      poll    => 'r',
        !          1835: 		      data    => "",
        !          1836: 		      fd      => $connection);
        !          1837: 	}
        !          1838:     }
        !          1839: }
        !          1840: 
        !          1841: sub get_remote_hostname {
        !          1842: 	my ($event)   = @_;
        !          1843: 	my $watcher   = $event->w;
        !          1844: 	my $socket    = $watcher->fd;
1.62      foxr     1845: 	
1.77    ! albertel 1846: 	my $thisread;
        !          1847: 	my $rv = $socket->recv($thisread, 1, 0);
        !          1848: 	Debug(8, "rcv:  data length = ".length($thisread)." read =".$thisread);
        !          1849: 	if (!defined($rv) || length($thisread) == 0) {
        !          1850: 	    # Likely eof on socket.
        !          1851: 	    Debug(5,"Client Socket closed on lonc for p_c_c");
        !          1852: 	    close($socket);
        !          1853: 	    $watcher->cancel();
        !          1854: 	    return;
        !          1855: 	}
        !          1856: 
        !          1857: 	my $data    = $watcher->data().$thisread;
        !          1858: 	$watcher->data($data);
        !          1859: 	if($data =~ /\n$/) {	# Request entirely read.
        !          1860: 	    chomp($data);
        !          1861: 	} else {
        !          1862: 	    return;
        !          1863: 	}
1.62      foxr     1864: 	
1.77    ! albertel 1865: 	&Debug(5,"Creating child for $data (parent_client_connection)");
        !          1866: 	&CreateChild($data);
1.62      foxr     1867: 	
                   1868: 	# Clean up the listen since now the child takes over until it exits.
                   1869: 	$watcher->cancel();		# Nolonger listening to this event
1.77    ! albertel 1870: 	$socket->send("done\n");
1.62      foxr     1871: 	$socket->close();
1.61      foxr     1872: }
                   1873: 
                   1874: # parent_listen:
                   1875: #    Opens a socket and starts a listen for the parent process on a client UNIX
                   1876: #    domain socket.
                   1877: #
                   1878: #    This involves:
                   1879: #       Creating a socket for listen.
                   1880: #       Removing any socket lock file
                   1881: #       Adding an event handler for this socket becoming readable
                   1882: #         To the parent's event dispatcher.
                   1883: # Parameters:
                   1884: #    loncapa_host    - LonCAPA cluster name of the host represented by the client
                   1885: #                      socket.
                   1886: # Returns:
                   1887: #    NONE
                   1888: #
                   1889: sub parent_listen {
                   1890:     my ($loncapa_host) = @_;
                   1891:     Debug(5, "parent_listen: $loncapa_host");
                   1892: 
1.77    ! albertel 1893:     my $socket   = &SetupLoncListener($loncapa_host);
1.62      foxr     1894:     $listening_to{$socket} = $loncapa_host;
1.61      foxr     1895:     if (!$socket) {
                   1896: 	die "Unable to create a listen socket for $loncapa_host";
                   1897:     }
                   1898:     
1.62      foxr     1899:     my $lock_file = &GetLoncSocketPath($loncapa_host).".lock";
1.61      foxr     1900:     unlink($lock_file);		# No problem if it doesn't exist yet [startup e.g.]
                   1901: 
1.77    ! albertel 1902:     my $watcher = 
        !          1903: 	Event->io(cb    => \&parent_client_connection,
        !          1904: 		  poll  => 'r',
        !          1905: 		  desc  => "Parent listener unix socket ($loncapa_host)",
        !          1906: 		  data => "",
        !          1907: 		  fd    => $socket);
1.62      foxr     1908:     $parent_dispatchers{$loncapa_host} = $watcher;
1.61      foxr     1909: 
                   1910: }
                   1911: 
1.77    ! albertel 1912: sub parent_clean_up {
        !          1913:     my ($loncapa_host) = @_;
        !          1914:     Debug(5, "parent_clean_up: $loncapa_host");
        !          1915: 
        !          1916:     my $socket_file = &GetLoncSocketPath($loncapa_host);
        !          1917:     unlink($socket_file);	# No problem if it doesn't exist yet [startup e.g.]
        !          1918:     my $lock_file   = $socket_file.".lock";
        !          1919:     unlink($lock_file);		# No problem if it doesn't exist yet [startup e.g.]
        !          1920: }
        !          1921: 
1.61      foxr     1922: 
                   1923: # listen_on_all_unix_sockets:
                   1924: #    This sub initiates a listen on all unix domain lonc client sockets.
                   1925: #    This will be called in the case where we are trimming idle processes.
                   1926: #    When idle processes are trimmed, loncnew starts up with no children,
                   1927: #    and only spawns off children when a connection request occurs on the
                   1928: #    client unix socket.  The spawned child continues to run until it has
                   1929: #    been idle a while at which point it eventually exits and once more
                   1930: #    the parent picks up the listen.
                   1931: #
                   1932: #  Parameters:
                   1933: #      NONE
                   1934: #  Implicit Inputs:
                   1935: #    The configuration file that has been read in by LondConnection.
                   1936: #  Returns:
                   1937: #     NONE
                   1938: #
                   1939: sub listen_on_all_unix_sockets {
                   1940:     Debug(5, "listen_on_all_unix_sockets");
                   1941:     my $host_iterator      =   &LondConnection::GetHostIterator();
                   1942:     while (!$host_iterator->end()) {
                   1943: 	my $host_entry_ref =   $host_iterator->get();
1.74      albertel 1944: 	my $host_name      = $host_entry_ref->[3];
1.61      foxr     1945: 	Debug(9, "Listen for $host_name");
                   1946: 	&parent_listen($host_name);
                   1947: 	$host_iterator->next();
                   1948:     }
1.1       foxr     1949: }
1.61      foxr     1950: 
1.77    ! albertel 1951: sub listen_on_common_socket {
        !          1952:     Debug(5, "listen_on_common_socket");
        !          1953:     &parent_listen('common');
        !          1954: }
        !          1955: 
1.63      foxr     1956: #   server_died is called whenever a child process exits.
                   1957: #   Since this is dispatched via a signal, we must process all
                   1958: #   dead children until there are no more left.  The action
                   1959: #   is to:
                   1960: #      - Remove the child from the bookeeping hashes
                   1961: #      - Re-establish a listen on the unix domain socket associated
                   1962: #        with that host.
                   1963: # Parameters:
                   1964: #    The event, but we don't actually care about it.
                   1965: sub server_died {
                   1966:     &Debug(9, "server_died called...");
                   1967:     
                   1968:     while(1) {			# Loop until waitpid nowait fails.
                   1969: 	my $pid = waitpid(-1, WNOHANG);
                   1970: 	if($pid <= 0) {
                   1971: 	    return;		# Nothing left to wait for.
                   1972: 	}
                   1973: 	# need the host to restart:
                   1974: 
                   1975: 	my $host = $ChildHash{$pid};
                   1976: 	if($host) {		# It's for real...
                   1977: 	    &Debug(9, "Caught sigchild for $host");
                   1978: 	    delete($ChildHash{$pid});
                   1979: 	    delete($HostToPid{$host});
1.77    ! albertel 1980: 	    if ($hosts_tab) {
        !          1981: 		&parent_listen($host);
        !          1982: 	    } else {
        !          1983: 		&parent_clean_up($host);
        !          1984: 	    }
        !          1985: 	    
1.63      foxr     1986: 	} else {
                   1987: 	    &Debug(5, "Caught sigchild for pid not in hosts hash: $pid");
                   1988: 	}
                   1989:     }
                   1990: 
                   1991: }
                   1992: 
1.1       foxr     1993: #
                   1994: #  Parent process logic pass 1:
                   1995: #   For each entry in the hosts table, we will
                   1996: #  fork off an instance of ChildProcess to service the transactions
                   1997: #  to that host.  Each pid will be entered in a global hash
                   1998: #  with the value of the key, the host.
                   1999: #  The parent will then enter a loop to wait for process exits.
                   2000: #  Each exit gets logged and the child gets restarted.
                   2001: #
                   2002: 
1.5       foxr     2003: #
                   2004: #   Fork and start in new session so hang-up isn't going to 
                   2005: #   happen without intent.
                   2006: #
                   2007: 
                   2008: 
1.6       foxr     2009: 
                   2010: 
1.8       foxr     2011: 
1.6       foxr     2012: 
                   2013: ShowStatus("Forming new session");
                   2014: my $childpid = fork;
                   2015: if ($childpid != 0) {
                   2016:     sleep 4;			# Give child a chacne to break to
                   2017:     exit 0;			# a new sesion.
                   2018: }
1.8       foxr     2019: #
                   2020: #   Write my pid into the pid file so I can be located
                   2021: #
                   2022: 
                   2023: ShowStatus("Parent writing pid file:");
1.23      foxr     2024: my $execdir = $perlvar{'lonDaemons'};
1.8       foxr     2025: open (PIDSAVE, ">$execdir/logs/lonc.pid");
                   2026: print PIDSAVE "$$\n";
                   2027: close(PIDSAVE);
1.6       foxr     2028: 
1.17      foxr     2029: 
                   2030: 
1.6       foxr     2031: if (POSIX::setsid() < 0) {
                   2032:     print "Could not create new session\n";
                   2033:     exit -1;
                   2034: }
1.5       foxr     2035: 
                   2036: ShowStatus("Forking node servers");
                   2037: 
1.9       foxr     2038: Log("CRITICAL", "--------------- Starting children ---------------");
                   2039: 
1.31      foxr     2040: LondConnection::ReadConfig;               # Read standard config files.
1.1       foxr     2041: my $HostIterator = LondConnection::GetHostIterator;
                   2042: 
1.60      foxr     2043: if ($DieWhenIdle) {
1.61      foxr     2044:     $RemoteHost = "[parent]";
1.77    ! albertel 2045:     if ($hosts_tab) {
        !          2046: 	&listen_on_all_unix_sockets();
        !          2047:     } else {
        !          2048: 	&listen_on_common_socket();
        !          2049:     }
1.60      foxr     2050: } else {
                   2051:     
                   2052:     while (! $HostIterator->end()) {
                   2053: 	
                   2054: 	my $hostentryref = $HostIterator->get();
                   2055: 	CreateChild($hostentryref->[0]);
                   2056: 	$HostHash{$hostentryref->[0]} = $hostentryref->[4];
                   2057: 	$HostIterator->next();
                   2058:     }
1.1       foxr     2059: }
1.60      foxr     2060: 
1.12      foxr     2061: $RemoteHost = "Parent Server";
1.1       foxr     2062: 
                   2063: # Maintain the population:
1.5       foxr     2064: 
                   2065: ShowStatus("Parent keeping the flock");
1.1       foxr     2066: 
1.12      foxr     2067: 
1.60      foxr     2068: if ($DieWhenIdle) {
1.63      foxr     2069:     # We need to setup a SIGChild event to handle the exit (natural or otherwise)
                   2070:     # of the children.
                   2071: 
                   2072:     Event->signal(cb       => \&server_died,
                   2073: 		   desc     => "Child exit handler",
                   2074: 		   signal   => "CHLD");
                   2075: 
                   2076: 
1.65      foxr     2077:     # Set up all the other signals we set up.  We'll vector them off to the
                   2078:     # same subs as we would for DieWhenIdle false and, if necessary, conditionalize
                   2079:     # the code there.
                   2080: 
                   2081:     $parent_handlers{INT} = Event->signal(cb       => \&Terminate,
                   2082: 					  desc     => "Parent INT handler",
                   2083: 					  signal   => "INT");
                   2084:     $parent_handlers{TERM} = Event->signal(cb       => \&Terminate,
                   2085: 					   desc     => "Parent TERM handler",
                   2086: 					   signal   => "TERM");
1.77    ! albertel 2087:     if ($hosts_tab) {
        !          2088: 	$parent_handlers{HUP}  = Event->signal(cb       => \&Restart,
        !          2089: 					       desc     => "Parent HUP handler.",
        !          2090: 					       signal   => "HUP");
        !          2091:     } else {
        !          2092: 	$parent_handlers{HUP}  = Event->signal(cb       => \&KillThemAll,
        !          2093: 					       desc     => "Parent HUP handler.",
        !          2094: 					       signal   => "HUP");
        !          2095:     }
1.65      foxr     2096:     $parent_handlers{USR1} = Event->signal(cb       => \&CheckKids,
                   2097: 					   desc     => "Parent USR1 handler",
                   2098: 					   signal   => "USR1");
                   2099:     $parent_handlers{USR2} = Event->signal(cb       => \&UpdateKids,
                   2100: 					   desc     => "Parent USR2 handler.",
                   2101: 					   signal   => "USR2");
                   2102:     
                   2103:     #  Start procdesing events.
                   2104: 
1.61      foxr     2105:     $Event::DebugLevel = $DebugLevel;
                   2106:     Debug(9, "Parent entering event loop");
                   2107:     my $ret = Event::loop();
                   2108:     die "Main Event loop exited: $ret";
                   2109: 
                   2110: 
1.60      foxr     2111: } else {
1.61      foxr     2112:     #
                   2113:     #   Set up parent signals:
                   2114:     #
1.60      foxr     2115:     
                   2116:     $SIG{INT}  = \&Terminate;
                   2117:     $SIG{TERM} = \&Terminate; 
1.77    ! albertel 2118:     if ($hosts_tab) {
        !          2119: 	$SIG{HUP}  = \&Restart;
        !          2120:     } else {
        !          2121: 	$SIG{HUP}  = \&KillThemAll;
        !          2122:     }
1.60      foxr     2123:     $SIG{USR1} = \&CheckKids; 
                   2124:     $SIG{USR2} = \&UpdateKids;	# LonManage update request.
                   2125:     
                   2126:     while(1) {
                   2127: 	my $deadchild = wait();
                   2128: 	if(exists $ChildHash{$deadchild}) {	# need to restart.
                   2129: 	    my $deadhost = $ChildHash{$deadchild};
                   2130: 	    delete($HostToPid{$deadhost});
                   2131: 	    delete($ChildHash{$deadchild});
                   2132: 	    Log("WARNING","Lost child pid= ".$deadchild.
                   2133: 		"Connected to host ".$deadhost);
                   2134: 	    Log("INFO", "Restarting child procesing ".$deadhost);
                   2135: 	    CreateChild($deadhost);
                   2136: 	}
1.1       foxr     2137:     }
1.13      foxr     2138: }
                   2139: 
1.14      foxr     2140: 
                   2141: =pod
                   2142: 
                   2143: =head1 CheckKids
                   2144: 
                   2145:   Since kids do not die as easily in this implementation
                   2146: as the previous one, there  is no need to restart the
                   2147: dead ones (all dead kids get restarted when they die!!)
                   2148: The only thing this function does is to pass USR1 to the
                   2149: kids so that they report their status.
                   2150: 
                   2151: =cut
                   2152: 
                   2153: sub CheckKids {
                   2154:     Debug(2, "Checking status of children");
                   2155:     my $docdir = $perlvar{'lonDocRoot'};
                   2156:     my $fh = IO::File->new(">$docdir/lon-status/loncstatus.txt");
                   2157:     my $now=time;
                   2158:     my $local=localtime($now);
                   2159:     print $fh "LONC status $local - parent $$ \n\n";
1.65      foxr     2160:     foreach my $host (keys %parent_dispatchers) {
                   2161: 	print $fh "LONC Parent process listening for $host\n";
                   2162:     }
1.23      foxr     2163:     foreach my $pid (keys %ChildHash) {
1.14      foxr     2164: 	Debug(2, "Sending USR1 -> $pid");
                   2165: 	kill 'USR1' => $pid;	# Tell Child to report status.
                   2166:     }
1.65      foxr     2167: 
1.14      foxr     2168: }
1.24      foxr     2169: 
                   2170: =pod
                   2171: 
                   2172: =head1  UpdateKids
                   2173: 
1.25      foxr     2174: parent's SIGUSR2 handler.  This handler:
1.24      foxr     2175: 
                   2176: =item
                   2177: 
                   2178: Rereads the hosts file.
                   2179: 
                   2180: =item
                   2181:  
                   2182: Kills off (via sigint) children for hosts that have disappeared.
                   2183: 
                   2184: =item
                   2185: 
1.27      foxr     2186: QUITs  children for hosts that already exist (this just forces a status display
1.24      foxr     2187: and resets the connection retry count for that host.
                   2188: 
                   2189: =item
                   2190: 
                   2191: Starts new children for hosts that have been added to the hosts.tab file since
                   2192: the start of the master program and maintains them.
                   2193: 
                   2194: =cut
                   2195: 
                   2196: sub UpdateKids {
1.27      foxr     2197: 
1.25      foxr     2198:     Log("INFO", "Updating connections via SIGUSR2");
1.27      foxr     2199: 
1.65      foxr     2200:     #  I'm not sure what I was thinking in the first implementation.
                   2201:     # someone will have to work hard to convince me the effect is any
                   2202:     # different than Restart, especially now that we don't start up 
                   2203:     # per host servers automatically, may as well just restart.
                   2204:     # The down side is transactions that are in flight will get timed out
                   2205:     # (lost unless they are critical).
1.27      foxr     2206: 
1.77    ! albertel 2207:     if ($hosts_tab) {
        !          2208: 	&Restart();
        !          2209:     } else {
        !          2210: 	&KillThemAll();
        !          2211:     }
1.24      foxr     2212: }
                   2213: 
1.14      foxr     2214: 
1.13      foxr     2215: =pod
                   2216: 
                   2217: =head1 Restart
                   2218: 
                   2219: Signal handler for HUP... all children are killed and
                   2220: we self restart.  This is an el-cheapo way to re read
                   2221: the config file.
                   2222: 
                   2223: =cut
                   2224: 
                   2225: sub Restart {
1.23      foxr     2226:     &KillThemAll;		# First kill all the children.
1.13      foxr     2227:     Log("CRITICAL", "Restarting");
                   2228:     my $execdir = $perlvar{'lonDaemons'};
                   2229:     unlink("$execdir/logs/lonc.pid");
1.65      foxr     2230:     exec("$executable");
1.10      foxr     2231: }
1.12      foxr     2232: 
                   2233: =pod
                   2234: 
                   2235: =head1 KillThemAll
                   2236: 
                   2237: Signal handler that kills all children by sending them a 
1.17      foxr     2238: SIGHUP.  Responds to sigint and sigterm.
1.12      foxr     2239: 
                   2240: =cut
                   2241: 
1.10      foxr     2242: sub KillThemAll {
1.12      foxr     2243:     Debug(2, "Kill them all!!");
                   2244:     local($SIG{CHLD}) = 'IGNORE';      # Our children >will< die.
1.23      foxr     2245:     foreach my $pid (keys %ChildHash) {
1.12      foxr     2246: 	my $serving = $ChildHash{$pid};
1.52      foxr     2247: 	ShowStatus("Nicely Killing lonc for $serving pid = $pid");
                   2248: 	Log("CRITICAL", "Nicely Killing lonc for $serving pid = $pid");
1.17      foxr     2249: 	kill 'QUIT' => $pid;
1.12      foxr     2250:     }
1.1       foxr     2251: }
1.12      foxr     2252: 
1.52      foxr     2253: 
                   2254: #
                   2255: #  Kill all children via KILL.  Just in case the
                   2256: #  first shot didn't get them.
                   2257: 
                   2258: sub really_kill_them_all_dammit
                   2259: {
                   2260:     Debug(2, "Kill them all Dammit");
                   2261:     local($SIG{CHLD} = 'IGNORE'); # In case some purist reenabled them.
                   2262:     foreach my $pid (keys %ChildHash) {
                   2263: 	my $serving = $ChildHash{$pid};
                   2264: 	&ShowStatus("Nastily killing lonc for $serving pid = $pid");
                   2265: 	Log("CRITICAL", "Nastily killing lonc for $serving pid = $pid");
                   2266: 	kill 'KILL' => $pid;
                   2267: 	delete($ChildHash{$pid});
                   2268: 	my $execdir = $perlvar{'lonDaemons'};
                   2269: 	unlink("$execdir/logs/lonc.pid");
                   2270:     }
                   2271: }
1.69      matthew  2272: 
1.14      foxr     2273: =pod
                   2274: 
                   2275: =head1 Terminate
                   2276:  
                   2277: Terminate the system.
                   2278: 
                   2279: =cut
                   2280: 
                   2281: sub Terminate {
1.52      foxr     2282:     &Log("CRITICAL", "Asked to kill children.. first be nice...");
                   2283:     &KillThemAll;
                   2284:     #
                   2285:     #  By now they really should all be dead.. but just in case 
                   2286:     #  send them all SIGKILL's after a bit of waiting:
                   2287: 
                   2288:     sleep(4);
                   2289:     &Log("CRITICAL", "Now kill children nasty");
                   2290:     &really_kill_them_all_dammit;
1.17      foxr     2291:     Log("CRITICAL","Master process exiting");
                   2292:     exit 0;
1.14      foxr     2293: 
                   2294: }
1.12      foxr     2295: =pod
1.1       foxr     2296: 
                   2297: =head1 Theory
1.3       albertel 2298: 
                   2299: The event class is used to build this as a single process with an
                   2300: event driven model.  The following events are handled:
1.1       foxr     2301: 
                   2302: =item UNIX Socket connection Received
                   2303: 
                   2304: =item Request data arrives on UNIX data transfer socket.
                   2305: 
                   2306: =item lond connection becomes writable.
                   2307: 
                   2308: =item timer fires at 1 second intervals.
                   2309: 
                   2310: All sockets are run in non-blocking mode.  Timeouts managed by the timer
                   2311: handler prevents hung connections.
                   2312: 
                   2313: Key data structures:
                   2314: 
1.3       albertel 2315: =item RequestQueue
                   2316: 
                   2317: A queue of requests received from UNIX sockets that are
                   2318: waiting for a chance to be forwarded on a lond connection socket.
                   2319: 
                   2320: =item ActiveConnections
                   2321: 
                   2322: A hash of lond connections that have transactions in process that are
                   2323: available to be timed out.
                   2324: 
                   2325: =item ActiveTransactions
                   2326: 
                   2327: A hash indexed by lond connections that contain the client reply
                   2328: socket for each connection that has an active transaction on it.
                   2329: 
                   2330: =item IdleConnections
                   2331: 
                   2332: A hash of lond connections that have no work to do.  These connections
                   2333: can be closed if they are idle for a long enough time.
1.1       foxr     2334: 
                   2335: =cut

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