--- loncom/lond	2004/07/22 23:08:43	1.206
+++ loncom/lond	2004/07/23 11:03:05	1.207
@@ -2,7 +2,7 @@
 # The LearningOnline Network
 # lond "LON Daemon" Server (port "LOND" 5663)
 #
-# $Id: lond,v 1.206 2004/07/22 23:08:43 raeburn Exp $
+# $Id: lond,v 1.207 2004/07/23 11:03:05 foxr Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -56,7 +56,7 @@ my $DEBUG = 0;		       # Non zero to ena
 my $status='';
 my $lastlog='';
 
-my $VERSION='$Revision: 1.206 $'; #' stupid emacs
+my $VERSION='$Revision: 1.207 $'; #' stupid emacs
 my $remoteVERSION;
 my $currenthostid;
 my $currentdomainid;
@@ -71,6 +71,9 @@ my $thisserver;			# DNS of us.
 
 my $keymode;
 
+my $cipher;			# Cipher key negotiated with client
+my $tmpsnum = 0;		# Id of tmpputs.
+
 # 
 #   Connection type is:
 #      client                   - All client actions are allowed
@@ -90,6 +93,20 @@ my %managers;			# Ip -> manager names
 my %perlvar;			# Will have the apache conf defined perl vars.
 
 #
+#   The hash below is used for command dispatching, and is therefore keyed on the request keyword.
+#    Each element of the hash contains a reference to an array that contains:
+#          A reference to a sub that executes the request corresponding to the keyword.
+#          A flag that is true if the request must be encoded to be acceptable.
+#          A mask with bits as follows:
+#                      CLIENT_OK    - Set when the function is allowed by ordinary clients
+#                      MANAGER_OK   - Set when the function is allowed to manager clients.
+#
+my $CLIENT_OK  = 1;
+my $MANAGER_OK = 2;
+my %Dispatcher;
+
+
+#
 #  The array below are password error strings."
 #
 my $lastpwderror    = 13;		# Largest error number from lcpasswd.
@@ -127,6 +144,23 @@ my @adderrors    = ("ok",
 		    "lcuseradd Password mismatch");
 
 
+
+#
+#   Statistics that are maintained and dislayed in the status line.
+#
+my $Transactions;		# Number of attempted transactions.
+my $Failures;			# Number of transcations failed.
+
+#   ResetStatistics: 
+#      Resets the statistics counters:
+#
+sub ResetStatistics {
+    $Transactions = 0;
+    $Failures     = 0;
+}
+
+
+
 #------------------------------------------------------------------------
 #
 #   LocalConnection
@@ -899,6 +933,227 @@ sub EditFile {
 
     return "ok\n";
 }
