Annotation of loncom/lonc, revision 1.25
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.25 ! albertel 573: handle($client);
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};
1.25 ! albertel 580:
1.1 albertel 581: $rv = $client->send($outbuffer{$client}, 0);
582: unless (defined $rv) {
583: # Whine, but move on.
1.15 www 584: &logthis("I was told I could write, but I can't.\n");
1.1 albertel 585: next;
586: }
1.15 www 587: $errno=$!;
1.1 albertel 588: if (($rv == length $outbuffer{$client}) ||
1.15 www 589: ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) {
1.1 albertel 590: substr($outbuffer{$client}, 0, $rv) = '';
591: delete $outbuffer{$client} unless length $outbuffer{$client};
592: } else {
593: # Couldn't write all the data, and it wasn't because
594: # it would have blocked. Shutdown and move on.
1.15 www 595:
596: &logthis("Dropping data with ".$errno.": ".
597: length($outbuffer{$client}).", $rv");
598:
1.1 albertel 599: delete $inbuffer{$client};
600: delete $outbuffer{$client};
601: delete $ready{$client};
602:
603: $select->remove($client);
604: close($client);
605: next;
606: }
607: }
608: }
609: }
1.25 ! albertel 610:
1.1 albertel 611: # ------------------------------------------------------- End of make_new_child
612:
613: # handle($socket) deals with all pending requests for $client
614: sub handle {
615: # requests are in $ready{$client}
616: # send output to $outbuffer{$client}
617: my $client = shift;
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.1 albertel 644: print $remotesock "$request";
1.18 www 645: &status("Waiting for reply from $conserver: $request");
1.1 albertel 646: $answer=<$remotesock>;
1.18 www 647: &status("Received reply: $request");
1.19 www 648: alarm(0);
649: };
650: if ($@=~/timeout/) {
651: $answer='';
652: &logthis(
653: "<font color=red>CRITICAL: Timeout $conserver: $request</font>");
654: }
655: $SIG{ALRM}='DEFAULT';
656: $SIG{__DIE__}=\&catchexception;
657:
658:
1.1 albertel 659: if ($answer) {
660: if ($answer =~ /^enc/) {
661: my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
662: chomp($encinput);
663: $answer='';
664: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
665: $answer.=$cipher->decrypt(
666: pack("H16",substr($encinput,$encidx,16))
667: );
668: }
669: $answer=substr($answer,0,$cmdlength);
670: $answer.="\n";
671: }
672: $outbuffer{$client} .= $answer;
673: } else {
674: $outbuffer{$client} .= "con_lost\n";
675: }
676:
677: # ===================================================== Done processing request
678: }
679: delete $ready{$client};
1.18 www 680: &status("Completed $conserver: $request");
1.1 albertel 681: # -------------------------------------------------------------- End non-forker
682: }
683: # ---------------------------------------------------------- End make_new_child
1.25 ! albertel 684: }
1.1 albertel 685:
686: # nonblock($socket) puts socket into nonblocking mode
687: sub nonblock {
688: my $socket = shift;
689: my $flags;
690:
691:
692: $flags = fcntl($socket, F_GETFL, 0)
1.11 harris41 693: or die "Can't get flags for socket: $!\n";
1.1 albertel 694: fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
1.11 harris41 695: or die "Can't make socket nonblocking: $!\n";
1.8 harris41 696: }
1.1 albertel 697:
1.23 harris41 698: # ----------------------------------- POD (plain old documentation, CPAN style)
699:
700: =head1 NAME
701:
702: lonc - LON TCP-MySQL-Server Daemon for handling database requests.
703:
704: =head1 SYNOPSIS
705:
706: Should only be run as user=www. This is a command-line script which
707: is invoked by loncron.
708:
709: =head1 DESCRIPTION
710:
711: Provides persistent TCP connections to the other servers in the network
712: through multiplexed domain sockets
713:
714: PID in subdir logs/lonc.pid
715: kill kills
716: HUP restarts
717: USR1 tries to open connections again
718:
719: =head1 README
720:
721: Not yet written.
722:
723: =head1 PREREQUISITES
724:
725: POSIX
726: IO::Socket
727: IO::Select
728: IO::File
729: Socket
730: Fcntl
731: Tie::RefHash
732: Crypt::IDEA
733:
734: =head1 COREQUISITES
735:
736: =head1 OSNAMES
737:
738: linux
739:
740: =head1 SCRIPT CATEGORIES
741:
742: Server/Process
743:
744: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonc CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom