Annotation of loncom/loncnew, revision 1.109

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

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