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: # $Id: lonc,v 1.47 2003/02/24 19:56:30 albertel Exp $
9: #
10: # Copyright Michigan State University Board of Trustees
11: #
12: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
13: #
14: # LON-CAPA is free software; you can redistribute it and/or modify
15: # it under the terms of the GNU General Public License as published by
16: # the Free Software Foundation; either version 2 of the License, or
17: # (at your option) any later version.
18: #
19: # LON-CAPA is distributed in the hope that it will be useful,
20: # but WITHOUT ANY WARRANTY; without even the implied warranty of
21: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22: # GNU General Public License for more details.
23: #
24: # You should have received a copy of the GNU General Public License
25: # along with LON-CAPA; if not, write to the Free Software
26: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
27: #
28: # /home/httpd/html/adm/gpl.txt
29: #
30: # http://www.lon-capa.org/
31: #
32: # PID in subdir logs/lonc.pid
33: # kill kills
34: # HUP restarts
35: # USR1 tries to open connections again
36:
37: # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,
38: # 10/8,10/9,10/15,11/18,12/22,
39: # 2/8,7/25 Gerd Kortemeyer
40: # 12/05 Gerd Kortemeyer
41: # YEAR=2001
42: # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer
43: # YEAR=2002
44: # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer
45: # 3/07/02 Ron Fox
46: # based on nonforker from Perl Cookbook
47: # - server who multiplexes without forking
48:
49: use lib '/home/httpd/lib/perl/';
50: use LONCAPA::Configuration;
51:
52: use POSIX;
53: use IO::Socket;
54: use IO::Select;
55: use IO::File;
56: use Socket;
57: use Fcntl;
58: use Tie::RefHash;
59: use Crypt::IDEA;
60: #use Net::Ping;
61: use LWP::UserAgent();
62:
63: $status='';
64: $lastlog='';
65: $conserver='SHELL';
66: $DEBUG = 0; # Set to 1 for annoyingly complete logs.
67:
68: # -------------------------------- Set signal handlers to record abnormal exits
69:
70: &status("Init exception handlers");
71: $SIG{QUIT}=\&catchexception;
72: $SIG{__DIE__}=\&catchexception;
73:
74: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
75: &status("Read loncapa.conf and loncapa_apache.conf");
76: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
77: my %perlvar=%{$perlvarref};
78: undef $perlvarref;
79:
80: # ----------------------------- Make sure this process is running from user=www
81: &status("Check user ID");
82: my $wwwid=getpwnam('www');
83: if ($wwwid!=$<) {
84: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
85: $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
86: system("echo 'User ID mismatch. lonc must be run as user www.' |\
87: mailto $emailto -s '$subj' > /dev/null");
88: exit 1;
89: }
90:
91: # --------------------------------------------- Check if other instance running
92:
93: my $pidfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
94:
95: if (-e $pidfile) {
96: my $lfh=IO::File->new("$pidfile");
97: my $pide=<$lfh>;
98: chomp($pide);
99: if (kill 0 => $pide) { die "already running"; }
100: }
101:
102: # ------------------------------------------------------------- Read hosts file
103:
104: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
105:
106: while ($configline=<CONFIG>) {
107: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
108: chomp($ip);
109: if ($ip) {
110: $hostip{$id}=$ip;
111: $hostname{$id}=$name;
112: }
113: }
114:
115: close(CONFIG);
116:
117: # -------------------------------------------------------- Routines for forking
118:
119: %children = (); # keys are current child process IDs,
120: # values are hosts
121: %childpid = (); # the other way around
122:
123: %childatt = (); # number of attempts to start server
124: # for ID
125:
126: $childmaxattempts=5;
127:
128: # ---------------------------------------------------- Fork once and dissociate
129: &status("Fork and dissociate");
130: $fpid=fork;
131: exit if $fpid;
132: die "Couldn't fork: $!" unless defined ($fpid);
133:
134: POSIX::setsid() or die "Can't start new session: $!";
135:
136: $conserver='PARENT';
137:
138: # ------------------------------------------------------- Write our PID on disk
139: &status("Write PID");
140: $execdir=$perlvar{'lonDaemons'};
141: open (PIDSAVE,">$execdir/logs/lonc.pid");
142: print PIDSAVE "$$\n";
143: close(PIDSAVE);
144: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
145:
146: # ----------------------------- Ignore signals generated during initial startup
147: $SIG{HUP}=$SIG{USR1}='IGNORE';
148: # ------------------------------------------------------- Now we are on our own
149:
150: # Fork off our children, one for every server
151:
152: &status("Forking ...");
153:
154: foreach $thisserver (keys %hostip) {
155: #if (&online($hostname{$thisserver})) {
156: make_new_child($thisserver);
157: #}
158: }
159:
160: &logthis("Done starting initial servers");
161: # ----------------------------------------------------- Install signal handlers
162:
163:
164: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
165: $SIG{HUP} = \&HUPSMAN;
166: $SIG{USR1} = \&USRMAN;
167:
168: # And maintain the population.
169: while (1) {
170: my $deadpid = wait; # Wait for the next child to die.
171: # See who died and start new one
172: # or a signal (e.g. USR1 for restart).
173: # if a signal, the wait will fail
174: # This is ordinarily detected by
175: # checking for the existence of the
176: # pid index inthe children hash since
177: # the return value from a failed wait is -1
178: # which is an impossible PID.
179: &status("Woke up");
180: my $skipping='';
181:
182: if(exists($children{$deadpid})) {
183:
184: $thisserver = $children{$deadpid}; # Look name of dead guy's peer.
185:
186: delete($children{$deadpid}); # Get rid of dead hash entry.
187:
188: if($childatt{$thisserver} < $childmaxattempts) {
189: $childatt{$thisserver}++;
190: &logthis(
191: "<font color=yellow>INFO: Trying to reconnect for $thisserver "
192: ."($childatt{$thisserver} of $childmaxattempts attempts)</font>");
193: make_new_child($thisserver);
194:
195: }
196: else {
197: $skipping .= $thisserver.' ';
198: }
199: if($skipping) {
200: &logthis("<font color=blue>WARNING: Skipped $skipping</font>");
201:
202: }
203: }
204:
205: }
206:
207:
208:
209: sub make_new_child {
210:
211: $newserver=shift;
212: my $pid;
213: my $sigset;
214: &logthis("Attempting to start child for server $newserver");
215: # block signal for fork
216: $sigset = POSIX::SigSet->new(SIGINT);
217: sigprocmask(SIG_BLOCK, $sigset)
218: or die "Can't block SIGINT for fork: $!\n";
219:
220: die "fork: $!" unless defined ($pid = fork);
221:
222: if ($pid) {
223: # Parent records the child's birth and returns.
224: sigprocmask(SIG_UNBLOCK, $sigset)
225: or die "Can't unblock SIGINT for fork: $!\n";
226: $children{$pid} = $newserver;
227: $childpid{$newserver} = $pid;
228: return;
229: } else {
230: $conserver=$newserver;
231: # Child can *not* return from this subroutine.
232: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
233: $SIG{USR1}= \&logstatus;
234:
235: # unblock signals
236: sigprocmask(SIG_UNBLOCK, $sigset)
237: or die "Can't unblock SIGINT for fork: $!\n";
238:
239: # ----------------------------- This is the modified main program of non-forker
240:
241: $port = "$perlvar{'lonSockDir'}/$conserver";
242:
243: unlink($port);
244:
245: # -------------------------------------------------------------- Open other end
246:
247: &openremote($conserver);
248: &logthis("<font color=green> Connection to $conserver open </font>");
249: # ----------------------------------------- We're online, send delayed messages
250: &status("Checking for delayed messages");
251:
252: my @allbuffered;
253: my $path="$perlvar{'lonSockDir'}/delayed";
254: opendir(DIRHANDLE,$path);
255: @allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;
256: closedir(DIRHANDLE);
257: my $dfname;
258: foreach (sort @allbuffered) {
259: &status("Sending delayed: $_");
260: $dfname="$path/$_";
261: if($DEBUG) { &logthis('Sending '.$dfname); }
262: my $wcmd;
263: {
264: my $dfh=IO::File->new($dfname);
265: $cmd=<$dfh>;
266: }
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: $answer = londtransaction($remotesock, $cmd, 60);
283: chomp($answer);
284:
285: if (($answer ne '') && ($@!~/timeout/)) {
286: unlink("$dfname");
287: &logthis("Delayed $cmd: >$answer<");
288: &logperm("S:$conserver:$bcmd");
289: }
290: }
291: if($DEBUG) { &logthis("<font color=green> Delayed transactions sent"); }
292:
293: # ------------------------------------------------------- Listen to UNIX socket
294: &status("Opening socket");
295: unless (
296: $server = IO::Socket::UNIX->new(Local => $port,
297: Type => SOCK_STREAM,
298: Listen => 10 )
299: ) {
300: my $st=120+int(rand(240));
301: &logthis(
302: "<font color=blue>WARNING: ".
303: "Can't make server socket ($st secs): .. exiting</font>");
304: sleep($st);
305: exit;
306: };
307:
308: # -----------------------------------------------------------------------------
309:
310: &logthis("<font color=green>$conserver online</font>");
311:
312: # -----------------------------------------------------------------------------
313: # begin with empty buffers
314: %inbuffer = ();
315: %outbuffer = ();
316: %ready = ();
317: %servers = (); # To be compatible with make filevector. indexed by
318: # File ids, values are sockets.
319: # note that the accept socket is omitted.
320:
321: tie %ready, 'Tie::RefHash';
322:
323: # nonblock($server);
324: # $select = IO::Select->new($server);
325:
326: # Main loop: check reads/accepts, check writes, check ready to process
327:
328: status("Main loop $conserver");
329: while (1) {
330: my $client;
331: my $rv;
332: my $data;
333:
334: my $infdset; # bit vec of fd's to select on input.
335:
336: my $outfdset; # Bit vec of fd's to select on output.
337:
338:
339: $infdset = MakeFileVector(\%servers);
340: $outfdset= MakeFileVector(\%outbuffer);
341: vec($infdset, $server->fileno, 1) = 1;
342: if($DEBUG) {
343: &logthis("Adding ".$server->fileno.
344: " to input select vector (listner)".
345: unpack("b*",$infdset)."\n");
346: }
347: DoSelect(\$infdset, \$outfdset); # Wait for input.
348: if($DEBUG) {
349: &logthis("Doselect completed!");
350: &logthis("ins = ".unpack("b*",$infdset)."\n");
351: &logthis("outs= ".unpack("b*",$outfdset)."\n");
352:
353: }
354:
355: # Checkfor new connections:
356: if (vec($infdset, $server->fileno, 1)) {
357: if($DEBUG) {
358: &logthis("New connection established");
359: }
360: # accept a new connection
361: &status("Accept new connection: $conserver");
362: $client = $server->accept();
363: if($DEBUG) {
364: &logthis("New client fd = ".$client->fileno."\n");
365: }
366: $servers{$client->fileno} = $client;
367: nonblock($client);
368: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
369: # connection liveness.
370: }
371: HandleInput($infdset, \%servers, \%inbuffer, \%outbuffer, \%ready);
372: HandleOutput($outfdset, \%servers, \%outbuffer, \%inbuffer,
373: \%ready);
374: # -------------------------------------------------------- Wow, connection lost
375:
376: }
377:
378: }
379: }
380:
381: # ------------------------------------------------------- End of make_new_child
382:
383:
384: #
385: # Make a vector of file descriptors to wait for in a select.
386: # parameters:
387: # \%fdhash -reference to a hash which has IO::Socket's as indices.
388: # We only care about the indices, not the values.
389: # A select vector is created from all indices of the hash.
390:
391: sub MakeFileVector
392: {
393: my $fdhash = shift;
394: my $selvar = "";
395:
396: foreach $socket (keys %$fdhash) {
397: if($DEBUG) {
398: &logthis("Adding ".$socket.
399: "to select vector. (client)\n");
400: }
401: vec($selvar, $socket, 1) = 1;
402: }
403: return $selvar;
404: }
405:
406:
407: #
408: # HandleOutput:
409: # Processes output on a buffered set of file descriptors which are
410: # ready to be read.
411: # Parameters:
412: # $selvector - Vector of file descriptors which are writable.
413: # \%sockets - Vector of socket references indexed by socket.
414: # \%buffers - Reference to a hash containing output buffers.
415: # Hashes are indexed by sockets. The file descriptors of some
416: # of those sockets will be present in $selvector.
417: # For each one of those, we will attempt to write the output
418: # buffer to the socket. Note that we will assume that
419: # the sockets are being run in non blocking mode.
420: # \%inbufs - Reference to hash containing input buffers.
421: # \%readys - Reference to hash containing flags for items with complete
422: # requests.
423: #
424: sub HandleOutput
425: {
426: my $selvector = shift;
427: my $sockets = shift;
428: my $buffers = shift;
429: my $inbufs = shift;
430: my $readys = shift;
431: my $sock;
432:
433: if($DEBUG) {
434: &logthis("HandleOutput entered\n");
435: }
436:
437: foreach $sock (keys %$sockets) {
438: my $socket = $sockets->{$sock};
439: if(vec($selvector, $sock, 1)) { # $socket is writable.
440: if($DEBUG) {
441: &logthis("Sending $buffers->{$sock} \n");
442: }
443: my $rv = $socket->send($buffers->{$sock}, 0);
444: $errno = $!;
445: unless ($buffers->{$sock} eq "con_lost\n") {
446: unless (defined $rv) { # Write failed... could be EINTR
447: unless ($errno == POSIX::EINTR) {
448: &logthis("Write failed on writable socket");
449: } # EINTR is not an error .. just retry.
450: next;
451: }
452: if( ($rv == length $buffers->{$sock}) ||
453: ($errno == POSIX::EWOULDBLOCK) ||
454: ($errno == POSIX::EAGAIN) || # same as above.
455: ($errno == POSIX::EINTR) || # signal during IO
456: ($errno == 0)) {
457: substr($buffers->{$sock}, 0, $rv)=""; # delete written part
458: delete $buffers->{$sock} unless length $buffers->{$sock};
459: } else {
460: # For some reason the write failed with an error code
461: # we didn't look for. Shutdown the socket.
462: &logthis("Unable to write data with ".$errno.": ".
463: "Dropping data: ".length($buffers->{$sock}).
464: ", $rv");
465: #
466: # kill off the buffers in the hash:
467:
468: delete $buffers->{$sock};
469: delete $inbufs->{$sock};
470: delete $readys->{$sock};
471:
472: close($socket); # Close the client socket.
473: next;
474: }
475: } else { # Kludgy way to mark lond connection lost.
476: &logthis(
477: "<font color=red>CRITICAL lond connection lost</font>");
478: status("Connection lost");
479: $remotesock->shutdown(2);
480: &logthis("Attempting to open a new connection");
481: &openremote($conserver);
482: }
483:
484: }
485: }
486:
487: }
488: #
489: # HandleInput - Deals with input on client sockets.
490: # Each socket has an associated input buffer.
491: # For each readable socket, the currently available
492: # data is appended to this buffer.
493: # If necessary, the buffer is created.
494: # On various failures, we may shutdown the client.
495: # Parameters:
496: # $selvec - Vector of readable sockets.
497: # \%sockets - Refers to the Hash of sockets indexed by sockets.
498: # Each of these may or may not have it's fd bit set
499: # in the $selvec.
500: # \%ibufs - Refers to the hash of input buffers indexed by socket.
501: # \%obufs - Hash of output buffers indexed by socket.
502: # \%ready - Hash of ready flags indicating the existence of a completed
503: # Request.
504: sub HandleInput
505: {
506:
507: # Marshall the parameters. Note that the hashes are actually
508: # references not values.
509:
510: my $selvec = shift;
511: my $sockets = shift;
512: my $ibufs = shift;
513: my $obufs = shift;
514: my $ready = shift;
515: my $sock;
516:
517: if($DEBUG) {
518: &logthis("Entered HandleInput\n");
519: }
520: foreach $sock (keys %$sockets) {
521: my $socket = $sockets->{$sock};
522: if(vec($selvec, $sock, 1)) { # Socket which is readable.
523:
524: # Attempt to read the data and do error management.
525: my $data = '';
526: my $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
527: if($DEBUG) {
528: &logthis("Received $data from socket");
529: }
530: unless (defined($rv) && length $data) {
531:
532: # Read an end of file.. this is a disconnect from the peer.
533:
534: delete $sockets->{$sock};
535: delete $ibufs->{$sock};
536: delete $obufs->{$sock};
537: delete $ready->{$sock};
538:
539: status("Idle");
540: close $socket;
541: next;
542: }
543: # Append the read data to the input buffer. If the buffer
544: # now contains a \n the request is complete and we can
545: # mark this in the $ready hash (one request for each \n.)
546:
547: $ibufs->{$sock} .= $data;
548: while($ibufs->{$sock} =~ s/(.*\n)//) {
549: push(@{$ready->{$sock}}, $1);
550: }
551:
552: }
553: }
554: # Now handle any requests which are ready:
555:
556: foreach $client (keys %ready) {
557: handle($client);
558: }
559: }
560:
561: # DoSelect: does a select with no timeout. On signal (errno == EINTR),
562: # the select is retried until there are items in the returned
563: # vectors.
564: #
565: # Parameters:
566: # \$readvec - Reference to a vector of file descriptors to
567: # check for readability.
568: # \$writevec - Reference to a vector of file descriptors to check for
569: # writability.
570: # On exit, the referents are modified with vectors indicating which
571: # file handles are readable/writable.
572: #
573: sub DoSelect {
574: my $readvec = shift;
575: my $writevec= shift;
576: my $outs;
577: my $ins;
578:
579: while (1) {
580: my $nfds = select( $ins = $$readvec, $outs = $$writevec, undef, undef);
581: if($nfds) {
582: if($DEBUG) {
583: &logthis("select exited with ".$nfds." fds\n");
584: &logthis("ins = ".unpack("b*",$ins).
585: " readvec = ".unpack("b*",$$readvec)."\n");
586: &logthis("outs = ".unpack("b*",$outs).
587: " writevec = ".unpack("b*",$$writevec)."\n");
588: }
589: $$readvec = $ins;
590: $$writevec = $outs;
591: return;
592: } else {
593: if($DEBUG) {
594: &logthis("Select exited with no bits set in mask\n");
595: }
596: die "Select failed" unless $! == EINTR;
597: }
598: }
599: }
600:
601: # handle($socket) deals with all pending requests for $client
602: #
603: sub handle {
604: # requests are in $ready{$client}
605: # send output to $outbuffer{$client}
606: my $client = shift;
607: my $request;
608: foreach $request (@{$ready{$client}}) {
609: # ============================================================= Process request
610: # $request is the text of the request
611: # put text of reply into $outbuffer{$client}
612: # ------------------------------------------------------------ Is this the end?
613: chomp($request);
614: if($DEBUG) {
615: &logthis("<font color=green> Request $request processing starts</font>");
616: }
617: if ($request eq "close_connection_exit\n") {
618: &status("Request close connection");
619: &logthis(
620: "<font color=red>CRITICAL: Request Close Connection ... exiting</font>");
621: $remotesock->shutdown(2);
622: $server->close();
623: exit;
624: }
625: # -----------------------------------------------------------------------------
626: if ($request =~ /^encrypt\:/) {
627: my $cmd=$request;
628: $cmd =~ s/^encrypt\://;
629: chomp($cmd);
630: my $cmdlength=length($cmd);
631: $cmd.=" ";
632: my $encrequest='';
633: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
634: $encrequest.=
635: unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
636: }
637: $request="enc:$cmdlength:$encrequest";
638: }
639: # --------------------------------------------------------------- Main exchange
640: $answer = londtransaction($remotesock, $request, 300);
641:
642: if($DEBUG) {
643: &logthis("<font color=green> Request data exchange complete");
644: }
645: if ($@=~/timeout/) {
646: $answer='';
647: &logthis(
648: "<font color=red>CRITICAL: Timeout: $request</font>");
649: }
650:
651:
652: if ($answer) {
653: if ($answer =~ /^enc/) {
654: my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
655: chomp($encinput);
656: $answer='';
657: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
658: $answer.=$cipher->decrypt(
659: pack("H16",substr($encinput,$encidx,16))
660: );
661: }
662: $answer=substr($answer,0,$cmdlength);
663: $answer.="\n";
664: }
665: if($DEBUG) {
666: &logthis("sending $answer to client\n");
667: }
668: $outbuffer{$client} .= $answer;
669: } else {
670: $outbuffer{$client} .= "con_lost\n";
671: }
672:
673: &status("Completed: $request");
674: if($DEBUG) {
675: &logthis("<font color=green> Request processing complete</font>");
676: }
677: # ===================================================== Done processing request
678: }
679: delete $ready{$client};
680: # -------------------------------------------------------------- End non-forker
681: if($DEBUG) {
682: &logthis("<font color=green> requests for child handled</font>");
683: }
684: }
685: # ---------------------------------------------------------- End make_new_child
686:
687: # nonblock($socket) puts socket into nonblocking mode
688: sub nonblock {
689: my $socket = shift;
690: my $flags;
691:
692:
693: $flags = fcntl($socket, F_GETFL, 0)
694: or die "Can't get flags for socket: $!\n";
695: fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
696: or die "Can't make socket nonblocking: $!\n";
697: }
698:
699:
700: sub openremote {
701: # ---------------------------------------------------- Client to network server
702:
703: my $conserver=shift;
704:
705: &status("Opening TCP $conserver");
706: my $st=120+int(rand(240)); # Sleep before opening:
707:
708: unless (
709: $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
710: PeerPort => $perlvar{'londPort'},
711: Proto => "tcp",
712: Type => SOCK_STREAM)
713: ) {
714:
715: &logthis(
716: "<font color=blue>WARNING: Couldn't connect to $conserver ($st secs): </font>");
717: sleep($st);
718: exit;
719: };
720: # ----------------------------------------------------------------- Init dialog
721:
722: &logthis("<font color=green>INFO Connected to $conserver, initing </font>");
723: &status("Init dialogue: $conserver");
724:
725: $answer = londtransaction($remotesock, "init", 60);
726: chomp($answer);
727: $answer = londtransaction($remotesock, $answer, 60);
728: chomp($answer);
729:
730: if ($@=~/timeout/) {
731: &logthis("Timed out during init.. exiting");
732: exit;
733: }
734:
735: if ($answer ne 'ok') {
736: &logthis("Init reply: >$answer<");
737: my $st=120+int(rand(240));
738: &logthis(
739: "<font color=blue>WARNING: Init failed ($st secs)</font>");
740: sleep($st);
741: exit;
742: }
743:
744: sleep 5;
745: &status("Ponging $conserver");
746: print $remotesock "pong\n";
747: $answer=<$remotesock>;
748: chomp($answer);
749: if ($answer!~/^$conserver/) {
750: &logthis("Pong reply: >$answer<");
751: }
752: # ----------------------------------------------------------- Initialize cipher
753:
754: &status("Initialize cipher");
755: print $remotesock "ekey\n";
756: my $buildkey=<$remotesock>;
757: my $key=$conserver.$perlvar{'lonHostID'};
758: $key=~tr/a-z/A-Z/;
759: $key=~tr/G-P/0-9/;
760: $key=~tr/Q-Z/0-9/;
761: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
762: $key=substr($key,0,32);
763: my $cipherkey=pack("H32",$key);
764: if ($cipher=new IDEA $cipherkey) {
765: &logthis("Secure connection initialized");
766: } else {
767: my $st=120+int(rand(240));
768: &logthis(
769: "<font color=blue>WARNING: ".
770: "Could not establish secure connection ($st secs)!</font>");
771: sleep($st);
772: exit;
773: }
774: &logthis("<font color=green> Remote open success </font>");
775: }
776:
777:
778:
779: # grabs exception and records it to log before exiting
780: sub catchexception {
781: my ($signal)=@_;
782: $SIG{QUIT}='DEFAULT';
783: $SIG{__DIE__}='DEFAULT';
784: chomp($signal);
785: &logthis("<font color=red>CRITICAL: "
786: ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through "
787: ."\"$signal\" with parameter </font>");
788: die("Signal abend");
789: }
790:
791: # -------------------------------------- Routines to see if other box available
792:
793: #sub online {
794: # my $host=shift;
795: # &status("Pinging ".$host);
796: # my $p=Net::Ping->new("tcp",20);
797: # my $online=$p->ping("$host");
798: # $p->close();
799: # undef ($p);
800: # return $online;
801: #}
802:
803: sub connected {
804: my ($local,$remote)=@_;
805: &status("Checking connection $local to $remote");
806: $local=~s/\W//g;
807: $remote=~s/\W//g;
808:
809: unless ($hostname{$local}) { return 'local_unknown'; }
810: unless ($hostname{$remote}) { return 'remote_unknown'; }
811:
812: #unless (&online($hostname{$local})) { return 'local_offline'; }
813:
814: my $ua=new LWP::UserAgent;
815:
816: my $request=new HTTP::Request('GET',
817: "http://".$hostname{$local}.'/cgi-bin/ping.pl?'.$remote);
818:
819: my $response=$ua->request($request);
820:
821: unless ($response->is_success) { return 'local_error'; }
822:
823: my $reply=$response->content;
824: $reply=(split("\n",$reply))[0];
825: $reply=~s/\W//g;
826: if ($reply ne $remote) { return $reply; }
827: return 'ok';
828: }
829:
830:
831:
832: sub hangup {
833: foreach (keys %children) {
834: $wasserver=$children{$_};
835: &status("Closing $wasserver");
836: &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver));
837: &status("Kill PID $_ for $wasserver");
838: kill ('INT',$_);
839: }
840: }
841:
842: sub HUNTSMAN { # signal handler for SIGINT
843: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
844: &hangup();
845: my $execdir=$perlvar{'lonDaemons'};
846: unlink("$execdir/logs/lonc.pid");
847: &logthis("<font color=red>CRITICAL: Shutting down</font>");
848: exit; # clean up with dignity
849: }
850:
851: sub HUPSMAN { # signal handler for SIGHUP
852: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
853: &hangup();
854: &logthis("<font color=red>CRITICAL: Restarting</font>");
855: unlink("$execdir/logs/lonc.pid");
856: my $execdir=$perlvar{'lonDaemons'};
857: exec("$execdir/lonc"); # here we go again
858: }
859:
860: sub checkchildren {
861: &initnewstatus();
862: &logstatus();
863: &logthis('Going to check on the children');
864: foreach (sort keys %children) {
865: sleep 1;
866: unless (kill 'USR1' => $_) {
867: &logthis ('<font color=red>CRITICAL: Child '.$_.' is dead</font>');
868: &logstatus($$.' is dead');
869: }
870: }
871: }
872:
873: sub USRMAN {
874: &logthis("USR1: Trying to establish connections again");
875: #
876: # It is really important not to just clear the childatt hash or we will
877: # lose all memory of the children. What we really want to do is this:
878: # For each index where childatt is >= $childmaxattempts
879: # Zero the associated counter and do a make_child for the host.
880: # Regardles, the childatt entry is zeroed:
881: my $host;
882: foreach $host (keys %childatt) {
883: if ($childatt{$host} >= $childmaxattempts) {
884: $childatt{$host} = 0;
885: &logthis("<font color=green>INFO: Restarting child for server: "
886: .$host."</font>\n");
887: make_new_child($host);
888: }
889: else {
890: $childatt{$host} = 0;
891: }
892: }
893: &checkchildren(); # See if any children are still dead...
894: }
895:
896: # -------------------------------------------------- Non-critical communication
897: sub subreply {
898: my ($cmd,$server)=@_;
899: my $answer='';
900: if ($server ne $perlvar{'lonHostID'}) {
901: my $peerfile="$perlvar{'lonSockDir'}/$server";
902: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
903: Type => SOCK_STREAM,
904: Timeout => 10)
905: or return "con_lost";
906:
907:
908: $answer = londtransaction($sclient, $cmd, 10);
909:
910: if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; }
911: $SIG{ALRM}='DEFAULT';
912: $SIG{__DIE__}=\&catchexception;
913: } else { $answer='self_reply'; }
914: return $answer;
915: }
916:
917: # --------------------------------------------------------------------- Logging
918:
919: sub logthis {
920: my $message=shift;
921: my $execdir=$perlvar{'lonDaemons'};
922: my $fh=IO::File->new(">>$execdir/logs/lonc.log");
923: my $now=time;
924: my $local=localtime($now);
925: $lastlog=$local.': '.$message;
926: print $fh "$local ($$) [$conserver] [$status]: $message\n";
927: }
928:
929: #-------------------------------------- londtransaction:
930: #
931: # Performs a transaction with lond with timeout support.
932: # result = londtransaction(socket,request,timeout)
933: #
934: sub londtransaction {
935: my ($socket, $request, $tmo) = @_;
936:
937: if($DEBUG) {
938: &logthis("londtransaction request: $request");
939: }
940:
941: # Set the signal handlers: ALRM for timeout and disble the others.
942:
943: $SIG{ALRM} = sub { die "timeout" };
944: $SIG{__DIE__} = 'DEFAULT';
945:
946: # Disable all but alarm so that only that can interupt the
947: # send /receive.
948: #
949: my $sigset = POSIX::SigSet->new(QUIT, USR1, HUP, INT, TERM);
950: my $priorsigs = POSIX::SigSet->new;
951: unless (defined sigprocmask(SIG_BLOCK, $sigset, $priorsigs)) {
952: &logthis("<font color=red> CRITICAL -- londtransaction ".
953: "failed to block signals </font>");
954: die "could not block signals in londtransaction";
955: }
956: $answer = '';
957: #
958: # Send request to lond.
959: #
960: eval {
961: alarm($tmo);
962: print $socket "$request\n";
963: alarm(0);
964: };
965: # If request didn't timeout, try for the response.
966: #
967:
968: if ($@!~/timeout/) {
969: eval {
970: alarm($tmo);
971: $answer = <$socket>;
972: if($DEBUG) {
973: &logthis("Received $answer in londtransaction");
974: }
975: alarm(0);
976: };
977: } else {
978: &logthis("lonc - suiciding on send Timeout");
979: die("lonc - suiciding on send Timeout");
980: }
981: if ($@ =~ /timeout/) {
982: &logthis("lonc - suiciding on send Timeout");
983: die("lonc - suiciding on send Timeout");
984: }
985: #
986: # Restore the initial sigmask set.
987: #
988: unless (defined sigprocmask(SIG_UNBLOCK, $priorsigs)) {
989: &logthis("<font color=red> CRITICAL -- londtransaction ".
990: "failed to re-enable signal processing. </font>");
991: die "londtransaction failed to re-enable signals";
992: }
993: #
994: # go back to the prior handler set.
995: #
996: $SIG{ALRM} = 'DEFAULT';
997: $SIG{__DIE__} = \&cathcexception;
998:
999: # chomp $answer;
1000: if ($DEBUG) {
1001: &logthis("Returning $answer in londtransaction");
1002: }
1003: return $answer;
1004:
1005: }
1006:
1007: sub logperm {
1008: my $message=shift;
1009: my $execdir=$perlvar{'lonDaemons'};
1010: my $now=time;
1011: my $local=localtime($now);
1012: my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log");
1013: print $fh "$now:$message:$local\n";
1014: }
1015: # ------------------------------------------------------------------ Log status
1016:
1017: sub logstatus {
1018: my $docdir=$perlvar{'lonDocRoot'};
1019: my $fh=IO::File->new(">>$docdir/lon-status/loncstatus.txt");
1020: print $fh $$."\t".$conserver."\t".$status."\t".$lastlog."\n";
1021: }
1022:
1023: sub initnewstatus {
1024: my $docdir=$perlvar{'lonDocRoot'};
1025: my $fh=IO::File->new(">$docdir/lon-status/loncstatus.txt");
1026: my $now=time;
1027: my $local=localtime($now);
1028: print $fh "LONC status $local - parent $$\n\n";
1029: }
1030:
1031: # -------------------------------------------------------------- Status setting
1032:
1033: sub status {
1034: my $what=shift;
1035: my $now=time;
1036: my $local=localtime($now);
1037: $status=$local.': '.$what;
1038: $0='lonc: '.$what.' '.$local;
1039: }
1040:
1041:
1042:
1043: # ----------------------------------- POD (plain old documentation, CPAN style)
1044:
1045: =head1 NAME
1046:
1047: lonc - LON TCP-MySQL-Server Daemon for handling database requests.
1048:
1049: =head1 SYNOPSIS
1050:
1051: Usage: B<lonc>
1052:
1053: Should only be run as user=www. This is a command-line script which
1054: is invoked by B<loncron>. There is no expectation that a typical user
1055: will manually start B<lonc> from the command-line. (In other words,
1056: DO NOT START B<lonc> YOURSELF.)
1057:
1058: =head1 DESCRIPTION
1059:
1060: Provides persistent TCP connections to the other servers in the network
1061: through multiplexed domain sockets
1062:
1063: B<lonc> forks off children processes that correspond to the other servers
1064: in the network. Management of these processes can be done at the
1065: parent process level or the child process level.
1066:
1067: After forking off the children, B<lonc> the B<parent>
1068: executes a main loop which simply waits for processes to exit.
1069: As a process exits, a new process managing a link to the same
1070: peer as the exiting process is created.
1071:
1072: B<logs/lonc.log> is the location of log messages.
1073:
1074: The process management is now explained in terms of linux shell commands,
1075: subroutines internal to this code, and signal assignments:
1076:
1077: =over 4
1078:
1079: =item *
1080:
1081: PID is stored in B<logs/lonc.pid>
1082:
1083: This is the process id number of the parent B<lonc> process.
1084:
1085: =item *
1086:
1087: SIGTERM and SIGINT
1088:
1089: Parent signal assignment:
1090: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
1091:
1092: Child signal assignment:
1093: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also)
1094: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber
1095: to restart a new child.)
1096:
1097: Command-line invocations:
1098: B<kill> B<-s> SIGTERM I<PID>
1099: B<kill> B<-s> SIGINT I<PID>
1100:
1101: Subroutine B<HUNTSMAN>:
1102: This is only invoked for the B<lonc> parent I<PID>.
1103: This kills all the children, and then the parent.
1104: The B<lonc.pid> file is cleared.
1105:
1106: =item *
1107:
1108: SIGHUP
1109:
1110: Current bug:
1111: This signal can only be processed the first time
1112: on the parent process. Subsequent SIGHUP signals
1113: have no effect.
1114:
1115: Parent signal assignment:
1116: $SIG{HUP} = \&HUPSMAN;
1117:
1118: Child signal assignment:
1119: none (nothing happens)
1120:
1121: Command-line invocations:
1122: B<kill> B<-s> SIGHUP I<PID>
1123:
1124: Subroutine B<HUPSMAN>:
1125: This is only invoked for the B<lonc> parent I<PID>,
1126: This kills all the children, and then the parent.
1127: The B<lonc.pid> file is cleared.
1128:
1129: =item *
1130:
1131: SIGUSR1
1132:
1133: Parent signal assignment:
1134: $SIG{USR1} = \&USRMAN;
1135:
1136: Child signal assignment:
1137: $SIG{USR1}= \&logstatus;
1138:
1139: Command-line invocations:
1140: B<kill> B<-s> SIGUSR1 I<PID>
1141:
1142: Subroutine B<USRMAN>:
1143: When invoked for the B<lonc> parent I<PID>,
1144: SIGUSR1 is sent to all the children, and the status of
1145: each connection is logged.
1146:
1147:
1148: =back
1149:
1150: =head1 PREREQUISITES
1151:
1152: POSIX
1153: IO::Socket
1154: IO::Select
1155: IO::File
1156: Socket
1157: Fcntl
1158: Tie::RefHash
1159: Crypt::IDEA
1160:
1161: =head1 COREQUISITES
1162:
1163: =head1 OSNAMES
1164:
1165: linux
1166:
1167: =head1 SCRIPT CATEGORIES
1168:
1169: Server/Process
1170:
1171: =cut
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