--- loncom/loncnew 2003/04/18 03:10:36 1.3 +++ loncom/loncnew 2005/01/19 21:38:25 1.57.2.1 @@ -2,13 +2,12 @@ # The LearningOnline Network with CAPA # lonc maintains the connections to remote computers # -# $Id: loncnew,v 1.3 2003/04/18 03:10:36 albertel Exp $ +# $Id: loncnew,v 1.57.2.1 2005/01/19 21:38:25 albertel Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). -# -# LON-CAPA is free software; you can redistribute it and/or modify +## LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. @@ -27,47 +26,42 @@ # http://www.lon-capa.org/ # # -# new lonc handles n requestors spread out bver m connections to londs. +# new lonc handles n request out bver m connections to londs. # This module is based on the Event class. # Development iterations: # - Setup basic event loop. (done) # - Add timer dispatch. (done) # - Add ability to accept lonc UNIX domain sockets. (done) # - Add ability to create/negotiate lond connections (done). -# - Add general logic for dispatching requests and timeouts. -# - Add support for the lonc/lond requests. -# - Add logging/status monitoring. -# - Add Signal handling - HUP restarts. USR1 status report. -# - Add Configuration file I/O -# - Add Pending request processing on startup. -# - Add management/status request interface. +# - Add general logic for dispatching requests and timeouts. (done). +# - Add support for the lonc/lond requests. (done). +# - Add logging/status monitoring. (done) +# - Add Signal handling - HUP restarts. USR1 status report. (done) +# - Add Configuration file I/O (done). +# - Add management/status request interface. (done) +# - Add deferred request capability. (done) +# - Detect transmission timeouts. (done) +# +use strict; use lib "/home/httpd/lib/perl/"; -use lib "/home/foxr/newloncapa/types"; use Event qw(:DEFAULT ); use POSIX qw(:signal_h); +use POSIX; use IO::Socket; use IO::Socket::INET; use IO::Socket::UNIX; +use IO::File; +use IO::Handle; use Socket; use Crypt::IDEA; use LONCAPA::Queue; use LONCAPA::Stack; use LONCAPA::LondConnection; +use LONCAPA::LondTransaction; use LONCAPA::Configuration; use LONCAPA::HashIterator; - -print "Loncnew starting\n"; - -# -# Disable all signals we might receive from outside for now. -# -$SIG{QUIT} = IGNORE; -$SIG{HUP} = IGNORE; -$SIG{USR1} = IGNORE; -$SIG{INT} = IGNORE; -$SIG{CHLD} = IGNORE; -$SIG{__DIE__} = IGNORE; +use Fcntl qw(:flock); # Read the httpd configuration file to get perl variables @@ -80,29 +74,134 @@ my %perlvar = %{$perlvarref}; # parent and shared variables. my %ChildHash; # by pid -> host. +my %HostToPid; # By host -> pid. +my %HostHash; # by loncapaname -> IP. -my $MaxConnectionCount = 5; # Will get from config later. +my $MaxConnectionCount = 10; # Will get from config later. my $ClientConnection = 0; # Uniquifier for client events. -my $DebugLevel = 5; -my $IdleTimeout= 3600; # Wait an hour before pruning connections. +my $DebugLevel = 0; +my $NextDebugLevel= 2; # So Sigint can toggle this. +my $IdleTimeout= 600; # Wait 10 minutes before pruning connections. + +my $LogTransactions = 0; # When True, all transactions/replies get logged. # # The variables below are only used by the child processes. # my $RemoteHost; # Name of host child is talking to. -my $UnixSocketDir= "/home/httpd/sockets"; +my $UnixSocketDir= $perlvar{'lonSockDir'}; my $IdleConnections = Stack->new(); # Set of idle connections my %ActiveConnections; # Connections to the remote lond. -my %ActiveTransactions; # Transactions in flight. +my %ActiveTransactions; # LondTransactions in flight. my %ActiveClients; # Serial numbers of active clients by socket. my $WorkQueue = Queue->new(); # Queue of pending transactions. -my $ClientQueue = Queue->new(); # Queue of clients causing xactinos. my $ConnectionCount = 0; +my $IdleSeconds = 0; # Number of seconds idle. +my $Status = ""; # Current status string. +my $RecentLogEntry = ""; +my $ConnectionRetries=2; # Number of connection retries allowed. +my $ConnectionRetriesLeft=2; # Number of connection retries remaining. +my $LondVersion = "unknown"; # Version of lond we talk with. +my $KeyMode = ""; # e.g. ssl, local, insecure from last connect. +my $LondConnecting = 0; # True when a connection is being built. +my $DieWhenIdle = 0; # When true children die when trimmed -> 0. # +# The hash below gives the HTML format for log messages +# given a severity. +# +my %LogFormats; + +$LogFormats{"CRITICAL"} = "CRITICAL: %s"; +$LogFormats{"SUCCESS"} = "SUCCESS: %s"; +$LogFormats{"INFO"} = "INFO: %s"; +$LogFormats{"WARNING"} = "WARNING: %s"; +$LogFormats{"DEFAULT"} = " %s "; + + +# UpdateStatus; +# Update the idle status display to show how many connections +# are left, retries and other stuff. +# +sub UpdateStatus { + if ($ConnectionRetriesLeft > 0) { + ShowStatus(GetServerHost()." Connection count: ".$ConnectionCount + ." Retries remaining: ".$ConnectionRetriesLeft + ." ($KeyMode)"); + } else { + ShowStatus(GetServerHost()." >> DEAD <<"); + } +} + + +=pod + +=head2 LogPerm + +Makes an entry into the permanent log file. + +=cut +sub LogPerm { + my $message=shift; + my $execdir=$perlvar{'lonDaemons'}; + my $now=time; + my $local=localtime($now); + my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log"); + print $fh "$now:$message:$local\n"; +} + +=pod + +=head2 Log + +Logs a message to the log file. +Parameters: + +=item severity + +One of CRITICAL, WARNING, INFO, SUCCESS used to select the +format string used to format the message. if the severity is +not a defined severity the Default format string is used. + +=item message + +The base message. In addtion to the format string, the message +will be appended to a string containing the name of our remote +host and the time will be formatted into the message. + +=cut + +sub Log { + + my ($severity, $message) = @_; + + if(!$LogFormats{$severity}) { + $severity = "DEFAULT"; + } + + my $format = $LogFormats{$severity}; + + # Put the window dressing in in front of the message format: + + my $now = time; + my $local = localtime($now); + my $finalformat = "$local ($$) [$RemoteHost] [$Status] "; + my $finalformat = $finalformat.$format."\n"; + + # open the file and put the result. + + my $execdir = $perlvar{'lonDaemons'}; + my $fh = IO::File->new(">>$execdir/logs/lonc.log"); + my $msg = sprintf($finalformat, $message); + $RecentLogEntry = $msg; + print $fh $msg; + + +} + =pod @@ -113,14 +212,16 @@ Returns the name of the host that a sock =cut sub GetPeername { - my $connection = shift; - my $AdrFamily = shift; + + + my ($connection, $AdrFamily) = @_; + my $peer = $connection->peername(); my $peerport; my $peerip; if($AdrFamily == AF_INET) { ($peerport, $peerip) = sockaddr_in($peer); - my $peername = gethostbyaddr($iaddr, $AdrFamily); + my $peername = gethostbyaddr($peerip, $AdrFamily); return $peername; } elsif ($AdrFamily == AF_UNIX) { my $peerfile; @@ -128,7 +229,6 @@ sub GetPeername { return $peerfile; } } -#----------------------------- Timer management ------------------------ =pod =head2 Debug @@ -138,36 +238,153 @@ Invoked to issue a debug message. =cut sub Debug { - my $level = shift; - my $message = shift; + + my ($level, $message) = @_; + if ($level <= $DebugLevel) { - print $message." host = ".$RemoteHost."\n"; + Log("INFO", "-Debug- $message host = $RemoteHost"); } } sub SocketDump { - my $level = shift; - my $socket= shift; + + my ($level, $socket) = @_; + if($level <= $DebugLevel) { - $socket->Dump(); + $socket->Dump(-1); # Ensure it will get dumped. } } =pod +=head2 ShowStatus + + Place some text as our pid status. + and as what we return in a SIGUSR1 + +=cut +sub ShowStatus { + my $state = shift; + my $now = time; + my $local = localtime($now); + $Status = $local.": ".$state; + $0='lonc: '.$state.' '.$local; +} + +=pod + +=head 2 SocketTimeout + + Called when an action on the socket times out. The socket is + destroyed and any active transaction is failed. + + +=cut +sub SocketTimeout { + my $Socket = shift; + Log("WARNING", "A socket timeout was detected"); + Debug(5, " SocketTimeout called: "); + $Socket->Dump(0); + if(exists($ActiveTransactions{$Socket})) { + FailTransaction($ActiveTransactions{$Socket}); + } + KillSocket($Socket); # A transaction timeout also counts as + # a connection failure: + $ConnectionRetriesLeft--; + if($ConnectionRetriesLeft <= 0) { + Log("CRITICAL", "Host marked DEAD: ".GetServerHost()); + $LondConnecting = 0; + } + +} +#----------------------------- Timer management ------------------------ + +=pod + =head2 Tick Invoked each timer tick. =cut + sub Tick { + my ($Event) = @_; + my $clock_watcher = $Event->w; + my $client; - Debug(6, "Tick"); - Debug(6, " Current connection count: ".$ConnectionCount); - foreach $client (keys %ActiveClients) { - Debug(7, " Have client: with id: ".$ActiveClients{$client}); + UpdateStatus(); + + # Is it time to prune connection count: + + + if($IdleConnections->Count() && + ($WorkQueue->Count() == 0)) { # Idle connections and nothing to do? + $IdleSeconds++; + if($IdleSeconds > $IdleTimeout) { # Prune a connection... + my $Socket = $IdleConnections->pop(); + KillSocket($Socket); + $IdleSeconds = 0; # Otherwise all connections get trimmed to fast. + UpdateStatus(); + if(($ConnectionCount == 0) && $DieWhenIdle) { + # + # Create a lock file since there will be a time window + # between our exit and the parent's picking up the listen + # during which no listens will be done on the + # lonnet client socket. + # + my $lock_file = GetLoncSocketPath().".lock"; + open(LOCK,">$lock_file"); + print LOCK "Contents not important"; + close(LOCK); + + exit(0); + } + } + } else { + $IdleSeconds = 0; # Reset idle count if not idle. + } + # + # For each inflight transaction, tick down its timeout counter. + # + + foreach my $item (keys %ActiveConnections) { + my $State = $ActiveConnections{$item}->data->GetState(); + if ($State ne 'Idle') { + Debug(5,"Ticking Socket $State $item"); + $ActiveConnections{$item}->data->Tick(); + } } + # Do we have work in the queue, but no connections to service them? + # If so, try to make some new connections to get things going again. + # + # Note this code is dead now... + # + my $Requests = $WorkQueue->Count(); + if (($ConnectionCount == 0) && ($Requests > 0) && (!$LondConnecting)) { + if ($ConnectionRetriesLeft > 0) { + Debug(5,"Work but no connections, Make a new one"); + my $success; + $success = &MakeLondConnection; + if($success == 0) { # All connections failed: + Debug(5,"Work in queue failed to make any connectiouns\n"); + EmptyQueue(); # Fail pending transactions with con_lost. + CloseAllLondConnections(); # Should all be closed but.... + } + } else { + $LondConnecting = 0; + ShowStatus(GetServerHost()." >>> DEAD!!! <<<"); + Debug(5,"Work in queue, but gave up on connections..flushing\n"); + EmptyQueue(); # Connections can't be established. + CloseAllLondConnections(); # Should all already be closed but... + } + + } + if ($ConnectionCount == 0) { + $KeyMode = ""; + $clock_watcher->cancel(); + } + &UpdateStatus(); } =pod @@ -188,7 +405,7 @@ Trigger disconnections of idle sockets. sub SetupTimer { Debug(6, "SetupTimer"); - Event->timer(interval => 1, debug => 1, cb => \&Tick ); + Event->timer(interval => 1, cb => \&Tick ); } =pod @@ -208,24 +425,22 @@ long enough, it will be shut down and re sub ServerToIdle { my $Socket = shift; # Get the socket. + $KeyMode = $Socket->{AuthenticationMode}; + delete($ActiveTransactions{$Socket}); # Server has no transaction - &Debug(6, "Server to idle"); + &Debug(5, "Server to idle"); # If there's work to do, start the transaction: - $reqdata = $WorkQueue->dequeue(); - Debug(9, "Queue gave request data: ".$reqdata); - unless($reqdata eq undef) { - my $unixSocket = $ClientQueue->dequeue(); - &Debug(6, "Starting new work request"); - &Debug(7, "Request: ".$reqdata); - - &StartRequest($Socket, $unixSocket, $reqdata); + my $reqdata = $WorkQueue->dequeue(); # This is a LondTransaction + if ($reqdata ne undef) { + Debug(5, "Queue gave request data: ".$reqdata->getRequest()); + &StartRequest($Socket, $reqdata); + } else { # There's no work waiting, so push the server to idle list. - &Debug(8, "No new work requests, server connection going idle"); - delete($ActiveTransactions{$Socket}); + &Debug(5, "No new work requests, server connection going idle"); $IdleConnections->push($Socket); } } @@ -260,51 +475,61 @@ sub ClientWritable { &Debug(6, "ClientWritable writing".$Data); &Debug(9, "Socket is: ".$Socket); - my $result = $Socket->send($Data, 0); - - # $result undefined: the write failed. - # otherwise $result is the number of bytes written. - # Remove that preceding string from the data. - # If the resulting data is empty, destroy the watcher - # and set up a read event handler to accept the next - # request. - - &Debug(9,"Send result is ".$result." Defined: ".defined($result)); - if(defined($result)) { - &Debug(9, "send result was defined"); - if($result == length($Data)) { # Entire string sent. - &Debug(9, "ClientWritable data all written"); - $Watcher->cancel(); - # - # Set up to read next request from socket: - - my $descr = sprintf("Connection to lonc client %d", - $ActiveClients{$Socket}); - Event->io(cb => \&ClientRequest, - poll => 'r', - desc => $descr, - data => "", - fd => $Socket); - - } else { # Partial string sent. - $Watcher->data(substr($Data, $result)); - } + if($Socket->connected) { + my $result = $Socket->send($Data, 0); - } else { # Error of some sort... - - # Some errnos are possible: - my $errno = $!; - if($errno == POSIX::EWOULDBLOCK || - $errno == POSIX::EAGAIN || - $errno == POSIX::EINTR) { - # No action taken? - } else { # Unanticipated errno. - &Debug(5,"ClientWritable error or peer shutdown".$RemoteHost); - $Watcher->cancel; # Stop the watcher. - $Socket->shutdown(2); # Kill connection - $Socket->close(); # Close the socket. - } + # $result undefined: the write failed. + # otherwise $result is the number of bytes written. + # Remove that preceding string from the data. + # If the resulting data is empty, destroy the watcher + # and set up a read event handler to accept the next + # request. + &Debug(9,"Send result is ".$result." Defined: ".defined($result)); + if($result ne undef) { + &Debug(9, "send result was defined"); + if($result == length($Data)) { # Entire string sent. + &Debug(9, "ClientWritable data all written"); + $Watcher->cancel(); + # + # Set up to read next request from socket: + + my $descr = sprintf("Connection to lonc client %d", + $ActiveClients{$Socket}); + Event->io(cb => \&ClientRequest, + poll => 'r', + desc => $descr, + data => "", + fd => $Socket); + + } else { # Partial string sent. + $Watcher->data(substr($Data, $result)); + if($result == 0) { # client hung up on us!! + # Log("INFO", "lonc pipe client hung up on us!"); + $Watcher->cancel; + $Socket->shutdown(2); + $Socket->close(); + } + } + + } else { # Error of some sort... + + # Some errnos are possible: + my $errno = $!; + if($errno == POSIX::EWOULDBLOCK || + $errno == POSIX::EAGAIN || + $errno == POSIX::EINTR) { + # No action taken? + } else { # Unanticipated errno. + &Debug(5,"ClientWritable error or peer shutdown".$RemoteHost); + $Watcher->cancel; # Stop the watcher. + $Socket->shutdown(2); # Kill connection + $Socket->close(); # Close the socket. + } + + } + } else { + $Watcher->cancel(); # A delayed request...just cancel. } } @@ -325,18 +550,53 @@ Parameters: Socket on which the lond transaction occured. This is a LondConnection. The data received is in the TransactionReply member. -=item Client +=item Transaction -Unix domain socket open on the ultimate client. +The transaction that is being completed. =cut sub CompleteTransaction { - &Debug(6,"Complete transaction"); - my $Socket = shift; - my $Client = shift; + &Debug(5,"Complete transaction"); + + my ($Socket, $Transaction) = @_; + + if (!$Transaction->isDeferred()) { # Normal transaction + my $data = $Socket->GetReply(); # Data to send. + if($LogTransactions) { + Log("SUCCESS", "Reply from lond: '$data'"); + } + StartClientReply($Transaction, $data); + } else { # Delete deferred transaction file. + Log("SUCCESS", "A delayed transaction was completed"); + LogPerm("S:$Transaction->getClient() :".$Transaction->getRequest()); + unlink $Transaction->getFile(); + } +} + +=pod + +=head1 StartClientReply + + Initiates a reply to a client where the reply data is a parameter. + +=head2 parameters: + +=item Transaction + + The transaction for which we are responding to the client. + +=item data + + The data to send to apached client. + +=cut + +sub StartClientReply { - my $data = $Socket->GetReply(); # Data to send. + my ($Transaction, $data) = @_; + + my $Client = $Transaction->getClient(); &Debug(8," Reply was: ".$data); my $Serial = $ActiveClients{$Client}; @@ -349,6 +609,128 @@ sub CompleteTransaction { data => $data); } +=pod + +=head2 FailTransaction + + Finishes a transaction with failure because the associated lond socket + disconnected. There are two possibilities: + - The transaction is deferred: in which case we just quietly + delete the transaction since there is no client connection. + - The transaction is 'live' in which case we initiate the sending + of "con_lost" to the client. + +Deleting the transaction means killing it from the %ActiveTransactions hash. + +Parameters: + +=item client + + The LondTransaction we are failing. + + +=cut + +sub FailTransaction { + my $transaction = shift; + + # If the socket is dead, that's already logged. + + if ($ConnectionRetriesLeft > 0) { + Log("WARNING", "Failing transaction " + .$transaction->getRequest()); + } + Debug(1, "Failing transaction: ".$transaction->getRequest()); + if (!$transaction->isDeferred()) { # If the transaction is deferred we'll get to it. + my $client = $transaction->getClient(); + Debug(1," Replying con_lost to ".$transaction->getRequest()); + StartClientReply($transaction, "con_lost\n"); + } + +} + +=pod +=head1 EmptyQueue + + Fails all items in the work queue with con_lost. + Note that each item in the work queue is a transaction. + +=cut +sub EmptyQueue { + $ConnectionRetriesLeft--; # Counts as connection failure too. + while($WorkQueue->Count()) { + my $request = $WorkQueue->dequeue(); # This is a transaction + FailTransaction($request); + } +} + +=pod + +=head2 CloseAllLondConnections + +Close all connections open on lond prior to exit e.g. + +=cut +sub CloseAllLondConnections { + foreach my $Socket (keys %ActiveConnections) { + if(exists($ActiveTransactions{$Socket})) { + FailTransaction($ActiveTransactions{$Socket}); + } + KillSocket($Socket); + } +} +=cut + +=pod + +=head2 KillSocket + +Destroys a socket. This function can be called either when a socket +has died of 'natural' causes or because a socket needs to be pruned due to +idleness. If the socket has died naturally, if there are no longer any +live connections a new connection is created (in case there are transactions +in the queue). If the socket has been pruned, it is never re-created. + +Parameters: + +=item Socket + + The socket to kill off. + +=item Restart + +nonzero if we are allowed to create a new connection. + + +=cut +sub KillSocket { + my $Socket = shift; + + Log("WARNING", "Shutting down a socket"); + $Socket->Shutdown(); + + # If the socket came from the active connection set, + # delete its transaction... note that FailTransaction should + # already have been called!!! + # otherwise it came from the idle set. + # + + if(exists($ActiveTransactions{$Socket})) { + delete ($ActiveTransactions{$Socket}); + } + if(exists($ActiveConnections{$Socket})) { + delete($ActiveConnections{$Socket}); + $ConnectionCount--; + if ($ConnectionCount < 0) { $ConnectionCount = 0; } + } + # If the connection count has gone to zero and there is work in the + # work queue, the work all gets failed with con_lost. + # + if($ConnectionCount == 0) { + EmptyQueue(); + CloseAllLondConnections; # Should all already be closed but... + } +} =pod @@ -372,6 +754,17 @@ The connection must echo the challenge b The challenge has been replied to. The we are receiveing the 'ok' from the partner. +=head3 State=ReadingVersionString + +We have requested the lond version and are reading the +version back. Upon completion, we'll store the version away +for future use(?). + +=head3 State=HostSet + +We have selected the domain name of our peer (multhomed hosts) +and are getting the reply (presumably ok) back. + =head3 State=RequestingKey The ok has been received and we need to send the request for @@ -409,59 +802,114 @@ transaction is in progress, the socket a =cut sub LondReadable { + my $Event = shift; my $Watcher = $Event->w; my $Socket = $Watcher->data; my $client = undef; + &Debug(6,"LondReadable called state = ".$Socket->GetState()); + my $State = $Socket->GetState(); # All action depends on the state. - &Debug(6,"LondReadable called state = ".$State); SocketDump(6, $Socket); + my $status = $Socket->Readable(); + + &Debug(2, "Socket->Readable returned: $status"); + + if($status != 0) { + # bad return from socket read. Currently this means that + # The socket has become disconnected. We fail the transaction. - if($Socket->Readable() != 0) { - # bad return from socket read. + Log("WARNING", + "Lond connection lost."); + if(exists($ActiveTransactions{$Socket})) { + FailTransaction($ActiveTransactions{$Socket}); + } else { + # Socket is connecting and failed... need to mark + # no longer connecting. + + $LondConnecting = 0; + } + $Watcher->cancel(); + KillSocket($Socket); + $ConnectionRetriesLeft--; # Counts as connection failure + return; } SocketDump(6,$Socket); $State = $Socket->GetState(); # Update in case of transition. &Debug(6, "After read, state is ".$State); - if($State eq "Initialized") { + if($State eq "Initialized") { } elsif ($State eq "ChallengeReceived") { # The challenge must be echoed back; The state machine # in the connection takes care of setting that up. Just # need to transition to writable: - - $Watcher->poll("w"); + $Watcher->cb(\&LondWritable); + $Watcher->poll("w"); } elsif ($State eq "ChallengeReplied") { + } elsif ($State eq "RequestingVersion") { + # Need to ask for the version... that is writiability: + + $Watcher->cb(\&LondWritable); + $Watcher->poll("w"); + + } elsif ($State eq "ReadingVersionString") { + # Read the rest of the version string... + } elsif ($State eq "SetHost") { + # Need to request the actual domain get set... + + $Watcher->cb(\&LondWritable); + $Watcher->poll("w"); + } elsif ($State eq "HostSet") { + # Reading the 'ok' from the peer. } elsif ($State eq "RequestingKey") { # The ok was received. Now we need to request the key # That requires us to be writable: - $Watcher->poll("w"); $Watcher->cb(\&LondWritable); + $Watcher->poll("w"); } elsif ($State eq "ReceivingKey") { } elsif ($State eq "Idle") { + + # This is as good a spot as any to get the peer version + # string: + + if($LondVersion eq "unknown") { + $LondVersion = $Socket->PeerVersion(); + Log("INFO", "Connected to lond version: $LondVersion"); + } # If necessary, complete a transaction and then go into the # idle queue. + # Note that a trasition to idle indicates a live lond + # on the other end so reset the connection retries. + # + $ConnectionRetriesLeft = $ConnectionRetries; # success resets the count + $Watcher->cancel(); if(exists($ActiveTransactions{$Socket})) { - Debug(8,"Completing transaction!!"); + Debug(5,"Completing transaction!!"); CompleteTransaction($Socket, $ActiveTransactions{$Socket}); + } else { + Log("SUCCESS", "Connection ".$ConnectionCount." to " + .$RemoteHost." now ready for action"); } - $Watcher->cancel(); ServerToIdle($Socket); # Next work unit or idle. + # + $LondConnecting = 0; # Best spot I can think of for this. + # + } elsif ($State eq "SendingRequest") { # We need to be writable for this and probably don't belong # here inthe first place. @@ -474,7 +922,7 @@ sub LondReadable { } else { - # Invalid state. + # Invalid state. Debug(4, "Invalid state in LondReadable"); } } @@ -543,82 +991,116 @@ is the socket on which to return a reply sub LondWritable { my $Event = shift; my $Watcher = $Event->w; - my @data = $Watcher->data; - Debug(6,"LondWritable State = ".$State." data has ".@data." elts.\n"); + my $Socket = $Watcher->data; + my $State = $Socket->GetState(); - my $Socket = $data[0]; # I know there's at least a socket. + Debug(6,"LondWritable State = ".$State."\n"); + # Figure out what to do depending on the state of the socket: - my $State = $Socket->GetState(); SocketDump(6,$Socket); + # If the socket is writable, we must always write. + # Only by writing will we undergo state transitions. + # Old logic wrote in state specific code below, however + # That forces us at least through another invocation of + # this function after writability is possible again. + # This logic also factors out common code for handling + # write failures... in all cases, write failures + # Kill the socket. + # This logic makes the branches of the >big< if below + # so that the writing states are actually NO-OPs. + + if ($Socket->Writable() != 0) { + # The write resulted in an error. + # We'll treat this as if the socket got disconnected: + Log("WARNING", "Connection to ".$RemoteHost. + " has been disconnected"); + if(exists($ActiveTransactions{$Socket})) { + FailTransaction($ActiveTransactions{$Socket}); + } else { + # In the process of conneting, so need to turn that off. + + $LondConnecting = 0; + } + $Watcher->cancel(); + KillSocket($Socket); + return; + } + + + if ($State eq "Connected") { - # "init" is being sent... - if ($Socket->Writable() != 0) { - # The write resulted in an error. - } - + # "init" is being sent... + } elsif ($State eq "Initialized") { # Now that init was sent, we switch # to watching for readability: - $Watcher->poll("r"); $Watcher->cb(\&LondReadable); - + $Watcher->poll("r"); + } elsif ($State eq "ChallengeReceived") { # We received the challenge, now we # are echoing it back. This is a no-op, # we're waiting for the state to change - if($Socket->Writable() != 0) { - # Write of the next chunk resulted in an error. - } - } elsif ($State eq "ChallengeReplied") { # The echo was sent back, so we switch # to watching readability. + $Watcher->cb(\&LondReadable); $Watcher->poll("r"); + } elsif ($State eq "RequestingVersion") { + # Sending the peer a version request... + + } elsif ($State eq "ReadingVersionString") { + # Transition to read since we have sent the + # version command and now just need to read the + # version string from the peer: + + $Watcher->cb(\&LondReadable); + $Watcher->poll("r"); + + } elsif ($State eq "SetHost") { + # Setting the remote domain... + + } elsif ($State eq "HostSet") { + # Back to readable to get the ok. + $Watcher->cb(\&LondReadable); + $Watcher->poll("r"); + } elsif ($State eq "RequestingKey") { # At this time we're requesting the key. # again, this is essentially a no-op. - # we'll write the next chunk until the - # state changes. - - if($Socket->Writable() != 0) { - # Write resulted in an error. - } } elsif ($State eq "ReceivingKey") { # Now we need to wait for the key # to come back from the peer: - $Watcher->poll("r"); $Watcher->cb(\&LondReadable); + $Watcher->poll("r"); } elsif ($State eq "SendingRequest") { + # At this time we are sending a request to the # peer... write the next chunk: - if($Socket->Writable() != 0) { - # Write resulted in an error. - - } } elsif ($State eq "ReceivingReply") { # The send has completed. Wait for the # data to come in for a reply. Debug(8,"Writable sent request/receiving reply"); - $Watcher->poll("r"); $Watcher->cb(\&LondReadable); + $Watcher->poll("r"); } else { # Control only passes here on an error: @@ -630,6 +1112,34 @@ sub LondWritable { } } +=pod + +=cut +sub QueueDelayed { + Debug(3,"QueueDelayed called"); + + my $path = "$perlvar{'lonSockDir'}/delayed"; + + Debug(4, "Delayed path: ".$path); + opendir(DIRHANDLE, $path); + + my @alldelayed = grep /\.$RemoteHost$/, readdir DIRHANDLE; + closedir(DIRHANDLE); + my $dfname; + my $reqfile; + foreach $dfname (sort @alldelayed) { + $reqfile = "$path/$dfname"; + Debug(4, "queueing ".$reqfile); + my $Handle = IO::File->new($reqfile); + my $cmd = <$Handle>; + chomp $cmd; # There may or may not be a newline... + $cmd = $cmd."\n"; # now for sure there's exactly one newline. + my $Transaction = LondTransaction->new($cmd); + $Transaction->SetDeferred($reqfile); + QueueTransaction($Transaction); + } + +} =pod @@ -650,32 +1160,45 @@ sub MakeLondConnection { my $Connection = LondConnection->new(&GetServerHost(), &GetServerPort()); - if($Connection == undef) { # Needs to be more robust later. - die "Failed to make a connection!!".$!."\n"; + if($Connection eq undef) { # Needs to be more robust later. + Log("CRITICAL","Failed to make a connection with lond."); + $ConnectionRetriesLeft--; + return 0; # Failure. + } else { + + # The connection needs to have writability + # monitored in order to send the init sequence + # that starts the whole authentication/key + # exchange underway. + # + my $Socket = $Connection->GetSocket(); + if($Socket eq undef) { + die "did not get a socket from the connection"; + } else { + &Debug(9,"MakeLondConnection got socket: ".$Socket); + } - } - # The connection needs to have writability - # monitored in order to send the init sequence - # that starts the whole authentication/key - # exchange underway. - # - my $Socket = $Connection->GetSocket(); - if($Socket == undef) { - die "did not get a socket from the connection"; - } else { - &Debug(9,"MakeLondConnection got socket: ".$Socket); - } - - - $event = Event->io(fd => $Socket, - poll => 'w', - cb => \&LondWritable, - data => ($Connection, undef), - desc => 'Connection to lond server'); - $ActiveConnections{$Lond} = $event; + $Connection->SetTimeoutCallback(\&SocketTimeout); - $ConnectionCount++; - + my $event = Event->io(fd => $Socket, + poll => 'w', + cb => \&LondWritable, + data => $Connection, + desc => 'Connection to lond server'); + $ActiveConnections{$Connection} = $event; + if ($ConnectionCount == 0) { + &SetupTimer; # Need to handle timeouts with connections... + } + $ConnectionCount++; + Debug(4, "Connection count = ".$ConnectionCount); + if($ConnectionCount == 1) { # First Connection: + QueueDelayed; + } + Log("SUCESS", "Created connection ".$ConnectionCount + ." to host ".GetServerHost()); + $LondConnecting = 1; # Connection in progress. + return 1; # Return success. + } } @@ -705,18 +1228,18 @@ The text of the request to send. =cut sub StartRequest { - my $Lond = shift; - my $Client = shift; - my $Request = shift; + + my ($Lond, $Request) = @_; - Debug(6, "StartRequest: ".$Request); + Debug(6, "StartRequest: ".$Request->getRequest()); my $Socket = $Lond->GetSocket(); - $ActiveTransactions{$Lond} = $Client; # Socket to relay to client. + $Request->Activate($Lond); + $ActiveTransactions{$Lond} = $Request; - $Lond->InitiateTransaction($Request); - $event = Event->io(fd => $Lond->GetSocket(), + $Lond->InitiateTransaction($Request->getRequest()); + my $event = Event->io(fd => $Socket, poll => "w", cb => \&LondWritable, data => $Lond, @@ -747,23 +1270,35 @@ data to send to the lond. =cut sub QueueTransaction { - my $requestSocket = shift; - my $requestData = shift; - Debug(6,"QueueTransaction: ".$requestData); + my $requestData = shift; # This is a LondTransaction. + my $cmd = $requestData->getRequest(); + + Debug(6,"QueueTransaction: ".$cmd); my $LondSocket = $IdleConnections->pop(); if(!defined $LondSocket) { # Need to queue request. - Debug(8,"Must queue..."); - $ClientQueue->enqueue($requestSocket); + Debug(5,"Must queue..."); $WorkQueue->enqueue($requestData); - if($ConnectionCount < $MaxConnectionCount) { - Debug(4,"Starting additional lond connection"); - MakeLondConnection(); + Debug(5, "Queue Transaction startnew $ConnectionCount $LondConnecting"); + if(($ConnectionCount < $MaxConnectionCount) && (! $LondConnecting)) { + + if($ConnectionRetriesLeft > 0) { + Debug(5,"Starting additional lond connection"); + if(&MakeLondConnection() == 0) { + EmptyQueue(); # Fail transactions, can't make connection. + CloseAllLondConnections; # Should all be closed but... + } + } else { + ShowStatus(GetServerHost()." >>> DEAD !!!! <<<"); + $LondConnecting = 0; + EmptyQueue(); # It's worse than that ... he's dead Jim. + CloseAllLondConnections; # Should all be closed but.. + } } } else { # Can start the request: Debug(8,"Can start..."); - StartRequest($LondSocket, $requestSocket, $requestData); + StartRequest($LondSocket, $requestData); } } @@ -772,7 +1307,6 @@ sub QueueTransaction { =pod =head2 ClientRequest - Callback that is called when data can be read from the UNIX domain socket connecting us with an apache server process. @@ -791,19 +1325,31 @@ sub ClientRequest { my $rv = $socket->recv($thisread, POSIX::BUFSIZ, 0); Debug(8, "rcv: data length = ".length($thisread) ." read =".$thisread); - unless (defined $rv && length($thisread)) { + unless (defined $rv && length($thisread)) { # Likely eof on socket. Debug(5,"Client Socket closed on lonc for ".$RemoteHost); close($socket); $watcher->cancel(); delete($ActiveClients{$socket}); + return; } Debug(8,"Data: ".$data." this read: ".$thisread); $data = $data.$thisread; # Append new data. $watcher->data($data); - if($data =~ /(.*\n)/) { # Request entirely read. + if($data =~ /\n$/) { # Request entirely read. + if($data eq "close_connection_exit\n") { + Log("CRITICAL", + "Request Close Connection ... exiting"); + CloseAllLondConnections(); + exit; + } Debug(8, "Complete transaction received: ".$data); - QueueTransaction($socket, $data); + if($LogTransactions) { + Log("SUCCESS", "Transaction: '$data'"); # Transaction has \n. + } + my $Transaction = LondTransaction->new($data); + $Transaction->SetClient($socket); + QueueTransaction($Transaction); $watcher->cancel(); # Done looking for input data. } @@ -865,7 +1411,7 @@ Returns the host whose lond we talk with =cut -sub GetServerHost { # Stub - get this from config. +sub GetServerHost { return $RemoteHost; # Setup by the fork. } @@ -877,7 +1423,7 @@ Returns the lond port number. =cut -sub GetServerPort { # Stub - get this from config. +sub GetServerPort { return $perlvar{londPort}; } @@ -898,8 +1444,8 @@ sub SetupLoncListener { my $socket; my $SocketName = GetLoncSocketPath(); unlink($SocketName); - unless ($socket = IO::Socket::UNIX->new(Local => $SocketName, - Listen => 10, + unless ($socket =IO::Socket::UNIX->new(Local => $SocketName, + Listen => 250, Type => SOCK_STREAM)) { die "Failed to create a lonc listner socket"; } @@ -909,8 +1455,106 @@ sub SetupLoncListener { fd => $socket); } +# +# Toggle transaction logging. +# Implicit inputs: +# LogTransactions +# Implicit Outputs: +# LogTransactions +sub ToggleTransactionLogging { + print STDERR "Toggle transaction logging...\n"; + if(!$LogTransactions) { + $LogTransactions = 1; + } else { + $LogTransactions = 0; + } + + + Log("SUCCESS", "Toggled transaction logging: $LogTransactions \n"); +} + +=pod + +=head2 ChildStatus + +Child USR1 signal handler to report the most recent status +into the status file. + +We also use this to reset the retries count in order to allow the +client to retry connections with a previously dead server. +=cut + +sub ChildStatus { + my $event = shift; + my $watcher = $event->w; + + Debug(2, "Reporting child status because : ".$watcher->data); + my $docdir = $perlvar{'lonDocRoot'}; + + open(LOG,">>$docdir/lon-status/loncstatus.txt"); + flock(LOG,LOCK_EX); + print LOG $$."\t".$RemoteHost."\t".$Status."\t". + $RecentLogEntry."\n"; + # + # Write out information about each of the connections: + # + if ($DebugLevel > 2) { + print LOG "Active connection statuses: \n"; + my $i = 1; + print STDERR "================================= Socket Status Dump:\n"; + foreach my $item (keys %ActiveConnections) { + my $Socket = $ActiveConnections{$item}->data; + my $state = $Socket->GetState(); + print LOG "Connection $i State: $state\n"; + print STDERR "---------------------- Connection $i \n"; + $Socket->Dump(-1); # Ensure it gets dumped.. + $i++; + } + } + flock(LOG,LOCK_UN); + close(LOG); + $ConnectionRetriesLeft = $ConnectionRetries; +} + =pod +=head2 SignalledToDeath + +Called in response to a signal that causes a chid process to die. + +=cut + + +sub SignalledToDeath { + my $event = shift; + my $watcher= $event->w; + + Debug(2,"Signalled to death! via ".$watcher->data); + my ($signal) = $watcher->data; + chomp($signal); + Log("CRITICAL", "Abnormal exit. Child $$ for $RemoteHost " + ."died through "."\"$signal\""); + LogPerm("F:lonc: $$ on $RemoteHost signalled to death: " + ."\"$signal\""); + exit 0; + +} + +=head2 ToggleDebug + +This sub toggles trace debugging on and off. + +=cut + +sub ToggleDebug { + my $Current = $DebugLevel; + $DebugLevel = $NextDebugLevel; + $NextDebugLevel = $Current; + + Log("SUCCESS", "New debugging level for $RemoteHost now $DebugLevel"); + +} + =head2 ChildProcess This sub implements a child process for a single lonc daemon. @@ -919,18 +1563,26 @@ This sub implements a child process for sub ChildProcess { - print "Loncnew\n"; - # For now turn off signals. - - $SIG{QUIT} = IGNORE; - $SIG{HUP} = IGNORE; - $SIG{USR1} = IGNORE; - $SIG{INT} = IGNORE; - $SIG{CHLD} = IGNORE; - $SIG{__DIE__} = IGNORE; + # + # Signals must be handled by the Event framework... +# + + Event->signal(signal => "QUIT", + cb => \&SignalledToDeath, + data => "QUIT"); + Event->signal(signal => "HUP", + cb => \&ChildStatus, + data => "HUP"); + Event->signal(signal => "USR1", + cb => \&ChildStatus, + data => "USR1"); + Event->signal(signal => "USR2", + cb => \&ToggleTransactionLogging); + Event->signal(signal => "INT", + cb => \&ToggleDebug, + data => "INT"); - SetupTimer(); SetupLoncListener(); @@ -940,8 +1592,9 @@ sub ChildProcess { # Setup the initial server connection: - &MakeLondConnection(); - + # &MakeLondConnection(); // let first work requirest do it. + + Debug(9,"Entering event loop"); my $ret = Event::loop(); # Start the main event loop. @@ -953,14 +1606,23 @@ sub ChildProcess { sub CreateChild { my $host = shift; + + my $sigset = POSIX::SigSet->new(SIGINT); + sigprocmask(SIG_BLOCK, $sigset); $RemoteHost = $host; - Debug(3, "Forking off child for ".$RemoteHost); - sleep(5); - $pid = fork; + Log("CRITICAL", "Forking server for ".$host); + my $pid = fork; if($pid) { # Parent - $ChildHash{$pid} = $RemoteHost; + $RemoteHost = "Parent"; + $ChildHash{$pid} = $host; + $HostToPid{$host}= $pid; + sigprocmask(SIG_UNBLOCK, $sigset); + } else { # child. - ChildProcess; + ShowStatus("Connected to ".$RemoteHost); + $SIG{INT} = 'DEFAULT'; + sigprocmask(SIG_UNBLOCK, $sigset); + ChildProcess; # Does not return. } } @@ -974,27 +1636,299 @@ sub CreateChild { # Each exit gets logged and the child gets restarted. # +# +# Fork and start in new session so hang-up isn't going to +# happen without intent. +# + + + + + + +ShowStatus("Forming new session"); +my $childpid = fork; +if ($childpid != 0) { + sleep 4; # Give child a chacne to break to + exit 0; # a new sesion. +} +# +# Write my pid into the pid file so I can be located +# + +ShowStatus("Parent writing pid file:"); +my $execdir = $perlvar{'lonDaemons'}; +open (PIDSAVE, ">$execdir/logs/lonc.pid"); +print PIDSAVE "$$\n"; +close(PIDSAVE); + + + +if (POSIX::setsid() < 0) { + print "Could not create new session\n"; + exit -1; +} + +ShowStatus("Forking node servers"); + +Log("CRITICAL", "--------------- Starting children ---------------"); + +LondConnection::ReadConfig; # Read standard config files. my $HostIterator = LondConnection::GetHostIterator; while (! $HostIterator->end()) { - $hostentryref = $HostIterator->get(); + my $hostentryref = $HostIterator->get(); CreateChild($hostentryref->[0]); + $HostHash{$hostentryref->[0]} = $hostentryref->[4]; $HostIterator->next(); } +$RemoteHost = "Parent Server"; # Maintain the population: +ShowStatus("Parent keeping the flock"); + +# +# Set up parent signals: +# + +$SIG{INT} = \&Terminate; +$SIG{TERM} = \&Terminate; +$SIG{HUP} = \&Restart; +$SIG{USR1} = \&CheckKids; +$SIG{USR2} = \&UpdateKids; # LonManage update request. + while(1) { - $deadchild = wait(); + my $deadchild = wait(); if(exists $ChildHash{$deadchild}) { # need to restart. - $deadhost = $ChildHash{$deadchild}; + my $deadhost = $ChildHash{$deadchild}; + delete($HostToPid{$deadhost}); delete($ChildHash{$deadchild}); - Debug(4,"Lost child pid= ".$deadchild. + Log("WARNING","Lost child pid= ".$deadchild. "Connected to host ".$deadhost); + Log("INFO", "Restarting child procesing ".$deadhost); CreateChild($deadhost); } } + + +=pod + +=head1 CheckKids + + Since kids do not die as easily in this implementation +as the previous one, there is no need to restart the +dead ones (all dead kids get restarted when they die!!) +The only thing this function does is to pass USR1 to the +kids so that they report their status. + +=cut + +sub CheckKids { + Debug(2, "Checking status of children"); + my $docdir = $perlvar{'lonDocRoot'}; + my $fh = IO::File->new(">$docdir/lon-status/loncstatus.txt"); + my $now=time; + my $local=localtime($now); + print $fh "LONC status $local - parent $$ \n\n"; + foreach my $pid (keys %ChildHash) { + Debug(2, "Sending USR1 -> $pid"); + kill 'USR1' => $pid; # Tell Child to report status. + } +} + +=pod + +=head1 UpdateKids + +parent's SIGUSR2 handler. This handler: + +=item + +Rereads the hosts file. + +=item + +Kills off (via sigint) children for hosts that have disappeared. + +=item + +QUITs children for hosts that already exist (this just forces a status display +and resets the connection retry count for that host. + +=item + +Starts new children for hosts that have been added to the hosts.tab file since +the start of the master program and maintains them. + +=cut + +sub UpdateKids { + + Log("INFO", "Updating connections via SIGUSR2"); + + # Just in case we need to kill our own lonc, we wait a few seconds to + # give it a chance to receive and relay lond's response to the + # re-init command. + # + + sleep(2); # Wait a couple of seconds. + + my %hosts; # Indexed by loncapa hostname, value=ip. + + # Need to re-read the host table: + + + LondConnection::ReadConfig(); + my $I = LondConnection::GetHostIterator; + while (! $I->end()) { + my $item = $I->get(); + $hosts{$item->[0]} = $item->[4]; + $I->next(); + } + + # The logic below is written for clarity not for efficiency. + # Since I anticipate that this function is only rarely called, that's + # appropriate. There are certainly ways to combine the loops below, + # and anyone wishing to obscure the logic is welcome to go for it. + # Note that we don't re-direct sigchild. Instead we do what's needed + # to the data structures that keep track of children to ensure that + # when sigchild is honored, no new child is born. + # + + # For each existing child; if it's host doesn't exist, kill the child. + + foreach my $child (keys %ChildHash) { + my $oldhost = $ChildHash{$child}; + if (!(exists $hosts{$oldhost})) { + Log("CRITICAL", "Killing child for $oldhost host no longer exists"); + delete $ChildHash{$child}; + delete $HostToPid{$oldhost}; + kill 'QUIT' => $child; + } + } + # For each remaining existing child; if it's host's ip has changed, + # Restart the child on the new IP. + + foreach my $child (keys %ChildHash) { + my $oldhost = $ChildHash{$child}; + my $oldip = $HostHash{$oldhost}; + if ($hosts{$oldhost} ne $oldip) { + + # kill the old child. + + Log("CRITICAL", "Killing child for $oldhost host ip has changed..."); + delete $ChildHash{$child}; + delete $HostToPid{$oldhost}; + kill 'QUIT' => $child; + + # Do the book-keeping needed to start a new child on the + # new ip. + + $HostHash{$oldhost} = $hosts{$oldhost}; + CreateChild($oldhost); + } + } + # Finally, for each new host, not in the host hash, create a + # enter the host and create a new child. + # Force a status display of any existing process. + + foreach my $host (keys %hosts) { + if(!(exists $HostHash{$host})) { + Log("INFO", "New host $host discovered in hosts.tab..."); + $HostHash{$host} = $hosts{$host}; + CreateChild($host); + } else { + kill 'HUP' => $HostToPid{$host}; # status display. + } + } +} + + +=pod + +=head1 Restart + +Signal handler for HUP... all children are killed and +we self restart. This is an el-cheapo way to re read +the config file. + +=cut + +sub Restart { + &KillThemAll; # First kill all the children. + Log("CRITICAL", "Restarting"); + my $execdir = $perlvar{'lonDaemons'}; + unlink("$execdir/logs/lonc.pid"); + exec("$execdir/loncnew"); +} + +=pod + +=head1 KillThemAll + +Signal handler that kills all children by sending them a +SIGHUP. Responds to sigint and sigterm. + +=cut + +sub KillThemAll { + Debug(2, "Kill them all!!"); + local($SIG{CHLD}) = 'IGNORE'; # Our children >will< die. + foreach my $pid (keys %ChildHash) { + my $serving = $ChildHash{$pid}; + ShowStatus("Nicely Killing lonc for $serving pid = $pid"); + Log("CRITICAL", "Nicely Killing lonc for $serving pid = $pid"); + kill 'QUIT' => $pid; + } + + +} + + +# +# Kill all children via KILL. Just in case the +# first shot didn't get them. + +sub really_kill_them_all_dammit +{ + Debug(2, "Kill them all Dammit"); + local($SIG{CHLD} = 'IGNORE'); # In case some purist reenabled them. + foreach my $pid (keys %ChildHash) { + my $serving = $ChildHash{$pid}; + &ShowStatus("Nastily killing lonc for $serving pid = $pid"); + Log("CRITICAL", "Nastily killing lonc for $serving pid = $pid"); + kill 'KILL' => $pid; + delete($ChildHash{$pid}); + my $execdir = $perlvar{'lonDaemons'}; + unlink("$execdir/logs/lonc.pid"); + } +} +=pod + +=head1 Terminate + +Terminate the system. + +=cut + +sub Terminate { + &Log("CRITICAL", "Asked to kill children.. first be nice..."); + &KillThemAll; + # + # By now they really should all be dead.. but just in case + # send them all SIGKILL's after a bit of waiting: + + sleep(4); + &Log("CRITICAL", "Now kill children nasty"); + &really_kill_them_all_dammit; + Log("CRITICAL","Master process exiting"); + exit 0; + +} +=pod + =head1 Theory The event class is used to build this as a single process with an