[BACK]Return to lonc CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/Attic/lonc between versions 1.31 and 1.43

version 1.31, 2002/03/03 18:13:07 version 1.43, 2002/10/30 14:50:04
Line 45 Line 45
 # 12/20 Scott Harrison  # 12/20 Scott Harrison
 # YEAR=2002  # YEAR=2002
 # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer  # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer
 #   # 3/07/02 Ron Fox 
 # based on nonforker from Perl Cookbook  # based on nonforker from Perl Cookbook
 # - server who multiplexes without forking  # - server who multiplexes without forking
   # 5/11/2002 Scott Harrison
   
   use lib '/home/httpd/lib/perl/';
   use LONCAPA::Configuration;
   
 use POSIX;  use POSIX;
 use IO::Socket;  use IO::Socket;
Line 57  use Socket; Line 61  use Socket;
 use Fcntl;  use Fcntl;
 use Tie::RefHash;  use Tie::RefHash;
 use Crypt::IDEA;  use Crypt::IDEA;
 use Net::Ping;  #use Net::Ping;
 use LWP::UserAgent();  use LWP::UserAgent();
   
 $status='';  $status='';
 $lastlog='';  $lastlog='';
 $conserver='SHELL';  $conserver='SHELL';
   $DEBUG = 0; # Set to 1 for annoyingly complete logs.
   
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
   
Line 70  $conserver='SHELL'; Line 75  $conserver='SHELL';
 $SIG{QUIT}=\&catchexception;  $SIG{QUIT}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
 # ------------------------------------ Read httpd access.conf and get variables  # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
 &status("Read access.conf");  &status("Read loncapa.conf and loncapa_apache.conf");
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
   my %perlvar=%{$perlvarref};
 while ($configline=<CONFIG>) {  undef $perlvarref;
     if ($configline =~ /PerlSetVar/) {  
  my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);  
         chomp($varvalue);  
         $perlvar{$varname}=$varvalue;  
     }  
 }  
 close(CONFIG);  
   
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
 &status("Check user ID");  &status("Check user ID");
