loncom/lonc - view

File: [LON-CAPA] / loncom / Attic / lonc
Revision 1.48: download - view: text, annotated - select for diffs
Tue Mar 18 22:51:03 2003 UTC (21 years, 1 month ago) by albertel
Branches: MAIN
CVS tags: HEAD

- Machines with multiple domains now supporteda somewhat
http://bugs.loncapa.org/show_bug.cgi?id=1320

  - Requirements:
      hosts.tab must have several enetries one for each hostid/domain
          but the domain name and IP addresses must be the same
      The last entry of the host must correspond with the entries in loncapa.conf

  - Known isssues,
      1) CSTR space has no domain info in it, username conflicts can occur
      2) while you can add the Author role to user, if the role isn't the main domain they can't author


  - Tested areas
      1) Course creation
      2) DOCS mods on course in main/non-main domain
      3) problems in course in main/non-main domain

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.48 2003/03/18 22:51:03 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("CRITICAL: ---------- Starting ----------"); 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: "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 (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(" 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: "WARNING: ". 303: "Can't make server socket ($st secs): .. exiting"); 304: sleep($st); 305: exit; 306: }; 307: 308: # ----------------------------------------------------------------------------- 309: 310: &logthis("$conserver online"); 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: "CRITICAL lond connection lost"); 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(" Request $request processing starts"); 616: } 617: if ($request eq "close_connection_exit\n") { 618: &status("Request close connection"); 619: &logthis( 620: "CRITICAL: Request Close Connection ... exiting"); 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(" Request data exchange complete"); 644: } 645: if ($@=~/timeout/) { 646: $answer=''; 647: &logthis( 648: "CRITICAL: Timeout: $request"); 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(" Request processing complete"); 676: } 677: # ===================================================== Done processing request 678: } 679: delete $ready{$client}; 680: # -------------------------------------------------------------- End non-forker 681: if($DEBUG) { 682: &logthis(" requests for child handled"); 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: "WARNING: Couldn't connect to $conserver ($st secs): "); 717: sleep($st); 718: exit; 719: }; 720: # ----------------------------------------------------------------- Init dialog 721: 722: &logthis("INFO Connected to $conserver, initing "); 723: &status("Init dialogue: $conserver"); 724: 725: $answer = londtransaction($remotesock, "init:$conserver", 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: "WARNING: Init failed ($st secs)"); 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: "WARNING: ". 770: "Could not establish secure connection ($st secs)!"); 771: sleep($st); 772: exit; 773: } 774: &logthis(" Remote open success "); 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("CRITICAL: " 786: ."ABNORMAL EXIT. Child $$ for server [$wasserver] died through " 787: ."\"$signal\" with parameter "); 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("CRITICAL: Shutting down"); 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("CRITICAL: Restarting"); 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 ('CRITICAL: Child '.$_.' is dead'); 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("INFO: Restarting child for server: " 886: .$host."\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(" CRITICAL -- londtransaction ". 953: "failed to block signals "); 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(" CRITICAL -- londtransaction ". 990: "failed to re-enable signal processing. "); 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