Annotation of loncom/lonc, revision 1.1.1.1

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

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