--- loncom/lond 2000/02/08 17:39:23 1.10 +++ loncom/lond 2000/12/05 18:02:14 1.24 @@ -4,7 +4,11 @@ # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30, # 7/8,7/9,7/10,7/12,7/17,7/19,9/21, # 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 Gerd Kortemeyer +# 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 +# # based on "Perl Cookbook" ISBN 1-56592-243-3 # preforker - server who forks first # runs as a daemon @@ -21,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/) { @@ -34,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); @@ -55,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 @@ -103,6 +146,23 @@ sub logthis { print $fh "$local ($$): $message\n"; } + +# -------------------------------------------------------- Escape Special Chars + +sub escape { + my $str=shift; + $str =~ s/(\W)/"%".unpack('H2',$1)/eg; + return $str; +} + +# ----------------------------------------------------- Un-Escape Special Chars + +sub unescape { + my $str=shift; + $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; + return $str; +} + # ----------------------------------------------------------- Send USR1 to lonc sub reconlonc { @@ -133,6 +193,7 @@ sub reconlonc { } # -------------------------------------------------- Non-critical communication + sub subreply { my ($cmd,$server)=@_; my $peerfile="$perlvar{'lonSockDir'}/$server"; @@ -165,18 +226,44 @@ sub reply { return $answer; } +# -------------------------------------------------------------- Talk to lonsql + +sub sqlreply { + my ($cmd)=@_; + my $answer=subsqlreply($cmd); + if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); } + return $answer; +} + +sub subsqlreply { + my ($cmd)=@_; + my $unixsock="mysqlsock"; + my $peerfile="$perlvar{'lonSockDir'}/$unixsock"; + 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"; } + return $answer; +} + # -------------------------------------------- Return path to profile directory + 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; } # --------------------------------------- Is this the home server of an author? + sub ishome { my $author=shift; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; @@ -194,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 @@ -235,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; @@ -252,7 +339,9 @@ 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; # handle connections until we've reached $MAX_CLIENTS_PER_CHILD for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { @@ -283,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 @@ -354,6 +446,7 @@ sub make_new_child { if ($wasenc==1) { my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput); chomp($upass); + $upass=unescape($upass); my $proname=propath($udom,$uname); my $passfilename="$proname/passwd"; if (-e $passfilename) { @@ -457,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); } } @@ -490,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}"); @@ -498,12 +603,28 @@ 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"; } } else { print $client "rejected\n"; } +# ------------------------------------------------------------------------- log + } elsif ($userinput =~ /^log/) { + my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); + chomp($what); + my $proname=propath($udom,$uname); + my $now=time; + { + my $hfh; + if ($hfh=IO::File->new(">>$proname/activity.log")) { + print $hfh "$now:$hostid{$clientip}:$what\n"; + print $client "ok\n"; + } else { + print $client "error:$!\n"; + } + } # ------------------------------------------------------------------------- put } elsif ($userinput =~ /^put/) { my ($cmd,$udom,$uname,$namespace,$what) @@ -581,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]}&"; } @@ -604,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]}&"; } @@ -666,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&"; } @@ -687,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}&"; } @@ -751,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; @@ -761,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)) { @@ -773,6 +894,24 @@ sub make_new_child { } else { print $client "error:$!\n"; } +# ------------------------------------------------------------------- querysend + } elsif ($userinput =~ /^querysend/) { + my ($cmd,$query)=split(/:/,$userinput); + $query=~s/\n*$//g; + print $client sqlreply("$hostid{$clientip}\&$query")."\n"; +# ------------------------------------------------------------------ queryreply + } elsif ($userinput =~ /^queryreply/) { + my ($cmd,$id,$reply)=split(/:/,$userinput); + my $store; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new(">$execdir/tmp/$id")) { + print $store $reply; + close $store; + print $client "ok\n"; + } + else { + print $client "error:$!\n"; + } # ----------------------------------------------------------------------- idput } elsif ($userinput =~ /^idput/) { my ($cmd,$udom,$what)=split(/:/,$userinput); @@ -808,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]}&"; } @@ -821,6 +960,40 @@ sub make_new_child { } else { print $client "error:$!\n"; } +# ---------------------------------------------------------------------- tmpput + } elsif ($userinput =~ /^tmpput/) { + my ($cmd,$what)=split(/:/,$userinput); + my $store; + $tmpsnum++; + my $id=$$.'_'.$clientip.'_'.$tmpsnum; + $id=~s/\W/\_/g; + $what=~s/\n//g; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) { + print $store $what; + close $store; + print $client "$id\n"; + } + else { + print $client "error:$!\n"; + } + +# ---------------------------------------------------------------------- tmpget + } elsif ($userinput =~ /^tmpget/) { + my ($cmd,$id)=split(/:/,$userinput); + chomp($id); + $id=~s/\W/\_/g; + my $store; + my $execdir=$perlvar{'lonDaemons'}; + if ($store=IO::File->new("$execdir/tmp/$id.tmp")) { + my $reply=<$store>; + print $client "$reply\n"; + close $store; + } + else { + print $client "error:$!\n"; + } + # -------------------------------------------------------------------------- ls } elsif ($userinput =~ /^ls/) { my ($cmd,$ulsdir)=split(/:/,$userinput); @@ -834,6 +1007,7 @@ sub make_new_child { } else { $ulsout='no_such_dir'; } + if ($ulsout eq '') { $ulsout='empty'; } print $client "$ulsout\n"; # ------------------------------------------------------------- unknown command } else {