Annotation of loncom/lonc, revision 1.18

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

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