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

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

version 1.25, 2002/02/06 14:15:37 version 1.31, 2002/03/03 18:13:07
Line 43 Line 43
 # 01/10/01 Scott Harrison  # 01/10/01 Scott Harrison
 # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer  # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer
 # 12/20 Scott Harrison  # 12/20 Scott Harrison
   # YEAR=2002
   # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer
 #   # 
 # based on nonforker from Perl Cookbook  # based on nonforker from Perl Cookbook
 # - server who multiplexes without forking  # - server who multiplexes without forking
Line 55  use Socket; Line 57  use Socket;
 use Fcntl;  use Fcntl;
 use Tie::RefHash;  use Tie::RefHash;
 use Crypt::IDEA;  use Crypt::IDEA;
   use Net::Ping;
   use LWP::UserAgent();
   
 my $status='';  $status='';
 my $lastlog='';  $lastlog='';
   $conserver='SHELL';
 # grabs exception and records it to log before exiting  
 sub catchexception {  
     my ($signal)=@_;  
     $SIG{'QUIT'}='DEFAULT';  
     $SIG{__DIE__}='DEFAULT';  
     &logthis("<font color=red>CRITICAL: "  
      ."ABNORMAL EXIT. Child $$ for server $wasserver died through "  
      ."\"$signal\" with this parameter->[$@]</font>");  
     die($@);  
 }  
   
 $childmaxattempts=5;  
   
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
   
 $SIG{'QUIT'}=\&catchexception;  &status("Init exception handlers");
   $SIG{QUIT}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
 # ------------------------------------ Read httpd access.conf and get variables  # ------------------------------------ Read httpd access.conf and get variables
   &status("Read access.conf");
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
   
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
Line 91  while ($configline=<CONFIG>) { Line 84  while ($configline=<CONFIG>) {
 close(CONFIG);  close(CONFIG);
   
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
   &status("Check user ID");
 my $wwwid=getpwnam('www');  my $wwwid=getpwnam('www');
 if ($wwwid!=$<) {  if ($wwwid!=$<) {
    $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";     $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
Line 118  open (CONFIG,"$perlvar{'lonTabDir'}/host Line 112  open (CONFIG,"$perlvar{'lonTabDir'}/host
 while ($configline=<CONFIG>) {  while ($configline=<CONFIG>) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
     chomp($ip);      chomp($ip);
     $hostip{$id}=$ip;      if ($ip) {
        $hostip{$id}=$ip;
        $hostname{$id}=$name;
       }
 }  }
   
 close(CONFIG);  close(CONFIG);
   
 # -------------------------------------------------------- Routines for forking  # -------------------------------------------------------- Routines for forking
Line 131  close(CONFIG); Line 129  close(CONFIG);
 %childatt               = ();       # number of attempts to start server  %childatt               = ();       # number of attempts to start server
                                     # for ID                                      # for ID
   
 sub REAPER {                        # takes care of dead children  $childmaxattempts=5;
     $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 HUNTSMAN {                      # signal handler for SIGINT  
     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children  
     foreach (keys %children) {  
         $wasserver=$children{$_};  
         &status("Closing $wasserver");  
         &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver));  
         &status("Kill PID $_ for $wasserver");  
  kill ('INT',$_);  
     }  
     my $execdir=$perlvar{'lonDaemons'};  
     unlink("$execdir/logs/lonc.pid");  
     &logthis("<font color=red>CRITICAL: Shutting down</font>");  
     exit;                           # clean up with dignity  
 }  
   
 sub HUPSMAN {                      # signal handler for SIGHUP  
     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children  
     foreach (keys %children) {  
         $wasserver=$children{$_};  
         &status("Closing $wasserver");  
         &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver));  
         &status("Kill PID $_ for $wasserver");  
  kill ('INT',$_);  
     }  
     &logthis("<font color=red>CRITICAL: Restarting</font>");  
     unlink("$execdir/logs/lonc.pid");  
     my $execdir=$perlvar{'lonDaemons'};  
     exec("$execdir/lonc");         # here we go again  
 }  
   
 sub checkchildren {  
     &initnewstatus();  
     &logstatus();  
     &logthis('Going to check on the children');  
     foreach (sort keys %children) {  
  sleep 1;  
         unless (kill 'USR1' => $_) {  
     &logthis ('Child '.$_.' is dead');  
             &logstatus($$.' is dead');  
         }   
     }  
 }  
   
 sub USRMAN {  
     &logthis("USR1: Trying to establish connections again");  
     foreach $thisserver (keys %hostip) {  
  $answer=subreply("ping",$thisserver);  
         &logthis("USR1: Ping $thisserver "  
         ."(pid >$childpid{$thisserver}<, $childatt{thisserver} attempts): "  
         ." >$answer<");  
     }  
     %childatt=();  
     &checkchildren();  
 }  
   
 # -------------------------------------------------- Non-critical communication  
 sub subreply {   
  my ($cmd,$server)=@_;  
  my $answer='';  
  if ($server ne $perlvar{'lonHostID'}) {   
     my $peerfile="$perlvar{'lonSockDir'}/$server";  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
   
   
     $SIG{ALRM}=sub { die "timeout" };  
     $SIG{__DIE__}='DEFAULT';  
     eval {  
      alarm(10);  
      print $sclient "$cmd\n";  
      $answer=<$sclient>;  
      chomp($answer);  
      alarm(0);  
     };  
     if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; }  
     $SIG{ALRM}='DEFAULT';  
     $SIG{__DIE__}=\&catchexception;  
  } else { $answer='self_reply'; }  
  return $answer;  
 }  
   
 # --------------------------------------------------------------------- Logging  
   
 sub logthis {  
     my $message=shift;  
     my $execdir=$perlvar{'lonDaemons'};  
     my $fh=IO::File->new(">>$execdir/logs/lonc.log");  
     my $now=time;  
     my $local=localtime($now);  
     $lastlog=$local.': '.$message;  
     print $fh "$local ($$): $message\n";  
 }  
   
   
 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";  
 }  
 # ------------------------------------------------------------------ Log status  
   
 sub logstatus {  
     my $docdir=$perlvar{'lonDocRoot'};  
     my $fh=IO::File->new(">>$docdir/lon-status/loncstatus.txt");  
     print $fh $$."\t".$status."\t".$lastlog."\n";  
 }  
   
 sub initnewstatus {  
     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";  
 }  
   
 # -------------------------------------------------------------- Status setting  
   
 sub status {  
     my $what=shift;  
     my $now=time;  
     my $local=localtime($now);  
     $status=$local.': '.$what;  
 }  
   
   
 # ---------------------------------------------------- Fork once and dissociate  # ---------------------------------------------------- Fork once and dissociate
   &status("Fork and dissociate");
 $fpid=fork;  $fpid=fork;
 exit if $fpid;  exit if $fpid;
 die "Couldn't fork: $!" unless defined ($fpid);  die "Couldn't fork: $!" unless defined ($fpid);
   
 POSIX::setsid() or die "Can't start new session: $!";  POSIX::setsid() or die "Can't start new session: $!";
   
 # ------------------------------------------------------- Write our PID on disk  $conserver='PARENT';
   
   # ------------------------------------------------------- Write our PID on disk
   &status("Write PID");
 $execdir=$perlvar{'lonDaemons'};  $execdir=$perlvar{'lonDaemons'};
 open (PIDSAVE,">$execdir/logs/lonc.pid");  open (PIDSAVE,">$execdir/logs/lonc.pid");
 print PIDSAVE "$$\n";  print PIDSAVE "$$\n";
Line 298  $SIG{HUP}=$SIG{USR1}='IGNORE'; Line 158  $SIG{HUP}=$SIG{USR1}='IGNORE';
 &status("Forking ...");  &status("Forking ...");
   
 foreach $thisserver (keys %hostip) {  foreach $thisserver (keys %hostip) {
     make_new_child($thisserver);      if (&online($hostname{$thisserver})) {
          make_new_child($thisserver);
       }
 }  }
   
 &logthis("Done starting initial servers");  &logthis("Done starting initial servers");
Line 315  while (1) { Line 177  while (1) {
     sleep;                          # wait for a signal (i.e., child's death)      sleep;                          # wait for a signal (i.e., child's death)
                                     # See who died and start new one                                      # See who died and start new one
     &status("Woke up");      &status("Woke up");
       my $skipping='';
     foreach $thisserver (keys %hostip) {      foreach $thisserver (keys %hostip) {
         if (!$childpid{$thisserver}) {          if (!$childpid{$thisserver}) {
     if ($childatt{$thisserver}<$childmaxattempts) {      if (($childatt{$thisserver}<$childmaxattempts) &&
                   (&online($hostname{$thisserver}))) {
        $childatt{$thisserver}++;         $childatt{$thisserver}++;
                &logthis(                 &logthis(
    "<font color=yellow>INFO: Trying to reconnect for $thisserver "     "<font color=yellow>INFO: Trying to reconnect for $thisserver "
   ."($childatt{$thisserver} of $childmaxattempts attempts)</font>");     ."($childatt{$thisserver} of $childmaxattempts attempts)</font>"); 
                make_new_child($thisserver);                 make_new_child($thisserver);
     }     } else {
                  $skipping.=$thisserver.' ';
              } 
                  
         }                 }       
     }      }
       if ($skipping) { 
          &logthis("<font color=blue>WARNING: Skipped $skipping</font>");
       }
 }  }
   
   
 sub make_new_child {  sub make_new_child {
         
     my $conserver=shift;      $newserver=shift;
     my $pid;      my $pid;
     my $sigset;      my $sigset;
     &logthis("Attempting to start child for server $conserver");      &logthis("Attempting to start child for server $newserver");
     # block signal for fork      # block signal for fork
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)      sigprocmask(SIG_BLOCK, $sigset)
Line 346  sub make_new_child { Line 216  sub make_new_child {
         # Parent records the child's birth and returns.          # Parent records the child's birth and returns.
         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} = $conserver;          $children{$pid} = $newserver;
         $childpid{$conserver} = $pid;          $childpid{$conserver} = $pid;
         return;          return;
     } else {      } else {
           $conserver=$newserver;
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before          $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
         $SIG{USR1}= \&logstatus;          $SIG{USR1}= \&logstatus;
Line 364  $port = "$perlvar{'lonSockDir'}/$conserv Line 235  $port = "$perlvar{'lonSockDir'}/$conserv
   
 unlink($port);  unlink($port);
   
 # ---------------------------------------------------- Client to network server  # -------------------------------------------------------------- Open other end
   
 &status("Opening TCP: $conserver");  
   
 unless (  
   $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},  
                                       PeerPort => $perlvar{'londPort'},  
                                       Proto    => "tcp",  
                                       Type     => SOCK_STREAM)  
    ) {   
        my $st=120+int(rand(240));  
        &logthis(  
 "<font color=blue>WARNING: Couldn't connect $conserver ($st secs): $@</font>");  
        sleep($st);  
        exit;   
      };  
 # ----------------------------------------------------------------- Init dialog  
   
 &status("Init dialogue: $conserver");  &openremote($conserver);
   
      $SIG{ALRM}=sub { die "timeout" };  
      $SIG{__DIE__}='DEFAULT';  
      eval {  
          alarm(60);  
 print $remotesock "init\n";  
 $answer=<$remotesock>;  
 print $remotesock "$answer";  
 $answer=<$remotesock>;  
 chomp($answer);  
           alarm(0);  
      };  
      $SIG{ALRM}='DEFAULT';  
      $SIG{__DIE__}=\&catchexception;  
    
      if ($@=~/timeout/) {  
  &logthis("Timed out during init: $conserver");  
          exit;  
      }  
   
   
 &logthis("Init reply for $conserver: >$answer<");  
 if ($answer ne 'ok') {  
        my $st=120+int(rand(240));  
        &logthis(  
 "<font color=blue>WARNING: Init failed $conserver ($st secs)</font>");  
        sleep($st);  
        exit;   
 }  
 sleep 5;  
 &status("Ponging $conserver");  
 print $remotesock "pong\n";  
 $answer=<$remotesock>;  
 chomp($answer);  
 &logthis("Pong reply for $conserver: >$answer<");  
 # ----------------------------------------------------------- Initialize cipher  
   
 &status("Initialize cipher: $conserver");  
 print $remotesock "ekey\n";  
 my $buildkey=<$remotesock>;  
 my $key=$conserver.$perlvar{'lonHostID'};  
 $key=~tr/a-z/A-Z/;  
 $key=~tr/G-P/0-9/;  
 $key=~tr/Q-Z/0-9/;  
 $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;  
 $key=substr($key,0,32);  
 my $cipherkey=pack("H32",$key);  
 if ($cipher=new IDEA $cipherkey) {  
    &logthis("Secure connection initialized: $conserver");  
 } else {  
    my $st=120+int(rand(240));  
    &logthis(  
      "<font color=blue>WARNING: ".  
      "Could not establish secure connection, $conserver ($st secs)!</font>");  
    sleep($st);  
    exit;  
 }  
   
 # ----------------------------------------- We're online, send delayed messages  # ----------------------------------------- We're online, send delayed messages
     &status("Checking for delayed messages");      &status("Checking for delayed messages");
