--- loncom/lond 2000/07/14 07:43:15 1.15 +++ loncom/lond 2000/12/05 19:03:13 1.25 @@ -7,7 +7,9 @@ # 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 Gerd Kortemeyer +# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer +# 12/05 Scott Harrison +# 12/05 Gerd Kortemeyer # # based on "Perl Cookbook" ISBN 1-56592-243-3 # preforker - server who forks first @@ -25,9 +27,43 @@ use LWP::UserAgent(); use GDBM_File; use Authen::Krb4; +# grabs exception and records it to log before exiting +sub catchexception { + my ($signal)=@_; + $SIG{'QUIT'}='DEFAULT'; + $SIG{__DIE__}='DEFAULT'; + &logthis("CRITICAL: " + ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."$signal with this parameter->[$@]"); + if ($client) { print $client "error: $@\n"; } + die($@); +} + +# grabs exception and records it to log before exiting +# NOTE: we must NOT use the regular (non-overrided) die function in +# the code because a handler CANNOT be attached to it +# (despite what some of the documentation says about SIG{__DIE__}. + +sub catchdie { + my ($message)=@_; + $SIG{'QUIT'}='DEFAULT'; + $SIG{__DIE__}='DEFAULT'; + &logthis("CRITICAL: " + ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."\_\_DIE\_\_ with this parameter->[$message]"); + if ($client) { print $client "error: $message\n"; } + die($message); +} + +# -------------------------------- Set signal handlers to record abnormal exits + +$SIG{'QUIT'}=\&catchexception; +$SIG{__DIE__}=\&catchexception; + # ------------------------------------ Read httpd access.conf and get variables -open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; +open (CONFIG,"/etc/httpd/conf/access.conf") + || catchdie "Can't read access.conf"; while ($configline=) { if ($configline =~ /PerlSetVar/) { @@ -38,11 +74,23 @@ while ($configline=) { } close(CONFIG); +# --------------------------------------------- Check if other instance running + +my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; + +if (-e $pidfile) { + my $lfh=IO::File->new("$pidfile"); + my $pide=<$lfh>; + chomp($pide); + if (kill 0 => $pide) { catchdie "already running"; } +} + $PREFORK=4; # number of children to maintain, at least four spare # ------------------------------------------------------------- Read hosts file -open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; +open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") + || catchdie "Can't read host file"; while ($configline=) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); @@ -59,7 +107,7 @@ $server = IO::Socket::INET->new(LocalPor Proto => 'tcp', Reuse => 1, Listen => 10 ) - or die "making socket: $@\n"; + or catchdie "making socket: $@\n"; # --------------------------------------------------------- Do global variables @@ -217,7 +265,7 @@ sub propath { my ($udom,$uname)=@_; $udom=~s/\W//g; $uname=~s/\W//g; - my $subdir=$uname.'___'; + my $subdir=$uname.'__'; $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; return $proname; @@ -242,9 +290,9 @@ sub ishome { $fpid=fork; exit if $fpid; -die "Couldn't fork: $!" unless defined ($fpid); +catchdie "Couldn't fork: $!" unless defined ($fpid); -POSIX::setsid() or die "Can't start new session: $!"; +POSIX::setsid() or catchdie "Can't start new session: $!"; # ------------------------------------------------------- Write our PID on disk @@ -283,14 +331,14 @@ sub make_new_child { # block signal for fork $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) - or die "Can't block SIGINT for fork: $!\n"; + or catchdie "Can't block SIGINT for fork: $!\n"; - die "fork: $!" unless defined ($pid = fork); + catchdie "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"; + or catchdie "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = 1; $children++; return; @@ -300,7 +348,7 @@ sub make_new_child { # unblock signals sigprocmask(SIG_UNBLOCK, $sigset) - or die "Can't unblock SIGINT for fork: $!\n"; + or catchdie "Can't unblock SIGINT for fork: $!\n"; $tmpsnum=0; @@ -333,15 +381,18 @@ sub make_new_child { } else { &logthis( "WARNING: $clientip did not reply challenge"); + print $client "bye\n"; } } else { &logthis( "WARNING: " ."$clientip failed to initialize: >$remotereq< "); + print $client "bye\n"; } } else { &logthis( "WARNING: Unknown client $clientip"); + print $client "bye\n"; } if ($clientok) { # ---------------- New known client connecting, could mean machine online again @@ -508,7 +559,7 @@ sub make_new_child { $response=$ua->request($request,$transname); } if ($response->is_error()) { - unline($transname); + unlink($transname); my $message=$response->status_line; &logthis( "LWP GET: $message for $fname ($remoteurl)"); @@ -550,14 +601,21 @@ sub make_new_child { my $ownership=ishome($fname); if ($ownership eq 'owner') { if (-e $fname) { + if (-d $fname) { + print $client "directory\n"; + } else { $now=time; { - my $sh=IO::File->new(">$fname.$hostid{$clientip}"); - print $sh "$clientip:$now\n"; + my sh; + if ($sh= + IO::File->new(">$fname.$hostid{$clientip}")) { + print $sh "$clientip:$now\n"; + } } $fname=~s/\/home\/httpd\/html\/res/raw/; $fname="http://$thisserver/".$fname; print $client "$fname\n"; + } } else { print $client "not_found\n"; } @@ -656,7 +714,7 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -679,7 +737,7 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -741,7 +799,7 @@ sub make_new_child { $namespace=~s/\W//g; my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { foreach $key (keys %hash) { $qresult.="$key&"; } @@ -762,7 +820,7 @@ sub make_new_child { $namespace=~s/\W//g; my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { foreach $key (keys %hash) { $qresult.="$key=$hash{$key}&"; } @@ -826,7 +884,7 @@ sub make_new_child { chomp($rid); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { my $version=$hash{"version:$rid"}; $qresult.="version=$version&"; my $scope; @@ -836,7 +894,7 @@ sub make_new_child { my $key; $qresult.="$scope:keys=$vkeys&"; foreach $key (@keys) { - $qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&"; + $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; } } if (untie(%hash)) { @@ -901,7 +959,7 @@ sub make_new_child { my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; my @queries=split(/\&/,$what); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } @@ -961,6 +1019,7 @@ sub make_new_child { } else { $ulsout='no_such_dir'; } + if ($ulsout eq '') { $ulsout='empty'; } print $client "$ulsout\n"; # ------------------------------------------------------------- unknown command } else {