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