--- loncom/lond 2002/10/07 13:50:36 1.102
+++ loncom/lond 2003/03/14 19:29:36 1.114
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.102 2002/10/07 13:50:36 www Exp $
+# $Id: lond,v 1.114 2003/03/14 19:29:36 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -31,36 +31,27 @@
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8,
# 03/07,05/31 Gerd Kortemeyer
-# 06/26 Scott Harrison
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer
-# 12/05 Scott Harrison
# 12/05,12/13,12/29 Gerd Kortemeyer
# YEAR=2001
-# Jan 01 Scott Harrison
# 02/12 Gerd Kortemeyer
-# 03/15 Scott Harrison
# 03/24 Gerd Kortemeyer
-# 04/02 Scott Harrison
# 05/11,05/28,08/30 Gerd Kortemeyer
-# 9/30,10/22,11/13,11/15,11/16 Scott Harrison
# 11/26,11/27 Gerd Kortemeyer
-# 12/20 Scott Harrison
# 12/22 Gerd Kortemeyer
# YEAR=2002
# 01/20/02,02/05 Gerd Kortemeyer
# 02/05 Guy Albertelli
-# 02/07 Scott Harrison
# 02/12 Gerd Kortemeyer
# 02/19 Matthew Hall
# 02/25 Gerd Kortemeyer
-# 05/11 Scott Harrison
+# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon
+# logic simpler (and there were problems maintaining the preforked
+# population). Since the time averaged connection rate is close to zero
+# because lonc's purpose is to maintain near continuous connnections,
+# preforking is not really needed.
###
-# based on "Perl Cookbook" ISBN 1-56592-243-3
-# preforker - server who forks first
-# runs as a daemon
-# HUPs
-# uses IDEA encryption
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
@@ -272,17 +263,25 @@ sub checkchildren {
}
}
sleep 5;
+ $SIG{ALRM} = sub { die "timeout" };
+ $SIG{__DIE__} = 'DEFAULT';
foreach (sort keys %children) {
unless (-e "$docdir/lon-status/londchld/$_.txt") {
+ eval {
+ alarm(300);
&logthis('Child '.$_.' did not respond');
kill 9 => $_;
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
$subj="LON: $perlvar{'lonHostID'} killed lond process $_";
my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
$execdir=$perlvar{'lonDaemons'};
- $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`
+ $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
+ alarm(0);
+ }
}
}
+ $SIG{ALRM} = 'DEFAULT';
+ $SIG{__DIE__} = \&cathcexception;
}
# --------------------------------------------------------------------- Logging
@@ -340,6 +339,7 @@ sub status {
my $now=time;
my $local=localtime($now);
$status=$local.': '.$what;
+ $0='lond: '.$what.' '.$local;
}
# -------------------------------------------------------- Escape Special Chars
@@ -490,37 +490,35 @@ close(PIDSAVE);
&logthis("CRITICAL: ---------- Starting ----------");
&status('Starting');
-# ------------------------------------------------------- Now we are on our own
-
-# Fork off our children.
-for (1 .. $PREFORK) {
- make_new_child();
-}
+
# ----------------------------------------------------- Install signal handlers
-&status('Forked children');
$SIG{CHLD} = \&REAPER;
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
$SIG{HUP} = \&HUPSMAN;
$SIG{USR1} = \&checkchildren;
-# And maintain the population.
+
+
+# --------------------------------------------------------------
+# Accept connections. When a connection comes in, it is validated
+# and if good, a child process is created to process transactions
+# along the connection.
+
while (1) {
- &status('Sleeping');
- sleep; # wait for a signal (i.e., child's death)
- &logthis('Woke up');
- &status('Woke up');
- for ($i = $children; $i < $PREFORK; $i++) {
- make_new_child(); # top up the child pool
- }
+ $client = $server->accept() or next;
+ make_new_child($client);
}
sub make_new_child {
+ my $client;
my $pid;
my $cipher;
my $sigset;
+
+ $client = shift;
&logthis("Attempting to start child");
# block signal for fork
$sigset = POSIX::SigSet->new(SIGINT);
@@ -554,10 +552,6 @@ sub make_new_child {
&Authen::Krb5::init_context();
&Authen::Krb5::init_ets();
- # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
- for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
- &status('Idle, waiting for connection');
- $client = $server->accept() or last;
&status('Accepted connection');
# =============================================================================
# do something with the connection
@@ -565,7 +559,7 @@ sub make_new_child {
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
# connection liveness.
# see if we know client and check for spoof IP by challenge
- my $caller=getpeername($client);
+ my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);
my $clientip=inet_ntoa($iaddr);
my $clientrec=($hostid{$clientip} ne undef);
@@ -720,13 +714,22 @@ sub make_new_child {
}
}
} elsif ($howpwd eq 'krb4') {
- $null=pack("C",0);
- unless ($upass=~/$null/) {
- $pwdcorrect=(
- Authen::Krb4::get_pw_in_tkt($uname,"",
- $contentpwd,'krbtgt',$contentpwd,1,
- $upass) == 0);
- } else { $pwdcorrect=0; }
+ $null=pack("C",0);
+ unless ($upass=~/$null/) {
+ my $krb4_error = &Authen::Krb4::get_pw_in_tkt
+ ($uname,"",$contentpwd,'krbtgt',
+ $contentpwd,1,$upass);
+ if (!$krb4_error) {
+ $pwdcorrect = 1;
+ } else {
+ $pwdcorrect=0;
+ # log error if it is not a bad password
+ if ($krb4_error != 62) {
+ &logthis('krb4:'.$uname.','.$contentpwd.','.
+ &Authen::Krb4::get_err_txt($Authen::Krb4::error));
+ }
+ }
+ }
} elsif ($howpwd eq 'krb5') {
$null=pack("C",0);
unless ($upass=~/$null/) {
@@ -860,7 +863,9 @@ sub make_new_child {
$fpnow.='/'.$fpparts[$i];
unless (-e $fpnow) {
unless (mkdir($fpnow,0777)) {
- $fperror="error:$!";
+ $fperror="error: ".($!+0)
+ ." mkdir failed while attempting "
+ ."makeuser\n";
}
}
}
@@ -1031,7 +1036,9 @@ sub make_new_child {
print $hfh "$now:$hostid{$clientip}:$what\n";
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." IO::File->new Failed "
+ ."while attempting log\n";
}
}
# ------------------------------------------------------------------------- put
@@ -1059,10 +1066,14 @@ sub make_new_child {
if (untie(%hash)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) failed ".
+ "while attempting put\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!)
+ ." tie(GDBM) Failed ".
+ "while attempting put\n";
}
} else {
print $client "refused\n";
@@ -1101,10 +1112,14 @@ sub make_new_child {
if (untie(%hash)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting rolesput\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting rolesput\n";
}
} else {
print $client "refused\n";
@@ -1127,10 +1142,19 @@ sub make_new_child {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting get\n";
}
} else {
- print $client "error:$!\n";
+ if ($!+0 == 2) {
+ print $client "error:No such file or ".
+ "GDBM reported bad block error\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting get\n";
+ }
}
# ------------------------------------------------------------------------ eget
} elsif ($userinput =~ /^eget/) {
@@ -1163,10 +1187,14 @@ sub make_new_child {
print $client "error:no_key\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting eget\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting eget\n";
}
# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {
@@ -1191,10 +1219,14 @@ sub make_new_child {
if (untie(%hash)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting del\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting del\n";
}
# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {
@@ -1212,10 +1244,59 @@ sub make_new_child {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting keys\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting keys\n";
+ }
+# ----------------------------------------------------------------- dumpcurrent
+ } elsif ($userinput =~ /^currentdump/) {
+ my ($cmd,$udom,$uname,$namespace)
+ =split(/:/,$userinput);
+ $namespace=~s/\//\_/g;
+ $namespace=~s/\W//g;
+ my $qresult='';
+ my $proname=propath($udom,$uname);
+ if (tie(%hash,'GDBM_File',
+ "$proname/$namespace.db",
+ &GDBM_READER(),0640)) {
+ # Structure of %data:
+ # $data{$symb}->{$parameter}=$value;
+ # $data{$symb}->{'v.'.$parameter}=$version;
+ # since $parameter will be unescaped, we do not
+ # have to worry about silly parameter names...
+ my %data = ();
+ while (my ($key,$value) = each(%hash)) {
+ my ($v,$symb,$param) = split(/:/,$key);
+ next if ($v eq 'version' || $symb eq 'keys');
+ next if (exists($data{$symb}) &&
+ exists($data{$symb}->{$param}) &&
+ $data{$symb}->{'v.'.$param} > $v);
+ $data{$symb}->{$param}=$value;
+ $data{$symb}->{'v.'.$param}=$v;
+ }
+ if (untie(%hash)) {
+ while (my ($symb,$param_hash) = each(%data)) {
+ while(my ($param,$value) = each (%$param_hash)){
+ next if ($param =~ /^v\./);
+ $qresult.=$symb.':'.$param.'='.$value.'&';
+ }
+ }
+ chop($qresult);
+ print $client "$qresult\n";
+ } else {
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting currentdump\n";
+ }
+ } else {
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting currentdump\n";
}
# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {
@@ -1246,10 +1327,14 @@ sub make_new_child {
chop($qresult);
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting dump\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting dump\n";
}
# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {
@@ -1286,10 +1371,14 @@ sub make_new_child {
if (untie(%hash)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting store\n";
}
} else {
print $client "refused\n";
@@ -1320,10 +1409,14 @@ sub make_new_child {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting restore\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting restore\n";
}
# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {
@@ -1362,7 +1455,9 @@ sub make_new_child {
print $client "ok\n";
}
else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." IO::File->new Failed ".
+ "while attempting queryreply\n";
}
# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {
@@ -1386,10 +1481,14 @@ sub make_new_child {
if (untie(%hash)) {
print $client "ok\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting idput\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting idput\n";
}
# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {
@@ -1407,10 +1506,14 @@ sub make_new_child {
$qresult=~s/\&$//;
print $client "$qresult\n";
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." untie(GDBM) Failed ".
+ "while attempting idget\n";
}
} else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ." tie(GDBM) Failed ".
+ "while attempting idget\n";
}
# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {
@@ -1427,7 +1530,9 @@ sub make_new_child {
print $client "$id\n";
}
else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ."IO::File->new Failed ".
+ "while attempting tmpput\n";
}
# ---------------------------------------------------------------------- tmpget
@@ -1443,9 +1548,24 @@ sub make_new_child {
close $store;
}
else {
- print $client "error:$!\n";
+ print $client "error: ".($!+0)
+ ."IO::File->new Failed ".
+ "while attempting tmpget\n";
}
+# ---------------------------------------------------------------------- tmpdel
+ } elsif ($userinput =~ /^tmpdel/) {
+ my ($cmd,$id)=split(/:/,$userinput);
+ chomp($id);
+ $id=~s/\W/\_/g;
+ my $execdir=$perlvar{'lonDaemons'};
+ if (unlink("$execdir/tmp/$id.tmp")) {
+ print $client "ok\n";
+ } else {
+ print $client "error: ".($!+0)
+ ."Unlink tmp Failed ".
+ "while attempting tmpdel\n";
+ }
# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {
my ($cmd,$ulsdir)=split(/:/,$userinput);
@@ -1494,21 +1614,19 @@ sub make_new_child {
&logthis("WARNING: "
."Rejected client $clientip, closing connection");
}
- }
+ }
# =============================================================================
&logthis("CRITICAL: "
."Disconnect from $clientip ($hostid{$clientip})");
- # tidy up gracefully and finish
-
- $server->close();
+
# this exit is VERY important, otherwise the child will become
# a producer of more and more children, forking yourself into
# process death.
exit;
- }
+
}
@@ -1658,20 +1776,26 @@ sub currentversion {
if ($fname=~/^(.+)\/[^\/]+$/) {
$ulsdir=$1;
}
+ my ($fnamere1,$fnamere2);
+ # remove version if already specified
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
- $fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/;
-
+ # get the bits that go before and after the version number
+ if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
+ $fnamere1=$1;
+ $fnamere2='.'.$2;
+ }
if (-e $fname) { $version=1; }
if (-e $ulsdir) {
if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {
+
while ($ulsfn=readdir(LSDIR)) {
# see if this is a regular file (ignore links produced earlier)
my $thisfile=$ulsdir.'/'.$ulsfn;
unless (-l $thisfile) {
- if ($thisfile=~/$fname/) {
- if ($1>$version) { $version=$1; }
- }
+ if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) {
+ if ($1>$version) { $version=$1; }
+ }
}
}
closedir(LSDIR);