--- loncom/lond 2004/06/21 13:25:53 1.200 +++ 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.200 2004/06/21 13:25:53 matthew Exp $ +# $Id: lond,v 1.207 2004/07/23 11:03:05 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -51,12 +51,12 @@ use LONCAPA::ConfigFileEdit; use LONCAPA::lonlocal; use LONCAPA::lonssl; -my $DEBUG = 11; # Non zero to enable debug log entries. +my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.200 $'; #' 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 @@ -354,7 +388,6 @@ sub ReadManagerTable { while(my $host = ) { chomp($host); if ($host =~ "^#") { # Comment line. - logthis(' Skipping line: '. "$host\n"); next; } if (!defined $hostip{$host}) { # This is a non cluster member @@ -900,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::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. # @@ -1426,7 +1680,7 @@ while (1) { sub make_new_child { my $pid; - my $cipher; +# my $cipher; # Now global my $sigset; $client = shift; @@ -1485,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(); @@ -2233,11 +2487,14 @@ sub make_new_child { # ------------------------------------------------------------------------- put } elsif ($userinput =~ /^put/) { if(isClient) { - my ($cmd,$udom,$uname,$namespace,$what) + my ($cmd,$udom,$uname,$namespace,$what,@extras) =split(/:/,$userinput); $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; @@ -2836,8 +3093,8 @@ sub make_new_child { my %hash; if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { foreach my $pair (@pairs) { - my ($key,$value)=split(/=/,$pair); - $hash{$key}=$value.':'.$now; + my ($key,$descr,$inst_code)=split(/=/,$pair); + $hash{$key}=$descr.':'.$inst_code.':'.$now; } if (untie(%hash)) { print $client "ok\n"; @@ -2872,14 +3129,19 @@ sub make_new_child { my %hash; if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { while (my ($key,$value) = each(%hash)) { - my ($descr,$lasttime)=split(/\:/,$value); + my ($descr,$lasttime,$inst_code); + if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) { + ($descr,$inst_code,$lasttime)=($1,$2,$3); + } else { + ($descr,$lasttime) = split(/\:/,$value); + } if ($lasttime<$since) { next; } if ($description eq '.') { - $qresult.=$key.'='.$descr.'&'; + $qresult.=$key.'='.$descr.':'.$inst_code.'&'; } else { my $unescapeVal = &unescape($descr); if (eval('$unescapeVal=~/\Q$description\E/i')) { - $qresult.="$key=$descr&"; + $qresult.=$key.'='.$descr.':'.$inst_code.'&'; } } } @@ -3033,6 +3295,24 @@ sub make_new_child { Reply($client, "refused\n", $userinput); } +# ----------------------------------------- portfolio directory list (portls) + } elsif ($userinput =~ /^portls/) { + if(isClient) { + my ($cmd,$uname,$udom)=split(/:/,$userinput); + my $udir=propath($udom,$uname).'/userfiles/portfolio'; + my $dirLine=''; + my $dirContents=''; + if (opendir(LSDIR,$udir.'/')){ + while ($dirLine = readdir(LSDIR)){ + $dirContents = $dirContents.$dirLine.'
'; + } + } else { + $dirContents = "No directory found\n"; + } + print $client $dirContents."\n"; + } else { + Reply($client, "refused\n", $userinput); + } # -------------------------------------------------------------------------- ls } elsif ($userinput =~ /^ls/) { if(isClient) { @@ -3192,6 +3472,32 @@ sub make_new_child { } else { print $client "refused\n"; } +#--------------------- read and retrieve institutional code format (for support form). + } elsif ($userinput =~/^autoinstcodeformat:/) { + if (isClient) { + my $reply; + my($cmd,$cdom,$course) = split(/:/,$userinput); + my @pairs = split/\&/,$course; + my %instcodes = (); + my %codes = (); + my @codetitles = (); + my %cat_titles = (); + my %cat_order = (); + foreach (@pairs) { + my ($key,$value) = split/=/,$_; + $instcodes{&unescape($key)} = &unescape($value); + } + my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order); + if ($formatreply eq 'ok') { + my $codes_str = &hash2str(%codes); + my $codetitles_str = &array2str(@codetitles); + my $cat_titles_str = &hash2str(%cat_titles); + my $cat_order_str = &hash2str(%cat_order); + print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n"; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------- unknown command } else { @@ -3599,6 +3905,73 @@ sub userload { return $userloadpercent; } +# Routines for serializing arrays and hashes (copies from lonnet) + +sub array2str { + my (@array) = @_; + my $result=&arrayref2str(\@array); + $result=~s/^__ARRAY_REF__//; + $result=~s/__END_ARRAY_REF__$//; + return $result; +} + +sub arrayref2str { + my ($arrayref) = @_; + my $result='__ARRAY_REF__'; + foreach my $elem (@$arrayref) { + if(ref($elem) eq 'ARRAY') { + $result.=&arrayref2str($elem).'&'; + } elsif(ref($elem) eq 'HASH') { + $result.=&hashref2str($elem).'&'; + } elsif(ref($elem)) { + #print("Got a ref of ".(ref($elem))." skipping."); + } else { + $result.=&escape($elem).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_ARRAY_REF__'; + return $result; +} + +sub hash2str { + my (%hash) = @_; + my $result=&hashref2str(\%hash); + $result=~s/^__HASH_REF__//; + $result=~s/__END_HASH_REF__$//; + return $result; +} + +sub hashref2str { + my ($hashref)=@_; + my $result='__HASH_REF__'; + foreach (sort(keys(%$hashref))) { + if (ref($_) eq 'ARRAY') { + $result.=&arrayref2str($_).'='; + } elsif (ref($_) eq 'HASH') { + $result.=&hashref2str($_).'='; + } elsif (ref($_)) { + $result.='='; + #print("Got a ref of ".(ref($_))." skipping."); + } else { + if ($_) {$result.=&escape($_).'=';} else { last; } + } + + if(ref($hashref->{$_}) eq 'ARRAY') { + $result.=&arrayref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_}) eq 'HASH') { + $result.=&hashref2str($hashref->{$_}).'&'; + } elsif(ref($hashref->{$_})) { + $result.='&'; + #print("Got a ref of ".(ref($hashref->{$_}))." skipping."); + } else { + $result.=&escape($hashref->{$_}).'&'; + } + } + $result=~s/\&$//; + $result .= '__END_HASH_REF__'; + return $result; +} # ----------------------------------- POD (plain old documentation, CPAN style) 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.