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