Annotation of loncom/lonc, revision 1.1
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: #
! 8: # PID in subdir logs/lonc.pid
! 9: # kill kills
! 10: # HUP restarts
! 11: # USR1 tries to open connections again
! 12:
! 13: # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,10/8,10/9 Gerd Kortemeyer
! 14: # based on nonforker from Perl Cookbook
! 15: # - server who multiplexes without forking
! 16:
! 17: use POSIX;
! 18: use IO::Socket;
! 19: use IO::Select;
! 20: use IO::File;
! 21: use Socket;
! 22: use Fcntl;
! 23: use Tie::RefHash;
! 24: use Crypt::IDEA;
! 25:
! 26: # ------------------------------------ Read httpd access.conf and get variables
! 27:
! 28: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
! 29:
! 30: while ($configline=<CONFIG>) {
! 31: if ($configline =~ /PerlSetVar/) {
! 32: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
! 33: $perlvar{$varname}=$varvalue;
! 34: }
! 35: }
! 36: close(CONFIG);
! 37:
! 38: # ------------------------------------------------------------- Read hosts file
! 39:
! 40: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
! 41:
! 42: while ($configline=<CONFIG>) {
! 43: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
! 44: chomp($ip);
! 45: $hostip{$id}=$ip;
! 46: }
! 47: close(CONFIG);
! 48:
! 49: # -------------------------------------------------------- Routines for forking
! 50:
! 51: %children = (); # keys are current child process IDs,
! 52: # values are hosts
! 53: %childpid = (); # the other way around
! 54:
! 55: %childatt = (); # number of attempts to start server
! 56: # for ID
! 57:
! 58: sub REAPER { # takes care of dead children
! 59: $SIG{CHLD} = \&REAPER;
! 60: my $pid = wait;
! 61: my $wasserver=$children{$pid};
! 62: &logthis("Child $pid for server $wasserver died");
! 63: delete $children{$pid};
! 64: delete $childpid{$wasserver};
! 65: my $port = "$perlvar{'lonSockDir'}/$wasserver";
! 66: unlink($port);
! 67: }
! 68:
! 69: sub HUNTSMAN { # signal handler for SIGINT
! 70: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
! 71: kill 'INT' => keys %children;
! 72: my $execdir=$perlvar{'lonDaemons'};
! 73: unlink("$execdir/logs/lonc.pid");
! 74: &logthis("Shutting down");
! 75: exit; # clean up with dignity
! 76: }
! 77:
! 78: sub HUPSMAN { # signal handler for SIGHUP
! 79: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
! 80: kill 'INT' => keys %children;
! 81: &logthis("Restarting");
! 82: my $execdir=$perlvar{'lonDaemons'};
! 83: exec("$execdir/lonc"); # here we go again
! 84: }
! 85:
! 86: sub USRMAN {
! 87: %childatt=();
! 88: &logthis("USR1: Trying to establish connections again");
! 89: foreach $thisserver (keys %hostip) {
! 90: $answer=subreply("ping",$thisserver);
! 91: &logthis(
! 92: "USR1: Ping $thisserver (pid >$childpid{$thisserver}<): >$answer<");
! 93: }
! 94: }
! 95:
! 96: # -------------------------------------------------- Non-critical communication
! 97: sub subreply {
! 98: my ($cmd,$server)=@_;
! 99: if ($server ne $perlvar{'lonHostID'}) {
! 100: my $peerfile="$perlvar{'lonSockDir'}/$server";
! 101: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
! 102: Type => SOCK_STREAM,
! 103: Timeout => 10)
! 104: or return "con_lost";
! 105: print $sclient "$cmd\n";
! 106: my $answer=<$sclient>;
! 107: chomp($answer);
! 108: if (!$answer) { $answer="con_lost"; }
! 109: } else { $answer='self_reply'; }
! 110: return $answer;
! 111: }
! 112:
! 113: # --------------------------------------------------------------------- Logging
! 114:
! 115: sub logthis {
! 116: my $message=shift;
! 117: my $execdir=$perlvar{'lonDaemons'};
! 118: my $fh=IO::File->new(">>$execdir/logs/lonc.log");
! 119: my $now=time;
! 120: my $local=localtime($now);
! 121: print $fh "$local ($$): $message\n";
! 122: }
! 123:
! 124: # ---------------------------------------------------- Fork once and dissociate
! 125:
! 126: $fpid=fork;
! 127: exit if $fpid;
! 128: die "Couldn't fork: $!" unless defined ($fpid);
! 129:
! 130: POSIX::setsid() or die "Can't start new session: $!";
! 131:
! 132: # ------------------------------------------------------- Write our PID on disk
! 133:
! 134: $execdir=$perlvar{'lonDaemons'};
! 135: open (PIDSAVE,">$execdir/logs/lonc.pid");
! 136: print PIDSAVE "$$\n";
! 137: close(PIDSAVE);
! 138: &logthis("---------- Starting ----------");
! 139:
! 140: # ----------------------------- Ignore signals generated during initial startup
! 141: $SIG{HUP}=$SIG{USR1}='IGNORE';
! 142: # ------------------------------------------------------- Now we are on our own
! 143:
! 144: # Fork off our children, one for every server
! 145:
! 146: foreach $thisserver (keys %hostip) {
! 147: make_new_child($thisserver);
! 148: }
! 149:
! 150: &logthis("Done starting initial servers");
! 151: # ----------------------------------------------------- Install signal handlers
! 152:
! 153: $SIG{CHLD} = \&REAPER;
! 154: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
! 155: $SIG{HUP} = \&HUPSMAN;
! 156: $SIG{USR1} = \&USRMAN;
! 157:
! 158: # And maintain the population.
! 159: while (1) {
! 160: sleep; # wait for a signal (i.e., child's death)
! 161: # See who died and start new one
! 162: foreach $thisserver (keys %hostip) {
! 163: if (!$childpid{$thisserver}) {
! 164: if ($childatt{$thisserver}<5) {
! 165: make_new_child($thisserver);
! 166: $childatt{$thisserver}++;
! 167: }
! 168: }
! 169: }
! 170: }
! 171:
! 172:
! 173: sub make_new_child {
! 174:
! 175: my $conserver=shift;
! 176: my $pid;
! 177: my $sigset;
! 178: &logthis("Attempting to start child for server $conserver");
! 179: # block signal for fork
! 180: $sigset = POSIX::SigSet->new(SIGINT);
! 181: sigprocmask(SIG_BLOCK, $sigset)
! 182: or die "Can't block SIGINT for fork: $!\n";
! 183:
! 184: die "fork: $!" unless defined ($pid = fork);
! 185:
! 186: if ($pid) {
! 187: # Parent records the child's birth and returns.
! 188: sigprocmask(SIG_UNBLOCK, $sigset)
! 189: or die "Can't unblock SIGINT for fork: $!\n";
! 190: $children{$pid} = $conserver;
! 191: $childpid{$conserver} = $pid;
! 192: return;
! 193: } else {
! 194: # Child can *not* return from this subroutine.
! 195: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
! 196:
! 197: # unblock signals
! 198: sigprocmask(SIG_UNBLOCK, $sigset)
! 199: or die "Can't unblock SIGINT for fork: $!\n";
! 200:
! 201: # ----------------------------- This is the modified main program of non-forker
! 202:
! 203: $port = "$perlvar{'lonSockDir'}/$conserver";
! 204:
! 205: unlink($port);
! 206: # ---------------------------------------------------- Client to network server
! 207: unless (
! 208: $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
! 209: PeerPort => $perlvar{'londPort'},
! 210: Proto => "tcp",
! 211: Type => SOCK_STREAM)
! 212: ) { &logthis("Couldn't connect $conserver: $@");
! 213: sleep(5);
! 214: exit;
! 215: };
! 216: # --------------------------------------- Send a ping to make other end do USR1
! 217: print $remotesock "ping\n";
! 218: $answer=<$remotesock>;
! 219: chomp($answer);
! 220: &logthis("Ping reply for $conserver: >$answer<");
! 221: sleep 5;
! 222: print $remotesock "pong\n";
! 223: $answer=<$remotesock>;
! 224: chomp($answer);
! 225: &logthis("Pong reply for $conserver: >$answer<");
! 226: # ----------------------------------------------------------- Initialize cipher
! 227:
! 228: print $remotesock "ekey\n";
! 229: my $buildkey=<$remotesock>;
! 230: my $key=$conserver.$perlvar{'lonHostID'};
! 231: $key=~tr/a-z/A-Z/;
! 232: $key=~tr/G-P/0-9/;
! 233: $key=~tr/Q-Z/0-9/;
! 234: $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
! 235: $key=substr($key,0,32);
! 236: my $cipherkey=pack("H32",$key);
! 237: if ($cipher=new IDEA $cipherkey) {
! 238: &logthis("Secure connection inititalized: $conserver");
! 239: } else {
! 240: &logthis("Error: Could not establish secure connection, $conserver!");
! 241: }
! 242:
! 243:
! 244: # ------------------------------------------------------- Listen to UNIX socket
! 245: unless (
! 246: $server = IO::Socket::UNIX->new(Local => $port,
! 247: Type => SOCK_STREAM,
! 248: Listen => 10 )
! 249: ) { &logthis("Can't make server socket $conserver: $@");
! 250: sleep(5);
! 251: exit;
! 252: };
! 253:
! 254: # -----------------------------------------------------------------------------
! 255:
! 256: # begin with empty buffers
! 257: %inbuffer = ();
! 258: %outbuffer = ();
! 259: %ready = ();
! 260:
! 261: tie %ready, 'Tie::RefHash';
! 262:
! 263: nonblock($server);
! 264: $select = IO::Select->new($server);
! 265:
! 266: # Main loop: check reads/accepts, check writes, check ready to process
! 267: while (1) {
! 268: my $client;
! 269: my $rv;
! 270: my $data;
! 271:
! 272: # check for new information on the connections we have
! 273:
! 274: # anything to read or accept?
! 275: foreach $client ($select->can_read(1)) {
! 276:
! 277: if ($client == $server) {
! 278: # accept a new connection
! 279:
! 280: $client = $server->accept();
! 281: $select->add($client);
! 282: nonblock($client);
! 283: } else {
! 284: # read data
! 285: $data = '';
! 286: $rv = $client->recv($data, POSIX::BUFSIZ, 0);
! 287:
! 288: unless (defined($rv) && length $data) {
! 289: # This would be the end of file, so close the client
! 290: delete $inbuffer{$client};
! 291: delete $outbuffer{$client};
! 292: delete $ready{$client};
! 293:
! 294: $select->remove($client);
! 295: close $client;
! 296: next;
! 297: }
! 298:
! 299: $inbuffer{$client} .= $data;
! 300:
! 301: # test whether the data in the buffer or the data we
! 302: # just read means there is a complete request waiting
! 303: # to be fulfilled. If there is, set $ready{$client}
! 304: # to the requests waiting to be fulfilled.
! 305: while ($inbuffer{$client} =~ s/(.*\n)//) {
! 306: push( @{$ready{$client}}, $1 );
! 307: }
! 308: }
! 309: }
! 310:
! 311: # Any complete requests to process?
! 312: foreach $client (keys %ready) {
! 313: handle($client);
! 314: }
! 315:
! 316: # Buffers to flush?
! 317: foreach $client ($select->can_write(1)) {
! 318: # Skip this client if we have nothing to say
! 319: next unless exists $outbuffer{$client};
! 320:
! 321: $rv = $client->send($outbuffer{$client}, 0);
! 322: unless (defined $rv) {
! 323: # Whine, but move on.
! 324: warn "I was told I could write, but I can't.\n";
! 325: next;
! 326: }
! 327: if (($rv == length $outbuffer{$client}) ||
! 328: ($! == POSIX::EWOULDBLOCK)) {
! 329: substr($outbuffer{$client}, 0, $rv) = '';
! 330: delete $outbuffer{$client} unless length $outbuffer{$client};
! 331: } else {
! 332: # Couldn't write all the data, and it wasn't because
! 333: # it would have blocked. Shutdown and move on.
! 334: delete $inbuffer{$client};
! 335: delete $outbuffer{$client};
! 336: delete $ready{$client};
! 337:
! 338: $select->remove($client);
! 339: close($client);
! 340: next;
! 341: }
! 342: }
! 343: }
! 344: }
! 345:
! 346: # ------------------------------------------------------- End of make_new_child
! 347:
! 348: # handle($socket) deals with all pending requests for $client
! 349: sub handle {
! 350: # requests are in $ready{$client}
! 351: # send output to $outbuffer{$client}
! 352: my $client = shift;
! 353: my $request;
! 354:
! 355: foreach $request (@{$ready{$client}}) {
! 356: # ============================================================= Process request
! 357: # $request is the text of the request
! 358: # put text of reply into $outbuffer{$client}
! 359: # -----------------------------------------------------------------------------
! 360: if ($request =~ /^encrypt\:/) {
! 361: my $cmd=$request;
! 362: $cmd =~ s/^encrypt\://;
! 363: chomp($cmd);
! 364: my $cmdlength=length($cmd);
! 365: $cmd.=" ";
! 366: my $encrequest='';
! 367: for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
! 368: $encrequest.=
! 369: unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
! 370: }
! 371: $request="enc:$cmdlength:$encrequest\n";
! 372: }
! 373: print $remotesock "$request";
! 374: $answer=<$remotesock>;
! 375: if ($answer) {
! 376: if ($answer =~ /^enc/) {
! 377: my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
! 378: chomp($encinput);
! 379: $answer='';
! 380: for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
! 381: $answer.=$cipher->decrypt(
! 382: pack("H16",substr($encinput,$encidx,16))
! 383: );
! 384: }
! 385: $answer=substr($answer,0,$cmdlength);
! 386: $answer.="\n";
! 387: }
! 388: $outbuffer{$client} .= $answer;
! 389: } else {
! 390: $outbuffer{$client} .= "con_lost\n";
! 391: }
! 392:
! 393: # ===================================================== Done processing request
! 394: }
! 395: delete $ready{$client};
! 396: # -------------------------------------------------------------- End non-forker
! 397: }
! 398: # ---------------------------------------------------------- End make_new_child
! 399: }
! 400:
! 401: # nonblock($socket) puts socket into nonblocking mode
! 402: sub nonblock {
! 403: my $socket = shift;
! 404: my $flags;
! 405:
! 406:
! 407: $flags = fcntl($socket, F_GETFL, 0)
! 408: or die "Can't get flags for socket: $!\n";
! 409: fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
! 410: or die "Can't make socket nonblocking: $!\n";
! 411: }
! 412:
! 413:
! 414:
! 415:
! 416:
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