--- loncom/lond 2004/08/02 21:02:20 1.205.2.1 +++ 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.205.2.1 2004/08/02 21:02:20 albertel Exp $ +# $Id: lond,v 1.209 2004/07/23 14:10:47 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -50,14 +50,13 @@ use File::Copy; use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; -use Fcntl qw(:flock); my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.205.2.1 $'; #' stupid emacs +my $VERSION='$Revision: 1.209 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; @@ -72,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 @@ -91,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. @@ -128,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 @@ -900,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::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. # @@ -1146,11 +1397,10 @@ sub checkchildren { &logthis('Going to check on the children'); my $docdir=$perlvar{'lonDocRoot'}; foreach (sort keys %children) { - #sleep 1; + sleep 1; unless (kill 'USR1' => $_) { &logthis ('Child '.$_.' is dead'); &logstatus($$.' is dead'); - delete($children{$_}); } } sleep 5; @@ -1168,7 +1418,6 @@ sub checkchildren { #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; #$execdir=$perlvar{'lonDaemons'}; #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; - delete($children{$_}); alarm(0); } } @@ -1176,7 +1425,6 @@ sub checkchildren { $SIG{ALRM} = 'DEFAULT'; $SIG{__DIE__} = \&catchexception; &status("Finished checking children"); - &logthis('Finished Checking children'); } # --------------------------------------------------------------------- Logging @@ -1221,19 +1469,17 @@ sub logstatus { &status("Doing logging"); my $docdir=$perlvar{'lonDocRoot'}; { + my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); + print $fh $$."\t".$clientname."\t".$currenthostid."\t" + .$status."\t".$lastlog."\t $keymode\n"; + $fh->close(); + } + &status("Finished londstatus.txt"); + { my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); print $fh $status."\n".$lastlog."\n".time."\n$keymode"; $fh->close(); } - &status("Finished $$.txt"); - { - open(LOG,">>$docdir/lon-status/londstatus.txt"); - flock(LOG,LOCK_EX); - print LOG $$."\t".$clientname."\t".$currenthostid."\t" - .$status."\t".$lastlog."\t $keymode\n"; - flock(DB,LOCK_UN); - close(LOG); - } &status("Finished logging"); } @@ -1431,7 +1677,7 @@ while (1) { sub make_new_child { my $pid; - my $cipher; +# my $cipher; # Now global my $sigset; $client = shift; @@ -1490,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(); @@ -2239,24 +2485,23 @@ sub make_new_child { } elsif ($userinput =~ /^put/) { if(isClient) { my ($cmd,$udom,$uname,$namespace,$what) - =split(/:/,$userinput); + =split(/:/,$userinput,5); $namespace=~s/\//\_/g; $namespace=~s/\W//g; if ($namespace ne 'roles') { 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; @@ -2291,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... @@ -2343,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, @@ -2394,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}; } @@ -2521,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}); } @@ -2684,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"}++; @@ -2918,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;