[BACK]Return to lonc CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom
File:  [LON-CAPA] / loncom / Attic / lonc
Revision 1.34: download - view: text, annotated - select for diffs
Wed Mar 20 03:44:11 2002 UTC (22 years, 1 month ago) by foxr
Branches: MAIN
CVS tags: HEAD
Put the small timeout back into the read select for now.

#!/usr/bin/perl

# The LearningOnline Network
# lonc - LON TCP-Client Domain-Socket-Server
# provides persistent TCP connections to the other servers in the network
# through multiplexed domain sockets
#
# $Id: lonc,v 1.34 2002/03/20 03:44:11 foxr 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
# 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.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
# PID in subdir logs/lonc.pid
# kill kills
# HUP restarts
# USR1 tries to open connections again

# 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,
# 10/8,10/9,10/15,11/18,12/22,
# 2/8,7/25 Gerd Kortemeyer
# 12/05 Scott Harrison
# 12/05 Gerd Kortemeyer
# YEAR=2001
# 01/10/01 Scott Harrison
# 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer
# 12/20 Scott Harrison
# YEAR=2002
# 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer
# 3/07/02 Ron Fox 
# based on nonforker from Perl Cookbook
# - server who multiplexes without forking

use POSIX;
use IO::Socket;
use IO::Select;
use IO::File;
use Socket;
use Fcntl;
use Tie::RefHash;
use Crypt::IDEA;
#use Net::Ping;
use LWP::UserAgent();

$status='';
$lastlog='';
$conserver='SHELL';
$DEBUG = 0;			# Set to 1 for annoyingly complete logs.

# -------------------------------- Set signal handlers to record abnormal exits

&status("Init exception handlers");
$SIG{QUIT}=\&catchexception;
$SIG{__DIE__}=\&catchexception;

# ------------------------------------ Read httpd access.conf and get variables
&status("Read access.conf");
open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";

while ($configline=<CONFIG>) {
    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
&status("Check user ID");
my $wwwid=getpwnam('www');
if ($wwwid!=$<) {
   $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
   $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
   system("echo 'User ID mismatch.  lonc must be run as user www.' |\
 mailto $emailto -s '$subj' > /dev/null");
   exit 1;
}

# --------------------------------------------- Check if other instance running

my $pidfile="$perlvar{'lonDaemons'}/logs/lonc.pid";

if (-e $pidfile) {
   my $lfh=IO::File->new("$pidfile");
   my $pide=<$lfh>;
   chomp($pide);
   if (kill 0 => $pide) { die "already running"; }
}

# ------------------------------------------------------------- Read hosts file

open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";

while ($configline=<CONFIG>) {
    my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
    chomp($ip);
    if ($ip) {
     $hostip{$id}=$ip;
     $hostname{$id}=$name;
    }
}

close(CONFIG);

# -------------------------------------------------------- Routines for forking

%children               = ();       # keys are current child process IDs,
                                    # values are hosts
%childpid               = ();       # the other way around

%childatt               = ();       # number of attempts to start server
                                    # for ID

$childmaxattempts=5;

# ---------------------------------------------------- Fork once and dissociate
&status("Fork and dissociate");
$fpid=fork;
exit if $fpid;
die "Couldn't fork: $!" unless defined ($fpid);

POSIX::setsid() or die "Can't start new session: $!";

$conserver='PARENT';

# ------------------------------------------------------- Write our PID on disk
&status("Write PID");
$execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lonc.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");

# ----------------------------- Ignore signals generated during initial startup
$SIG{HUP}=$SIG{USR1}='IGNORE';
# ------------------------------------------------------- Now we are on our own
    
# Fork off our children, one for every server

&status("Forking ...");

foreach $thisserver (keys %hostip) {
    #if (&online($hostname{$thisserver})) {
       make_new_child($thisserver);
    #}
}

&logthis("Done starting initial servers");
# ----------------------------------------------------- Install signal handlers


$SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP}  = \&HUPSMAN;
$SIG{USR1} = \&USRMAN;

# And maintain the population.
while (1) {
    my $deadpid = wait;		# Wait for the next child to die.
                                    # See who died and start new one
    &status("Woke up");
    my $skipping='';

    if(exists($children{$deadpid})) {

	$thisserver = $children{$deadpid}; # Look name of dead guy's peer.

	delete($children{$deadpid}); # Get rid of dead hash entry.

	if($childatt{$thisserver} < $childmaxattempts) {
	    $childatt{$thisserver}++;
	    &logthis(
	       "<font color=yellow>INFO: Trying to reconnect for $thisserver "
            ."($childatt{$thisserver} of $childmaxattempts attempts)</font>"); 
	    make_new_child($thisserver);
	
	}
	else {
	    $skipping .= $thisserver.' ';
	}
	if($skipping) {
	    &logthis("<font color=blue>WARNING: Skipped $skipping</font>");
  
	}
    }

}