Line 158  $SIG{HUP}=$SIG{USR1}='IGNORE'; Line 156  $SIG{HUP}=$SIG{USR1}='IGNORE';
 &status("Forking ...");  &status("Forking ...");
   
 foreach $thisserver (keys %hostip) {  foreach $thisserver (keys %hostip) {
     if (&online($hostname{$thisserver})) {      #if (&online($hostname{$thisserver})) {
        make_new_child($thisserver);         make_new_child($thisserver);
     }      #}
 }  }
   
 &logthis("Done starting initial servers");  &logthis("Done starting initial servers");
 # ----------------------------------------------------- Install signal handlers  # ----------------------------------------------------- Install signal handlers
   
 $SIG{CHLD} = \&REAPER;  
 $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 $SIG{HUP}  = \&HUPSMAN;  $SIG{HUP}  = \&HUPSMAN;
 $SIG{USR1} = \&USRMAN;  $SIG{USR1} = \&USRMAN;
   
 # And maintain the population.  # And maintain the population.
 while (1) {  while (1) {
     &status("Sleeping");      my $deadpid = wait; # Wait for the next child to die.
     sleep;                          # wait for a signal (i.e., child's death)                                  # See who died and start new one
                                     # See who died and start new one                                  # or a signal (e.g. USR1 for restart).
                                   # if a signal, the wait will fail
                                   # This is ordinarily detected by
                                   # checking for the existence of the
                                   # pid index inthe children hash since
                                   # the return value from a failed wait is -1
                                   # which is an impossible PID.
     &status("Woke up");      &status("Woke up");
     my $skipping='';      my $skipping='';
     foreach $thisserver (keys %hostip) {  
         if (!$childpid{$thisserver}) {      if(exists($children{$deadpid})) {
     if (($childatt{$thisserver}<$childmaxattempts) &&  
                 (&online($hostname{$thisserver}))) {   $thisserver = $children{$deadpid}; # Look name of dead guy's peer.
        $childatt{$thisserver}++;  
                &logthis(   delete($children{$deadpid}); # Get rid of dead hash entry.
    "<font color=yellow>INFO: Trying to reconnect for $thisserver "  
   ."($childatt{$thisserver} of $childmaxattempts attempts)</font>");    if($childatt{$thisserver} < $childmaxattempts) {
                make_new_child($thisserver);      $childatt{$thisserver}++;
    } else {      &logthis(
                $skipping.=$thisserver.' ';         "<font color=yellow>INFO: Trying to reconnect for $thisserver "
            }               ."($childatt{$thisserver} of $childmaxattempts attempts)</font>"); 
                      make_new_child($thisserver);
         }         
     }   }
     if ($skipping) {    else {
        &logthis("<font color=blue>WARNING: Skipped $skipping</font>");      $skipping .= $thisserver.' ';
    }
    if($skipping) {
       &logthis("<font color=blue>WARNING: Skipped $skipping</font>");
     
    }
     }      }
   
 }  }
   
   
   
 sub make_new_child {  sub make_new_child {
         
     $newserver=shift;      $newserver=shift;
Line 217  sub make_new_child { Line 228  sub make_new_child {
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $newserver;          $children{$pid} = $newserver;
         $childpid{$conserver} = $pid;          $childpid{$newserver} = $pid;
         return;          return;
     } else {      } else {
         $conserver=$newserver;          $conserver=$newserver;
Line 238  unlink($port); Line 249  unlink($port);
 # -------------------------------------------------------------- Open other end  # -------------------------------------------------------------- Open other end
   
 &openremote($conserver);  &openremote($conserver);
    &logthis("<font color=green> Connection to $conserver open </font>");
 # ----------------------------------------- We're online, send delayed messages  # ----------------------------------------- We're online, send delayed messages
     &status("Checking for delayed messages");      &status("Checking for delayed messages");
   
     my @allbuffered;      my @allbuffered;
     my $path="$perlvar{'lonSockDir'}/delayed";      my $path="$perlvar{'lonSockDir'}/delayed";
     opendir(DIRHANDLE,$path);      opendir(DIRHANDLE,$path);
Line 250  unlink($port); Line 262  unlink($port);
     foreach (@allbuffered) {      foreach (@allbuffered) {
         &status("Sending delayed: $_");          &status("Sending delayed: $_");
         $dfname="$path/$_";          $dfname="$path/$_";
         &logthis('Sending '.$dfname);          if($DEBUG) { &logthis('Sending '.$dfname); }
         my $wcmd;          my $wcmd;
         {          {
          my $dfh=IO::File->new($dfname);           my $dfh=IO::File->new($dfname);
Line 271  unlink($port); Line 283  unlink($port);
             }              }
             $cmd="enc:$cmdlength:$encrequest\n";              $cmd="enc:$cmdlength:$encrequest\n";
         }          }
     $SIG{ALRM}=sub { die "timeout" };   $answer = londtransaction($remotesock, $cmd, 60);
     $SIG{__DIE__}='DEFAULT';  
     eval {  
         alarm(60);  
         print $remotesock "$cmd\n";  
         $answer=<$remotesock>;  
  chomp($answer);   chomp($answer);
         alarm(0);  
     };  
     $SIG{ALRM}='DEFAULT';  
     $SIG{__DIE__}=\&catchexception;  
   
         if (($answer ne '') && ($@!~/timeout/)) {          if (($answer ne '') && ($@!~/timeout/)) {
     unlink("$dfname");      unlink("$dfname");
Line 289  unlink($port); Line 292  unlink($port);
             &logperm("S:$conserver:$bcmd");              &logperm("S:$conserver:$bcmd");
         }                  }        
     }      }
    if($DEBUG) { &logthis("<font color=green> Delayed transactions sent"); }
   
 # ------------------------------------------------------- Listen to UNIX socket  # ------------------------------------------------------- Listen to UNIX socket
 &status("Opening socket");  &status("Opening socket");
Line 300  unless ( Line 304  unless (
        my $st=120+int(rand(240));         my $st=120+int(rand(240));
        &logthis(         &logthis(
          "<font color=blue>WARNING: ".           "<font color=blue>WARNING: ".
          "Can't make server socket ($st secs): $@</font>");           "Can't make server socket ($st secs):  .. exiting</font>");
        sleep($st);         sleep($st);
        exit;          exit; 
      };       };
      
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
   
 &logthis("<font color=green>$conserver online</font>");  &logthis("<font color=green>$conserver online</font>");
Line 314  unless ( Line 318  unless (
 %inbuffer  = ();  %inbuffer  = ();
 %outbuffer = ();  %outbuffer = ();
 %ready     = ();  %ready     = ();
   %servers   = (); # To be compatible with make filevector.  indexed by
    # File ids, values are sockets.
    # note that the accept socket is omitted.
   
 tie %ready, 'Tie::RefHash';  tie %ready, 'Tie::RefHash';
   
 nonblock($server);  # nonblock($server);
 $select = IO::Select->new($server);  # $select = IO::Select->new($server);
   
 # Main loop: check reads/accepts, check writes, check ready to process  # Main loop: check reads/accepts, check writes, check ready to process
   
   status("Main loop");
 while (1) {  while (1) {
     my $client;      my $client;
     my $rv;      my $rv;
     my $data;      my $data;
   
     # check for new information on the connections we have      my $infdset; # bit vec of fd's to select on input.
   
     # anything to read or accept?      my $outfdset; # Bit vec of fd's to select on output.
     foreach $client ($select->can_read(0.1)) {  
   
         if ($client == $server) {  
             # accept a new connection  
             &status("Accept new connection: $conserver");  
             $client = $server->accept();  
             $select->add($client);  
             nonblock($client);  
         } else {  
             # read data  
             $data = '';  
             $rv   = $client->recv($data, POSIX::BUFSIZ, 0);  
   
             unless (defined($rv) && length $data) {  
                 # This would be the end of file, so close the client  
                 delete $inbuffer{$client};  
                 delete $outbuffer{$client};  
                 delete $ready{$client};  
   
                 &status("Idle");  
                 $select->remove($client);  
                 close $client;  
                 next;  
             }  
   
             $inbuffer{$client} .= $data;      $infdset = MakeFileVector(\%servers);
       $outfdset= MakeFileVector(\%outbuffer);
       vec($infdset, $server->fileno, 1) = 1;
       if($DEBUG) {
    &logthis("Adding ".$server->fileno.
    " to input select vector (listner)".
    unpack("b*",$infdset)."\n");
       }
       DoSelect(\$infdset, \$outfdset); # Wait for input.
       if($DEBUG) {
    &logthis("Doselect completed!");
    &logthis("ins = ".unpack("b*",$infdset)."\n");
    &logthis("outs= ".unpack("b*",$outfdset)."\n");
     
       }
   
             # test whether the data in the buffer or the data we      # Checkfor new connections:
             # just read means there is a complete request waiting      if (vec($infdset, $server->fileno, 1)) {
             # to be fulfilled.  If there is, set $ready{$client}   if($DEBUG) {
             # to the requests waiting to be fulfilled.      &logthis("New connection established");
             while ($inbuffer{$client} =~ s/(.*\n)//) {   }
                 push( @{$ready{$client}}, $1 );   # accept a new connection
             }   &status("Accept new connection: $conserver");
         }   $client = $server->accept();
    if($DEBUG) {
       &logthis("New client fd = ".$client->fileno."\n");
    }
    $servers{$client->fileno} = $client;
    nonblock($client);
     }      }
       HandleInput($infdset, \%servers, \%inbuffer, \%outbuffer, \%ready);
       HandleOutput($outfdset, \%servers, \%outbuffer, \%inbuffer,
    \%ready);
   # -------------------------------------------------------- Wow, connection lost
   
     # Any complete requests to process?  }
     foreach $client (keys %ready) {     
         handle($client);  
     }      }
   }
   
     # Buffers to flush?  # ------------------------------------------------------- End of make_new_child
     foreach $client ($select->can_write(1)) {  
         # Skip this client if we have nothing to say  
         next unless exists $outbuffer{$client};  
   
         $rv = $client->send($outbuffer{$client}, 0);  
   
       unless ($outbuffer{$client} eq "con_lost\n") {  #
         unless (defined $rv) {  #  Make a vector of file descriptors to wait for in a select.
             # Whine, but move on.  #  parameters:
             &logthis("I was told I could write, but I can't.\n");  #     \%fdhash  -reference to a hash which has IO::Socket's as indices.  
             next;  #                We only care about the indices, not the values.
         }  #  A select vector is created from all indices of the hash.
         $errno=$!;  
         if (($rv == length $outbuffer{$client}) ||  sub MakeFileVector
             ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) {  {
             substr($outbuffer{$client}, 0, $rv) = '';      my $fdhash = shift;
             delete $outbuffer{$client} unless length $outbuffer{$client};      my $selvar = "";
         } else {  
             # Couldn't write all the data, and it wasn't because      foreach $socket (keys %$fdhash) {
             # it would have blocked.  Shutdown and move on.   if($DEBUG) {
       &logthis("Adding  ".$socket.
        "to select vector. (client)\n");
    }
    vec($selvar, $socket, 1) = 1;
       }
       return $selvar;
   }
   
     &logthis("Dropping data with ".$errno.": ".  
                      length($outbuffer{$client}).", $rv");  
   
             delete $inbuffer{$client};  #
             delete $outbuffer{$client};  #  HandleOutput:
             delete $ready{$client};  #    Processes output on a buffered set of file descriptors which are
   #    ready to be read.
             $select->remove($client);  #  Parameters:
             close($client);  #    $selvector - Vector of file descriptors which are writable.
             next;  #    \%sockets  - Vector of socket references indexed by socket.
         }  #    \%buffers  - Reference to a hash containing output buffers.
       } else {  #                 Hashes are indexed by sockets.  The file descriptors of some
 # -------------------------------------------------------- Wow, connection lost  #                 of those sockets will be present in $selvector.
          &logthis(  #                 For each one of those, we will attempt to write the output
      "<font color=red>CRITICAL: Closing connection</font>");  #                 buffer to the socket.  Note that we will assume that
  &status("Connection lost");  #                 the sockets are being run in non blocking mode.
          $remotesock->shutdown(2);  #   \%inbufs    - Reference to hash containing input buffers.
          &logthis("Attempting to open new connection");  #   \%readys    - Reference to hash containing flags for items with complete
          &openremote($conserver);            #                 requests.
       }  #
   sub HandleOutput
   {
       my $selvector = shift;
       my $sockets   = shift;
       my $buffers   = shift;
       my $inbufs    = shift;
       my $readys    = shift;
       my $sock;
   
       if($DEBUG) {
    &logthis("HandleOutput entered\n");
     }      }
      
       foreach $sock (keys %$sockets) {
    my $socket = $sockets->{$sock};
    if(vec($selvector, $sock, 1)) { # $socket is writable.
       if($DEBUG) {
    &logthis("Sending $buffers->{$sock} \n");
       }
       my $rv = $socket->send($buffers->{$sock}, 0);
       $errno = $!;
       unless ($buffers->{$sock} eq "con_lost\n") {
    unless (defined $rv) { # Write failed... could be EINTR
       unless ($errno == POSIX::EINTR) {
    &logthis("Write failed on writable socket");
       } # EINTR is not an error .. just retry.
       next;
    }
    if( ($rv == length $buffers->{$sock})    ||
       ($errno == POSIX::EWOULDBLOCK)       ||
       ($errno == POSIX::EAGAIN)            || # same as above.
       ($errno == POSIX::EINTR)             || # signal during IO
       ($errno == 0)) {
       substr($buffers->{$sock}, 0, $rv)=""; # delete written part
       delete $buffers->{$sock} unless length $buffers->{$sock};
    } else {
       # For some reason the write failed with an error code
       # we didn't look for.  Shutdown the socket.
       &logthis("Unable to write data with ".$errno.": ".
        "Dropping data: ".length($buffers->{$sock}).
        ", $rv");
       #
       # kill off the buffers in the hash:
   
       delete $buffers->{$sock};
       delete $inbufs->{$sock};
       delete $readys->{$sock};
   
       close($socket); # Close the client socket.
       next;
    }
       } else { # Kludgy way to mark lond connection lost.
    &logthis(
    "<font color=red>CRITICAL lond connection lost</font>");
    status("Connection lost");
    $remotesock->shutdown(2);
    &logthis("Attempting to open a new connection");
    &openremote($conserver);
       }
      
    }
       }
   
 }  }
   #
   #   HandleInput - Deals with input on client sockets.
   #                 Each socket has an associated input buffer.
   #                 For each readable socket, the currently available
   #                 data is appended to this buffer.
   #                 If necessary, the buffer is created.
   #                 On various failures, we may shutdown the client.
   #  Parameters:
   #     $selvec   - Vector of readable sockets.
   #     \%sockets - Refers to the  Hash of sockets indexed by sockets.  
   #                 Each of these may or may not have it's fd bit set 
   #                 in the $selvec.
   #     \%ibufs   - Refers to the hash of input buffers indexed by socket.
   #     \%obufs   - Hash of output buffers indexed by socket. 
   #     \%ready   - Hash of ready flags indicating the existence of a completed
   #                 Request.
   sub HandleInput 
   {
   
       # Marshall the parameters.   Note that the hashes are actually
       # references not values.
   
       my $selvec  = shift;
       my $sockets = shift;
       my $ibufs   = shift;
       my $obufs   = shift;
       my $ready   = shift;
       my $sock;
   
       if($DEBUG) {
    &logthis("Entered HandleInput\n");
       }
       foreach $sock (keys %$sockets) {
    my $socket = $sockets->{$sock};
    if(vec($selvec, $sock, 1)) { # Socket which is readable.
   
       #  Attempt to read the data and do error management.
       my $data = '';
       my $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
       if($DEBUG) {
    &logthis("Received $data from socket");
       }
       unless (defined($rv) && length $data) {
   
    # Read an end of file.. this is a disconnect from the peer.
   
    delete $sockets->{$sock};
    delete $ibufs->{$sock};
    delete $obufs->{$sock};
    delete $ready->{$sock};
   
    status("Idle");
    close $socket;
    next;
       }
       #  Append the read data to the input buffer. If the buffer
       # now contains a \n the request is complete and we can 
       # mark this in the $ready hash (one request for each \n.)
   
       $ibufs->{$sock} .= $data;
       while($ibufs->{$sock} =~ s/(.*\n)//) {
    push(@{$ready->{$sock}}, $1);
       }
       
    }
       }
       #  Now handle any requests which are ready:
   
       foreach $client (keys %ready) {
    handle($client);
       }
 }  }
   
 # ------------------------------------------------------- End of make_new_child  # DoSelect:  does a select with no timeout.  On signal (errno == EINTR), 
   #            the select is retried until there are items in the returned
   #            vectors.  
   #
   # Parameters:
   #   \$readvec   - Reference to a vector of file descriptors to 
   #                 check for readability.
   #   \$writevec  - Reference to a vector of file descriptors to check for
   #                 writability.
   #  On exit, the referents are modified with vectors indicating which 
   #  file handles are readable/writable.
   #
   sub DoSelect {
       my $readvec = shift;
       my $writevec= shift;
       my $outs;
       my $ins;
   
       while (1) {
    my $nfds = select( $ins = $$readvec, $outs = $$writevec, undef, undef);
    if($nfds) {
       if($DEBUG) {
    &logthis("select exited with ".$nfds." fds\n");
    &logthis("ins = ".unpack("b*",$ins).
    " readvec = ".unpack("b*",$$readvec)."\n");
    &logthis("outs = ".unpack("b*",$outs).
    " writevec = ".unpack("b*",$$writevec)."\n");
       }
       $$readvec  = $ins;
       $$writevec = $outs;
       return;
    } else {
       if($DEBUG) {
    &logthis("Select exited with no bits set in mask\n");
       }
       die "Select failed" unless $! == EINTR;
    }
       }
   }
   
 # handle($socket) deals with all pending requests for $client  # handle($socket) deals with all pending requests for $client
   #
 sub handle {  sub handle {
     # requests are in $ready{$client}      # requests are in $ready{$client}
     # send output to $outbuffer{$client}      # send output to $outbuffer{$client}
     my $client = shift;      my $client = shift;
     my $request;      my $request;
   
     foreach $request (@{$ready{$client}}) {      foreach $request (@{$ready{$client}}) {
 # ============================================================= Process request  # ============================================================= Process request
         # $request is the text of the request          # $request is the text of the request
         # put text of reply into $outbuffer{$client}          # put text of reply into $outbuffer{$client}
 # ------------------------------------------------------------ Is this the end?  # ------------------------------------------------------------ Is this the end?
    chomp($request);
    if($DEBUG) {
        &logthis("<font color=green> Request $request processing starts</font>");
           }
         if ($request eq "close_connection_exit\n") {          if ($request eq "close_connection_exit\n") {
     &status("Request close connection");      &status("Request close connection");
            &logthis(             &logthis(
      "<font color=red>CRITICAL: Request Close Connection</font>");       "<font color=red>CRITICAL: Request Close Connection ... exiting</font>");
            $remotesock->shutdown(2);             $remotesock->shutdown(2);
            $server->close();             $server->close();
            exit;             exit;
Line 452  sub handle { Line 636  sub handle {
                 $encrequest.=                  $encrequest.=
                     unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));                      unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
             }              }
             $request="enc:$cmdlength:$encrequest\n";              $request="enc:$cmdlength:$encrequest";
         }          }
 # --------------------------------------------------------------- Main exchange  # --------------------------------------------------------------- Main exchange
     $SIG{ALRM}=sub { die "timeout" };   $answer = londtransaction($remotesock, $request, 300);
     $SIG{__DIE__}='DEFAULT';  
     eval {   if($DEBUG) { 
         alarm(300);      &logthis("<font color=green> Request data exchange complete");
         &status("Sending: $request");   }
         print $remotesock "$request";   if ($@=~/timeout/) { 
         &status("Waiting for reply from $conserver: $request");      $answer='';
         $answer=<$remotesock>;      &logthis(
         &status("Received reply: $request");       "<font color=red>CRITICAL: Timeout: $request</font>");
         alarm(0);   }  
     };  
     if ($@=~/timeout/) {   
        $answer='';  
        &logthis(  
         "<font color=red>CRITICAL: Timeout: $request</font>");  
     }    
     $SIG{ALRM}='DEFAULT';  
     $SIG{__DIE__}=\&catchexception;  
   
   
         if ($answer) {          if ($answer) {
Line 488  sub handle { Line 664  sub handle {
       $answer=substr($answer,0,$cmdlength);        $answer=substr($answer,0,$cmdlength);
       $answer.="\n";        $answer.="\n";
    }     }
      if($DEBUG) {
          &logthis("sending $answer to client\n");
      }
            $outbuffer{$client} .= $answer;             $outbuffer{$client} .= $answer;
         } else {          } else {
            $outbuffer{$client} .= "con_lost\n";             $outbuffer{$client} .= "con_lost\n";
         }          }
   
      &status("Completed: $request");       &status("Completed: $request");
    if($DEBUG) {
       &logthis("<font color=green> Request processing complete</font>");
    }
 # ===================================================== Done processing request  # ===================================================== Done processing request
     }      }
     delete $ready{$client};      delete $ready{$client};
 # -------------------------------------------------------------- End non-forker  # -------------------------------------------------------------- End non-forker
       if($DEBUG) {
    &logthis("<font color=green> requests for child handled</font>");
       }
 }  }
 # ---------------------------------------------------------- End make_new_child  # ---------------------------------------------------------- End make_new_child
 }  
   
 # nonblock($socket) puts socket into nonblocking mode  # nonblock($socket) puts socket into nonblocking mode
 sub nonblock {  sub nonblock {
Line 522  sub openremote { Line 705  sub openremote {
     my $conserver=shift;      my $conserver=shift;
   
 &status("Opening TCP");  &status("Opening TCP");
       my $st=120+int(rand(240)); # Sleep before opening:
   
 unless (  unless (
   $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},    $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
Line 529  unless ( Line 713  unless (
                                       Proto    => "tcp",                                        Proto    => "tcp",
                                       Type     => SOCK_STREAM)                                        Type     => SOCK_STREAM)
    ) {      ) { 
        my $st=120+int(rand(240));  
        &logthis(         &logthis(
 "<font color=blue>WARNING: Couldn't connect ($st secs): $@</font>");  "<font color=blue>WARNING: Couldn't connect to $conserver ($st secs): </font>");
        sleep($st);         sleep($st);
        exit;          exit; 
      };       };
 # ----------------------------------------------------------------- Init dialog  # ----------------------------------------------------------------- Init dialog
   
   &logthis("<font color=green>INFO Connected to $conserver, initing </font>");
 &status("Init dialogue: $conserver");  &status("Init dialogue: $conserver");
   
      $SIG{ALRM}=sub { die "timeout" };      $answer = londtransaction($remotesock, "init", 60);
      $SIG{__DIE__}='DEFAULT';      chomp($answer);
      eval {      $answer = londtransaction($remotesock, $answer, 60);
          alarm(60);      chomp($answer);
 print $remotesock "init\n";  
 $answer=<$remotesock>;  
 print $remotesock "$answer";  
 $answer=<$remotesock>;  
 chomp($answer);  
           alarm(0);  
      };  
      $SIG{ALRM}='DEFAULT';  
      $SIG{__DIE__}=\&catchexception;  
     
      if ($@=~/timeout/) {       if ($@=~/timeout/) {
  &logthis("Timed out during init");   &logthis("Timed out during init.. exiting");
          exit;           exit;
      }       }
   
Line 597  if ($cipher=new IDEA $cipherkey) { Line 773  if ($cipher=new IDEA $cipherkey) {
    sleep($st);     sleep($st);
    exit;     exit;
 }  }
       &logthis("<font color=green> Remote open success </font>");
 }  }
   
   
Line 610  sub catchexception { Line 786  sub catchexception {
     chomp($signal);      chomp($signal);
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color=red>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through "       ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through "
      ."\"$signal\" with parameter [$@]</font>");       ."\"$signal\" with parameter </font>");
     die($@);      die("Signal abend");
 }  }
   
 # -------------------------------------- Routines to see if other box available  # -------------------------------------- Routines to see if other box available
   
 sub online {  #sub online {
     my $host=shift;  #    my $host=shift;
     &status("Pinging ".$host);  #    &status("Pinging ".$host);
     my $p=Net::Ping->new("tcp",20);  #    my $p=Net::Ping->new("tcp",20);
     my $online=$p->ping("$host");  #    my $online=$p->ping("$host");
     $p->close();  #    $p->close();
     undef ($p);  #    undef ($p);
     return $online;  #    return $online;
 }  #}
   
 sub connected {  sub connected {
     my ($local,$remote)=@_;      my ($local,$remote)=@_;
Line 635  sub connected { Line 811  sub connected {
     unless ($hostname{$local}) { return 'local_unknown'; }      unless ($hostname{$local}) { return 'local_unknown'; }
     unless ($hostname{$remote}) { return 'remote_unknown'; }      unless ($hostname{$remote}) { return 'remote_unknown'; }
   
     unless (&online($hostname{$local})) { return 'local_offline'; }      #unless (&online($hostname{$local})) { return 'local_offline'; }
   
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
           
Line 654  sub connected { Line 830  sub connected {
 }  }
   
   
 sub REAPER {                        # takes care of dead children  
     $SIG{CHLD} = \&REAPER;  
     my $pid = wait;  
     my $wasserver=$children{$pid};  
     &logthis("<font color=red>CRITICAL: "  
      ."Child $pid for server $wasserver died ($childatt{$wasserver})</font>");  
     delete $children{$pid};  
     delete $childpid{$wasserver};  
     my $port = "$perlvar{'lonSockDir'}/$wasserver";  
     unlink($port);  
 }  
   
 sub hangup {  sub hangup {
     foreach (keys %children) {      foreach (keys %children) {
Line 709  sub checkchildren { Line 874  sub checkchildren {
   
 sub USRMAN {  sub USRMAN {
     &logthis("USR1: Trying to establish connections again");      &logthis("USR1: Trying to establish connections again");
     %childatt=();      #
     &checkchildren();      #  It is really important not to just clear the childatt hash or we will
       #  lose all memory of the children.  What we really want to do is this:
       #  For each index where childatt is >= $childmaxattempts
       #  Zero the associated counter and do a make_child for the host.
       #  Regardles, the childatt entry is zeroed:
       my $host;
       foreach $host (keys %childatt) {
    if ($childatt{$host} >= $childmaxattempts) {
       $childatt{$host} = 0;
       &logthis("<font color=green>INFO: Restarting child for server: "
        .$host."</font>\n");
       make_new_child($host);
    }
    else {
       $childatt{$host} = 0;
    }
       }
       &checkchildren(); # See if any children are still dead...
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
Line 725  sub subreply { Line 907  sub subreply {
        or return "con_lost";         or return "con_lost";
   
   
     $SIG{ALRM}=sub { die "timeout" };      $answer = londtransaction($sclient, $cmd, 10);
     $SIG{__DIE__}='DEFAULT';  
     eval {  
      alarm(10);  
      print $sclient "$cmd\n";  
      $answer=<$sclient>;  
      chomp($answer);  
      alarm(0);  
     };  
     if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; }      if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; }
     $SIG{ALRM}='DEFAULT';      $SIG{ALRM}='DEFAULT';
     $SIG{__DIE__}=\&catchexception;      $SIG{__DIE__}=\&catchexception;
Line 753  sub logthis { Line 928  sub logthis {
     print $fh "$local ($$) [$conserver] [$status]: $message\n";      print $fh "$local ($$) [$conserver] [$status]: $message\n";
 }  }
   
   #--------------------------------------  londtransaction:
   #  
   #  Performs a transaction with lond with timeout support.
   #    result = londtransaction(socket,request,timeout)
   #
   sub londtransaction {
       my ($socket, $request, $tmo) = @_;
   
       if($DEBUG) {
    &logthis("londtransaction request: $request");
       }
   
       # Set the signal handlers: ALRM for timeout and disble the others.
   
       $SIG{ALRM} = sub { die "timeout" };
       $SIG{__DIE__} = 'DEFAULT';
       
       # Disable all but alarm so that only that can interupt the
       # send /receive.
       #
       my $sigset = POSIX::SigSet->new(QUIT, USR1, HUP, INT, TERM);
       my $priorsigs = POSIX::SigSet->new;
       unless (defined sigprocmask(SIG_BLOCK, $sigset, $priorsigs)) {
    &logthis("<font color=red> CRITICAL -- londtransaction ".
    "failed to block signals </font>");
    die "could not block signals in londtransaction";
       }
       $answer = '';
       #
       #  Send request to lond.
       #
       eval { 
    alarm($tmo);
    print $socket "$request\n";
    alarm(0);
       };
       #  If request didn't timeout, try for the response.
       #
   
       if ($@!~/timeout/) {
    eval {
       alarm($tmo);
       $answer = <$socket>;
       if($DEBUG) {
    &logthis("Received $answer in londtransaction");
       }
       alarm(0);
    };
       } else {
    if($DEBUG) {
       &logthis("Timeout on send in londtransaction");
    }
       }
       if( ($@ =~ /timeout/)  && ($DEBUG)) {
    &logthis("Timeout on receive in londtransaction");
       }
       #
       # Restore the initial sigmask set.
       #
       unless (defined sigprocmask(SIG_UNBLOCK, $priorsigs)) {
    &logthis("<font color=red> CRITICAL -- londtransaction ".
    "failed to re-enable signal processing. </font>");
    die "londtransaction failed to re-enable signals";
       }
       #
       # go back to the prior handler set.
       #
       $SIG{ALRM} = 'DEFAULT';
       $SIG{__DIE__} = \&cathcexception;
   
       #    chomp $answer;
       if ($DEBUG) {
    &logthis("Returning $answer in londtransaction");
       }
       return $answer;
   
   }
   
 sub logperm {  sub logperm {
     my $message=shift;      my $message=shift;
Line 785  sub status { Line 1037  sub status {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     $status=$local.': '.$what;      $status=$local.': '.$what;
       $0='lonc: '.$what.' '.$local;
 }  }
   
   
Line 813  B<lonc> forks off children processes tha Line 1066  B<lonc> forks off children processes tha
 in the network.  Management of these processes can be done at the  in the network.  Management of these processes can be done at the
 parent process level or the child process level.  parent process level or the child process level.
   
     After forking off the children, B<lonc> the B<parent> 
   executes a main loop which simply waits for processes to exit.
   As a process exits, a new process managing a link to the same
   peer as the exiting process is created.  
   
 B<logs/lonc.log> is the location of log messages.  B<logs/lonc.log> is the location of log messages.
   
 The process management is now explained in terms of linux shell commands,  The process management is now explained in terms of linux shell commands,
Line 888  Subroutine B<USRMAN>: Line 1146  Subroutine B<USRMAN>:
 SIGUSR1 is sent to all the children, and the status of  SIGUSR1 is sent to all the children, and the status of
 each connection is logged.  each connection is logged.
   
 =item *  
   
 SIGCHLD  
   
 Parent signal assignment:  
  $SIG{CHLD} = \&REAPER;  
   
 Child signal assignment:  
  none  
   
 Command-line invocations:  
  B<kill> B<-s> SIGCHLD I<PID>  
   
 Subroutine B<REAPER>:  
  This is only invoked for the B<lonc> parent I<PID>.  
 Information pertaining to the child is removed.  
 The socket port is cleaned up.  
   
 =back  =back
   
Removed from v.1.31  
changed lines
  Added in v.1.43

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