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