+
+#---------------------------------------------------------------
+#
+# Manipulation of hash based databases (factoring out common code
+# for later use as we refactor.
+#
+#  Ties a domain level resource file to a hash.
+#  If requested a history entry is created in the associated hist file.
+#
+#  Parameters:
+#     domain    - Name of the domain in which the resource file lives.
+#     namespace - Name of the hash within that domain.
+#     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
+#     loghead   - Optional parameter, if present a log entry is created
+#                 in the associated history file and this is the first part
+#                  of that entry.
+#     logtail   - Goes along with loghead,  The actual logentry is of the
+#                 form $loghead:<timestamp>:logtail.
+# Returns:
+#    Reference to a hash bound to the db file or alternatively undef
+#    if the tie failed.
+#
+sub TieDomainHash {
+    my ($domain, 
+	$namespace,
+	$how)     = @_;
+    
+    # Filter out any whitespace in the domain name:
+    
+    $domain =~ s/\W//g;
+    
+    # We have enough to go on to tie the hash:
+    
+    my $user_top_dir   = $perlvar{'lonUsersDir'};
+    my $domain_dir     = $user_top_dir."/$domain";
+    my $resource_file  = $domain_dir."/$namespace.db";
+    my %hash;
+    if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {
+	if (scalar @_) {	# Need to log the operation.
+	    my $logFh = IO::File->new(">>domain_dir/$namespace.hist");
+	    if($logFh) {
+		my $timestamp = time;
+		my ($loghead, $logtail) = @_;
+		print $logFh "$loghead:$timestamp:$logtail\n";
+	    }
+	}
+	return \%hash;		# Return the tied hash.
+    }
+    else {
+	return undef;		# Tie failed.
+    }
+}
+
+#
+#   Ties a user's resource file to a hash.  
+#   If necessary, an appropriate history
+#   log file entry is made as well.
+#   This sub factors out common code from the subs that manipulate
+#   the various gdbm files that keep keyword value pairs.
+# Parameters:
+#   domain       - Name of the domain the user is in.
+#   user         - Name of the 'current user'.
+#   namespace    - Namespace representing the file to tie.
+#   how          - What the tie is done to (e.g. GDBM_WRCREAT().
+#   loghead      - Optional first part of log entry if there may be a
+#                  history file.
+#   what         - Optional tail of log entry if there may be a history
+#                  file.
+# Returns:
+#   hash to which the database is tied.  It's up to the caller to untie.
+#   undef if the has could not be tied.
+#
+sub TieUserHash {
+    my ($domain,
+	$user,
+	$namespace,
+	$how)       = @_;
+
+    
+    $namespace=~s/\//\_/g;	# / -> _
+    $namespace=~s/\W//g;		# whitespace eliminated.
+    my $proname     = propath($domain, $user);
+   
+    # If this is a namespace for which a history is kept,
+    # make the history log entry:
+    
+    
+    if (($namespace =~/^nohist\_/) && (scalar @_ > 0)) {
+	my $args = scalar @_;
+	Debug(" Opening history: $namespace $args");
+	my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
+	if($hfh) {
+	    my $now = time;
+	    my $loghead  = shift;
+	    my $what    = shift;
+	    print $hfh "$loghead:$now:$what\n";
+	}
+    }
+    #  Tie the database.
+    
+    my %hash;
+    if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
+	   $how, 0640)) {
+	return \%hash;
+    }
+    else {
+	return undef;
+    }
+    
+}
+#---------------------------------------------------------------
+#
+#   Getting, decoding and dispatching requests:
+#
+
+#
+#   Get a Request:
+#   Gets a Request message from the client.  The transaction
+#   is defined as a 'line' of text.  We remove the new line
+#   from the text line.  
+#   
+sub GetRequest {
+    my $input = <$client>;
+    chomp($input);
+
+    Debug("Request = $input\n");
+
+    &status('Processing '.$clientname.':'.$input);
+
+    return $input;
+}
+#
+#   Decipher encoded traffic
+#  Parameters:
+#     input      - Encoded data.
+#  Returns:
+#     Decoded data or undef if encryption key was not yet negotiated.
+#  Implicit input:
+#     cipher  - This global holds the negotiated encryption key.
+#
+sub Decipher {
+    my ($input)  = @_;
+    my $output = '';
+   
+   
+    if($cipher) {
+	my($enc, $enclength, $encinput) = split(/:/, $input);
+	for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
+	    $output .= 
+		$cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
+	}
+	return substr($output, 0, $enclength);
+    } else {
+	return undef;
+    }
+}
+
+#
+#   Register a command processor.  This function is invoked to register a sub
+#   to process a request.  Once registered, the ProcessRequest sub can automatically
+#   dispatch requests to an appropriate sub, and do the top level validity checking
+#   as well:
+#    - Is the keyword recognized.
+#    - Is the proper client type attempting the request.
+#    - Is the request encrypted if it has to be.
+#   Parameters:
+#    $request_name         - Name of the request being registered.
+#                           This is the command request that will match
+#                           against the hash keywords to lookup the information
+#                           associated with the dispatch information.
+#    $procedure           - Reference to a sub to call to process the request.
+#                           All subs get called as follows:
+#                             Procedure($cmd, $tail, $replyfd, $key)
+#                             $cmd    - the actual keyword that invoked us.
+#                             $tail   - the tail of the request that invoked us.
+#                             $replyfd- File descriptor connected to the client
+#    $must_encode          - True if the request must be encoded to be good.
+#    $client_ok            - True if it's ok for a client to request this.
+#    $manager_ok           - True if it's ok for a manager to request this.
+# Side effects:
+#      - On success, the Dispatcher hash has an entry added for the key $RequestName
+#      - On failure, the program will die as it's a bad internal bug to try to 
+#        register a duplicate command handler.
+#
+sub RegisterHandler {
+    my ($request_name,
+	$procedure,
+	$must_encode,
+	$client_ok,
+	$manager_ok)   = @_;
+
+    #  Don't allow duplication#
+   
+    if (defined $Dispatcher{$request_name}) {
+	die "Attempting to define a duplicate request handler for $request_name\n";
+    }
+    #   Build the client type mask:
+    
+    my $client_type_mask = 0;
+    if($client_ok) {
+	$client_type_mask  |= $CLIENT_OK;
+    }
+    if($manager_ok) {
+	$client_type_mask  |= $MANAGER_OK;
+    }
+   
+    #  Enter the hash:
+      
+    my @entry = ($procedure, $must_encode, $client_type_mask);
+   
+    $Dispatcher{$request_name} = \@entry;
+   
+   
+}
+
+
+#------------------------------------------------------------------
+
+
+
+
 #
 #  Convert an error return code from lcpasswd to a string value.
 #
@@ -1425,7 +1680,7 @@ while (1) {
 
 sub make_new_child {
     my $pid;
-    my $cipher;
+#    my $cipher;     # Now global
     my $sigset;
 
     $client = shift;
@@ -1484,7 +1739,7 @@ sub make_new_child {
         sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";
 
-        my $tmpsnum=0;
+#        my $tmpsnum=0;            # Now global
 #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();