[LON-CAPA-cvs] cvs: loncom / lond
foxr
lon-capa-cvs@mail.lon-capa.org
Fri, 23 Jul 2004 11:03:06 -0000
This is a MIME encoded message
--foxr1090580586
Content-Type: text/plain
foxr Fri Jul 23 07:03:06 2004 EDT
Modified files:
/loncom lond
Log:
Begin rolling refactoring into lond. Note: at this point,
only support subs are being put in...therefore there are a bunch
of subs that are not yet called... PLEASE PLEASE PLEASE
do not remove any subs that appear to be dead wood without asking
fox@nscl.msu.edu as you may be undoing what I'm doing
RF
--foxr1090580586
Content-Type: text/plain
Content-Disposition: attachment; filename="foxr-20040723070306.txt"
Index: loncom/lond
diff -u loncom/lond:1.206 loncom/lond:1.207
--- loncom/lond:1.206 Thu Jul 22 19:08:43 2004
+++ loncom/lond Fri Jul 23 07:03:05 2004
@@ -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 $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 $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 %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 @@
"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 @@
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 @@
sub make_new_child {
my $pid;
- my $cipher;
+# my $cipher; # Now global
my $sigset;
$client = shift;
@@ -1484,7 +1739,7 @@
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();
--foxr1090580586--