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