sub make_new_child {
   
    $newserver=shift;
    my $pid;
    my $sigset;
    &logthis("Attempting to start child for server $newserver");
    # block signal for fork
    $sigset = POSIX::SigSet->new(SIGINT);
    sigprocmask(SIG_BLOCK, $sigset)
        or die "Can't block SIGINT for fork: $!\n";
    
    die "fork: $!" unless defined ($pid = fork);
    
    if ($pid) {
        # Parent records the child's birth and returns.
        sigprocmask(SIG_UNBLOCK, $sigset)
            or die "Can't unblock SIGINT for fork: $!\n";
        $children{$pid} = $newserver;
        $childpid{$newserver} = $pid;
        return;
    } else {
        $conserver=$newserver;
        # Child can *not* return from this subroutine.
        $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
        $SIG{USR1}= \&logstatus;
   
        # unblock signals
        sigprocmask(SIG_UNBLOCK, $sigset)
            or die "Can't unblock SIGINT for fork: $!\n";

# ----------------------------- This is the modified main program of non-forker

$port = "$perlvar{'lonSockDir'}/$conserver";

unlink($port);

# -------------------------------------------------------------- Open other end

&openremote($conserver);
	&logthis("<font color=green> Connection to $conserver open </font>");
# ----------------------------------------- We're online, send delayed messages
    &status("Checking for delayed messages");

    my @allbuffered;
    my $path="$perlvar{'lonSockDir'}/delayed";
    opendir(DIRHANDLE,$path);
    @allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;
    closedir(DIRHANDLE);
    my $dfname;
    foreach (@allbuffered) {
        &status("Sending delayed: $_");
        $dfname="$path/$_";
        if($DEBUG) { &logthis('Sending '.$dfname); }
        my $wcmd;
        {
         my $dfh=IO::File->new($dfname);
         $cmd=<$dfh>;
        }
        chomp($cmd);
        my $bcmd=$cmd;
        if ($cmd =~ /^encrypt\:/) {
	    my $rcmd=$cmd;
            $rcmd =~ s/^encrypt\://;
            chomp($rcmd);
            my $cmdlength=length($rcmd);
            $rcmd.="         ";
            my $encrequest='';
            for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
                $encrequest.=
                    unpack("H16",$cipher->encrypt(substr($rcmd,$encidx,8)));
            }
            $cmd="enc:$cmdlength:$encrequest\n";
        }
	$answer = londtransaction($remotesock, $cmd, 60);
	chomp($answer);

        if (($answer ne '') && ($@!~/timeout/)) {
	    unlink("$dfname");
            &logthis("Delayed $cmd: >$answer<");
            &logperm("S:$conserver:$bcmd");
        }        
    }
	if($DEBUG) { &logthis("<font color=green> Delayed transactions sent"); }

# ------------------------------------------------------- Listen to UNIX socket
&status("Opening socket");
unless (
  $server = IO::Socket::UNIX->new(Local  => $port,
                                  Type   => SOCK_STREAM,
                                  Listen => 10 )
   ) { 
       my $st=120+int(rand(240));
       &logthis(
         "<font color=blue>WARNING: ".
         "Can't make server socket ($st secs):  .. exiting</font>");
       sleep($st);
       exit; 
     };
   
# -----------------------------------------------------------------------------

&logthis("<font color=green>$conserver online</font>");

# -----------------------------------------------------------------------------
# begin with empty buffers
%inbuffer  = ();
%outbuffer = ();
%ready     = ();

tie %ready, 'Tie::RefHash';

nonblock($server);
$select = IO::Select->new($server);

# Main loop: check reads/accepts, check writes, check ready to process
while (1) {
    my $client;
    my $rv;
    my $data;

    # check for new information on the connections we have

    # anything to read or accept?

    foreach $client ($select->can_read(00.10)) {
        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;


            # 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) {
        handle($client);
    }
 
    # 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};
            delete $ready{$client};

            $select->remove($client);
            close($client);
            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);          
      }
    }
   
}
}

# ------------------------------------------------------- End of make_new_child

