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