Return to lonc CVS log

Up to [LON-CAPA] / loncom

(somewhat unexpectedly) need to move subroutines to top of code
due to limits of perl program parser (otherwise received predeclaration
error) -Scott

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