Annotation of loncom/loncnew, revision 1.57.2.1

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

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