File:  [LON-CAPA] / loncom / Attic / lonc
Revision 1.24: download - view: text, annotated - select for diffs
Wed Feb 6 14:13:19 2002 UTC (22 years, 3 months ago) by albertel
Branches: MAIN
CVS tags: HEAD
- logging info now in

    1: #!/usr/bin/perl
    2: 
    3: # The LearningOnline Network
    4: # lonc - LON TCP-Client Domain-Socket-Server
    5: # provides persistent TCP connections to the other servers in the network
    6: # through multiplexed domain sockets
    7: #
    8: # $Id: lonc,v 1.24 2002/02/06 14:13:19 albertel Exp $
    9: #
   10: # Copyright Michigan State University Board of Trustees
   11: #
   12: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
   13: #
   14: # LON-CAPA is free software; you can redistribute it and/or modify
   15: # it under the terms of the GNU General Public License as published by
   16: # the Free Software Foundation; either version 2 of the License, or
   17: # (at your option) any later version.
   18: #
   19: # LON-CAPA is distributed in the hope that it will be useful,
   20: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   21: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   22: # GNU General Public License for more details.
   23: #
   24: # You should have received a copy of the GNU General Public License
   25: # along with LON-CAPA; if not, write to the Free Software
   26: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   27: #
   28: # /home/httpd/html/adm/gpl.txt
   29: #
   30: # http://www.lon-capa.org/
   31: #
   32: # PID in subdir logs/lonc.pid
   33: # kill kills
   34: # HUP restarts
   35: # USR1 tries to open connections again
   36: 
   37: # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,
   38: # 10/8,10/9,10/15,11/18,12/22,
   39: # 2/8,7/25 Gerd Kortemeyer
   40: # 12/05 Scott Harrison
   41: # 12/05 Gerd Kortemeyer
   42: # YEAR=2001
   43: # 01/10/01 Scott Harrison
   44: # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer
   45: # 12/20 Scott Harrison
   46: # 
   47: # based on nonforker from Perl Cookbook
   48: # - server who multiplexes without forking
   49: 
   50: use POSIX;
   51: use IO::Socket;
   52: use IO::Select;
   53: use IO::File;
   54: use Socket;
   55: use Fcntl;
   56: use Tie::RefHash;
   57: use Crypt::IDEA;
   58: 
   59: my $status='';
   60: my $lastlog='';
   61: 
   62: # grabs exception and records it to log before exiting
   63: sub catchexception {
   64:     my ($signal)=@_;
   65:     $SIG{'QUIT'}='DEFAULT';
   66:     $SIG{__DIE__}='DEFAULT';
   67:     &logthis("<font color=red>CRITICAL: "
   68:      ."ABNORMAL EXIT. Child $$ for server $wasserver died through "
   69:      ."\"$signal\" with this parameter->[$@]</font>");
   70:     die($@);
   71: }
   72: 
   73: $childmaxattempts=5;
   74: 
   75: # -------------------------------- Set signal handlers to record abnormal exits
   76: 
   77: $SIG{'QUIT'}=\&catchexception;
   78: $SIG{__DIE__}=\&catchexception;
   79: 
   80: # ------------------------------------ Read httpd access.conf and get variables
   81: 
   82: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
   83: 
   84: while ($configline=<CONFIG>) {
   85:     if ($configline =~ /PerlSetVar/) {
   86: 	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
   87:         chomp($varvalue);
   88:         $perlvar{$varname}=$varvalue;
   89:     }
   90: }
   91: close(CONFIG);
   92: 
   93: # ----------------------------- Make sure this process is running from user=www
   94: my $wwwid=getpwnam('www');
   95: if ($wwwid!=$<) {
   96:    $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
   97:    $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
   98:    system("echo 'User ID mismatch.  lonc must be run as user www.' |\
   99:  mailto $emailto -s '$subj' > /dev/null");
  100:    exit 1;
  101: }
  102: 
  103: # --------------------------------------------- Check if other instance running
  104: 
  105: my $pidfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
  106: 
  107: if (-e $pidfile) {
  108:    my $lfh=IO::File->new("$pidfile");
  109:    my $pide=<$lfh>;
  110:    chomp($pide);
  111:    if (kill 0 => $pide) { die "already running"; }
  112: }
  113: 
  114: # ------------------------------------------------------------- Read hosts file
  115: 
  116: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
  117: 
  118: while ($configline=<CONFIG>) {
  119:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  120:     chomp($ip);
  121:     $hostip{$id}=$ip;
  122: }
  123: close(CONFIG);
  124: 
  125: # -------------------------------------------------------- Routines for forking
  126: 
  127: %children               = ();       # keys are current child process IDs,
  128:                                     # values are hosts
  129: %childpid               = ();       # the other way around
  130: 
  131: %childatt               = ();       # number of attempts to start server
  132:                                     # for ID
  133: 
  134: sub REAPER {                        # takes care of dead children
  135:     $SIG{CHLD} = \&REAPER;
  136:     my $pid = wait;
  137:     my $wasserver=$children{$pid};
  138:     &logthis("<font color=red>CRITICAL: "
  139:      ."Child $pid for server $wasserver died ($childatt{$wasserver})</font>");
  140:     delete $children{$pid};
  141:     delete $childpid{$wasserver};
  142:     my $port = "$perlvar{'lonSockDir'}/$wasserver";
  143:     unlink($port);
  144: }
  145: 
  146: sub HUNTSMAN {                      # signal handler for SIGINT
  147:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
  148:     foreach (keys %children) {
  149:         $wasserver=$children{$_};
  150:         &status("Closing $wasserver");
  151:         &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver));
  152:         &status("Kill PID $_ for $wasserver");
  153: 	kill ('INT',$_);
  154:     }
  155:     my $execdir=$perlvar{'lonDaemons'};
  156:     unlink("$execdir/logs/lonc.pid");
  157:     &logthis("<font color=red>CRITICAL: Shutting down</font>");
  158:     exit;                           # clean up with dignity
  159: }
  160: 
  161: sub HUPSMAN {                      # signal handler for SIGHUP
  162:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
  163:     foreach (keys %children) {
  164:         $wasserver=$children{$_};
  165:         &status("Closing $wasserver");
  166:         &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver));
  167:         &status("Kill PID $_ for $wasserver");
  168: 	kill ('INT',$_);
  169:     }
  170:     &logthis("<font color=red>CRITICAL: Restarting</font>");
  171:     unlink("$execdir/logs/lonc.pid");
  172:     my $execdir=$perlvar{'lonDaemons'};
  173:     exec("$execdir/lonc");         # here we go again
  174: }
  175: 
  176: sub checkchildren {
  177:     &initnewstatus();
  178:     &logstatus();
  179:     &logthis('Going to check on the children');
  180:     foreach (sort keys %children) {
  181: 	sleep 1;
  182:         unless (kill 'USR1' => $_) {
  183: 	    &logthis ('Child '.$_.' is dead');
  184:             &logstatus($$.' is dead');
  185:         } 
  186:     }
  187: }
  188: 
  189: sub USRMAN {
  190:     &logthis("USR1: Trying to establish connections again");
  191:     foreach $thisserver (keys %hostip) {
  192: 	$answer=subreply("ping",$thisserver);
  193:         &logthis("USR1: Ping $thisserver "
  194:         ."(pid >$childpid{$thisserver}<, $childatt{thisserver} attempts): "
  195:         ." >$answer<");
  196:     }
  197:     %childatt=();
  198:     &checkchildren();
  199: }
  200: 
  201: # -------------------------------------------------- Non-critical communication
  202: sub subreply { 
  203:  my ($cmd,$server)=@_;
  204:  my $answer='';
  205:  if ($server ne $perlvar{'lonHostID'}) { 
  206:     my $peerfile="$perlvar{'lonSockDir'}/$server";
  207:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  208:                                       Type    => SOCK_STREAM,
  209:                                       Timeout => 10)
  210:        or return "con_lost";
  211: 
  212: 
  213:     $SIG{ALRM}=sub { die "timeout" };
  214:     $SIG{__DIE__}='DEFAULT';
  215:     eval {
  216:      alarm(10);
  217:      print $sclient "$cmd\n";
  218:      $answer=<$sclient>;
  219:      chomp($answer);
  220:      alarm(0);
  221:     };
  222:     if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; }
  223:     $SIG{ALRM}='DEFAULT';
  224:     $SIG{__DIE__}=\&catchexception;
  225:  } else { $answer='self_reply'; }
  226:  return $answer;
  227: }
  228: 
  229: # --------------------------------------------------------------------- Logging
  230: 
  231: sub logthis {
  232:     my $message=shift;
  233:     my $execdir=$perlvar{'lonDaemons'};
  234:     my $fh=IO::File->new(">>$execdir/logs/lonc.log");
  235:     my $now=time;
  236:     my $local=localtime($now);
  237:     $lastlog=$local.': '.$message;
  238:     print $fh "$local ($$): $message\n";
  239: }
  240: 
  241: 
  242: sub logperm {
  243:     my $message=shift;
  244:     my $execdir=$perlvar{'lonDaemons'};
  245:     my $now=time;
  246:     my $local=localtime($now);
  247:     my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log");
  248:     print $fh "$now:$message:$local\n";
  249: }
  250: # ------------------------------------------------------------------ Log status
  251: 
  252: sub logstatus {
  253:     my $docdir=$perlvar{'lonDocRoot'};
  254:     my $fh=IO::File->new(">>$docdir/lon-status/loncstatus.txt");
  255:     print $fh $$."\t".$status."\t".$lastlog."\n";
  256: }
  257: 
  258: sub initnewstatus {
  259:     my $docdir=$perlvar{'lonDocRoot'};
  260:     my $fh=IO::File->new(">$docdir/lon-status/loncstatus.txt");
  261:     my $now=time;
  262:     my $local=localtime($now);
  263:     print $fh "LONC status $local - parent $$\n\n";
  264: }
  265: 
  266: # -------------------------------------------------------------- Status setting
  267: 
  268: sub status {
  269:     my $what=shift;
  270:     my $now=time;
  271:     my $local=localtime($now);
  272:     $status=$local.': '.$what;
  273: }
  274: 
  275: 
  276: # ---------------------------------------------------- Fork once and dissociate
  277: 
  278: $fpid=fork;
  279: exit if $fpid;
  280: die "Couldn't fork: $!" unless defined ($fpid);
  281: 
  282: POSIX::setsid() or die "Can't start new session: $!";
  283: 
  284: # ------------------------------------------------------- Write our PID on disk
  285: 
  286: $execdir=$perlvar{'lonDaemons'};
  287: open (PIDSAVE,">$execdir/logs/lonc.pid");
  288: print PIDSAVE "$$\n";
  289: close(PIDSAVE);
  290: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
  291: 
  292: # ----------------------------- Ignore signals generated during initial startup
  293: $SIG{HUP}=$SIG{USR1}='IGNORE';
  294: # ------------------------------------------------------- Now we are on our own
  295:     
  296: # Fork off our children, one for every server
  297: 
  298: &status("Forking ...");
  299: 
  300: foreach $thisserver (keys %hostip) {
  301:     make_new_child($thisserver);
  302: }
  303: 
  304: &logthis("Done starting initial servers");
  305: # ----------------------------------------------------- Install signal handlers
  306: 
  307: $SIG{CHLD} = \&REAPER;
  308: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
  309: $SIG{HUP}  = \&HUPSMAN;
  310: $SIG{USR1} = \&USRMAN;
  311: 
  312: # And maintain the population.
  313: while (1) {
  314:     &status("Sleeping");
  315:     sleep;                          # wait for a signal (i.e., child's death)
  316:                                     # See who died and start new one
  317:     &status("Woke up");
  318:     foreach $thisserver (keys %hostip) {
  319:         if (!$childpid{$thisserver}) {
  320: 	    if ($childatt{$thisserver}<$childmaxattempts) {
  321: 	       $childatt{$thisserver}++;
  322:                &logthis(
  323:    "<font color=yellow>INFO: Trying to reconnect for $thisserver "
  324:   ."($childatt{$thisserver} of $childmaxattempts attempts)</font>"); 
  325:                make_new_child($thisserver);
  326: 	    }
  327:         }       
  328:     }
  329: }
  330: 
  331: 
  332: sub make_new_child {
  333:    
  334:     my $conserver=shift;
  335:     my $pid;
  336:     my $sigset;
  337:     &logthis("Attempting to start child for server $conserver");
  338:     # block signal for fork
  339:     $sigset = POSIX::SigSet->new(SIGINT);
  340:     sigprocmask(SIG_BLOCK, $sigset)
  341:         or die "Can't block SIGINT for fork: $!\n";
  342:     
  343:     die "fork: $!" unless defined ($pid = fork);
  344:     
  345:     if ($pid) {
  346:         # Parent records the child's birth and returns.
  347:         sigprocmask(SIG_UNBLOCK, $sigset)
  348:             or die "Can't unblock SIGINT for fork: $!\n";
  349:         $children{$pid} = $conserver;
  350:         $childpid{$conserver} = $pid;
  351:         return;
  352:     } else {
  353:         # Child can *not* return from this subroutine.
  354:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
  355:         $SIG{USR1}= \&logstatus;
  356:    
  357:         # unblock signals
  358:         sigprocmask(SIG_UNBLOCK, $sigset)
  359:             or die "Can't unblock SIGINT for fork: $!\n";
  360: 
  361: # ----------------------------- This is the modified main program of non-forker
  362: 
  363: $port = "$perlvar{'lonSockDir'}/$conserver";
  364: 
  365: unlink($port);
  366: 
  367: # ---------------------------------------------------- Client to network server
  368: 
  369: &status("Opening TCP: $conserver");
  370: 
  371: unless (
  372:   $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
  373:                                       PeerPort => $perlvar{'londPort'},
  374:                                       Proto    => "tcp",
  375:                                       Type     => SOCK_STREAM)
  376:    ) { 
  377:        my $st=120+int(rand(240));
  378:        &logthis(
  379: "<font color=blue>WARNING: Couldn't connect $conserver ($st secs): $@</font>");
  380:        sleep($st);
  381:        exit; 
  382:      };
  383: # ----------------------------------------------------------------- Init dialog
  384: 
  385: &status("Init dialogue: $conserver");
  386: 
  387:      $SIG{ALRM}=sub { die "timeout" };
  388:      $SIG{__DIE__}='DEFAULT';
  389:      eval {
  390:          alarm(60);
  391: print $remotesock "init\n";
  392: $answer=<$remotesock>;
  393: print $remotesock "$answer";
  394: $answer=<$remotesock>;
  395: chomp($answer);
  396:           alarm(0);
  397:      };
  398:      $SIG{ALRM}='DEFAULT';
  399:      $SIG{__DIE__}=\&catchexception;
  400:  
  401:      if ($@=~/timeout/) {
  402: 	 &logthis("Timed out during init: $conserver");
  403:          exit;
  404:      }
  405: 
  406: 
  407: &logthis("Init reply for $conserver: >$answer<");
  408: if ($answer ne 'ok') {
  409:        my $st=120+int(rand(240));
  410:        &logthis(
  411: "<font color=blue>WARNING: Init failed $conserver ($st secs)</font>");
  412:        sleep($st);
  413:        exit; 
  414: }
  415: sleep 5;
  416: &status("Ponging $conserver");
  417: print $remotesock "pong\n";
  418: $answer=<$remotesock>;
  419: chomp($answer);
  420: &logthis("Pong reply for $conserver: >$answer<");
  421: # ----------------------------------------------------------- Initialize cipher
  422: 
  423: &status("Initialize cipher: $conserver");
  424: print $remotesock "ekey\n";
  425: my $buildkey=<$remotesock>;
  426: my $key=$conserver.$perlvar{'lonHostID'};
  427: $key=~tr/a-z/A-Z/;
  428: $key=~tr/G-P/0-9/;
  429: $key=~tr/Q-Z/0-9/;
  430: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
  431: $key=substr($key,0,32);
  432: my $cipherkey=pack("H32",$key);
  433: if ($cipher=new IDEA $cipherkey) {
  434:    &logthis("Secure connection initialized: $conserver");
  435: } else {
  436:    my $st=120+int(rand(240));
  437:    &logthis(
  438:      "<font color=blue>WARNING: ".
  439:      "Could not establish secure connection, $conserver ($st secs)!</font>");
  440:    sleep($st);
  441:    exit;
  442: }
  443: 
  444: # ----------------------------------------- We're online, send delayed messages
  445:     &status("Checking for delayed messages");
  446:     my @allbuffered;
  447:     my $path="$perlvar{'lonSockDir'}/delayed";
  448:     opendir(DIRHANDLE,$path);
  449:     @allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;
  450:     closedir(DIRHANDLE);
  451:     my $dfname;
  452:     foreach (@allbuffered) {
  453:         &status("Sending delayed $conserver $_");
  454:         $dfname="$path/$_";
  455:         &logthis($dfname);
  456:         my $wcmd;
  457:         {
  458:          my $dfh=IO::File->new($dfname);
  459:          $cmd=<$dfh>;
  460:         }
  461:         chomp($cmd);
  462:         my $bcmd=$cmd;
  463:         if ($cmd =~ /^encrypt\:/) {
  464: 	    my $rcmd=$cmd;
  465:             $rcmd =~ s/^encrypt\://;
  466:             chomp($rcmd);
  467:             my $cmdlength=length($rcmd);
  468:             $rcmd.="         ";
  469:             my $encrequest='';
  470:             for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
  471:                 $encrequest.=
  472:                     unpack("H16",$cipher->encrypt(substr($rcmd,$encidx,8)));
  473:             }
  474:             $cmd="enc:$cmdlength:$encrequest\n";
  475:         }
  476:     $SIG{ALRM}=sub { die "timeout" };
  477:     $SIG{__DIE__}='DEFAULT';
  478:     eval {
  479:         alarm(60);
  480:         print $remotesock "$cmd\n";
  481:         $answer=<$remotesock>;
  482: 	chomp($answer);
  483:         alarm(0);
  484:     };
  485:     $SIG{ALRM}='DEFAULT';
  486:     $SIG{__DIE__}=\&catchexception;
  487: 
  488:         if (($answer ne '') && ($@!~/timeout/)) {
  489: 	    unlink("$dfname");
  490:             &logthis("Delayed $cmd to $conserver: >$answer<");
  491:             &logperm("S:$conserver:$bcmd");
  492:         }        
  493:     }
  494: 
  495: # ------------------------------------------------------- Listen to UNIX socket
  496: &status("Opening socket $conserver");
  497: unless (
  498:   $server = IO::Socket::UNIX->new(Local  => $port,
  499:                                   Type   => SOCK_STREAM,
  500:                                   Listen => 10 )
  501:    ) { 
  502:        my $st=120+int(rand(240));
  503:        &logthis(
  504:          "<font color=blue>WARNING: ".
  505:          "Can't make server socket $conserver ($st secs): $@</font>");
  506:        sleep($st);
  507:        exit; 
  508:      };
  509: 
  510: # -----------------------------------------------------------------------------
  511: 
  512: &logthis("<font color=green>$conserver online</font>");
  513: 
  514: # -----------------------------------------------------------------------------
  515: # begin with empty buffers
  516: %inbuffer  = ();
  517: %outbuffer = ();
  518: %ready     = ();
  519: 
  520: tie %ready, 'Tie::RefHash';
  521: 
  522: nonblock($server);
  523: $select = IO::Select->new($server);
  524: 
  525: # Main loop: check reads/accepts, check writes, check ready to process
  526: while (1) {
  527:     my $client;
  528:     my $rv;
  529:     my $data;
  530: 
  531:     # check for new information on the connections we have
  532: 
  533:     # anything to read or accept?
  534:     foreach $client ($select->can_read(0.1)) {
  535: 
  536:         if ($client == $server) {
  537:             # accept a new connection
  538:             &status("Accept new connection: $conserver");
  539:             $client = $server->accept();
  540:             $select->add($client);
  541:             nonblock($client);
  542:         } else {
  543:             # read data
  544:             $data = '';
  545:             $rv   = $client->recv($data, POSIX::BUFSIZ, 0);
  546: 
  547:             unless (defined($rv) && length $data) {
  548:                 # This would be the end of file, so close the client
  549:                 delete $inbuffer{$client};
  550:                 delete $outbuffer{$client};
  551:                 delete $ready{$client};
  552: 
  553:                 &status("Idle $conserver");
  554:                 $select->remove($client);
  555:                 close $client;
  556:                 next;
  557:             }
  558: 
  559:             $inbuffer{$client} .= $data;
  560: 
  561:             # test whether the data in the buffer or the data we
  562:             # just read means there is a complete request waiting
  563:             # to be fulfilled.  If there is, set $ready{$client}
  564:             # to the requests waiting to be fulfilled.
  565:             while ($inbuffer{$client} =~ s/(.*\n)//) {
  566:                 push( @{$ready{$client}}, $1 );
  567:             }
  568:         }
  569:     }
  570: 
  571:     # Any complete requests to process?
  572:     foreach $client (keys %ready) {
  573: 	handle($client,$conserver);
  574:     }
  575: 
  576:     # Buffers to flush?
  577:     foreach $client ($select->can_write(1)) {
  578:         # Skip this client if we have nothing to say
  579:         next unless exists $outbuffer{$client};
  580:         $rv = $client->send($outbuffer{$client}, 0);
  581:         unless (defined $rv) {
  582:             # Whine, but move on.
  583:             &logthis("I was told I could write, but I can't.\n");
  584:             next;
  585:         }
  586:         $errno=$!;
  587:         if (($rv == length $outbuffer{$client}) ||
  588:             ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) {
  589:             substr($outbuffer{$client}, 0, $rv) = '';
  590:             delete $outbuffer{$client} unless length $outbuffer{$client};
  591:         } else {
  592:             # Couldn't write all the data, and it wasn't because
  593:             # it would have blocked.  Shutdown and move on.
  594: 
  595: 	    &logthis("Dropping data with ".$errno.": ".
  596:                      length($outbuffer{$client}).", $rv");
  597: 
  598:             delete $inbuffer{$client};
  599:             delete $outbuffer{$client};
  600:             delete $ready{$client};
  601: 
  602:             $select->remove($client);
  603:             close($client);
  604:             next;
  605:         }
  606:     }
  607: }
  608: }
  609: }
  610: # ------------------------------------------------------- End of make_new_child
  611: 
  612: # handle($socket) deals with all pending requests for $client
  613: sub handle {
  614:     # requests are in $ready{$client}
  615:     # send output to $outbuffer{$client}
  616:     my $client = shift;
  617:     my $conserver = shift;
  618:     my $request;
  619: 
  620:     foreach $request (@{$ready{$client}}) {
  621: # ============================================================= Process request
  622:         # $request is the text of the request
  623:         # put text of reply into $outbuffer{$client}
  624: # -----------------------------------------------------------------------------
  625:         if ($request =~ /^encrypt\:/) {
  626: 	    my $cmd=$request;
  627:             $cmd =~ s/^encrypt\://;
  628:             chomp($cmd);
  629:             my $cmdlength=length($cmd);
  630:             $cmd.="         ";
  631:             my $encrequest='';
  632:             for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
  633:                 $encrequest.=
  634:                     unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
  635:             }
  636:             $request="enc:$cmdlength:$encrequest\n";
  637:         }
  638: # --------------------------------------------------------------- Main exchange
  639:     $SIG{ALRM}=sub { die "timeout" };
  640:     $SIG{__DIE__}='DEFAULT';
  641:     eval {
  642:         alarm(300);
  643:         &status("Sending $conserver: $request");
  644:         &logthis("Sending $conserver: $request");
  645:         print $remotesock "$request";
  646:         &status("Waiting for reply from $conserver: $request");
  647:         &logthis("Waiting for reply from $conserver: $request");
  648:         $answer=<$remotesock>;
  649:         &status("Received reply: $request");
  650:         &logthis("Received reply $conserver: $answer");
  651:         alarm(0);
  652:     };
  653:     if ($@=~/timeout/) { 
  654:        $answer='';
  655:        &logthis(
  656:         "<font color=red>CRITICAL: Timeout $conserver: $request</font>");
  657:     }  
  658:     $SIG{ALRM}='DEFAULT';
  659:     $SIG{__DIE__}=\&catchexception;
  660: 
  661: 
  662:         if ($answer) {
  663: 	   if ($answer =~ /^enc/) {
  664:                my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
  665:                chomp($encinput);
  666: 	       $answer='';
  667:                for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
  668:                   $answer.=$cipher->decrypt(
  669:                    pack("H16",substr($encinput,$encidx,16))
  670:                   );
  671: 	       }
  672: 	      $answer=substr($answer,0,$cmdlength);
  673: 	      $answer.="\n";
  674: 	   }
  675:            $outbuffer{$client} .= $answer;
  676:         } else {
  677:            $outbuffer{$client} .= "con_lost\n";
  678:         }
  679: 
  680: # ===================================================== Done processing request
  681: 	&logthis("Completed $conserver: $request");
  682:     }
  683:     delete $ready{$client};
  684:     &status("Completed $conserver: $request");
  685: # -------------------------------------------------------------- End non-forker
  686: }
  687: # ---------------------------------------------------------- End make_new_child
  688: 
  689: # nonblock($socket) puts socket into nonblocking mode
  690: sub nonblock {
  691:     my $socket = shift;
  692:     my $flags;
  693: 
  694:     
  695:     $flags = fcntl($socket, F_GETFL, 0)
  696:             or die "Can't get flags for socket: $!\n";
  697:     fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
  698:             or die "Can't make socket nonblocking: $!\n";
  699: }
  700: 
  701: # ----------------------------------- POD (plain old documentation, CPAN style)
  702: 
  703: =head1 NAME
  704: 
  705: lonc - LON TCP-MySQL-Server Daemon for handling database requests.
  706: 
  707: =head1 SYNOPSIS
  708: 
  709: Should only be run as user=www.  This is a command-line script which
  710: is invoked by loncron.
  711: 
  712: =head1 DESCRIPTION
  713: 
  714: Provides persistent TCP connections to the other servers in the network
  715: through multiplexed domain sockets
  716: 
  717:  PID in subdir logs/lonc.pid
  718:  kill kills
  719:  HUP restarts
  720:  USR1 tries to open connections again
  721: 
  722: =head1 README
  723: 
  724: Not yet written.
  725: 
  726: =head1 PREREQUISITES
  727: 
  728: POSIX
  729: IO::Socket
  730: IO::Select
  731: IO::File
  732: Socket
  733: Fcntl
  734: Tie::RefHash
  735: Crypt::IDEA
  736: 
  737: =head1 COREQUISITES
  738: 
  739: =head1 OSNAMES
  740: 
  741: linux
  742: 
  743: =head1 SCRIPT CATEGORIES
  744: 
  745: Server/Process
  746: 
  747: =cut

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