--- loncom/lond 2000/06/29 20:43:03 1.13 +++ loncom/lond 2000/12/05 18:02:14 1.24 @@ -7,7 +7,7 @@ # 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 Gerd Kortemeyer +# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer # # based on "Perl Cookbook" ISBN 1-56592-243-3 # preforker - server who forks first @@ -25,9 +25,36 @@ use LWP::UserAgent(); use GDBM_File; use Authen::Krb4; +# grabs exception and records it to log before exiting +sub catchexception { + my ($signal)=@_; + &logthis("CRITICAL: " + ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."$signal with this parameter->[$@]"); + 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)=@_; + &logthis("CRITICAL: " + ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."\_\_DIE\_\_ with this parameter->[$message]"); + 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 +65,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 +98,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 +256,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 +281,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 +322,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 +339,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 +372,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,11 +550,20 @@ 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)"); } else { + if ($remoteurl!~/\.meta$/) { + my $mrequest= + new HTTP::Request('GET',$remoteurl.'.meta'); + my $mresponse= + $ua->request($mrequest,$fname.'.meta'); + if ($mresponse->is_error()) { + unlink($fname.'.meta'); + } + } rename($transname,$fname); } } @@ -541,6 +592,9 @@ 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}"); @@ -549,6 +603,7 @@ sub make_new_child { $fname=~s/\/home\/httpd\/html\/res/raw/; $fname="http://$thisserver/".$fname; print $client "$fname\n"; + } } else { print $client "not_found\n"; } @@ -647,7 +702,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]}&"; } @@ -670,7 +725,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]}&"; } @@ -732,7 +787,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&"; } @@ -753,7 +808,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}&"; } @@ -817,7 +872,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; @@ -827,7 +882,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)) { @@ -892,7 +947,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]}&"; } @@ -952,6 +1007,7 @@ sub make_new_child { } else { $ulsout='no_such_dir'; } + if ($ulsout eq '') { $ulsout='empty'; } print $client "$ulsout\n"; # ------------------------------------------------------------- unknown command } else {