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