Return to lonc CVS log

Up to [LON-CAPA] / loncom

Implementation of encryption
Different login mechanisms
IP Spoof Protection

#!/usr/bin/perl

# The LearningOnline Network
# lonc - LON TCP-Client Domain-Socket-Server
# provides persistent TCP connections to the other servers in the network
# through multiplexed domain sockets
#
# PID in subdir logs/lonc.pid
# kill kills
# HUP restarts
# USR1 tries to open connections again

# 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,10/15 Gerd Kortemeyer 
# based on nonforker from Perl Cookbook
# - server who multiplexes without forking

use POSIX;
use IO::Socket;
use IO::Select;
use IO::File;
use Socket;
use Fcntl;
use Tie::RefHash;
use Crypt::IDEA;

# ------------------------------------ Read httpd access.conf and get variables

open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";

while ($configline=<CONFIG>) {
    if ($configline =~ /PerlSetVar/) {
	my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
        $perlvar{$varname}=$varvalue;
    }
}
close(CONFIG);

# ------------------------------------------------------------- Read hosts file

open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";

while ($configline=<CONFIG>) {
    my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
    chomp($ip);
    $hostip{$id}=$ip;
}
close(CONFIG);

# -------------------------------------------------------- Routines for forking

%children               = ();       # keys are current child process IDs,
                                    # values are hosts
%childpid               = ();       # the other way around

%childatt               = ();       # number of attempts to start server
                                    # for ID

sub REAPER {                        # takes care of dead children
    $SIG{CHLD} = \&REAPER;
    my $pid = wait;
    my $wasserver=$children{$pid};
    &logthis("Child $pid for server $wasserver died");
    delete $children{$pid};
    delete $childpid{$wasserver};
    my $port = "$perlvar{'lonSockDir'}/$wasserver";
    unlink($port);
}

sub HUNTSMAN {                      # signal handler for SIGINT
    local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
    kill 'INT' => keys %children;
    my $execdir=$perlvar{'lonDaemons'};
    unlink("$execdir/logs/lonc.pid");
    &logthis("Shutting down");
    exit;                           # clean up with dignity
}

sub HUPSMAN {                      # signal handler for SIGHUP
    local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
    kill 'INT' => keys %children;
    &logthis("Restarting");
    my $execdir=$perlvar{'lonDaemons'};
    exec("$execdir/lonc");         # here we go again
}

sub USRMAN {
    %childatt=();
    &logthis("USR1: Trying to establish connections again");
    foreach $thisserver (keys %hostip) {
	$answer=subreply("ping",$thisserver);
        &logthis(
          "USR1: Ping $thisserver (pid >$childpid{$thisserver}<): >$answer<");
    }
}

# -------------------------------------------------- Non-critical communication
sub subreply { 
 my ($cmd,$server)=@_;
 if ($server ne $perlvar{'lonHostID'}) { 
    my $peerfile="$perlvar{'lonSockDir'}/$server";
    my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                      Type    => SOCK_STREAM,
                                      Timeout => 10)
       or return "con_lost";
    print $sclient "$cmd\n";
    my $answer=<$sclient>;
    chomp($answer);
    if (!$answer) { $answer="con_lost"; }
 } else { $answer='self_reply'; }
 return $answer;
}

# --------------------------------------------------------------------- Logging

sub logthis {
    my $message=shift;
    my $execdir=$perlvar{'lonDaemons'};
    my $fh=IO::File->new(">>$execdir/logs/lonc.log");
    my $now=time;
    my $local=localtime($now);
    print $fh "$local ($$): $message\n";
}

# ---------------------------------------------------- Fork once and dissociate

$fpid=fork;
exit if $fpid;
die "Couldn't fork: $!" unless defined ($fpid);

POSIX::setsid() or die "Can't start new session: $!";

# ------------------------------------------------------- Write our PID on disk

$execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lonc.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);
&logthis("---------- Starting ----------");

