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

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

version 1.33, 2002/03/20 03:42:45 version 1.43, 2002/10/30 14:50:04
Line 48 Line 48
 # 3/07/02 Ron Fox   # 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 71  $DEBUG = 0;   # Set to 1 for annoyingly Line 75  $DEBUG = 0;   # Set to 1 for annoyingly
 $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 175  $SIG{USR1} = \&USRMAN; Line 172  $SIG{USR1} = \&USRMAN;
 # And maintain the population.  # And maintain the population.
 while (1) {  while (1) {
     my $deadpid = wait; # Wait for the next child to die.      my $deadpid = wait; # Wait for the next child to die.
                                     # 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='';
   
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(100.0)) {  
         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");
     
       }
   
       # Checkfor new connections:
       if (vec($infdset, $server->fileno, 1)) {
    if($DEBUG) {
       &logthis("New connection established");
    }
    # 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
   
             # test whether the data in the buffer or the data we  }
             # just read means there is a complete request waiting     
             # to be fulfilled.  If there is, set $ready{$client}  
             # to the requests waiting to be fulfilled.  
             while ($inbuffer{$client} =~ s/(.*\n)//) {  
                 push( @{$ready{$client}}, $1 );  
             }  
         }  
     }      }
       }
     # Any complete requests to process?  
     foreach $client (keys %ready) {  # ------------------------------------------------------- End of make_new_child
         handle($client);  
   
   #
   #  Make a vector of file descriptors to wait for in a select.
   #  parameters:
   #     \%fdhash  -reference to a hash which has IO::Socket's as indices.  
   #                We only care about the indices, not the values.
   #  A select vector is created from all indices of the hash.
   
   sub MakeFileVector
   {
       my $fdhash = shift;
       my $selvar = "";
   
       foreach $socket (keys %$fdhash) {
    if($DEBUG) {
       &logthis("Adding  ".$socket.
        "to select vector. (client)\n");
    }
    vec($selvar, $socket, 1) = 1;
     }      }
        return $selvar;
     # Buffers to flush?  }
     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) {  
             # Whine, but move on.  
             &logthis("I was told I could write, but I can't.\n");  
             next;  
         }  
         $errno=$!;  
         if (($rv == length $outbuffer{$client}) ||  
             ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) {  
             substr($outbuffer{$client}, 0, $rv) = '';  
             delete $outbuffer{$client} unless length $outbuffer{$client};  
         } else {  
             # Couldn't write all the data, and it wasn't because  
             # it would have blocked.  Shutdown and move on.  
   
     &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}
Line 505  sub handle { Line 685  sub handle {
     }      }
 }  }
 # ---------------------------------------------------------- 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 695  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 841  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;
 }  }
   
   
Removed from v.1.33  
changed lines
  Added in v.1.43

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