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