# ----------------------------- Ignore signals generated during initial startup
$SIG{HUP}=$SIG{USR1}='IGNORE';
# ------------------------------------------------------- Now we are on our own
    
# Fork off our children, one for every server

foreach $thisserver (keys %hostip) {
    make_new_child($thisserver);
}

&logthis("Done starting initial servers");
# ----------------------------------------------------- Install signal handlers

$SIG{CHLD} = \&REAPER;
$SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP}  = \&HUPSMAN;
$SIG{USR1} = \&USRMAN;

# And maintain the population.
while (1) {
    sleep;                          # wait for a signal (i.e., child's death)
                                    # See who died and start new one
    foreach $thisserver (keys %hostip) {
        if (!$childpid{$thisserver}) {
	    if ($childatt{$thisserver}<5) {
               make_new_child($thisserver);
               $childatt{$thisserver}++;
	    }
        }       
    }
}


sub make_new_child {
   
    my $conserver=shift;
    my $pid;
    my $sigset;
    &logthis("Attempting to start child for server $conserver");
    # block signal for fork
    $sigset = POSIX::SigSet->new(SIGINT);
    sigprocmask(SIG_BLOCK, $sigset)
        or die "Can't block SIGINT for fork: $!\n";
    
    die "fork: $!" unless defined ($pid = fork);
    
    if ($pid) {
        # Parent records the child's birth and returns.
        sigprocmask(SIG_UNBLOCK, $sigset)
            or die "Can't unblock SIGINT for fork: $!\n";
        $children{$pid} = $conserver;
        $childpid{$conserver} = $pid;
        return;
    } else {
        # Child can *not* return from this subroutine.
        $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
    
        # unblock signals
        sigprocmask(SIG_UNBLOCK, $sigset)
            or die "Can't unblock SIGINT for fork: $!\n";

# ----------------------------- This is the modified main program of non-forker

$port = "$perlvar{'lonSockDir'}/$conserver";

unlink($port);
# ---------------------------------------------------- Client to network server
unless (
  $remotesock = IO::Socket::INET->new(PeerAddr => $hostip{$conserver},
                                      PeerPort => $perlvar{'londPort'},
                                      Proto    => "tcp",
                                      Type     => SOCK_STREAM)
   ) { &logthis("Couldn't connect $conserver: $@");
       sleep(5);
       exit; 
     };
# --------------------------------------- Send a ping to make other end do USR1
print $remotesock "init\n";
$answer=<$remotesock>;
print $remotesock "$answer";
$answer=<$remotesock>;
chomp($answer);
&logthis("Init reply for $conserver: >$answer<");
sleep 5;
print $remotesock "pong\n";
$answer=<$remotesock>;
chomp($answer);
&logthis("Pong reply for $conserver: >$answer<");
# ----------------------------------------------------------- Initialize cipher

print $remotesock "ekey\n";
my $buildkey=<$remotesock>;
my $key=$conserver.$perlvar{'lonHostID'};
$key=~tr/a-z/A-Z/;
$key=~tr/G-P/0-9/;
$key=~tr/Q-Z/0-9/;
$key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
$key=substr($key,0,32);
my $cipherkey=pack("H32",$key);
if ($cipher=new IDEA $cipherkey) {
   &logthis("Secure connection inititalized: $conserver");
} else {
   &logthis("Error: Could not establish secure connection, $conserver!");
}


# ------------------------------------------------------- Listen to UNIX socket
unless (
  $server = IO::Socket::UNIX->new(Local  => $port,
                                  Type   => SOCK_STREAM,
                                  Listen => 10 )
   ) { &logthis("Can't make server socket $conserver: $@");
       sleep(5);
       exit; 
     };

# -----------------------------------------------------------------------------

# begin with empty buffers
%inbuffer  = ();
%outbuffer = ();
%ready     = ();

tie %ready, 'Tie::RefHash';

nonblock($server);
$select = IO::Select->new($server);

# Main loop: check reads/accepts, check writes, check ready to process
while (1) {
    my $client;
    my $rv;
    my $data;

    # check for new information on the connections we have

    # anything to read or accept?
    foreach $client ($select->can_read(1)) {

        if ($client == $server) {
            # accept a new connection

            $client = $server->accept();
            $select->add($client);
            nonblock($client);
        } else {
            # read data
            $data = '';
            $rv   = $client->recv($data, POSIX::BUFSIZ, 0);

            unless (defined($rv) && length $data) {
                # This would be the end of file, so close the client
                delete $inbuffer{$client};
                delete $outbuffer{$client};
                delete $ready{$client};

                $select->remove($client);
                close $client;
                next;
            }

            $inbuffer{$client} .= $data;

            # test whether the data in the buffer or the data we
            # just read means there is a complete request waiting
            # to be fulfilled.  If there is, set $ready{$client}
            # to the requests waiting to be fulfilled.
            while ($inbuffer{$client} =~ s/(.*\n)//) {
                push( @{$ready{$client}}, $1 );
            }
        }
    }

    # Any complete requests to process?
    foreach $client (keys %ready) {
        handle($client);
    }

    # Buffers to flush?
    foreach $client ($select->can_write(1)) {
        # Skip this client if we have nothing to say
        next unless exists $outbuffer{$client};

        $rv = $client->send($outbuffer{$client}, 0);
        unless (defined $rv) {
            # Whine, but move on.
            warn "I was told I could write, but I can't.\n";
            next;
        }
        if (($rv == length $outbuffer{$client}) ||
            ($! == POSIX::EWOULDBLOCK)) {
            substr($outbuffer{$client}, 0, $rv) = '';
            delete $outbuffer{$client} unless length $outbuffer{$client};
        } else {
            # Couldn't write all the data, and it wasn't because
            # it would have blocked.  Shutdown and move on.
            delete $inbuffer{$client};
            delete $outbuffer{$client};
            delete $ready{$client};

            $select->remove($client);
            close($client);
            next;
        }
    }
}
}

# ------------------------------------------------------- End of make_new_child

# handle($socket) deals with all pending requests for $client
sub handle {
    # requests are in $ready{$client}
    # send output to $outbuffer{$client}
    my $client = shift;
    my $request;

    foreach $request (@{$ready{$client}}) {
# ============================================================= Process request
        # $request is the text of the request
        # put text of reply into $outbuffer{$client}
# -----------------------------------------------------------------------------
        if ($request =~ /^encrypt\:/) {
	    my $cmd=$request;
            $cmd =~ s/^encrypt\://;
            chomp($cmd);
            my $cmdlength=length($cmd);
            $cmd.="         ";
            my $encrequest='';
            for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
                $encrequest.=
                    unpack("H16",$cipher->encrypt(substr($cmd,$encidx,8)));
            }
            $request="enc:$cmdlength:$encrequest\n";
        }
        print $remotesock "$request";
        $answer=<$remotesock>;
        if ($answer) {
	   if ($answer =~ /^enc/) {
               my ($cmd,$cmdlength,$encinput)=split(/:/,$answer);
               chomp($encinput);
	       $answer='';
               for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
                  $answer.=$cipher->decrypt(
                   pack("H16",substr($encinput,$encidx,16))
                  );
	       }
	      $answer=substr($answer,0,$cmdlength);
	      $answer.="\n";
	   }
           $outbuffer{$client} .= $answer;
        } else {
           $outbuffer{$client} .= "con_lost\n";
        }

# ===================================================== Done processing request
    }
    delete $ready{$client};
# -------------------------------------------------------------- End non-forker
}
# ---------------------------------------------------------- End make_new_child
}

# nonblock($socket) puts socket into nonblocking mode
sub nonblock {
    my $socket = shift;
    my $flags;

    
    $flags = fcntl($socket, F_GETFL, 0)
            or die "Can't get flags for socket: $!\n";
    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
            or die "Can't make socket nonblocking: $!\n";
}

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.