# handle($socket) deals with all pending requests for $client
sub handle {
    # requests are in $ready{$client}
    # send output to $outbuffer{$client}
    my $client = shift;
    my $request;
    foreach $request (@{$ready{$client}}) {
# ============================================================= Process request
        # $request is the text of the request
        # put text of reply into $outbuffer{$client}
# ------------------------------------------------------------ Is this the end?
	chomp($request);
	if($DEBUG) {
     &logthis("<font color=green> Request $request processing starts</font>");
        }
        if ($request eq "close_connection_exit\n") {
	    &status("Request close connection");
           &logthis(
     "<font color=red>CRITICAL: Request Close Connection ... exiting</font>");
           $remotesock->shutdown(2);
           $server->close();
           exit;
        }
# -----------------------------------------------------------------------------
        if ($request =~ /^encrypt\:/) {
	    my $cmd=$request;
            $cmd =~ s/^encrypt\://;
            chomp($cmd);
            my $cmdlength=length($cmd);
            $cmd.="         ";
            my $encrequest='';
            for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
                $encrequest.=
                    unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
            }
            $request="enc:$cmdlength:$encrequest";
        }
# --------------------------------------------------------------- Main exchange
	$answer = londtransaction($remotesock, $request, 300);

	if($DEBUG) { 
	    &logthis("<font color=green> Request data exchange complete");
	}
	if ($@=~/timeout/) { 
	    $answer='';
	    &logthis(
		     "<font color=red>CRITICAL: Timeout: $request</font>");
	}  


        if ($answer) {
	   if ($answer =~ /^enc/) {
               my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
               chomp($encinput);
	       $answer='';
               for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
                  $answer.=$cipher->decrypt(
                   pack("H16",substr($encinput,$encidx,16))
                  );
	       }
	      $answer=substr($answer,0,$cmdlength);
	      $answer.="\n";
	   }
	   if($DEBUG) {
	       &logthis("sending $answer to client\n");
	   }
           $outbuffer{$client} .= $answer;
        } else {
           $outbuffer{$client} .= "con_lost\n";
        }

     &status("Completed: $request");
	if($DEBUG) {
	    &logthis("<font color=green> Request processing complete</font>");
	}
# ===================================================== Done processing request
    }
    delete $ready{$client};
# -------------------------------------------------------------- End non-forker
    if($DEBUG) {
	&logthis("<font color=green> requests for child handled</font>");
    }
}
# ---------------------------------------------------------- End make_new_child
}

# nonblock($socket) puts socket into nonblocking mode
sub nonblock {
    my $socket = shift;
    my $flags;

    
    $flags = fcntl($socket, F_GETFL, 0)
            or die "Can't get flags for socket: $!\n";
    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
            or die "Can't make socket nonblocking: $!\n";
}


sub openremote {
# ---------------------------------------------------- Client to network server

    my $conserver=shift;

&status("Opening TCP");
    my $st=120+int(rand(240)); # Sleep before opening:

unless (
  $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
                                      PeerPort => $perlvar{'londPort'},
                                      Proto    => "tcp",
                                      Type     => SOCK_STREAM)
   ) { 

       &logthis(
"<font color=blue>WARNING: Couldn't connect to $conserver ($st secs): </font>");
       sleep($st);
       exit; 
     };
# ----------------------------------------------------------------- Init dialog

&logthis("<font color=green>INFO Connected to $conserver, initing </font>");
&status("Init dialogue: $conserver");

    $answer = londtransaction($remotesock, "init", 60);
    chomp($answer);
    $answer = londtransaction($remotesock, $answer, 60);
    chomp($answer);
 
     if ($@=~/timeout/) {
	 &logthis("Timed out during init.. exiting");
         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;
}
    &logthis("<font color=green> Remote open success </font>");
}



# 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("Signal abend");
}

# -------------------------------------- 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 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";


    $answer = londtransaction($sclient, $cmd, 10);

    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";
}

#--------------------------------------  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 {
    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)

=head1 NAME

lonc - LON TCP-MySQL-Server Daemon for handling database requests.

=head1 SYNOPSIS

Usage: B<lonc>

Should only be run as user=www.  This is a command-line script which
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

Provides persistent TCP connections to the other servers in the network
through multiplexed domain sockets

B<lonc> forks off children processes that correspond to the other servers
in the network.  Management of these processes can be done at the
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.

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.


=back

=head1 PREREQUISITES

POSIX
IO::Socket
IO::Select
IO::File
Socket
Fcntl
Tie::RefHash
Crypt::IDEA

=head1 COREQUISITES

=head1 OSNAMES

linux

=head1 SCRIPT CATEGORIES

Server/Process

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