Line 450  if ($cipher=new IDEA $cipherkey) { Line 248  if ($cipher=new IDEA $cipherkey) {
     closedir(DIRHANDLE);      closedir(DIRHANDLE);
     my $dfname;      my $dfname;
     foreach (@allbuffered) {      foreach (@allbuffered) {
         &status("Sending delayed $conserver $_");          &status("Sending delayed: $_");
         $dfname="$path/$_";          $dfname="$path/$_";
         &logthis($dfname);          &logthis('Sending '.$dfname);
         my $wcmd;          my $wcmd;
         {          {
          my $dfh=IO::File->new($dfname);           my $dfh=IO::File->new($dfname);
Line 487  if ($cipher=new IDEA $cipherkey) { Line 285  if ($cipher=new IDEA $cipherkey) {
   
         if (($answer ne '') && ($@!~/timeout/)) {          if (($answer ne '') && ($@!~/timeout/)) {
     unlink("$dfname");      unlink("$dfname");
             &logthis("Delayed $cmd to $conserver: >$answer<");              &logthis("Delayed $cmd: >$answer<");
             &logperm("S:$conserver:$bcmd");              &logperm("S:$conserver:$bcmd");
         }                  }        
     }      }
   
 # ------------------------------------------------------- Listen to UNIX socket  # ------------------------------------------------------- Listen to UNIX socket
 &status("Opening socket $conserver");  &status("Opening socket");
 unless (  unless (
   $server = IO::Socket::UNIX->new(Local  => $port,    $server = IO::Socket::UNIX->new(Local  => $port,
                                   Type   => SOCK_STREAM,                                    Type   => SOCK_STREAM,
Line 502  unless ( Line 300  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 $conserver ($st secs): $@</font>");           "Can't make server socket ($st secs): $@</font>");
        sleep($st);         sleep($st);
        exit;          exit; 
      };       };
Line 550  while (1) { Line 348  while (1) {
                 delete $outbuffer{$client};                  delete $outbuffer{$client};
                 delete $ready{$client};                  delete $ready{$client};
   
                 &status("Idle $conserver");                  &status("Idle");
                 $select->remove($client);                  $select->remove($client);
                 close $client;                  close $client;
                 next;                  next;
Line 579  while (1) { Line 377  while (1) {
         next unless exists $outbuffer{$client};          next unless exists $outbuffer{$client};
   
         $rv = $client->send($outbuffer{$client}, 0);          $rv = $client->send($outbuffer{$client}, 0);
   
         unless ($outbuffer{$client} eq "con_lost\n") {
         unless (defined $rv) {          unless (defined $rv) {
             # Whine, but move on.              # Whine, but move on.
             &logthis("I was told I could write, but I can't.\n");              &logthis("I was told I could write, but I can't.\n");
Line 604  while (1) { Line 404  while (1) {
             close($client);              close($client);
             next;              next;
         }          }
         } else {
   # -------------------------------------------------------- Wow, connection lost
            &logthis(
        "<font color=red>CRITICAL: Closing connection</font>");
    &status("Connection lost");
            $remotesock->shutdown(2);
            &logthis("Attempting to open new connection");
            &openremote($conserver);          
         }
     }      }
      
 }  }
 }  }
   
Line 621  sub handle { Line 431  sub handle {
 # ============================================================= 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?
           if ($request eq "close_connection_exit\n") {
       &status("Request close connection");
              &logthis(
        "<font color=red>CRITICAL: Request Close Connection</font>");
              $remotesock->shutdown(2);
              $server->close();
              exit;
           }
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
         if ($request =~ /^encrypt\:/) {          if ($request =~ /^encrypt\:/) {
     my $cmd=$request;      my $cmd=$request;
Line 640  sub handle { Line 459  sub handle {
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     eval {      eval {
         alarm(300);          alarm(300);
         &status("Sending $conserver: $request");          &status("Sending: $request");
         print $remotesock "$request";          print $remotesock "$request";
         &status("Waiting for reply from $conserver: $request");          &status("Waiting for reply from $conserver: $request");
         $answer=<$remotesock>;          $answer=<$remotesock>;
Line 650  sub handle { Line 469  sub handle {
     if ($@=~/timeout/) {       if ($@=~/timeout/) { 
        $answer='';         $answer='';
        &logthis(         &logthis(
         "<font color=red>CRITICAL: Timeout $conserver: $request</font>");          "<font color=red>CRITICAL: Timeout: $request</font>");
     }        }  
     $SIG{ALRM}='DEFAULT';      $SIG{ALRM}='DEFAULT';
     $SIG{__DIE__}=\&catchexception;      $SIG{__DIE__}=\&catchexception;
Line 674  sub handle { Line 493  sub handle {
            $outbuffer{$client} .= "con_lost\n";             $outbuffer{$client} .= "con_lost\n";
         }          }
   
        &status("Completed: $request");
   
 # ===================================================== Done processing request  # ===================================================== Done processing request
     }      }
     delete $ready{$client};      delete $ready{$client};
     &status("Completed $conserver: $request");  
 # -------------------------------------------------------------- End non-forker  # -------------------------------------------------------------- End non-forker
 }  }
 # ---------------------------------------------------------- End make_new_child  # ---------------------------------------------------------- End make_new_child
Line 695  sub nonblock { Line 515  sub nonblock {
             or die "Can't make socket nonblocking: $!\n";              or die "Can't make socket nonblocking: $!\n";
 }  }
   
   
   sub openremote {
   # ---------------------------------------------------- Client to network server
   
       my $conserver=shift;
   
   &status("Opening TCP");
   
   unless (
     $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
                                         PeerPort => $perlvar{'londPort'},
                                         Proto    => "tcp",
                                         Type     => SOCK_STREAM)
      ) { 
          my $st=120+int(rand(240));
          &logthis(
   "<font color=blue>WARNING: Couldn't connect ($st secs): $@</font>");
          sleep($st);
          exit; 
        };
   # ----------------------------------------------------------------- Init dialog
   
   &status("Init dialogue: $conserver");
   
        $SIG{ALRM}=sub { die "timeout" };
        $SIG{__DIE__}='DEFAULT';
        eval {
            alarm(60);
   print $remotesock "init\n";
   $answer=<$remotesock>;
   print $remotesock "$answer";
   $answer=<$remotesock>;
   chomp($answer);
             alarm(0);
        };
        $SIG{ALRM}='DEFAULT';
        $SIG{__DIE__}=\&catchexception;
    
        if ($@=~/timeout/) {
    &logthis("Timed out during init");
            exit;
        }
   
   if ($answer ne 'ok') {
          &logthis("Init reply: >$answer<");
          my $st=120+int(rand(240));
          &logthis(
   "<font color=blue>WARNING: Init failed ($st secs)</font>");
          sleep($st);
          exit; 
   }
   
   sleep 5;
   &status("Ponging");
   print $remotesock "pong\n";
   $answer=<$remotesock>;
   chomp($answer);
   if ($answer!~/^$conserver/) {
      &logthis("Pong reply: >$answer<");
   }
   # ----------------------------------------------------------- Initialize cipher
   
   &status("Initialize cipher");
   print $remotesock "ekey\n";
   my $buildkey=<$remotesock>;
   my $key=$conserver.$perlvar{'lonHostID'};
   $key=~tr/a-z/A-Z/;
   $key=~tr/G-P/0-9/;
   $key=~tr/Q-Z/0-9/;
   $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
   $key=substr($key,0,32);
   my $cipherkey=pack("H32",$key);
   if ($cipher=new IDEA $cipherkey) {
      &logthis("Secure connection initialized");
   } else {
      my $st=120+int(rand(240));
      &logthis(
        "<font color=blue>WARNING: ".
        "Could not establish secure connection ($st secs)!</font>");
      sleep($st);
      exit;
   }
   
   }
   
   
   
   # grabs exception and records it to log before exiting
   sub catchexception {
       my ($signal)=@_;
       $SIG{QUIT}='DEFAULT';
       $SIG{__DIE__}='DEFAULT';
       chomp($signal);
       &logthis("<font color=red>CRITICAL: "
        ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through "
        ."\"$signal\" with parameter [$@]</font>");
       die($@);
   }
   
   # -------------------------------------- Routines to see if other box available
   
   sub online {
       my $host=shift;
       &status("Pinging ".$host);
       my $p=Net::Ping->new("tcp",20);
       my $online=$p->ping("$host");
       $p->close();
       undef ($p);
       return $online;
   }
   
   sub connected {
       my ($local,$remote)=@_;
       &status("Checking connection $local to $remote");
       $local=~s/\W//g;
       $remote=~s/\W//g;
   
       unless ($hostname{$local}) { return 'local_unknown'; }
       unless ($hostname{$remote}) { return 'remote_unknown'; }
   
       unless (&online($hostname{$local})) { return 'local_offline'; }
   
       my $ua=new LWP::UserAgent;
       
       my $request=new HTTP::Request('GET',
         "http://".$hostname{$local}.'/cgi-bin/ping.pl?'.$remote);
   
       my $response=$ua->request($request);
   
       unless ($response->is_success) { return 'local_error'; }
   
       my $reply=$response->content;
       $reply=(split("\n",$reply))[0];
       $reply=~s/\W//g;
       if ($reply ne $remote) { return $reply; }
       return 'ok';
   }
   
   
   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 {
       foreach (keys %children) {
           $wasserver=$children{$_};
           &status("Closing $wasserver");
           &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver));
           &status("Kill PID $_ for $wasserver");
    kill ('INT',$_);
       }
   }
   
   sub HUNTSMAN {                      # signal handler for SIGINT
       local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
       &hangup();
       my $execdir=$perlvar{'lonDaemons'};
       unlink("$execdir/logs/lonc.pid");
       &logthis("<font color=red>CRITICAL: Shutting down</font>");
       exit;                           # clean up with dignity
   }
   
   sub HUPSMAN {                      # signal handler for SIGHUP
       local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
       &hangup();
       &logthis("<font color=red>CRITICAL: Restarting</font>");
       unlink("$execdir/logs/lonc.pid");
       my $execdir=$perlvar{'lonDaemons'};
       exec("$execdir/lonc");         # here we go again
   }
   
   sub checkchildren {
       &initnewstatus();
       &logstatus();
       &logthis('Going to check on the children');
       foreach (sort keys %children) {
    sleep 1;
           unless (kill 'USR1' => $_) {
       &logthis ('<font color=red>CRITICAL: Child '.$_.' is dead</font>');
               &logstatus($$.' is dead');
           } 
       }
   }
   
   sub USRMAN {
       &logthis("USR1: Trying to establish connections again");
       %childatt=();
       &checkchildren();
   }
   
   # -------------------------------------------------- Non-critical communication
   sub subreply { 
    my ($cmd,$server)=@_;
    my $answer='';
    if ($server ne $perlvar{'lonHostID'}) { 
       my $peerfile="$perlvar{'lonSockDir'}/$server";
       my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                         Type    => SOCK_STREAM,
                                         Timeout => 10)
          or return "con_lost";
   
   
       $SIG{ALRM}=sub { die "timeout" };
       $SIG{__DIE__}='DEFAULT';
       eval {
        alarm(10);
        print $sclient "$cmd\n";
        $answer=<$sclient>;
        chomp($answer);
        alarm(0);
       };
       if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; }
       $SIG{ALRM}='DEFAULT';
       $SIG{__DIE__}=\&catchexception;
    } else { $answer='self_reply'; }
    return $answer;
   }
   
   # --------------------------------------------------------------------- Logging
   
   sub logthis {
       my $message=shift;
       my $execdir=$perlvar{'lonDaemons'};
       my $fh=IO::File->new(">>$execdir/logs/lonc.log");
       my $now=time;
       my $local=localtime($now);
       $lastlog=$local.': '.$message;
       print $fh "$local ($$) [$conserver] [$status]: $message\n";
   }
   
   
   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";
   }
   # ------------------------------------------------------------------ Log status
   
   sub logstatus {
       my $docdir=$perlvar{'lonDocRoot'};
       my $fh=IO::File->new(">>$docdir/lon-status/loncstatus.txt");
       print $fh $$."\t".$conserver."\t".$status."\t".$lastlog."\n";
   }
   
   sub initnewstatus {
       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";
   }
   
   # -------------------------------------------------------------- Status setting
   
   sub status {
       my $what=shift;
       my $now=time;
       my $local=localtime($now);
       $status=$local.': '.$what;
   }
   
   
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
 =head1 NAME  =head1 NAME
Line 703  lonc - LON TCP-MySQL-Server Daemon for h Line 797  lonc - LON TCP-MySQL-Server Daemon for h
   
 =head1 SYNOPSIS  =head1 SYNOPSIS
   
   Usage: B<lonc>
   
 Should only be run as user=www.  This is a command-line script which  Should only be run as user=www.  This is a command-line script which
 is invoked by loncron.  is invoked by B<loncron>.  There is no expectation that a typical user
   will manually start B<lonc> from the command-line.  (In other words,
   DO NOT START B<lonc> YOURSELF.)
   
 =head1 DESCRIPTION  =head1 DESCRIPTION
   
 Provides persistent TCP connections to the other servers in the network  Provides persistent TCP connections to the other servers in the network
 through multiplexed domain sockets  through multiplexed domain sockets
   
  PID in subdir logs/lonc.pid  B<lonc> forks off children processes that correspond to the other servers
  kill kills  in the network.  Management of these processes can be done at the
  HUP restarts  parent process level or the child process level.
  USR1 tries to open connections again  
   B<logs/lonc.log> is the location of log messages.
   
   The process management is now explained in terms of linux shell commands,
   subroutines internal to this code, and signal assignments:
   
   =over 4
   
   =item *
   
   PID is stored in B<logs/lonc.pid>
   
   This is the process id number of the parent B<lonc> process.
   
   =item *
   
   SIGTERM and SIGINT
   
   Parent signal assignment:
    $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
   
   Child signal assignment:
    $SIG{INT}  = 'DEFAULT'; (and SIGTERM is DEFAULT also)
   (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
    to restart a new child.)
   
   Command-line invocations:
    B<kill> B<-s> SIGTERM I<PID>
    B<kill> B<-s> SIGINT I<PID>
   
   Subroutine B<HUNTSMAN>:
    This is only invoked for the B<lonc> parent I<PID>.
   This kills all the children, and then the parent.
   The B<lonc.pid> file is cleared.
   
   =item *
   
   SIGHUP
   
   Current bug:
    This signal can only be processed the first time
   on the parent process.  Subsequent SIGHUP signals
   have no effect.
   
   Parent signal assignment:
    $SIG{HUP}  = \&HUPSMAN;
   
   Child signal assignment:
    none (nothing happens)
   
   Command-line invocations:
    B<kill> B<-s> SIGHUP I<PID>
   
   Subroutine B<HUPSMAN>:
    This is only invoked for the B<lonc> parent I<PID>,
   This kills all the children, and then the parent.
   The B<lonc.pid> file is cleared.
   
   =item *
   
   SIGUSR1
   
   Parent signal assignment:
    $SIG{USR1} = \&USRMAN;
   
   Child signal assignment:
    $SIG{USR1}= \&logstatus;
   
   Command-line invocations:
    B<kill> B<-s> SIGUSR1 I<PID>
   
   Subroutine B<USRMAN>:
    When invoked for the B<lonc> parent I<PID>,
   SIGUSR1 is sent to all the children, and the status of
   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>
   
 =head1 README  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.
   
 Not yet written.  =back
   
 =head1 PREREQUISITES  =head1 PREREQUISITES
   
Removed from v.1.25  
changed lines
  Added in v.1.31

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