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