loncom/lonc - view

File: [LON-CAPA] / loncom / Attic / lonc
Revision 1.32: download - view: text, annotated - select for diffs
Fri Mar 8 03:56:19 2002 UTC (22 years, 2 months ago) by foxr
Branches: MAIN
CVS tags: HEAD

Corrected and simplified child management logic:
1. Removed SIGCHLD handler, made parent main loop
   just be a wait, rather than sleep.
2. Corrected book-keeping error in lonc's make_child_process
   which caused single child death to trigger attempts to
   restart all children...whether actually dead or not.

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.32 2002/03/08 03:56:19 foxr 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 Scott Harrison 41: # 12/05 Gerd Kortemeyer 42: # YEAR=2001 43: # 01/10/01 Scott Harrison 44: # 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer 45: # 12/20 Scott Harrison 46: # YEAR=2002 47: # 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer 48: # 49: # based on nonforker from Perl Cookbook 50: # - server who multiplexes without forking 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 httpd access.conf and get variables 75: &status("Read access.conf"); 76: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; 77: 78: while ($configline=<CONFIG>) { 79: if ($configline =~ /PerlSetVar/) { 80: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); 81: chomp($varvalue); 82: $perlvar{$varname}=$varvalue; 83: } 84: } 85: close(CONFIG); 86: 87: # ----------------------------- Make sure this process is running from user=www 88: &status("Check user ID"); 89: my $wwwid=getpwnam('www'); 90: if ($wwwid!=$<) { 91: $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; 92: $subj="LON: $perlvar{'lonHostID'} User ID mismatch"; 93: system("echo 'User ID mismatch. lonc must be run as user www.' |\ 94: mailto $emailto -s '$subj' > /dev/null"); 95: exit 1; 96: } 97: 98: # --------------------------------------------- Check if other instance running 99: 100: my $pidfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; 101: 102: if (-e $pidfile) { 103: my $lfh=IO::File->new("$pidfile"); 104: my $pide=<$lfh>; 105: chomp($pide); 106: if (kill 0 => $pide) { die "already running"; } 107: } 108: 109: # ------------------------------------------------------------- Read hosts file 110: 111: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; 112: 113: while ($configline=<CONFIG>) { 114: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); 115: chomp($ip); 116: if ($ip) { 117: $hostip{$id}=$ip; 118: $hostname{$id}=$name; 119: } 120: } 121: 122: close(CONFIG); 123: 124: # -------------------------------------------------------- Routines for forking 125: 126: %children = (); # keys are current child process IDs, 127: # values are hosts 128: %childpid = (); # the other way around 129: 130: %childatt = (); # number of attempts to start server 131: # for ID 132: 133: $childmaxattempts=5; 134: 135: # ---------------------------------------------------- Fork once and dissociate 136: &status("Fork and dissociate"); 137: $fpid=fork; 138: exit if $fpid; 139: die "Couldn't fork: $!" unless defined ($fpid); 140: 141: POSIX::setsid() or die "Can't start new session: $!"; 142: 143: $conserver='PARENT'; 144: 145: # ------------------------------------------------------- Write our PID on disk 146: &status("Write PID"); 147: $execdir=$perlvar{'lonDaemons'}; 148: open (PIDSAVE,">$execdir/logs/lonc.pid"); 149: print PIDSAVE "$$\n"; 150: close(PIDSAVE); 151: &logthis("CRITICAL: ---------- Starting ----------"); 152: 153: # ----------------------------- Ignore signals generated during initial startup 154: $SIG{HUP}=$SIG{USR1}='IGNORE'; 155: # ------------------------------------------------------- Now we are on our own 156: 157: # Fork off our children, one for every server 158: 159: &status("Forking ..."); 160: 161: foreach $thisserver (keys %hostip) { 162: #if (&online($hostname{$thisserver})) { 163: make_new_child($thisserver); 164: #} 165: } 166: 167: &logthis("Done starting initial servers"); 168: # ----------------------------------------------------- Install signal handlers 169: 170: 171: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 172: $SIG{HUP} = \&HUPSMAN; 173: $SIG{USR1} = \&USRMAN; 174: 175: # And maintain the population. 176: while (1) { 177: my $deadpid = wait; # Wait for the next child to die. 178: # See who died and start new one 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: "INFO: Trying to reconnect for $thisserver " 192: ."($childatt{$thisserver} of $childmaxattempts attempts)"); 193: make_new_child($thisserver); 194: 195: } 196: else { 197: $skipping .= $thisserver.' '; 198: } 199: if($skipping) { 200: &logthis("WARNING: Skipped $skipping"); 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(" Connection to $conserver open "); 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 (@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: $SIG{ALRM}=sub { die "timeout" }; 283: $SIG{__DIE__}='DEFAULT'; 284: eval { 285: alarm(60); 286: print $remotesock "$cmd\n"; 287: $answer=<$remotesock>; 288: chomp($answer); 289: alarm(0); 290: }; 291: $SIG{ALRM}='DEFAULT'; 292: $SIG{__DIE__}=\&catchexception; 293: 294: if (($answer ne '') && ($@!~/timeout/)) { 295: unlink("$dfname"); 296: &logthis("Delayed $cmd: >$answer<"); 297: &logperm("S:$conserver:$bcmd"); 298: } 299: } 300: if($DEBUG) { &logthis(" Delayed transactions sent"); } 301: 302: # ------------------------------------------------------- Listen to UNIX socket 303: &status("Opening socket"); 304: unless ( 305: $server = IO::Socket::UNIX->new(Local => $port, 306: Type => SOCK_STREAM, 307: Listen => 10 ) 308: ) { 309: my $st=120+int(rand(240)); 310: &logthis( 311: "WARNING: ". 312: "Can't make server socket ($st secs): $@ .. exiting"); 313: sleep($st); 314: exit; 315: }; 316: 317: # ----------------------------------------------------------------------------- 318: 319: &logthis("$conserver online"); 320: 321: # ----------------------------------------------------------------------------- 322: # begin with empty buffers 323: %inbuffer = (); 324: %outbuffer = (); 325: %ready = (); 326: 327: tie %ready, 'Tie::RefHash'; 328: 329: nonblock($server); 330: $select = IO::Select->new($server); 331: 332: # Main loop: check reads/accepts, check writes, check ready to process 333: while (1) { 334: my $client; 335: my $rv; 336: my $data; 337: 338: # check for new information on the connections we have 339: 340: # anything to read or accept? 341: 342: foreach $client ($select->can_read(100.0)) { 343: if ($client == $server) { 344: # accept a new connection 345: &status("Accept new connection: $conserver"); 346: $client = $server->accept(); 347: $select->add($client); 348: nonblock($client); 349: } else { 350: # read data 351: $data = ''; 352: $rv = $client->recv($data, POSIX::BUFSIZ, 0); 353: 354: unless (defined($rv) && length $data) { 355: # This would be the end of file, so close the client 356: delete $inbuffer{$client}; 357: delete $outbuffer{$client}; 358: delete $ready{$client}; 359: 360: &status("Idle"); 361: $select->remove($client); 362: close $client; 363: next; 364: } 365: 366: $inbuffer{$client} .= $data; 367: 368: 369: # test whether the data in the buffer or the data we 370: # just read means there is a complete request waiting 371: # to be fulfilled. If there is, set $ready{$client} 372: # to the requests waiting to be fulfilled. 373: while ($inbuffer{$client} =~ s/(.*\n)//) { 374: push( @{$ready{$client}}, $1 ); 375: } 376: } 377: } 378: 379: # Any complete requests to process? 380: foreach $client (keys %ready) { 381: handle($client); 382: } 383: 384: # Buffers to flush? 385: foreach $client ($select->can_write(1)) { 386: # Skip this client if we have nothing to say 387: next unless exists $outbuffer{$client}; 388: 389: $rv = $client->send($outbuffer{$client}, 0); 390: 391: unless ($outbuffer{$client} eq "con_lost\n") { 392: unless (defined $rv) { 393: # Whine, but move on. 394: &logthis("I was told I could write, but I can't.\n"); 395: next; 396: } 397: $errno=$!; 398: if (($rv == length $outbuffer{$client}) || 399: ($errno == POSIX::EWOULDBLOCK) || ($errno == 0)) { 400: substr($outbuffer{$client}, 0, $rv) = ''; 401: delete $outbuffer{$client} unless length $outbuffer{$client}; 402: } else { 403: # Couldn't write all the data, and it wasn't because 404: # it would have blocked. Shutdown and move on. 405: 406: &logthis("Dropping data with ".$errno.": ". 407: length($outbuffer{$client}).", $rv"); 408: 409: delete $inbuffer{$client}; 410: delete $outbuffer{$client}; 411: delete $ready{$client}; 412: 413: $select->remove($client); 414: close($client); 415: next; 416: } 417: } else { 418: # -------------------------------------------------------- Wow, connection lost 419: &logthis( 420: "CRITICAL: Closing connection"); 421: &status("Connection lost"); 422: $remotesock->shutdown(2); 423: &logthis("Attempting to open new connection"); 424: &openremote($conserver); 425: } 426: } 427: 428: } 429: } 430: 431: # ------------------------------------------------------- End of make_new_child 432: 433: # handle($socket) deals with all pending requests for $client 434: sub handle { 435: # requests are in $ready{$client} 436: # send output to $outbuffer{$client} 437: my $client = shift; 438: my $request; 439: foreach $request (@{$ready{$client}}) { 440: # ============================================================= Process request 441: # $request is the text of the request 442: # put text of reply into $outbuffer{$client} 443: # ------------------------------------------------------------ Is this the end? 444: if($DEBUG) { 445: &logthis(" Request $request processing starts"); 446: } 447: if ($request eq "close_connection_exit\n") { 448: &status("Request close connection"); 449: &logthis( 450: "CRITICAL: Request Close Connection ... exiting"); 451: $remotesock->shutdown(2); 452: $server->close(); 453: exit; 454: } 455: # ----------------------------------------------------------------------------- 456: if ($request =~ /^encrypt\:/) { 457: my $cmd=$request; 458: $cmd =~ s/^encrypt\://; 459: chomp($cmd); 460: my $cmdlength=length($cmd); 461: $cmd.=" "; 462: my $encrequest=''; 463: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) { 464: $encrequest.= 465: unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8))); 466: } 467: $request="enc:$cmdlength:$encrequest\n"; 468: } 469: # --------------------------------------------------------------- Main exchange 470: $SIG{ALRM}=sub { die "timeout" }; 471: $SIG{__DIE__}='DEFAULT'; 472: eval { 473: alarm(300); 474: &status("Sending: $request"); 475: print $remotesock "$request"; 476: &status("Waiting for reply from $conserver: $request"); 477: $answer=<$remotesock>; 478: &status("Received reply: $request"); 479: alarm(0); 480: }; 481: if($DEBUG) { 482: &logthis(" Request data exchange complete"); 483: } 484: if ($@=~/timeout/) { 485: $answer=''; 486: &logthis( 487: "CRITICAL: Timeout: $request"); 488: } 489: $SIG{ALRM}='DEFAULT'; 490: $SIG{__DIE__}=\&catchexception; 491: 492: 493: if ($answer) { 494: if ($answer =~ /^enc/) { 495: my ($cmd,$cmdlength,$encinput)=split(/:/,$answer); 496: chomp($encinput); 497: $answer=''; 498: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) { 499: $answer.=$cipher->decrypt( 500: pack("H16",substr($encinput,$encidx,16)) 501: ); 502: } 503: $answer=substr($answer,0,$cmdlength); 504: $answer.="\n"; 505: } 506: $outbuffer{$client} .= $answer; 507: } else { 508: $outbuffer{$client} .= "con_lost\n"; 509: } 510: 511: &status("Completed: $request"); 512: if($DEBUG) { 513: &logthis(" Request processing complete"); 514: } 515: # ===================================================== Done processing request 516: } 517: delete $ready{$client}; 518: # -------------------------------------------------------------- End non-forker 519: if($DEBUG) { 520: &logthis(" requests for child handled"); 521: } 522: } 523: # ---------------------------------------------------------- End make_new_child 524: } 525: 526: # nonblock($socket) puts socket into nonblocking mode 527: sub nonblock { 528: my $socket = shift; 529: my $flags; 530: 531: 532: $flags = fcntl($socket, F_GETFL, 0) 533: or die "Can't get flags for socket: $!\n"; 534: fcntl($socket, F_SETFL, $flags | O_NONBLOCK) 535: or die "Can't make socket nonblocking: $!\n"; 536: } 537: 538: 539: sub openremote { 540: # ---------------------------------------------------- Client to network server 541: 542: my $conserver=shift; 543: 544: &status("Opening TCP"); 545: my $st=120+int(rand(240)); # Sleep before opening: 546: 547: unless ( 548: $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver}, 549: PeerPort => $perlvar{'londPort'}, 550: Proto => "tcp", 551: Type => SOCK_STREAM) 552: ) { 553: 554: &logthis( 555: "WARNING: Couldn't connect to $conserver ($st secs): $@"); 556: sleep($st); 557: exit; 558: }; 559: # ----------------------------------------------------------------- Init dialog 560: 561: &logthis("INFO Connected to $conserver, initing "); 562: &status("Init dialogue: $conserver"); 563: 564: $SIG{ALRM}=sub { die "timeout" }; 565: $SIG{__DIE__}='DEFAULT'; 566: eval { 567: alarm(60); 568: print $remotesock "init\n"; 569: $answer=<$remotesock>; 570: print $remotesock "$answer"; 571: $answer=<$remotesock>; 572: chomp($answer); 573: alarm(0); 574: }; 575: $SIG{ALRM}='DEFAULT'; 576: $SIG{__DIE__}=\&catchexception; 577: 578: if ($@=~/timeout/) { 579: &logthis("Timed out during init.. exiting"); 580: exit; 581: } 582: 583: if ($answer ne 'ok') { 584: &logthis("Init reply: >$answer<"); 585: my $st=120+int(rand(240)); 586: &logthis( 587: "WARNING: Init failed ($st secs)"); 588: sleep($st); 589: exit; 590: } 591: 592: sleep 5; 593: &status("Ponging"); 594: print $remotesock "pong\n"; 595: $answer=<$remotesock>; 596: chomp($answer); 597: if ($answer!~/^$conserver/) { 598: &logthis("Pong reply: >$answer<"); 599: } 600: # ----------------------------------------------------------- Initialize cipher 601: 602: &status("Initialize cipher"); 603: print $remotesock "ekey\n"; 604: my $buildkey=<$remotesock>; 605: my $key=$conserver.$perlvar{'lonHostID'}; 606: $key=~tr/a-z/A-Z/; 607: $key=~tr/G-P/0-9/; 608: $key=~tr/Q-Z/0-9/; 609: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey; 610: $key=substr($key,0,32); 611: my $cipherkey=pack("H32",$key); 612: if ($cipher=new IDEA $cipherkey) { 613: &logthis("Secure connection initialized"); 614: } else { 615: my $st=120+int(rand(240)); 616: &logthis( 617: "WARNING: ". 618: "Could not establish secure connection ($st secs)!"); 619: sleep($st); 620: exit; 621: } 622: &logthis(" Remote open success "); 623: } 624: 625: 626: 627: # grabs exception and records it to log before exiting 628: sub catchexception { 629: my ($signal)=@_; 630: $SIG{QUIT}='DEFAULT'; 631: $SIG{__DIE__}='DEFAULT'; 632: chomp($signal); 633: &logthis("CRITICAL: " 634: ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through " 635: ."\"$signal\" with parameter [$@]"); 636: die($@); 637: } 638: 639: # -------------------------------------- Routines to see if other box available 640: 641: #sub online { 642: # my $host=shift; 643: # &status("Pinging ".$host); 644: # my $p=Net::Ping->new("tcp",20); 645: # my $online=$p->ping("$host"); 646: # $p->close(); 647: # undef ($p); 648: # return $online; 649: #} 650: 651: sub connected { 652: my ($local,$remote)=@_; 653: &status("Checking connection $local to $remote"); 654: $local=~s/\W//g; 655: $remote=~s/\W//g; 656: 657: unless ($hostname{$local}) { return 'local_unknown'; } 658: unless ($hostname{$remote}) { return 'remote_unknown'; } 659: 660: #unless (&online($hostname{$local})) { return 'local_offline'; } 661: 662: my $ua=new LWP::UserAgent; 663: 664: my $request=new HTTP::Request('GET', 665: "http://".$hostname{$local}.'/cgi-bin/ping.pl?'.$remote); 666: 667: my $response=$ua->request($request); 668: 669: unless ($response->is_success) { return 'local_error'; } 670: 671: my $reply=$response->content; 672: $reply=(split("\n",$reply))[0]; 673: $reply=~s/\W//g; 674: if ($reply ne $remote) { return $reply; } 675: return 'ok'; 676: } 677: 678: 679: 680: sub hangup { 681: foreach (keys %children) { 682: $wasserver=$children{$_}; 683: &status("Closing $wasserver"); 684: &logthis('Closing '.$wasserver.': '.&subreply('exit',$wasserver)); 685: &status("Kill PID $_ for $wasserver"); 686: kill ('INT',$_); 687: } 688: } 689: 690: sub HUNTSMAN { # signal handler for SIGINT 691: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 692: &hangup(); 693: my $execdir=$perlvar{'lonDaemons'}; 694: unlink("$execdir/logs/lonc.pid"); 695: &logthis("CRITICAL: Shutting down"); 696: exit; # clean up with dignity 697: } 698: 699: sub HUPSMAN { # signal handler for SIGHUP 700: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children 701: &hangup(); 702: &logthis("CRITICAL: Restarting"); 703: unlink("$execdir/logs/lonc.pid"); 704: my $execdir=$perlvar{'lonDaemons'}; 705: exec("$execdir/lonc"); # here we go again 706: } 707: 708: sub checkchildren { 709: &initnewstatus(); 710: &logstatus(); 711: &logthis('Going to check on the children'); 712: foreach (sort keys %children) { 713: sleep 1; 714: unless (kill 'USR1' => $_) { 715: &logthis ('CRITICAL: Child '.$_.' is dead'); 716: &logstatus($$.' is dead'); 717: } 718: } 719: } 720: 721: sub USRMAN { 722: &logthis("USR1: Trying to establish connections again"); 723: %childatt=(); 724: &checkchildren(); 725: } 726: 727: # -------------------------------------------------- Non-critical communication 728: sub subreply { 729: my ($cmd,$server)=@_; 730: my $answer=''; 731: if ($server ne $perlvar{'lonHostID'}) { 732: my $peerfile="$perlvar{'lonSockDir'}/$server"; 733: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", 734: Type => SOCK_STREAM, 735: Timeout => 10) 736: or return "con_lost"; 737: 738: 739: $SIG{ALRM}=sub { die "timeout" }; 740: $SIG{__DIE__}='DEFAULT'; 741: eval { 742: alarm(10); 743: print $sclient "$cmd\n"; 744: $answer=<$sclient>; 745: chomp($answer); 746: alarm(0); 747: }; 748: if ((!$answer) || ($@=~/timeout/)) { $answer="con_lost"; } 749: $SIG{ALRM}='DEFAULT'; 750: $SIG{__DIE__}=\&catchexception; 751: } else { $answer='self_reply'; } 752: return $answer; 753: } 754: 755: # --------------------------------------------------------------------- Logging 756: 757: sub logthis { 758: my $message=shift; 759: my $execdir=$perlvar{'lonDaemons'}; 760: my $fh=IO::File->new(">>$execdir/logs/lonc.log"); 761: my $now=time; 762: my $local=localtime($now); 763: $lastlog=$local.': '.$message; 764: print $fh "$local ($$) [$conserver] [$status]: $message\n"; 765: } 766: 767: 768: sub logperm { 769: my $message=shift; 770: my $execdir=$perlvar{'lonDaemons'}; 771: my $now=time; 772: my $local=localtime($now); 773: my $fh=IO::File->new(">>$execdir/logs/lonnet.perm.log"); 774: print $fh "$now:$message:$local\n"; 775: } 776: # ------------------------------------------------------------------ Log status 777: 778: sub logstatus { 779: my $docdir=$perlvar{'lonDocRoot'}; 780: my $fh=IO::File->new(">>$docdir/lon-status/loncstatus.txt"); 781: print $fh $$."\t".$conserver."\t".$status."\t".$lastlog."\n"; 782: } 783: 784: sub initnewstatus { 785: my $docdir=$perlvar{'lonDocRoot'}; 786: my $fh=IO::File->new(">$docdir/lon-status/loncstatus.txt"); 787: my $now=time; 788: my $local=localtime($now); 789: print $fh "LONC status $local - parent $$\n\n"; 790: } 791: 792: # -------------------------------------------------------------- Status setting 793: 794: sub status { 795: my $what=shift; 796: my $now=time; 797: my $local=localtime($now); 798: $status=$local.': '.$what; 799: } 800: 801: 802: 803: # ----------------------------------- POD (plain old documentation, CPAN style) 804: 805: =head1 NAME 806: 807: lonc - LON TCP-MySQL-Server Daemon for handling database requests. 808: 809: =head1 SYNOPSIS 810: 811: Usage: B<lonc> 812: 813: Should only be run as user=www. This is a command-line script which 814: is invoked by B<loncron>. There is no expectation that a typical user 815: will manually start B<lonc> from the command-line. (In other words, 816: DO NOT START B<lonc> YOURSELF.) 817: 818: =head1 DESCRIPTION 819: 820: Provides persistent TCP connections to the other servers in the network 821: through multiplexed domain sockets 822: 823: B<lonc> forks off children processes that correspond to the other servers 824: in the network. Management of these processes can be done at the 825: parent process level or the child process level. 826: 827: B<logs/lonc.log> is the location of log messages. 828: 829: The process management is now explained in terms of linux shell commands, 830: subroutines internal to this code, and signal assignments: 831: 832: =over 4 833: 834: =item * 835: 836: PID is stored in B<logs/lonc.pid> 837: 838: This is the process id number of the parent B<lonc> process. 839: 840: =item * 841: 842: SIGTERM and SIGINT 843: 844: Parent signal assignment: 845: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 846: 847: Child signal assignment: 848: $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) 849: (The child dies and a SIGALRM is sent to parent, awaking parent from slumber 850: to restart a new child.) 851: 852: Command-line invocations: 853: B<kill> B<-s> SIGTERM I<PID> 854: B<kill> B<-s> SIGINT I<PID> 855: 856: Subroutine B<HUNTSMAN>: 857: This is only invoked for the B<lonc> parent I<PID>. 858: This kills all the children, and then the parent. 859: The B<lonc.pid> file is cleared. 860: 861: =item * 862: 863: SIGHUP 864: 865: Current bug: 866: This signal can only be processed the first time 867: on the parent process. Subsequent SIGHUP signals 868: have no effect. 869: 870: Parent signal assignment: 871: $SIG{HUP} = \&HUPSMAN; 872: 873: Child signal assignment: 874: none (nothing happens) 875: 876: Command-line invocations: 877: B<kill> B<-s> SIGHUP I<PID> 878: 879: Subroutine B<HUPSMAN>: 880: This is only invoked for the B<lonc> parent I<PID>, 881: This kills all the children, and then the parent. 882: The B<lonc.pid> file is cleared. 883: 884: =item * 885: 886: SIGUSR1 887: 888: Parent signal assignment: 889: $SIG{USR1} = \&USRMAN; 890: 891: Child signal assignment: 892: $SIG{USR1}= \&logstatus; 893: 894: Command-line invocations: 895: B<kill> B<-s> SIGUSR1 I<PID> 896: 897: Subroutine B<USRMAN>: 898: When invoked for the B<lonc> parent I<PID>, 899: SIGUSR1 is sent to all the children, and the status of 900: each connection is logged. 901: 902: =item * 903: 904: SIGCHLD 905: 906: 907: Child signal assignment: 908: none 909: 910: Command-line invocations: 911: B<kill> B<-s> SIGCHLD I<PID> 912: 913: Subroutine B<REAPER>: 914: This is only invoked for the B<lonc> parent I<PID>. 915: Information pertaining to the child is removed. 916: The socket port is cleaned up. 917: 918: =back 919: 920: =head1 PREREQUISITES 921: 922: POSIX 923: IO::Socket 924: IO::Select 925: IO::File 926: Socket 927: Fcntl 928: Tie::RefHash 929: Crypt::IDEA 930: 931: =head1 COREQUISITES 932: 933: =head1 OSNAMES 934: 935: linux 936: 937: =head1 SCRIPT CATEGORIES 938: 939: Server/Process 940: 941: =cut