Return to lonc CVS log

Up to [LON-CAPA] / loncom

Put in additional sleep so that children do not die before reaper in place
(lonc)
Marked up logs
Put in report for after the lonc/lond start into loncron

    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: # PID in subdir logs/lonc.pid
    9: # kill kills
   10: # HUP restarts
   11: # USR1 tries to open connections again
   12: 
   13: # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,
   14: # 10/8,10/9,10/15,11/18,12/22,
   15: # 2/8 Gerd Kortemeyer 
   16: # based on nonforker from Perl Cookbook
   17: # - server who multiplexes without forking
   18: 
   19: use POSIX;
   20: use IO::Socket;
   21: use IO::Select;
   22: use IO::File;
   23: use Socket;
   24: use Fcntl;
   25: use Tie::RefHash;
   26: use Crypt::IDEA;
   27: 
   28: $childmaxattempts=10;
   29: 
   30: # ------------------------------------ Read httpd access.conf and get variables
   31: 
   32: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
   33: 
   34: while ($configline=<CONFIG>) {
   35:     if ($configline =~ /PerlSetVar/) {
   36: 	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
   37:         chomp($varvalue);
   38:         $perlvar{$varname}=$varvalue;
   39:     }
   40: }
   41: close(CONFIG);
   42: 
   43: # ------------------------------------------------------------- Read hosts file
   44: 
   45: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
   46: 
   47: while ($configline=<CONFIG>) {
   48:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
   49:     chomp($ip);
   50:     $hostip{$id}=$ip;
   51: }
   52: close(CONFIG);
   53: 
   54: # -------------------------------------------------------- Routines for forking
   55: 
   56: %children               = ();       # keys are current child process IDs,
   57:                                     # values are hosts
   58: %childpid               = ();       # the other way around
   59: 
   60: %childatt               = ();       # number of attempts to start server
   61:                                     # for ID
   62: 
   63: sub REAPER {                        # takes care of dead children
   64:     $SIG{CHLD} = \&REAPER;
   65:     my $pid = wait;
   66:     my $wasserver=$children{$pid};
   67:     &logthis(
   68:      "<font color=red>CRITICAL: Child $pid for server $wasserver died</font>");
   69:     delete $children{$pid};
   70:     delete $childpid{$wasserver};
   71:     my $port = "$perlvar{'lonSockDir'}/$wasserver";
   72:     unlink($port);
   73: }
   74: 
   75: sub HUNTSMAN {                      # signal handler for SIGINT
   76:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
   77:     kill 'INT' => keys %children;
   78:     my $execdir=$perlvar{'lonDaemons'};
   79:     unlink("$execdir/logs/lonc.pid");
   80:     &logthis("<font color=red>CRITICAL: Shutting down</font>");
   81:     exit;                           # clean up with dignity
   82: }
   83: 
   84: sub HUPSMAN {                      # signal handler for SIGHUP
   85:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
   86:     kill 'INT' => keys %children;
   87:     &logthis("<font color=red>CRITICAL: Restarting</font>");
   88:     my $execdir=$perlvar{'lonDaemons'};
   89:     exec("$execdir/lonc");         # here we go again
   90: }
   91: 
   92: sub USRMAN {
   93:     %childatt=();
   94:     &logthis("USR1: Trying to establish connections again");
   95:     foreach $thisserver (keys %hostip) {
   96: 	$answer=subreply("ping",$thisserver);
   97:         &logthis(
   98:           "USR1: Ping $thisserver (pid >$childpid{$thisserver}<): >$answer<");
   99:     }
  100: }
  101: 
  102: # -------------------------------------------------- Non-critical communication
  103: sub subreply { 
  104:  my ($cmd,$server)=@_;
  105:  my $answer='';
  106:  if ($server ne $perlvar{'lonHostID'}) { 
  107:     my $peerfile="$perlvar{'lonSockDir'}/$server";
  108:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
  109:                                       Type    => SOCK_STREAM,
  110:                                       Timeout => 10)
  111:        or return "con_lost";
  112:     print $sclient "$cmd\n";
  113:     my $answer=<$sclient>;
  114:     chomp($answer);
  115:     if (!$answer) { $answer="con_lost"; }
  116:  } else { $answer='self_reply'; }
  117:  return $answer;
  118: }
  119: 
  120: # --------------------------------------------------------------------- Logging
  121: 
  122: sub logthis {
  123:     my $message=shift;
  124:     my $execdir=$perlvar{'lonDaemons'};
  125:     my $fh=IO::File->new(">>$execdir/logs/lonc.log");
  126:     my $now=time;
  127:     my $local=localtime($now);
  128:     print $fh "$local ($$): $message\n";
  129: }
  130: 
  131: 
  132: sub logperm {
  133:     my $message=shift;
  134:     my $execdir=$perlvar{'lonDaemons'};
  135:     my $now=time;
  136:     my $local=localtime($now);
  137:     my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log");
  138:     print $fh "$now:$message:$local\n";
  139: }
  140: 
  141: # ---------------------------------------------------- Fork once and dissociate
  142: 
  143: $fpid=fork;
  144: exit if $fpid;
  145: die "Couldn't fork: $!" unless defined ($fpid);
  146: 
  147: POSIX::setsid() or die "Can't start new session: $!";
  148: 
  149: # ------------------------------------------------------- Write our PID on disk
  150: 
  151: $execdir=$perlvar{'lonDaemons'};
  152: open (PIDSAVE,">$execdir/logs/lonc.pid");
  153: print PIDSAVE "$$\n";
  154: close(PIDSAVE);
  155: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
  156: 
  157: # ----------------------------- Ignore signals generated during initial startup
  158: $SIG{HUP}=$SIG{USR1}='IGNORE';
  159: # ------------------------------------------------------- Now we are on our own
  160:     
  161: # Fork off our children, one for every server
  162: 
  163: foreach $thisserver (keys %hostip) {
  164:     make_new_child($thisserver);
  165: }
  166: 
  167: &logthis("Done starting initial servers");
  168: # ----------------------------------------------------- Install signal handlers
  169: 
  170: $SIG{CHLD} = \&REAPER;
  171: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
  172: $SIG{HUP}  = \&HUPSMAN;
  173: $SIG{USR1} = \&USRMAN;
  174: 
  175: # And maintain the population.
  176: while (1) {
  177:     sleep;                          # wait for a signal (i.e., child's death)
  178:                                     # See who died and start new one
  179:     foreach $thisserver (keys %hostip) {
  180:         if (!$childpid{$thisserver}) {
  181: 	    if ($childatt{$thisserver}<=$childmaxattempt) {
  182: 	       my $ainfoatt=1*$childatt{$thisserver};
  183:                &logthis(
  184:    "<font color=yellow>INFO: Trying to reconnect for $thisserver "
  185:   ."($ainfoatt of $childmaxattempts attempts)</font>"); 
  186:                make_new_child($thisserver);
  187:                $childatt{$thisserver}++;
  188: 	    }
  189:         }       
  190:     }
  191: }
  192: 
  193: 
  194: sub make_new_child {
  195:    
  196:     my $conserver=shift;
  197:     my $pid;
  198:     my $sigset;
  199:     &logthis("Attempting to start child for server $conserver");
  200:     # block signal for fork
  201:     $sigset = POSIX::SigSet->new(SIGINT);
  202:     sigprocmask(SIG_BLOCK, $sigset)
  203:         or die "Can't block SIGINT for fork: $!\n";
  204:     
  205:     die "fork: $!" unless defined ($pid = fork);
  206:     
  207:     if ($pid) {
  208:         # Parent records the child's birth and returns.
  209:         sigprocmask(SIG_UNBLOCK, $sigset)
  210:             or die "Can't unblock SIGINT for fork: $!\n";
  211:         $children{$pid} = $conserver;
  212:         $childpid{$conserver} = $pid;
  213:         return;
  214:     } else {
  215:         # Child can *not* return from this subroutine.
  216:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
  217:     
  218:         # unblock signals
  219:         sigprocmask(SIG_UNBLOCK, $sigset)
  220:             or die "Can't unblock SIGINT for fork: $!\n";
  221: 
  222: # ----------------------------- This is the modified main program of non-forker
  223: 
  224: $port = "$perlvar{'lonSockDir'}/$conserver";
  225: 
  226: unlink($port);
  227: # ---------------------------------------------------- Client to network server
  228: unless (
  229:   $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
  230:                                       PeerPort => $perlvar{'londPort'},
  231:                                       Proto    => "tcp",
  232:                                       Type     => SOCK_STREAM)
  233:    ) { 
  234:        my $st=120+int(rand(240));
  235:        &logthis(
  236: "<font color=blue>WARNING: Couldn't connect $conserver ($st secs): $@</font>");
  237:        sleep($st);
  238:        exit; 
  239:      };
  240: # --------------------------------------- Send a ping to make other end do USR1
  241: print $remotesock "init\n";
  242: $answer=<$remotesock>;
  243: print $remotesock "$answer";
  244: $answer=<$remotesock>;
  245: chomp($answer);
  246: &logthis("Init reply for $conserver: >$answer<");
  247: sleep 5;
  248: print $remotesock "pong\n";
  249: $answer=<$remotesock>;
  250: chomp($answer);
  251: &logthis("Pong reply for $conserver: >$answer<");
  252: # ----------------------------------------------------------- Initialize cipher
  253: 
  254: print $remotesock "ekey\n";
  255: my $buildkey=<$remotesock>;
  256: my $key=$conserver.$perlvar{'lonHostID'};
  257: $key=~tr/a-z/A-Z/;
  258: $key=~tr/G-P/0-9/;
  259: $key=~tr/Q-Z/0-9/;
  260: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
  261: $key=substr($key,0,32);
  262: my $cipherkey=pack("H32",$key);
  263: if ($cipher=new IDEA $cipherkey) {
  264:    &logthis("Secure connection inititalized: $conserver");
  265: } else {
  266:    my $st=120+int(rand(240));
  267:    &logthis(
  268:      "<font color=blue>WARNING: ".
  269:      "Could not establish secure connection, $conserver ($st secs)!</font>");
  270:    sleep($st);
  271:    exit;
  272: }
  273: 
  274: # ----------------------------------------- We're online, send delayed messages
  275: 
  276:     my @allbuffered;
  277:     my $path="$perlvar{'lonSockDir'}/delayed";
  278:     opendir(DIRHANDLE,$path);
  279:     @allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;
  280:     closedir(DIRHANDLE);
  281:     my $dfname;
  282:     map {
  283:         $dfname="$path/$_";
  284:         &logthis($dfname);
  285:         my $wcmd;
  286:         {
  287:          my $dfh=IO::File->new($dfname);
  288:          $cmd=<$dfh>;
  289:         }
  290:         chomp($cmd);
  291:         my $bcmd=$cmd;
  292:         if ($cmd =~ /^encrypt\:/) {
  293: 	    my $rcmd=$cmd;
  294:             $rcmd =~ s/^encrypt\://;
  295:             chomp($rcmd);
  296:             my $cmdlength=length($rcmd);
  297:             $rcmd.="         ";
  298:             my $encrequest='';
  299:             for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
  300:                 $encrequest.=
  301:                     unpack("H16",$cipher->encrypt(substr($rcmd,$encidx,8)));
  302:             }
  303:             $cmd="enc:$cmdlength:$encrequest\n";
  304:         }
  305: 
  306:         print $remotesock "$cmd\n";
  307:         $answer=<$remotesock>;
  308: 	chomp($answer);
  309:         if ($answer ne '') {
  310: 	    unlink("$dfname");
  311:             &logthis("Delayed $cmd to $conserver: >$answer<");
  312:             &logperm("S:$conserver:$bcmd");
  313:         }        
  314:     } @allbuffered;
  315: 
  316: # ------------------------------------------------------- Listen to UNIX socket
  317: unless (
  318:   $server = IO::Socket::UNIX->new(Local  => $port,
  319:                                   Type   => SOCK_STREAM,
  320:                                   Listen => 10 )
  321:    ) { 
  322:        my $st=120+int(rand(240));
  323:        &logthis(
  324:          "<font color=blue>WARNING: ".
  325:          "Can't make server socket $conserver ($st secs): $@</font>");
  326:        sleep($st);
  327:        exit; 
  328:      };
  329: 
  330: # -----------------------------------------------------------------------------
  331: 
  332: &logthis("<font color=green>$conserver online</font>");
  333: 
  334: # -----------------------------------------------------------------------------
  335: # begin with empty buffers
  336: %inbuffer  = ();
  337: %outbuffer = ();
  338: %ready     = ();
  339: 
  340: tie %ready, 'Tie::RefHash';
  341: 
  342: nonblock($server);
  343: $select = IO::Select->new($server);
  344: 
  345: # Main loop: check reads/accepts, check writes, check ready to process
  346: while (1) {
  347:     my $client;
  348:     my $rv;
  349:     my $data;
  350: 
  351:     # check for new information on the connections we have
  352: 
  353:     # anything to read or accept?
  354:     foreach $client ($select->can_read(1)) {
  355: 
  356:         if ($client == $server) {
  357:             # accept a new connection
  358: 
  359:             $client = $server->accept();
  360:             $select->add($client);
  361:             nonblock($client);
  362:         } else {
  363:             # read data
  364:             $data = '';
  365:             $rv   = $client->recv($data, POSIX::BUFSIZ, 0);
  366: 
  367:             unless (defined($rv) && length $data) {
  368:                 # This would be the end of file, so close the client
  369:                 delete $inbuffer{$client};
  370:                 delete $outbuffer{$client};
  371:                 delete $ready{$client};
  372: 
  373:                 $select->remove($client);
  374:                 close $client;
  375:                 next;
  376:             }
  377: 
  378:             $inbuffer{$client} .= $data;
  379: 
  380:             # test whether the data in the buffer or the data we
  381:             # just read means there is a complete request waiting
  382:             # to be fulfilled.  If there is, set $ready{$client}
  383:             # to the requests waiting to be fulfilled.
  384:             while ($inbuffer{$client} =~ s/(.*\n)//) {
  385:                 push( @{$ready{$client}}, $1 );
  386:             }
  387:         }
  388:     }
  389: 
  390:     # Any complete requests to process?
  391:     foreach $client (keys %ready) {
  392:         handle($client);
  393:     }
  394: 
  395:     # Buffers to flush?
  396:     foreach $client ($select->can_write(1)) {
  397:         # Skip this client if we have nothing to say
  398:         next unless exists $outbuffer{$client};
  399: 
  400:         $rv = $client->send($outbuffer{$client}, 0);
  401:         unless (defined $rv) {
  402:             # Whine, but move on.
  403:             warn "I was told I could write, but I can't.\n";
  404:             next;
  405:         }
  406:         if (($rv == length $outbuffer{$client}) ||
  407:             ($! == POSIX::EWOULDBLOCK)) {
  408:             substr($outbuffer{$client}, 0, $rv) = '';
  409:             delete $outbuffer{$client} unless length $outbuffer{$client};
  410:         } else {
  411:             # Couldn't write all the data, and it wasn't because
  412:             # it would have blocked.  Shutdown and move on.
  413:             delete $inbuffer{$client};
  414:             delete $outbuffer{$client};
  415:             delete $ready{$client};
  416: 
  417:             $select->remove($client);
  418:             close($client);
  419:             next;
  420:         }
  421:     }
  422: }
  423: }
  424: 
  425: # ------------------------------------------------------- End of make_new_child
  426: 
  427: # handle($socket) deals with all pending requests for $client
  428: sub handle {
  429:     # requests are in $ready{$client}
  430:     # send output to $outbuffer{$client}
  431:     my $client = shift;
  432:     my $request;
  433: 
  434:     foreach $request (@{$ready{$client}}) {
  435: # ============================================================= Process request
  436:         # $request is the text of the request
  437:         # put text of reply into $outbuffer{$client}
  438: # -----------------------------------------------------------------------------
  439:         if ($request =~ /^encrypt\:/) {
  440: 	    my $cmd=$request;
  441:             $cmd =~ s/^encrypt\://;
  442:             chomp($cmd);
  443:             my $cmdlength=length($cmd);
  444:             $cmd.="         ";
  445:             my $encrequest='';
  446:             for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
  447:                 $encrequest.=
  448:                     unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
  449:             }
  450:             $request="enc:$cmdlength:$encrequest\n";
  451:         }
  452:         print $remotesock "$request";
  453:         $answer=<$remotesock>;
  454:         if ($answer) {
  455: 	   if ($answer =~ /^enc/) {
  456:                my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
  457:                chomp($encinput);
  458: 	       $answer='';
  459:                for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
  460:                   $answer.=$cipher->decrypt(
  461:                    pack("H16",substr($encinput,$encidx,16))
  462:                   );
  463: 	       }
  464: 	      $answer=substr($answer,0,$cmdlength);
  465: 	      $answer.="\n";
  466: 	   }
  467:            $outbuffer{$client} .= $answer;
  468:         } else {
  469:            $outbuffer{$client} .= "con_lost\n";
  470:         }
  471: 
  472: # ===================================================== Done processing request
  473:     }
  474:     delete $ready{$client};
  475: # -------------------------------------------------------------- End non-forker
  476: }
  477: # ---------------------------------------------------------- End make_new_child
  478: }
  479: 
  480: # nonblock($socket) puts socket into nonblocking mode
  481: sub nonblock {
  482:     my $socket = shift;
  483:     my $flags;
  484: 
  485:     
  486:     $flags = fcntl($socket, F_GETFL, 0)
  487:             or die "Can't get flags for socket: $!\n";
  488:     fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
  489:             or die "Can't make socket nonblocking: $!\n";
  490: }
  491: 
  492: 
  493: 
  494: 
  495: