Annotation of loncom/lonc, revision 1.48
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: #
1.48 ! albertel 8: # $Id: lonc,v 1.47 2003/02/24 19:56:30 albertel Exp $
1.22 www 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: #
1.1 albertel 32: # PID in subdir logs/lonc.pid
33: # kill kills
34: # HUP restarts
35: # USR1 tries to open connections again
36:
1.2 www 37: # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,
1.5 www 38: # 10/8,10/9,10/15,11/18,12/22,
1.10 www 39: # 2/8,7/25 Gerd Kortemeyer
40: # 12/05 Gerd Kortemeyer
1.23 harris41 41: # YEAR=2001
1.21 www 42: # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer
1.26 www 43: # YEAR=2002
1.29 www 44: # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer
1.33 foxr 45: # 3/07/02 Ron Fox
1.1 albertel 46: # based on nonforker from Perl Cookbook
47: # - server who multiplexes without forking
1.40 harris41 48:
49: use lib '/home/httpd/lib/perl/';
50: use LONCAPA::Configuration;
1.1 albertel 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;
1.32 foxr 60: #use Net::Ping;
1.26 www 61: use LWP::UserAgent();
1.1 albertel 62:
1.30 www 63: $status='';
64: $lastlog='';
65: $conserver='SHELL';
1.32 foxr 66: $DEBUG = 0; # Set to 1 for annoyingly complete logs.
1.26 www 67:
1.8 harris41 68: # -------------------------------- Set signal handlers to record abnormal exits
69:
1.29 www 70: &status("Init exception handlers");
1.26 www 71: $SIG{QUIT}=\&catchexception;
1.8 harris41 72: $SIG{__DIE__}=\&catchexception;
73:
1.41 matthew 74: # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
1.42 harris41 75: &status("Read loncapa.conf and loncapa_apache.conf");
76: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.40 harris41 77: my %perlvar=%{$perlvarref};
78: undef $perlvarref;
1.7 www 79:
1.13 harris41 80: # ----------------------------- Make sure this process is running from user=www
1.29 www 81: &status("Check user ID");
1.13 harris41 82: my $wwwid=getpwnam('www');
83: if ($wwwid!=$<) {
84: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
85: $subj="LON: $perlvar{'lonHostID'} User ID mismatch";
1.14 www 86: system("echo 'User ID mismatch. lonc must be run as user www.' |\
1.13 harris41 87: mailto $emailto -s '$subj' > /dev/null");
88: exit 1;
89: }
90:
1.7 www 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);
1.11 harris41 99: if (kill 0 => $pide) { die "already running"; }
1.7 www 100: }
1.1 albertel 101:
102: # ------------------------------------------------------------- Read hosts file
103:
1.11 harris41 104: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
1.1 albertel 105:
106: while ($configline=<CONFIG>) {
107: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
108: chomp($ip);
1.28 www 109: if ($ip) {
110: $hostip{$id}=$ip;
111: $hostname{$id}=$name;
112: }
1.1 albertel 113: }
1.27 www 114:
1.1 albertel 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:
1.30 www 126: $childmaxattempts=5;
1.3 www 127:
1.1 albertel 128: # ---------------------------------------------------- Fork once and dissociate
1.29 www 129: &status("Fork and dissociate");
1.1 albertel 130: $fpid=fork;
131: exit if $fpid;
1.11 harris41 132: die "Couldn't fork: $!" unless defined ($fpid);
1.1 albertel 133:
1.11 harris41 134: POSIX::setsid() or die "Can't start new session: $!";
1.1 albertel 135:
1.30 www 136: $conserver='PARENT';
137:
1.1 albertel 138: # ------------------------------------------------------- Write our PID on disk
1.29 www 139: &status("Write PID");
1.1 albertel 140: $execdir=$perlvar{'lonDaemons'};
141: open (PIDSAVE,">$execdir/logs/lonc.pid");
142: print PIDSAVE "$$\n";
143: close(PIDSAVE);
1.5 www 144: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.1 albertel 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:
1.18 www 152: &status("Forking ...");
153:
1.1 albertel 154: foreach $thisserver (keys %hostip) {
1.32 foxr 155: #if (&online($hostname{$thisserver})) {
1.26 www 156: make_new_child($thisserver);
1.32 foxr 157: #}
1.1 albertel 158: }
159:
160: &logthis("Done starting initial servers");
161: # ----------------------------------------------------- Install signal handlers
162:
1.32 foxr 163:
1.1 albertel 164: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
165: $SIG{HUP} = \&HUPSMAN;
166: $SIG{USR1} = \&USRMAN;
167:
168: # And maintain the population.
169: while (1) {
1.32 foxr 170: my $deadpid = wait; # Wait for the next child to die.
1.39 foxr 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.
1.18 www 179: &status("Woke up");
1.30 www 180: my $skipping='';
1.32 foxr 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: }
1.30 www 203: }
1.32 foxr 204:
1.1 albertel 205: }
206:
207:
1.32 foxr 208:
1.1 albertel 209: sub make_new_child {
210:
1.30 www 211: $newserver=shift;
1.1 albertel 212: my $pid;
213: my $sigset;
1.30 www 214: &logthis("Attempting to start child for server $newserver");
1.1 albertel 215: # block signal for fork
216: $sigset = POSIX::SigSet->new(SIGINT);
217: sigprocmask(SIG_BLOCK, $sigset)
1.11 harris41 218: or die "Can't block SIGINT for fork: $!\n";
1.1 albertel 219:
1.11 harris41 220: die "fork: $!" unless defined ($pid = fork);
1.1 albertel 221:
222: if ($pid) {
223: # Parent records the child's birth and returns.
224: sigprocmask(SIG_UNBLOCK, $sigset)
1.11 harris41 225: or die "Can't unblock SIGINT for fork: $!\n";
1.30 www 226: $children{$pid} = $newserver;
1.32 foxr 227: $childpid{$newserver} = $pid;
1.1 albertel 228: return;
229: } else {
1.30 www 230: $conserver=$newserver;
1.1 albertel 231: # Child can *not* return from this subroutine.
232: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
1.18 www 233: $SIG{USR1}= \&logstatus;
234:
1.1 albertel 235: # unblock signals
236: sigprocmask(SIG_UNBLOCK, $sigset)
1.11 harris41 237: or die "Can't unblock SIGINT for fork: $!\n";
1.1 albertel 238:
239: # ----------------------------- This is the modified main program of non-forker
240:
241: $port = "$perlvar{'lonSockDir'}/$conserver";
242:
243: unlink($port);
1.18 www 244:
1.29 www 245: # -------------------------------------------------------------- Open other end
1.1 albertel 246:
1.29 www 247: &openremote($conserver);
1.32 foxr 248: &logthis("<font color=green> Connection to $conserver open </font>");
1.3 www 249: # ----------------------------------------- We're online, send delayed messages
1.18 www 250: &status("Checking for delayed messages");
1.32 foxr 251:
1.4 www 252: my @allbuffered;
1.3 www 253: my $path="$perlvar{'lonSockDir'}/delayed";
1.4 www 254: opendir(DIRHANDLE,$path);
255: @allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;
256: closedir(DIRHANDLE);
1.3 www 257: my $dfname;
1.44 www 258: foreach (sort @allbuffered) {
1.30 www 259: &status("Sending delayed: $_");
1.4 www 260: $dfname="$path/$_";
1.32 foxr 261: if($DEBUG) { &logthis('Sending '.$dfname); }
1.3 www 262: my $wcmd;
263: {
264: my $dfh=IO::File->new($dfname);
1.4 www 265: $cmd=<$dfh>;
1.3 www 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: }
1.33 foxr 282: $answer = londtransaction($remotesock, $cmd, 60);
1.3 www 283: chomp($answer);
1.20 www 284:
285: if (($answer ne '') && ($@!~/timeout/)) {
1.3 www 286: unlink("$dfname");
1.30 www 287: &logthis("Delayed $cmd: >$answer<");
1.3 www 288: &logperm("S:$conserver:$bcmd");
289: }
1.23 harris41 290: }
1.32 foxr 291: if($DEBUG) { &logthis("<font color=green> Delayed transactions sent"); }
1.1 albertel 292:
293: # ------------------------------------------------------- Listen to UNIX socket
1.30 www 294: &status("Opening socket");
1.1 albertel 295: unless (
296: $server = IO::Socket::UNIX->new(Local => $port,
297: Type => SOCK_STREAM,
298: Listen => 10 )
1.5 www 299: ) {
300: my $st=120+int(rand(240));
301: &logthis(
302: "<font color=blue>WARNING: ".
1.33 foxr 303: "Can't make server socket ($st secs): .. exiting</font>");
1.5 www 304: sleep($st);
1.1 albertel 305: exit;
306: };
1.32 foxr 307:
1.1 albertel 308: # -----------------------------------------------------------------------------
309:
1.5 www 310: &logthis("<font color=green>$conserver online</font>");
311:
312: # -----------------------------------------------------------------------------
1.1 albertel 313: # begin with empty buffers
314: %inbuffer = ();
315: %outbuffer = ();
316: %ready = ();
1.35 foxr 317: %servers = (); # To be compatible with make filevector. indexed by
1.37 foxr 318: # File ids, values are sockets.
1.35 foxr 319: # note that the accept socket is omitted.
1.1 albertel 320:
321: tie %ready, 'Tie::RefHash';
322:
1.37 foxr 323: # nonblock($server);
324: # $select = IO::Select->new($server);
1.1 albertel 325:
326: # Main loop: check reads/accepts, check writes, check ready to process
1.37 foxr 327:
1.46 albertel 328: status("Main loop $conserver");
1.1 albertel 329: while (1) {
330: my $client;
331: my $rv;
332: my $data;
333:
1.35 foxr 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);
1.37 foxr 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");
1.1 albertel 346: }
1.37 foxr 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:
1.1 albertel 353: }
1.15 www 354:
1.37 foxr 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);
1.46 albertel 368: $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
369: # connection liveness.
1.37 foxr 370: }
371: HandleInput($infdset, \%servers, \%inbuffer, \%outbuffer, \%ready);
372: HandleOutput($outfdset, \%servers, \%outbuffer, \%inbuffer,
373: \%ready);
374: # -------------------------------------------------------- Wow, connection lost
1.15 www 375:
1.37 foxr 376: }
377:
1.1 albertel 378: }
379: }
1.25 albertel 380:
1.1 albertel 381: # ------------------------------------------------------- End of make_new_child
382:
1.35 foxr 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:
1.37 foxr 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;
1.35 foxr 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:
1.37 foxr 412: # $selvector - Vector of file descriptors which are writable.
1.35 foxr 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;
1.37 foxr 431: my $sock;
1.35 foxr 432:
1.37 foxr 433: if($DEBUG) {
434: &logthis("HandleOutput entered\n");
435: }
436:
437: foreach $sock (keys %$sockets) {
1.35 foxr 438: my $socket = $sockets->{$sock};
1.37 foxr 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);
1.35 foxr 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:
1.37 foxr 472: close($socket); # Close the client socket.
1.35 foxr 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");
1.37 foxr 481: &openremote($conserver);
1.35 foxr 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;
1.37 foxr 515: my $sock;
1.35 foxr 516:
1.38 foxr 517: if($DEBUG) {
518: &logthis("Entered HandleInput\n");
519: }
1.37 foxr 520: foreach $sock (keys %$sockets) {
1.35 foxr 521: my $socket = $sockets->{$sock};
1.37 foxr 522: if(vec($selvec, $sock, 1)) { # Socket which is readable.
1.35 foxr 523:
524: # Attempt to read the data and do error management.
525: my $data = '';
1.37 foxr 526: my $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
527: if($DEBUG) {
528: &logthis("Received $data from socket");
529: }
1.35 foxr 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");
1.37 foxr 540: close $socket;
1.35 foxr 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);
1.36 foxr 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) {
1.37 foxr 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: }
1.36 foxr 589: $$readvec = $ins;
590: $$writevec = $outs;
591: return;
592: } else {
1.37 foxr 593: if($DEBUG) {
594: &logthis("Select exited with no bits set in mask\n");
595: }
1.36 foxr 596: die "Select failed" unless $! == EINTR;
597: }
1.35 foxr 598: }
599: }
600:
1.1 albertel 601: # handle($socket) deals with all pending requests for $client
1.35 foxr 602: #
1.1 albertel 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}
1.29 www 612: # ------------------------------------------------------------ Is this the end?
1.33 foxr 613: chomp($request);
1.32 foxr 614: if($DEBUG) {
615: &logthis("<font color=green> Request $request processing starts</font>");
616: }
1.29 www 617: if ($request eq "close_connection_exit\n") {
1.30 www 618: &status("Request close connection");
1.29 www 619: &logthis(
1.32 foxr 620: "<font color=red>CRITICAL: Request Close Connection ... exiting</font>");
1.29 www 621: $remotesock->shutdown(2);
622: $server->close();
623: exit;
624: }
1.1 albertel 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: }
1.33 foxr 637: $request="enc:$cmdlength:$encrequest";
1.1 albertel 638: }
1.19 www 639: # --------------------------------------------------------------- Main exchange
1.33 foxr 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: }
1.19 www 650:
651:
1.1 albertel 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: }
1.33 foxr 665: if($DEBUG) {
666: &logthis("sending $answer to client\n");
667: }
1.1 albertel 668: $outbuffer{$client} .= $answer;
669: } else {
670: $outbuffer{$client} .= "con_lost\n";
671: }
672:
1.30 www 673: &status("Completed: $request");
1.32 foxr 674: if($DEBUG) {
675: &logthis("<font color=green> Request processing complete</font>");
676: }
1.1 albertel 677: # ===================================================== Done processing request
678: }
679: delete $ready{$client};
680: # -------------------------------------------------------------- End non-forker
1.32 foxr 681: if($DEBUG) {
682: &logthis("<font color=green> requests for child handled</font>");
683: }
1.1 albertel 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)
1.11 harris41 694: or die "Can't get flags for socket: $!\n";
1.1 albertel 695: fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
1.11 harris41 696: or die "Can't make socket nonblocking: $!\n";
1.29 www 697: }
698:
699:
700: sub openremote {
701: # ---------------------------------------------------- Client to network server
702:
703: my $conserver=shift;
704:
1.46 albertel 705: &status("Opening TCP $conserver");
1.32 foxr 706: my $st=120+int(rand(240)); # Sleep before opening:
1.29 www 707:
708: unless (
709: $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
710: PeerPort => $perlvar{'londPort'},
711: Proto => "tcp",
712: Type => SOCK_STREAM)
713: ) {
1.32 foxr 714:
1.29 www 715: &logthis(
1.33 foxr 716: "<font color=blue>WARNING: Couldn't connect to $conserver ($st secs): </font>");
1.29 www 717: sleep($st);
718: exit;
719: };
720: # ----------------------------------------------------------------- Init dialog
721:
1.32 foxr 722: &logthis("<font color=green>INFO Connected to $conserver, initing </font>");
1.29 www 723: &status("Init dialogue: $conserver");
724:
1.48 ! albertel 725: $answer = londtransaction($remotesock, "init:$conserver", 60);
1.33 foxr 726: chomp($answer);
727: $answer = londtransaction($remotesock, $answer, 60);
728: chomp($answer);
1.29 www 729:
730: if ($@=~/timeout/) {
1.32 foxr 731: &logthis("Timed out during init.. exiting");
1.29 www 732: exit;
733: }
734:
735: if ($answer ne 'ok') {
1.30 www 736: &logthis("Init reply: >$answer<");
1.29 www 737: my $st=120+int(rand(240));
738: &logthis(
1.30 www 739: "<font color=blue>WARNING: Init failed ($st secs)</font>");
1.29 www 740: sleep($st);
741: exit;
742: }
743:
744: sleep 5;
1.46 albertel 745: &status("Ponging $conserver");
1.29 www 746: print $remotesock "pong\n";
747: $answer=<$remotesock>;
748: chomp($answer);
1.30 www 749: if ($answer!~/^$conserver/) {
750: &logthis("Pong reply: >$answer<");
1.29 www 751: }
752: # ----------------------------------------------------------- Initialize cipher
753:
1.30 www 754: &status("Initialize cipher");
1.29 www 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) {
1.30 www 765: &logthis("Secure connection initialized");
1.29 www 766: } else {
767: my $st=120+int(rand(240));
768: &logthis(
769: "<font color=blue>WARNING: ".
1.30 www 770: "Could not establish secure connection ($st secs)!</font>");
1.29 www 771: sleep($st);
772: exit;
773: }
1.32 foxr 774: &logthis("<font color=green> Remote open success </font>");
1.8 harris41 775: }
1.30 www 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 "
1.33 foxr 787: ."\"$signal\" with parameter </font>");
788: die("Signal abend");
1.30 www 789: }
790:
791: # -------------------------------------- Routines to see if other box available
792:
1.32 foxr 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: #}
1.30 www 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:
1.32 foxr 812: #unless (&online($hostname{$local})) { return 'local_offline'; }
1.30 www 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");
1.39 foxr 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...
1.30 www 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:
1.33 foxr 908: $answer = londtransaction($sclient, $cmd, 10);
909:
1.30 www 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:
1.33 foxr 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 {
1.47 albertel 978: &logthis("lonc - suiciding on send Timeout");
979: die("lonc - suiciding on send Timeout");
1.33 foxr 980: }
1.47 albertel 981: if ($@ =~ /timeout/) {
982: &logthis("lonc - suiciding on send Timeout");
983: die("lonc - suiciding on send Timeout");
1.33 foxr 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: }
1.30 www 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;
1.43 www 1038: $0='lonc: '.$what.' '.$local;
1.30 www 1039: }
1040:
1041:
1.1 albertel 1042:
1.23 harris41 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:
1.31 harris41 1051: Usage: B<lonc>
1052:
1.23 harris41 1053: Should only be run as user=www. This is a command-line script which
1.31 harris41 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.)
1.23 harris41 1057:
1058: =head1 DESCRIPTION
1059:
1060: Provides persistent TCP connections to the other servers in the network
1061: through multiplexed domain sockets
1062:
1.31 harris41 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:
1.33 foxr 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:
1.31 harris41 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:
1.23 harris41 1147:
1.31 harris41 1148: =back
1.23 harris41 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