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