Annotation of loncom/lonc, revision 1.24

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

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