--- loncom/lond 2004/07/22 23:08:43 1.206
+++ loncom/lond 2004/07/23 14:10:47 1.209
@@ -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.209 2004/07/23 14:10:47 albertel 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.209 $'; #' 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,224 @@ 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 tie_domain_hash {
+ 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);
+
+ # Tie the database.
+
+ my %hash;
+ if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
+ $how, 0640)) {
+ # 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";
+ }
+ }
+ 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 +1677,7 @@ while (1) {
sub make_new_child {
my $pid;
- my $cipher;
+# my $cipher; # Now global
my $sigset;
$client = shift;
@@ -1484,7 +1736,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();
@@ -2232,28 +2484,24 @@ sub make_new_child {
# ------------------------------------------------------------------------- put
} elsif ($userinput =~ /^put/) {
if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$what,@extras)
- =split(/:/,$userinput);
+ my ($cmd,$udom,$uname,$namespace,$what)
+ =split(/:/,$userinput,5);
$namespace=~s/\//\_/g;
$namespace=~s/\W//g;
if ($namespace ne 'roles') {
- if (@extras) {
- $what .= ':'.join(':',@extras);
- }
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if (
- $hfh=IO::File->new(">>$proname/$namespace.hist")
- ) { print $hfh "P:$now:$what\n"; }
- }
my @pairs=split(/\&/,$what);
my %hash;
if (tie(%hash,'GDBM_File',
"$proname/$namespace.db",
&GDBM_WRCREAT(),0640)) {
+ unless ($namespace=~/^nohist\_/) {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
+ }
+
foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;
@@ -2288,17 +2536,15 @@ sub make_new_child {
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if (
- $hfh=IO::File->new(">>$proname/$namespace.hist")
- ) { print $hfh "P:$now:$what\n"; }
- }
my @pairs=split(/\&/,$what);
my %hash;
if (tie(%hash,'GDBM_File',
"$proname/$namespace.db",
&GDBM_WRCREAT(),0640)) {
+ unless ($namespace=~/^nohist\_/) {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
+ }
foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);
# We could check that we have a number...
@@ -2340,17 +2586,16 @@ sub make_new_child {
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);
my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
+ print $hfh "P:$now:$exedom:$exeuser:$what\n";
+ }
+ }
+
foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);
&ManagePermissions($key, $udom, $uname,
@@ -2391,17 +2636,15 @@ sub make_new_child {
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
- {
- my $hfh;
- if (
- $hfh=IO::File->new(">>$proname/$namespace.hist")
- ) {
- print $hfh "D:$now:$exedom:$exeuser:$what\n";
- }
- }
my @rolekeys=split(/\&/,$what);
my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
+ print $hfh "D:$now:$exedom:$exeuser:$what\n";
+ }
+ }
foreach my $key (@rolekeys) {
delete $hash{$key};
}
@@ -2518,15 +2761,13 @@ sub make_new_child {
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if (
- $hfh=IO::File->new(">>$proname/$namespace.hist")
- ) { print $hfh "D:$now:$what\n"; }
- }
my @keys=split(/\&/,$what);
my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ unless ($namespace=~/^nohist\_/) {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }
+ }
foreach my $key (@keys) {
delete($hash{$key});
}
@@ -2681,15 +2922,15 @@ sub make_new_child {
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
- unless ($namespace=~/^nohist\_/) {
- my $hfh;
- if (
- $hfh=IO::File->new(">>$proname/$namespace.hist")
- ) { print $hfh "P:$now:$rid:$what\n"; }
- }
my @pairs=split(/\&/,$what);
my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
+ unless ($namespace=~/^nohist\_/) {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
+ print $hfh "P:$now:$rid:$what\n";
+ }
+ }
my @previouskeys=split(/&/,$hash{"keys:$rid"});
my $key;
$hash{"version:$rid"}++;
@@ -2915,15 +3156,15 @@ sub make_new_child {
$udom=~s/\W//g;
my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
my $now=time;
- {
- my $hfh;
- if (
- $hfh=IO::File->new(">>$proname.hist")
- ) { print $hfh "P:$now:$what\n"; }
- }
my @pairs=split(/\&/,$what);
my %hash;
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
+ {
+ my $hfh;
+ if ($hfh=IO::File->new(">>$proname.hist")) {
+ print $hfh "P:$now:$what\n";
+ }
+ }
foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);
$hash{$key}=$value;