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 Gerd Kortemeyer
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:
125: # ---------------------------------------------------- Fork once and dissociate
126:
127: $fpid=fork;
128: exit if $fpid;
129: die "Couldn't fork: $!" unless defined ($fpid);
130:
131: POSIX::setsid() or die "Can't start new session: $!";
132:
133: # ------------------------------------------------------- Write our PID on disk
134:
135: $execdir=$perlvar{'lonDaemons'};
136: open (PIDSAVE,">$execdir/logs/lonc.pid");
137: print PIDSAVE "$$\n";
138: close(PIDSAVE);
139: &logthis("---------- Starting ----------");
140:
141: # ----------------------------- Ignore signals generated during initial startup
142: $SIG{HUP}=$SIG{USR1}='IGNORE';
143: # ------------------------------------------------------- Now we are on our own
144:
145: # Fork off our children, one for every server
146:
147: foreach $thisserver (keys %hostip) {
148: make_new_child($thisserver);
149: }
150:
151: &logthis("Done starting initial servers");
152: # ----------------------------------------------------- Install signal handlers
153:
154: $SIG{CHLD} = \&REAPER;
155: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
156: $SIG{HUP} = \&HUPSMAN;
157: $SIG{USR1} = \&USRMAN;
158:
159: # And maintain the population.
160: while (1) {
161: sleep; # wait for a signal (i.e., child's death)
162: # See who died and start new one
163: foreach $thisserver (keys %hostip) {
164: if (!$childpid{$thisserver}) {
165: if ($childatt{$thisserver}<5) {
166: make_new_child($thisserver);
167: $childatt{$thisserver}++;
168: }
169: }
170: }
171: }
172:
173:
174: sub make_new_child {
175:
176: my $conserver=shift;
177: my $pid;
178: my $sigset;
179: &logthis("Attempting to start child for server $conserver");
180: # block signal for fork
181: $sigset = POSIX::SigSet->new(SIGINT);
182: sigprocmask(SIG_BLOCK, $sigset)
183: or die "Can't block SIGINT for fork: $!\n";
184:
185: die "fork: $!" unless defined ($pid = fork);
186:
187: if ($pid) {
188: # Parent records the child's birth and returns.
189: sigprocmask(SIG_UNBLOCK, $sigset)
190: or die "Can't unblock SIGINT for fork: $!\n";
191: $children{$pid} = $conserver;
192: $childpid{$conserver} = $pid;
193: return;
194: } else {
195: # Child can *not* return from this subroutine.
196: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
197:
198: # unblock signals
199: sigprocmask(SIG_UNBLOCK, $sigset)
200: or die "Can't unblock SIGINT for fork: $!\n";
201:
202: # ----------------------------- This is the modified main program of non-forker
203:
204: $port = "$perlvar{'lonSockDir'}/$conserver";
205:
206: unlink($port);
207: # ---------------------------------------------------- Client to network server
208: unless (
209: $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
210: PeerPort => $perlvar{'londPort'},
211: Proto => "tcp",
212: Type => SOCK_STREAM)
213: ) { &logthis("Couldn't connect $conserver: $@");
214: sleep(5);
215: exit;
216: };
217: # --------------------------------------- Send a ping to make other end do USR1
218: print $remotesock "init\n";
219: $answer=<$remotesock>;
220: print $remotesock "$answer";
221: $answer=<$remotesock>;
222: chomp($answer);
223: &logthis("Init reply for $conserver: >$answer<");
224: sleep 5;
225: print $remotesock "pong\n";
226: $answer=<$remotesock>;
227: chomp($answer);
228: &logthis("Pong reply for $conserver: >$answer<");
229: # ----------------------------------------------------------- Initialize cipher
230:
231: print $remotesock "ekey\n";
232: my $buildkey=<$remotesock>;
233: my $key=$conserver.$perlvar{'lonHostID'};
234: $key=~tr/a-z/A-Z/;
235: $key=~tr/G-P/0-9/;
236: $key=~tr/Q-Z/0-9/;
237: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
238: $key=substr($key,0,32);
239: my $cipherkey=pack("H32",$key);
240: if ($cipher=new IDEA $cipherkey) {
241: &logthis("Secure connection inititalized: $conserver");
242: } else {
243: &logthis("Error: Could not establish secure connection, $conserver!");
244: }
245:
246:
247: # ------------------------------------------------------- Listen to UNIX socket
248: unless (
249: $server = IO::Socket::UNIX->new(Local => $port,
250: Type => SOCK_STREAM,
251: Listen => 10 )
252: ) { &logthis("Can't make server socket $conserver: $@");
253: sleep(5);
254: exit;
255: };
256:
257: # -----------------------------------------------------------------------------
258:
259: # begin with empty buffers
260: %inbuffer = ();
261: %outbuffer = ();
262: %ready = ();
263:
264: tie %ready, 'Tie::RefHash';
265:
266: nonblock($server);
267: $select = IO::Select->new($server);
268:
269: # Main loop: check reads/accepts, check writes, check ready to process
270: while (1) {
271: my $client;
272: my $rv;
273: my $data;
274:
275: # check for new information on the connections we have
276:
277: # anything to read or accept?
278: foreach $client ($select->can_read(1)) {
279:
280: if ($client == $server) {
281: # accept a new connection
282:
283: $client = $server->accept();
284: $select->add($client);
285: nonblock($client);
286: } else {
287: # read data
288: $data = '';
289: $rv = $client->recv($data, POSIX::BUFSIZ, 0);
290:
291: unless (defined($rv) && length $data) {
292: # This would be the end of file, so close the client
293: delete $inbuffer{$client};
294: delete $outbuffer{$client};
295: delete $ready{$client};
296:
297: $select->remove($client);
298: close $client;
299: next;
300: }
301:
302: $inbuffer{$client} .= $data;
303:
304: # test whether the data in the buffer or the data we
305: # just read means there is a complete request waiting
306: # to be fulfilled. If there is, set $ready{$client}
307: # to the requests waiting to be fulfilled.
308: while ($inbuffer{$client} =~ s/(.*\n)//) {
309: push( @{$ready{$client}}, $1 );
310: }
311: }
312: }
313:
314: # Any complete requests to process?
315: foreach $client (keys %ready) {
316: handle($client);
317: }
318:
319: # Buffers to flush?
320: foreach $client ($select->can_write(1)) {
321: # Skip this client if we have nothing to say
322: next unless exists $outbuffer{$client};
323:
324: $rv = $client->send($outbuffer{$client}, 0);
325: unless (defined $rv) {
326: # Whine, but move on.
327: warn "I was told I could write, but I can't.\n";
328: next;
329: }
330: if (($rv == length $outbuffer{$client}) ||
331: ($! == POSIX::EWOULDBLOCK)) {
332: substr($outbuffer{$client}, 0, $rv) = '';
333: delete $outbuffer{$client} unless length $outbuffer{$client};
334: } else {
335: # Couldn't write all the data, and it wasn't because
336: # it would have blocked. Shutdown and move on.
337: delete $inbuffer{$client};
338: delete $outbuffer{$client};
339: delete $ready{$client};
340:
341: $select->remove($client);
342: close($client);
343: next;
344: }
345: }
346: }
347: }
348:
349: # ------------------------------------------------------- End of make_new_child
350:
351: # handle($socket) deals with all pending requests for $client
352: sub handle {
353: # requests are in $ready{$client}
354: # send output to $outbuffer{$client}
355: my $client = shift;
356: my $request;
357:
358: foreach $request (@{$ready{$client}}) {
359: # ============================================================= Process request
360: # $request is the text of the request
361: # put text of reply into $outbuffer{$client}
362: # -----------------------------------------------------------------------------
363: if ($request =~ /^encrypt\:/) {
364: my $cmd=$request;
365: $cmd =~ s/^encrypt\://;
366: chomp($cmd);
367: my $cmdlength=length($cmd);
368: $cmd.=" ";
369: my $encrequest='';
370: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
371: $encrequest.=
372: unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
373: }
374: $request="enc:$cmdlength:$encrequest\n";
375: }
376: print $remotesock "$request";
377: $answer=<$remotesock>;
378: if ($answer) {
379: if ($answer =~ /^enc/) {
380: my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
381: chomp($encinput);
382: $answer='';
383: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
384: $answer.=$cipher->decrypt(
385: pack("H16",substr($encinput,$encidx,16))
386: );
387: }
388: $answer=substr($answer,0,$cmdlength);
389: $answer.="\n";
390: }
391: $outbuffer{$client} .= $answer;
392: } else {
393: $outbuffer{$client} .= "con_lost\n";
394: }
395:
396: # ===================================================== Done processing request
397: }
398: delete $ready{$client};
399: # -------------------------------------------------------------- End non-forker
400: }
401: # ---------------------------------------------------------- End make_new_child
402: }
403:
404: # nonblock($socket) puts socket into nonblocking mode
405: sub nonblock {
406: my $socket = shift;
407: my $flags;
408:
409:
410: $flags = fcntl($socket, F_GETFL, 0)
411: or die "Can't get flags for socket: $!\n";
412: fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
413: or die "Can't make socket nonblocking: $!\n";
414: }
415:
416:
417:
418:
419:
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