Annotation of loncom/lonc, revision 1.15

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

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