--- loncom/lond	2002/09/30 21:38:18	1.100
+++ loncom/lond	2003/02/03 18:03:52	1.108
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # lond "LON Daemon" Server (port "LOND" 5663)
 #
-# $Id: lond,v 1.100 2002/09/30 21:38:18 matthew Exp $
+# $Id: lond,v 1.108 2003/02/03 18:03:52 harris41 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;
@@ -340,6 +331,7 @@ sub status {
     my $now=time;
     my $local=localtime($now);
     $status=$local.': '.$what;
+    $0='lond: '.$what.' '.$local;
 }
 
 # -------------------------------------------------------- Escape Special Chars
@@ -490,37 +482,35 @@ close(PIDSAVE);
 &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
 &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 +544,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 +551,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 +706,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/) {
@@ -1015,6 +1010,10 @@ sub make_new_child {
 # ------------------------------------------------------------------- subscribe
                    } elsif ($userinput =~ /^sub/) {
 		       print $client &subscribe($userinput,$clientip);
+# ------------------------------------------------------------- current version
+                   } elsif ($userinput =~ /^currentversion/) {
+                       my ($cmd,$fname)=split(/:/,$userinput);
+		       print $client &currentversion($fname)."\n";
 # ------------------------------------------------------------------------- log
                    } elsif ($userinput =~ /^log/) {
                        my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);
@@ -1213,6 +1212,47 @@ sub make_new_child {
                        } else {
                            print $client "error:$!\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:$!\n";
+                           }
+                       } else {
+                           print $client "error:$!\n";
+                       }
 # ------------------------------------------------------------------------ dump
                    } elsif ($userinput =~ /^dump/) {
                        my ($cmd,$udom,$uname,$namespace,$regexp)
@@ -1490,21 +1530,19 @@ sub make_new_child {
                 &logthis("<font color=blue>WARNING: "
                 ."Rejected client $clientip, closing connection</font>");
             }
-	}              
+	}             
 
 # =============================================================================
        
 	&logthis("<font color=red>CRITICAL: "
 		 ."Disconnect from $clientip ($hostid{$clientip})</font>");    
-        # 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;
-    }
+    
 }
 
 
@@ -1647,12 +1685,68 @@ sub unsub {
     return $result;
 }
 
+sub currentversion {
+    my $fname=shift;
+    my $version=-1;
+    my $ulsdir='';
+    if ($fname=~/^(.+)\/[^\/]+$/) {
+       $ulsdir=$1;
+    }
+    $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
+    $fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/;
+
+    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; }
+                    }
+		 }
+             }
+             closedir(LSDIR);
+             $version++;
+          }
+      }
+   }
+   return $version;
+}
+
+sub thisversion {
+    my $fname=shift;
+    my $version=-1;
+    if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
+	$version=$1;
+    }
+    return $version;
+}
+
 sub subscribe {
     my ($userinput,$clientip)=@_;
     my $result;
     my ($cmd,$fname)=split(/:/,$userinput);
     my $ownership=&ishome($fname);
     if ($ownership eq 'owner') {
+# explitly asking for the current version?
+        unless (-e $fname) {
+            my $currentversion=&currentversion($fname);
+	    if (&thisversion($fname)==$currentversion) {
+                if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
+		    my $root=$1;
+                    my $extension=$2;
+                    symlink($root.'.'.$extension,
+                            $root.'.'.$currentversion.'.'.$extension);
+                    unless ($extension=~/\.meta$/) {
+                       symlink($root.'.'.$extension.'.meta',
+                            $root.'.'.$currentversion.'.'.$extension.'.meta');
+		    }
+                }
+            }
+        }
 	if (-e $fname) {
 	    if (-d $fname) {
 		$result="directory\n";