--- loncom/lond 1999/11/04 20:12:47 1.3 +++ loncom/lond 2000/02/08 17:34:24 1.9 @@ -3,7 +3,8 @@ # lond "LON Daemon" Server (port "LOND" 5663) # 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 Gerd Kortemeyer +# 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 # based on "Perl Cookbook" ISBN 1-56592-243-3 # preforker - server who forks first # runs as a daemon @@ -27,6 +28,7 @@ open (CONFIG,"/etc/httpd/conf/access.con while ($configline=) { if ($configline =~ /PerlSetVar/) { my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); + chomp($varvalue); $perlvar{$varname}=$varvalue; } } @@ -77,7 +79,7 @@ sub HUNTSMAN { # si kill 'INT' => keys %children; my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); - &logthis("Shutting down"); + &logthis("CRITICAL: Shutting down"); exit; # clean up with dignity } @@ -85,7 +87,7 @@ sub HUPSMAN { # sig local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children kill 'INT' => keys %children; close($server); # free up socket - &logthis("Restarting"); + &logthis("CRITICAL: Restarting"); my $execdir=$perlvar{'lonDaemons'}; exec("$execdir/lond"); # here we go again } @@ -118,12 +120,15 @@ sub reconlonc { &logthis("$peerfile still not there, give it another try"); sleep 5; if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, giving up"); + &logthis( + "WARNING: $peerfile still not there, giving up"); } else { - &logthis("lonc at pid $loncpid not responding, giving up"); + &logthis( + "CRITICAL: " + ."lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('lonc not running, giving up'); + &logthis('CRITICAL: lonc not running, giving up'); } } @@ -199,7 +204,7 @@ $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lond.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); -&logthis("Starting"); +&logthis("CRITICAL: ---------- Starting ----------"); # ------------------------------------------------------- Now we are on our own @@ -261,7 +266,8 @@ sub make_new_child { my ($port,$iaddr)=unpack_sockaddr_in($caller); my $clientip=inet_ntoa($iaddr); my $clientrec=($hostid{$clientip} ne undef); - &logthis("Connect from $clientip ($hostid{$clientip})"); + &logthis( +"INFO: Connect from $clientip ($hostid{$clientip})"); my $clientok; if ($clientrec) { my $remotereq=<$client>; @@ -275,17 +281,23 @@ sub make_new_child { $clientok=1; print $client "ok\n"; } else { - &logthis("$clientip did not reply challenge"); + &logthis( + "WARNING: $clientip did not reply challenge"); } } else { - &logthis("$clientip failed to initialize: >$remotereq<"); + &logthis( + "WARNING: " + ."$clientip failed to initialize: >$remotereq< "); } } else { - &logthis("Unknown client $clientip"); + &logthis( + "WARNING: Unknown client $clientip"); } if ($clientok) { # ---------------- New known client connecting, could mean machine online again &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); + &logthis( + "Established connection: $hostid{$clientip}"); # ------------------------------------------------------------ Process requests while (my $userinput=<$client>) { chomp($userinput); @@ -494,9 +506,11 @@ sub make_new_child { } # ------------------------------------------------------------------------- put } elsif ($userinput =~ /^put/) { - my ($cmd,$udom,$uname,$namespace,$what) + my ($cmd,$udom,$uname,$namespace,$what) =split(/:/,$userinput); - $namespace=~s/\W//g; + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + if ($namespace ne 'roles') { chomp($what); my $proname=propath($udom,$uname); my $now=time; @@ -507,12 +521,46 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (dbmopen(%hash,"$proname/$namespace.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + foreach $pair (@pairs) { + ($key,$value)=split(/=/,$pair); + $hash{$key}=$value; + } + if (untie(%hash)) { + print $client "ok\n"; + } else { + print $client "error:$!\n"; + } + } else { + print $client "error:$!\n"; + } + } else { + print $client "refused\n"; + } +# -------------------------------------------------------------------- rolesput + } elsif ($userinput =~ /^rolesput/) { + if ($wasenc==1) { + my ($cmd,$exedom,$exeuser,$udom,$uname,$what) + =split(/:/,$userinput); + my $namespace='roles'; + chomp($what); + my $proname=propath($udom,$uname); + my $now=time; + { + my $hfh; + if ( + $hfh=IO::File->new(">>$proname/$namespace.hist") + ) { + print $hfh "P:$now:$exedom:$exeuser:$what\n"; + } + } + my @pairs=split(/\&/,$what); + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); $hash{$key}=$value; } - if (dbmclose(%hash)) { + if (untie(%hash)) { print $client "ok\n"; } else { print $client "error:$!\n"; @@ -520,20 +568,24 @@ sub make_new_child { } else { print $client "error:$!\n"; } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------- get } elsif ($userinput =~ /^get/) { my ($cmd,$udom,$uname,$namespace,$what) =split(/:/,$userinput); + $namespace=~s/\//\_/g; $namespace=~s/\W//g; chomp($what); my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (dbmopen(%hash,"$proname/$namespace.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } - if (dbmclose(%hash)) { + if (untie(%hash)) { $qresult=~s/\&$//; print $client "$qresult\n"; } else { @@ -546,16 +598,17 @@ sub make_new_child { } elsif ($userinput =~ /^eget/) { my ($cmd,$udom,$uname,$namespace,$what) =split(/:/,$userinput); + $namespace=~s/\//\_/g; $namespace=~s/\W//g; chomp($what); my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (dbmopen(%hash,"$proname/$namespace.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } - if (dbmclose(%hash)) { + if (untie(%hash)) { $qresult=~s/\&$//; if ($cipher) { my $cmdlength=length($qresult); @@ -581,6 +634,7 @@ sub make_new_child { } elsif ($userinput =~ /^del/) { my ($cmd,$udom,$uname,$namespace,$what) =split(/:/,$userinput); + $namespace=~s/\//\_/g; $namespace=~s/\W//g; chomp($what); my $proname=propath($udom,$uname); @@ -592,11 +646,11 @@ sub make_new_child { ) { print $hfh "D:$now:$what\n"; } } my @keys=split(/\&/,$what); - if (dbmopen(%hash,"$proname/$namespace.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { foreach $key (@keys) { delete($hash{$key}); } - if (dbmclose(%hash)) { + if (untie(%hash)) { print $client "ok\n"; } else { print $client "error:$!\n"; @@ -608,15 +662,15 @@ sub make_new_child { } elsif ($userinput =~ /^keys/) { my ($cmd,$udom,$uname,$namespace) =split(/:/,$userinput); + $namespace=~s/\//\_/g; $namespace=~s/\W//g; - chomp($namespace); my $proname=propath($udom,$uname); my $qresult=''; - if (dbmopen(%hash,"$proname/$namespace.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { foreach $key (keys %hash) { $qresult.="$key&"; } - if (dbmclose(%hash)) { + if (untie(%hash)) { $qresult=~s/\&$//; print $client "$qresult\n"; } else { @@ -629,15 +683,88 @@ sub make_new_child { } elsif ($userinput =~ /^dump/) { my ($cmd,$udom,$uname,$namespace) =split(/:/,$userinput); + $namespace=~s/\//\_/g; $namespace=~s/\W//g; - chomp($namespace); my $proname=propath($udom,$uname); my $qresult=''; - if (dbmopen(%hash,"$proname/$namespace.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { foreach $key (keys %hash) { $qresult.="$key=$hash{$key}&"; } - if (dbmclose(%hash)) { + if (untie(%hash)) { + $qresult=~s/\&$//; + print $client "$qresult\n"; + } else { + print $client "error:$!\n"; + } + } else { + print $client "error:$!\n"; + } +# ----------------------------------------------------------------------- store + } elsif ($userinput =~ /^store/) { + my ($cmd,$udom,$uname,$namespace,$rid,$what) + =split(/:/,$userinput); + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + if ($namespace ne 'roles') { + chomp($what); + my $proname=propath($udom,$uname); + my $now=time; + { + my $hfh; + if ( + $hfh=IO::File->new(">>$proname/$namespace.hist") + ) { print $hfh "P:$now:$rid:$what\n"; } + } + my @pairs=split(/\&/,$what); + + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + my @previouskeys=split(/&/,$hash{"keys:$rid"}); + my $key; + $hash{"version:$rid"}++; + my $version=$hash{"version:$rid"}; + my $allkeys=''; + foreach $pair (@pairs) { + ($key,$value)=split(/=/,$pair); + $allkeys.=$key.':'; + $hash{"$version:$rid:$key"}=$value; + } + $allkeys=~s/:$//; + $hash{"$version:keys:$rid"}=$allkeys; + if (untie(%hash)) { + print $client "ok\n"; + } else { + print $client "error:$!\n"; + } + } else { + print $client "error:$!\n"; + } + } else { + print $client "refused\n"; + } +# --------------------------------------------------------------------- restore + } elsif ($userinput =~ /^restore/) { + my ($cmd,$udom,$uname,$namespace,$rid) + =split(/:/,$userinput); + $namespace=~s/\//\_/g; + $namespace=~s/\W//g; + chomp($rid); + my $proname=propath($udom,$uname); + my $qresult=''; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + my $version=$hash{"version:$rid"}; + $qresult.="version=$version&"; + my $scope; + for ($scope=1;$scope<=$version;$scope++) { + my $vkeys=$hash{"$scope:keys:$rid"}; + my @keys=split(/:/,$vkeys); + my $key; + $qresult.="$scope:keys=$vkeys&"; + foreach $key (@keys) { + $qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&"; + } + } + if (untie(%hash)) { $qresult=~s/\&$//; print $client "$qresult\n"; } else { @@ -660,12 +787,12 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (dbmopen(%hash,"$proname.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); $hash{$key}=$value; } - if (dbmclose(%hash)) { + if (untie(%hash)) { print $client "ok\n"; } else { print $client "error:$!\n"; @@ -681,11 +808,11 @@ sub make_new_child { my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; my @queries=split(/\&/,$what); my $qresult=''; - if (dbmopen(%hash,"$proname.db",0644)) { + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { for ($i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } - if (dbmclose(%hash)) { + if (untie(%hash)) { $qresult=~s/\&$//; print $client "$qresult\n"; } else { @@ -694,6 +821,20 @@ sub make_new_child { } else { print $client "error:$!\n"; } +# -------------------------------------------------------------------------- ls + } elsif ($userinput =~ /^ls/) { + my ($cmd,$ulsdir)=split(/:/,$userinput); + my $ulsout=''; + my $ulsfn; + if (-e $ulsdir) { + while ($ulsfn=<$ulsdir/*>) { + my @ulsstats=stat($ulsfn); + $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; + } + } else { + $ulsout='no_such_dir'; + } + print $client "$ulsout\n"; # ------------------------------------------------------------- unknown command } else { # unknown command @@ -703,9 +844,11 @@ sub make_new_child { } } else { print $client "refused\n"; - &logthis("Rejected client $clientip, closing connection"); + &logthis("WARNING: " + ."Rejected client $clientip, closing connection"); } - &logthis("Disconnect from $clientip ($hostid{$clientip})"); + &logthis("CRITICAL: " + ."Disconnect from $clientip ($hostid{$clientip})"); # ============================================================================= }