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