Diff for /loncom/lond between versions 1.89 and 1.178.2.18

version 1.89, 2002/08/09 18:18:36 version 1.178.2.18, 2004/04/19 11:32:35
Line 10 Line 10
 #  #
 # LON-CAPA is free software; you can redistribute it and/or modify  # LON-CAPA is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by  # it under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2 of the License, or  # the Free Software Foundation; either version 2 of the License, or 
 # (at your option) any later version.  # (at your option) any later version.
 #  #
 # LON-CAPA is distributed in the hope that it will be useful,  # LON-CAPA is distributed in the hope that it will be useful,
Line 20 Line 20
 #  #
 # You should have received a copy of the GNU General Public License  # You should have received a copy of the GNU General Public License
 # along with LON-CAPA; if not, write to the Free Software  # along with LON-CAPA; if not, write to the Free Software
 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA  # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA    
 #  #
 # /home/httpd/html/adm/gpl.txt  # /home/httpd/html/adm/gpl.txt
 #  #
   
   
 # http://www.lon-capa.org/  # http://www.lon-capa.org/
 #  #
 # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30,  
 # 7/8,7/9,7/10,7/12,7/17,7/19,9/21,  
 # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16,  
 # 12/7,12/15,01/06,01/11,01/12,01/14,2/8,  
 # 03/07,05/31 Gerd Kortemeyer  
 # 06/26 Scott Harrison  
 # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer  
 # 12/05 Scott Harrison  
 # 12/05,12/13,12/29 Gerd Kortemeyer  
 # YEAR=2001  
 # Jan 01 Scott Harrison  
 # 02/12 Gerd Kortemeyer  
 # 03/15 Scott Harrison  
 # 03/24 Gerd Kortemeyer  
 # 04/02 Scott Harrison  
 # 05/11,05/28,08/30 Gerd Kortemeyer  
 # 9/30,10/22,11/13,11/15,11/16 Scott Harrison  
 # 11/26,11/27 Gerd Kortemeyer  
 # 12/20 Scott Harrison  
 # 12/22 Gerd Kortemeyer  
 # YEAR=2002  
 # 01/20/02,02/05 Gerd Kortemeyer  
 # 02/05 Guy Albertelli  
 # 02/07 Scott Harrison  
 # 02/12 Gerd Kortemeyer  
 # 02/19 Matthew Hall  
 # 02/25 Gerd Kortemeyer  
 # 05/11 Scott Harrison  
 ###  
   
 # based on "Perl Cookbook" ISBN 1-56592-243-3  
 # preforker - server who forks first  
 # runs as a daemon  
 # HUPs  
 # uses IDEA encryption  
   
   use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 use Apache::File;  #use Apache::File;
 use Symbol;  use Symbol;
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  use Authen::Krb4;
   use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
   use File::Copy;
   use LONCAPA::ConfigFileEdit;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 1;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
   
   my $VERSION='$Revision$'; #' stupid emacs
   my $remoteVERSION;
   my $currenthostid;
   my $currentdomainid;
   
   my $client;
   my $clientip;
   my $clientname;
   
   my $cipher; # Cipher key negotiated with client.
   my $tmpsnum = 0;; # Id of tmpputs.
   
   my $server;
   my $thisserver;
   
   # 
   #   Connection type is:
   #      client                   - All client actions are allowed
   #      manager                  - only management functions allowed.
   #      both                     - Both management and client actions are allowed
   #
   
   my $ConnectionType;
   
   my %hostid;
   my %hostdom;
   my %hostip;
   
   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.
   my @passwderrors = ("ok",
      "lcpasswd must be run as user 'www'",
      "lcpasswd got incorrect number of arguments",
      "lcpasswd did not get the right nubmer of input text lines",
      "lcpasswd too many simultaneous pwd changes in progress",
      "lcpasswd User does not exist.",
      "lcpasswd Incorrect current passwd",
      "lcpasswd Unable to su to root.",
      "lcpasswd Cannot set new passwd.",
      "lcpasswd Username has invalid characters",
      "lcpasswd Invalid characters in password",
       "11", "12",
       "lcpasswd Password mismatch");
   
   
   #  The array below are lcuseradd error strings.:
   
   my $lastadderror = 13;
   my @adderrors    = ("ok",
       "User ID mismatch, lcuseradd must run as user www",
       "lcuseradd Incorrect number of command line parameters must be 3",
       "lcuseradd Incorrect number of stdinput lines, must be 3",
       "lcuseradd Too many other simultaneous pwd changes in progress",
       "lcuseradd User does not exist",
       "lcuseradd Unable to make www member of users's group",
       "lcuseradd Unable to su to root",
       "lcuseradd Unable to set password",
       "lcuseradd Usrname has invalid characters",
       "lcuseradd Password has an invalid character",
       "lcuseradd User already exists",
       "lcuseradd Could not add user.",
       "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;
   }
   
   #
   #   Return true if client is a manager.
   #
   sub isManager {
       return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));
   }
   #
   #   Return tru if client can do client functions
   #
   sub isClient {
       return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
   }
   #
   #  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    = shift;
       my $namespace = shift;
       my $how       = shift;
       
       # Filter out any whitespace in the domain name:
       
       $domain =~ s/\W//g;
       
       # We have enough to go on to tie the hash:
       
       my $UserTopDir   = $perlvar{'lonUsersDir'};
       my $DomainDir    = $UserTopDir."/$domain";
       my $ResourceFile = $DomainDir."/$namespace.db";
       my %hash;
       if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) {
    if (scalar @_) { # Need to log the operation.
       my $logFh = IO::File->new(">>$DomainDir/$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      = shift;
       my $user        = shift;
       my $namespace   = shift;
       my $how         = shift;
       
       $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:
       
       
       unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) {
    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;
       }
       
   }
   
   #
   #   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  = shift;
       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:
   #    $RequestName         - 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
   #    $MustEncode          - True if the request must be encoded to be good.
   #    $ClientOk            - True if it's ok for a client to request this.
   #    $ManagerOk           - 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 $RequestName    = shift;
       my $Procedure      = shift;
       my $MustEncode     = shift;
       my $ClientOk       = shift;
       my $ManagerOk      = shift;
      
       #  Don't allow duplication#
      
       if (defined $Dispatcher{$RequestName}) {
    die "Attempting to define a duplicate request handler for $RequestName\n";
       }
       #   Build the client type mask:
       
       my $ClientTypeMask = 0;
       if($ClientOk) {
    $ClientTypeMask  |= $CLIENT_OK;
       }
       if($ManagerOk) {
    $ClientTypeMask  |= $MANAGER_OK;
       }
      
       #  Enter the hash:
         
       my @entry = ($Procedure, $MustEncode, $ClientTypeMask);
      
       $Dispatcher{$RequestName} = \@entry;
      
      
   }
   
   #--------------------- Request Handlers --------------------------------------------
   #
   #   By convention each request handler registers itself prior to the sub declaration:
   #
   
   #  Handles ping requests.
   #  Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host we are
   #                       known as.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   
   sub PingHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
      
       Reply( $client,"$currenthostid\n","$cmd:$tail");
      
       return 1;
   }
   RegisterHandler("ping", \&PingHandler, 0, 1, 1);       # Ping unencoded, client or manager.
   #
   # Handles pong reequests:
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host we are
   #                       connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   
   sub PongHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $replyfd = shift;
   
       my $reply=&reply("ping",$clientname);
       Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
       return 1;
   }
   RegisterHandler("pong", \&PongHandler, 0, 1, 1);       # Pong unencoded, client or manager
   
   #
   #   EstablishKeyHandler:
   #      Called to establish an encrypted session key with the remote client.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Implicit Outputs:
   #      Reply information is sent to the client.
   #      $cipher is set with a reference to a new IDEA encryption object.
   #
   sub EstablishKeyHandler {
       my $cmd      = shift;
       my $tail     = shift;
       my $replyfd  = shift;
   
       my $buildkey=time.$$.int(rand 100000);
       $buildkey=~tr/1-6/A-F/;
       $buildkey=int(rand 100000).$buildkey.int(rand 100000);
       my $key=$currenthostid.$clientname;
       $key=~tr/a-z/A-Z/;
       $key=~tr/G-P/0-9/;
       $key=~tr/Q-Z/0-9/;
       $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
       $key=substr($key,0,32);
       my $cipherkey=pack("H32",$key);
       $cipher=new IDEA $cipherkey;
       Reply($replyfd, "$buildkey\n", "$cmd:$tail"); 
      
       return 1;
   
   }
   RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1);
   
   #  LoadHandler:
   #     Handler for the load command.  Returns the current system load average
   #     to the requestor.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   sub LoadHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $replyfd = shift;
   
      # Get the load average from /proc/loadavg and calculate it as a percentage of
      # the allowed load limit as set by the perl global variable lonLoadLim
   
       my $loadavg;
       my $loadfile=IO::File->new('/proc/loadavg');
      
       $loadavg=<$loadfile>;
       $loadavg =~ s/\s.*//g;                      # Extract the first field only.
      
       my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
   
       Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");
      
       return 1;
   }
   RegisterHandler("load", \&LoadHandler, 0, 1, 0);
   
   
   #
   #   Process the userload request.  This sub returns to the client the current
   #  user load average.  It can be invoked either by clients or managers.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit inputs:
   #     whatever the userload() function requires.
   #  Implicit outputs:
   #     the reply is written to the client.
   #
   sub UserLoadHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $replyfd = shift;
   
       my $userloadpercent=&userload();
       Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
       
       return 1;
   }
   RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);
   
   #   Process a request for the authorization type of a user:
   #   (userauth).
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit outputs:
   #    The user authorization type is written to the client.
   #
   sub UserAuthorizationType {
       my $cmd     = shift;
       my $tail    = shift;
       my $replyfd = shift;
      
       my $userinput = "$cmd:$tail";
      
       #  Pull the domain and username out of the command tail.
       # and call GetAuthType to determine the authentication type.
      
       my ($udom,$uname)=split(/:/,$tail);
       my $result = GetAuthType($udom, $uname);
       if($result eq "nouser") {
    Failure( $replyfd, "unknown_user\n", $userinput);
       } else {
    #
    # We only want to pass the second field from GetAuthType
    # for ^krb.. otherwise we'll be handing out the encrypted
    # password for internals e.g.
    #
    my ($type,$otherinfo) = split(/:/,$result);
    if($type =~ /^krb/) {
       $type = $result;
    }
    Reply( $replyfd, "$type\n", $userinput);
       }
     
       return 1;
   }
   RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0);
   #
   #   Process a request by a manager to push a hosts or domain table 
   #   to us.  We pick apart the command and pass it on to the subs
   #   that already exist to do this.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $client - File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit Output:
   #    a reply is written to the client.
   
   sub PushFileHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
   
       my $userinput = "$cmd:$tail";
   
       # At this time we only know that the IP of our partner is a valid manager
       # the code below is a hook to do further authentication (e.g. to resolve
       # spoofing).
   
       my $cert = GetCertificate($userinput);
       if(ValidManager($cert)) { 
   
    # Now presumably we have the bona fides of both the peer host and the
    # process making the request.
         
    my $reply = PushFile($userinput);
    Reply($client, "$reply\n", $userinput);
   
       } else {
    Failure( $client, "refused\n", $userinput);
       } 
   }
   RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1);
   
   
   
   #   Process a reinit request.  Reinit requests that either
   #   lonc or lond be reinitialized so that an updated 
   #   host.tab or domain.tab can be processed.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $client - File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   #  Implicit output:
   #     a reply is sent to the client.
   #
   sub ReinitProcessHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
      
       my $userinput = "$cmd:$tail";
      
       my $cert = GetCertificate($userinput);
       if(ValidManager($cert)) {
    chomp($userinput);
    my $reply = ReinitProcess($userinput);
    Reply( $client,  "$reply\n", $userinput);
       } else {
    Failure( $client, "refused\n", $userinput);
       }
       return 1;
   }
   
   RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1);
   
   #  Process the editing script for a table edit operation.
   #  the editing operation must be encrypted and requested by
   #  a manager host.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $client - File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   #  Implicit output:
   #     a reply is sent to the client.
   #
   sub EditTableHandler {
       my $command    = shift;
       my $tail       = shift;
       my $client     = shift;
      
       my $userinput = "$command:$tail";
   
       my $cert = GetCertificate($userinput);
       if(ValidManager($cert)) {
    my($filetype, $script) = split(/:/, $tail);
    if (($filetype eq "hosts") || 
       ($filetype eq "domain")) {
       if($script ne "") {
    Reply($client,              # BUGBUG - EditFile
         EditFile($userinput), #   could fail.
         $userinput);
       } else {
    Failure($client,"refused\n",$userinput);
       }
    } else {
       Failure($client,"refused\n",$userinput);
    }
       } else {
    Failure($client,"refused\n",$userinput);
       }
       return 1;
   }
   RegisterHandler("edit", \&EditTableHandler, 1, 0, 1);
   
   
   #
   #   Authenticate a user against the LonCAPA authentication
   #   database.  Note that there are several authentication
   #   possibilities:
   #   - unix     - The user can be authenticated against the unix
   #                password file.
   #   - internal - The user can be authenticated against a purely 
   #                internal per user password file.
   #   - kerberos - The user can be authenticated against either a kerb4 or kerb5
   #                ticket granting authority.
   #   - user     - The person tailoring LonCAPA can supply a user authentication
   #                mechanism that is per system.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub AuthenticateHandler {
       my $cmd        = shift;
       my $tail       = shift;
       my $client     = shift;
       
       #  Regenerate the full input line 
       
       my $userinput  = $cmd.":".$tail;
       
       #  udom    - User's domain.
       #  uname   - Username.
       #  upass   - User's password.
       
       my ($udom,$uname,$upass)=split(/:/,$tail);
       Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
       chomp($upass);
       $upass=unescape($upass);
   
       my $pwdcorrect = ValidateUser($udom, $uname, $upass);
       if($pwdcorrect) {
    Reply( $client, "authorized\n", $userinput);
    #
    #  Bad credentials: Failed to authorize
    #
       } else {
    Failure( $client, "non_authorized\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);
   
   #
   #   Change a user's password.  Note that this function is complicated by
   #   the fact that a user may be authenticated in more than one way:
   #   At present, we are not able to change the password for all types of
   #   authentication methods.  Only for:
   #      unix    - unix password or shadow passoword style authentication.
   #      local   - Locally written authentication mechanism.
   #   For now, kerb4 and kerb5 password changes are not supported and result
   #   in an error.
   # FUTURE WORK:
   #    Support kerberos passwd changes?
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   sub ChangePasswordHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
      
       my $userinput = $cmd.":".$tail;           # Reconstruct client's string.
   
       #
       #  udom  - user's domain.
       #  uname - Username.
       #  upass - Current password.
       #  npass - New password.
      
       my ($udom,$uname,$upass,$npass)=split(/:/,$tail);
       chomp($npass);
       $upass=&unescape($upass);
       $npass=&unescape($npass);
       &Debug("Trying to change password for $uname");
   
       # First require that the user can be authenticated with their
       # old password:
   
       my $validated = ValidateUser($udom, $uname, $upass);
       if($validated) {
    my $realpasswd  = GetAuthType($udom, $uname); # Defined since authd.
   
    my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
    if ($howpwd eq 'internal') {
       &Debug("internal auth");
       my $salt=time;
       $salt=substr($salt,6,2);
       my $ncpass=crypt($npass,$salt);
       if(RewritePwFile($udom, $uname, "internal:$ncpass")) {
    &logthis("Result of password change for "
    ."$uname: pwchange_success");
    Reply($client, "ok\n", $userinput);
       } else {
    &logthis("Unable to open $uname passwd "               
    ."to change password");
    Failure( $client, "non_authorized\n",$userinput);
       }
    } elsif ($howpwd eq 'unix') {
       # Unix means we have to access /etc/password
       &Debug("auth is unix");
       my $execdir=$perlvar{'lonDaemons'};
       &Debug("Opening lcpasswd pipeline");
       my $pf = IO::File->new("|$execdir/lcpasswd > "
      ."$perlvar{'lonDaemons'}"
      ."/logs/lcpasswd.log");
       print $pf "$uname\n$npass\n$npass\n";
       close $pf;
       my $err = $?;
       my $result = ($err>0 ? 'pwchange_failure' : 'ok');
       &logthis("Result of password change for $uname: ".
        &lcpasswdstrerror($?));
       Reply($client, "$result\n", $userinput);
    } else {
       # this just means that the current password mode is not
       # one we know how to change (e.g the kerberos auth modes or
       # locally written auth handler).
       #
       Reply( $client, "auth_mode_error\n", $userinput);
    }  
   
       }
       else {
    Reply( $client, "non_authorized\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);
   
   #
   #   Create a new user.  User in this case means a lon-capa user.
   #   The user must either already exist in some authentication realm
   #   like kerberos or the /etc/passwd.  If not, a user completely local to
   #   this loncapa system is created.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   sub AddUserHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
   
       my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
       my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
   
       &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
   
   
       if($udom eq $currentdomainid) { # Reject new users for other domains...
   
    my $oldumask=umask(0077);
    chomp($npass);
    $npass=&unescape($npass);
    my $passfilename  = PasswordPath($udom, $uname);
    &Debug("Password file created will be:".$passfilename);
    if (-e $passfilename) {
       Failure( $client, "already_exists\n", $userinput);
    } else {
       my @fpparts=split(/\//,$passfilename);
       my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
       my $fperror='';
       for (my $i=3;$i<= ($#fpparts-1);$i++) {
    $fpnow.='/'.$fpparts[$i]; 
    unless (-e $fpnow) {
       &logthis("mkdir $fpnow");
       unless (mkdir($fpnow,0777)) {
    $fperror="error: ".($!+0)." mkdir failed while attempting "
       ."makeuser";
       }
    }
       }
       unless ($fperror) {
    my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
    Reply($client, $result, $userinput);     #BUGBUG - could be fail
       } else {
    Failure($client, "$fperror\n", $userinput);
       }
    }
    umask($oldumask);
       }  else {
    Failure($client, "not_right_domain\n",
    $userinput); # Even if we are multihomed.
       
       }
       return 1;
   
   }
   RegisterHandler("makeuser", \&AddUserHandler, 1, 1, 0);
   
   #
   #   Change the authentication method of a user.  Note that this may
   #   also implicitly change the user's password if, for example, the user is
   #   joining an existing authentication realm.  Known authentication realms at
   #   this time are:
   #    internal   - Purely internal password file (only loncapa knows this user)
   #    local      - Institutionally written authentication module.
   #    unix       - Unix user (/etc/passwd with or without /etc/shadow).
   #    kerb4      - kerberos version 4
   #    kerb5      - kerberos version 5
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub ChangeAuthenticationHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
      
       my $userinput  = "$cmd:$tail";              # Reconstruct user input.
   
       my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
       &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
       if ($udom ne $currentdomainid) {
    Failure( $client, "not_right_domain\n", $client);
       } else {
   
    chomp($npass);
   
    $npass=&unescape($npass);
    my $passfilename = PasswordPath($udom, $uname);
    if ($passfilename) { # Not allowed to create a new user!!
       my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
       Reply($client, $result, $userinput);
    } else {       
       Failure($client, "non_authorized", $userinput); # Fail the user now.
    }
       }
       return 1;
   }
   RegisterHandler("changeuserauth", \&ChangeAuthenticationHandler, 1,1, 0);
   
   #
   #   Determines if this is the home server for a user.  The home server
   #   for a user will have his/her lon-capa passwd file.  Therefore all we need
   #   to do is determine if this file exists.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub IsHomeHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
      
       my $userinput  = "$cmd:$tail";
      
       my ($udom,$uname)=split(/:/,$tail);
       chomp($uname);
       my $passfile = PasswordFilename($udom, $uname);
       if($passfile) {
    Reply( $client, "found\n", $userinput);
       } else {
    Failure($client, "not_found\n", $userinput);
       }
       return 1;
   }
   RegisterHandler("home", \&IsHomeHandler, 0,1,0);
   #
   #   Process an update request for a resource?? I think what's going on here is
   #   that a resource has been modified that we hold a subscription to.
   #   If the resource is not local, then we must update, or at least invalidate our
   #   cached copy of the resource. 
   #   FUTURE WORK:
   #      I need to look at this logic carefully.  My druthers would be to follow
   #      typical caching logic, and simple invalidate the cache, drop any subscription
   #      an let the next fetch start the ball rolling again... however that may
   #      actually be more difficult than it looks given the complex web of
   #      proxy servers.
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub UpdateResourceHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
      
       my $userinput = "$cmd:$tail";
      
       my $fname=$tail;
       my $ownership=ishome($fname);
       if ($ownership eq 'not_owner') {
    if (-e $fname) {
       my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
    $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
       my $now=time;
       my $since=$now-$atime;
       if ($since>$perlvar{'lonExpire'}) {
    my $reply=&reply("unsub:$fname","$clientname");
    unlink("$fname");
       } else {
    my $transname="$fname.in.transfer";
    my $remoteurl=&reply("sub:$fname","$clientname");
    my $response;
    alarm(120);
    {
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',"$remoteurl");
       $response=$ua->request($request,$transname);
    }
    alarm(0);
    if ($response->is_error()) {
       unlink($transname);
       my $message=$response->status_line;
       &logthis("LWP GET: $message for $fname ($remoteurl)");
    } else {
       if ($remoteurl!~/\.meta$/) {
    alarm(120);
    {
       my $ua=new LWP::UserAgent;
       my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
       my $mresponse=$ua->request($mrequest,$fname.'.meta');
       if ($mresponse->is_error()) {
    unlink($fname.'.meta');
       }
    }
    alarm(0);
       }
       rename($transname,$fname);
    }
       }
       Reply( $client, "ok\n", $userinput);
    } else {
       Failure($client, "not_found\n", $userinput);
    }
       } else {
    Failure($client, "rejected\n", $userinput);
       }
       return 1;
   }
   RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0);
   
   #
   #   Fetch a user file from a remote server:
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub FetchUserFileHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
      
       my $userinput = "$cmd:$tail";
       my $fname           = $tail;
       my ($udom,$uname,$ufile)=split(/\//,$fname);
       my $udir=propath($udom,$uname).'/userfiles';
       unless (-e $udir) {
    mkdir($udir,0770); 
       }
       if (-e $udir) {
    $ufile=~s/^[\.\~]+//;
    $ufile=~s/\///g;
    my $destname=$udir.'/'.$ufile;
    my $transname=$udir.'/'.$ufile.'.in.transit';
    my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
    my $response;
    alarm(120);
    {
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',"$remoteurl");
       $response=$ua->request($request,$transname);
    }
    alarm(0);
    if ($response->is_error()) {
       unlink($transname);
       my $message=$response->status_line;
       &logthis("LWP GET: $message for $fname ($remoteurl)");
       Failure($client, "failed\n", $userinput);
    } else {
       if (!rename($transname,$destname)) {
    &logthis("Unable to move $transname to $destname");
    unlink($transname);
    Failure($client, "failed\n", $userinput);
       } else {
    Reply($client, "ok\n", $userinput);
       }
    }   
       } else {
    Failure($client, "not_home\n", $userinput);
       }
       return 1;
   }
   RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);
   #
   #   Authenticate access to a user file. 
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   sub AuthenticateUserFileAccess {
       my $cmd       = shift;
       my $tail      = shift;
       my $client    = shift;
       my $userinput = "$cmd:$tail";
   
       my ($fname,$session)=split(/:/,$tail);
       chomp($session);
       my $reply='non_auth';
       if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.$session.'.id')) {
    while (my $line=<ENVIN>) {
       if ($line=~/userfile\.$fname\=/) { 
    $reply='ok'; 
       }
    }
    close(ENVIN);
    Reply($client, $reply."\n", $userinput);
       } else {
    Failure($client, "invalid_token\n", $userinput);
       }
       return 1;
      
   }
   RegisterHandler("tokenauthuserfile", \&AuthenticateUserFileAccess, 0, 1, 0);
   #
   #   Unsubscribe from a resource.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub UnsubscribeHandler {
       my $cmd      = shift;
       my $tail     = shift;
       my $client   = shift;
       my $userinput= "$cmd:$tail";
       
       my $fname = $tail;
       if (-e $fname) {
    Reply($client, &unsub($client,$fname,$clientip), $userinput);
       } else {
    Failure($client, "not_found\n", $userinput);
       }
       return 1;
   }
   RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);
   
   #   Subscribe to a resource
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub SubscribeHandler {
       my $cmd        = shift;
       my $tail       = shift;
       my $client     = shift;
       my $userinput  = "$cmd:$tail";
   
       Reply( $client, &subscribe($userinput,$clientip), $userinput);
   
       return 1;
   }
   RegisterHandler("sub", \&SubscribeHandler, 0, 1, 0);
   
   #
   #   Determine the version of a resource (?) Or is it return
   #   the top version of the resource?  Not yet clear from the
   #   code in currentversion.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub CurrentVersionHandler {
       my $cmd      = shift;
       my $tail     = shift;
       my $client   = shift;
       my $userinput= "$cmd:$tail";
      
       my $fname   = $tail;
       Reply( $client, &currentversion($fname)."\n", $userinput);
       return 1;
   
   }
   RegisterHandler("currentversion", \&CurrentVersionHandler, 0, 1, 0);
   
   
   #  Make an entry in a user's activity log.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub ActivityLogEntryHandler {
       my $cmd      = shift;
       my $tail     = shift;
       my $client   = shift;
       my $userinput= "$cmd:$tail";
   
       my ($udom,$uname,$what)=split(/:/,$tail);
       chomp($what);
       my $proname=propath($udom,$uname);
       my $now=time;
       my $hfh;
       if ($hfh=IO::File->new(">>$proname/activity.log")) { 
    print $hfh "$now:$clientname:$what\n";
    Reply( $client, "ok\n", $userinput); 
       } else {
    Failure($client, "error: ".($!+0)." IO::File->new Failed "
         ."while attempting log\n", 
         $userinput);
       }
   
       return 1;
   }
   RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0);
   #
   #   Put a namespace entry in a user profile hash.
   #   My druthers would be for this to be an encrypted interaction too.
   #   anything that might be an inadvertent covert channel about either
   #   user authentication or user personal information....
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub PutUserProfileEntry {
       my $cmd       = shift;
       my $tail      = shift;
       my $client    = shift;
       my $userinput = "$cmd:$tail";
       
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
    chomp($what);
    my $hashref = TieUserHash($udom, $uname, $namespace,
     &GDBM_WRCREAT(),"P",$what);
    if($hashref) {
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $hashref->{$key}=$value;
       }
       if (untie(%$hashref)) {
    Reply( $client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting put\n", 
    $userinput);
       }
    } else {
       Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
        "while attempting put\n", $userinput);
    }
       } else {
           Failure( $client, "refused\n", $userinput);
       }
       
       return 1;
   }
   RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);
   
   # 
   #   Increment a profile entry in the user history file.
   #   The history contains keyword value pairs.  In this case,
   #   The value itself is a pair of numbers.  The first, the current value
   #   the second an increment that this function applies to the current
   #   value.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub IncrementUserValueHandler {
       my $cmd         = shift;
       my $tail        = shift;
       my $client      = shift;
       my $userinput   = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
           chomp($what);
    my $hashref = TieUserHash($udom, $uname,
     $namespace, &GDBM_WRCREAT(),
     "P",$what);
    if ($hashref) {
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    # We could check that we have a number...
    if (! defined($value) || $value eq '') {
       $value = 1;
    }
    $hashref->{$key}+=$value;
       }
       if (untie(%$hashref)) {
    Reply( $client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting inc\n", $userinput);
       }
    } else {
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       "while attempting inc\n", $userinput);
    }
       } else {
    Failure($client, "refused\n", $userinput);
       }
       
       return 1;
   }
   RegisterHandler("inc", \&IncrementUserValueHandler, 0, 1, 0);
   #
   #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
   #   Each 'role' a user has implies a set of permissions.  Adding a new role
   #   for a person grants the permissions packaged with that role
   #   to that user when the role is selected.
   #
   # Parameters:
   #    $cmd       - The command string (rolesput).
   #    $tail      - The remainder of the request line.  For rolesput this
   #                 consists of a colon separated list that contains:
   #                 The domain and user that is granting the role (logged).
   #                 The domain and user that is getting the role.
   #                 The roles being granted as a set of & separated pairs.
   #                 each pair a key value pair.
   #    $client    - File descriptor connected to the client.
   # Returns:
   #     0         - If the daemon should exit
   #     1         - To continue processing.
   #
   #
   sub RolesPutHandler {
       my $cmd        = shift;
       my $tail       = shift;
       my $client     = shift;
       my $userinput  = "$cmd:$tail";
   
       my ($exedom,$exeuser,$udom,$uname,$what)   =split(/:/,$tail);
       &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
      "what = ".$what);
       my $namespace='roles';
       chomp($what);
       my $hashref = TieUserHash($udom, $uname, $namespace,
         &GDBM_WRCREAT(), "P",
         "$exedom:$exeuser:$what");
       #
       #  Log the attempt to set a role.  The {}'s here ensure that the file 
       #  handle is open for the minimal amount of time.  Since the flush
       #  is done on close this improves the chances the log will be an un-
       #  corrupted ordered thing.
       if ($hashref) {
    my @pairs=split(/\&/,$what);
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       &ManagePermissions($key, $udom, $uname,
          &GetAuthType( $udom, $uname));
       $hashref->{$key}=$value;
    }
    if (untie($hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting rolesput\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting rolesput\n", $userinput);
       }
       return 1;
   }
   RegisterHandler("rolesput", \&RolesPutHandler, 1,1,0);  # Encoded client only.
   #
   #   Deletes (removes) a role for a user.   This is equivalent to removing
   #  a permissions package associated with the role from the user's profile.
   #
   # Parameters:
   #     $cmd                 - The command (rolesdel)
   #     $tail                - The remainder of the request line. This consists
   #                             of:
   #                             The domain and user requesting the change (logged)
   #                             The domain and user being changed.
   #                             The roles being revoked.  These are shipped to us
   #                             as a bunch of & separated role name keywords.
   #     $client              - The file handle open on the client.
   # Returns:
   #     1                    - Continue processing
   #     0                    - Exit.
   #
   sub RolesDeleteHandler {
       my $cmd          = shift;
       my $tail         = shift;
       my $client       = shift;
       my $userinput    = "$cmd:$tail";
      
       my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
       &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
      "what = ".$what);
       my $namespace='roles';
       chomp($what);
       my $hashref = TieUserHash($udom, $uname, $namespace,
         &GDBM_WRCREAT(), "D",
         "$exedom:$exeuser:$what");
       
       if ($hashref) {
    my @rolekeys=split(/\&/,$what);
   
    foreach my $key (@rolekeys) {
       delete $hashref->{$key};
    }
    if (untie(%$hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting rolesdel\n", $userinput);
    }
       } else {
           Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting rolesdel\n", $userinput);
       }
       
       return 1;
   }
   RegisterHandler("rolesdel", \&RolesDeleteHandler, 1,1, 0); # Encoded client only
   
   # Unencrypted get from a user's profile database.  See 
   # GetProfileEntryEncrypted for a version that does end-to-end encryption.
   # This function retrieves a keyed item from a specific named database in the
   # user's directory.
   #
   # Parameters:
   #   $cmd             - Command request keyword (get).
   #   $tail            - Tail of the command.  This is a colon separated list
   #                      consisting of the domain and username that uniquely
   #                      identifies the profile,
   #                      The 'namespace' which selects the gdbm file to 
   #                      do the lookup in, 
   #                      & separated list of keys to lookup.  Note that
   #                      the values are returned as an & separated list too.
   #   $client          - File descriptor open on the client.
   # Returns:
   #   1       - Continue processing.
   #   0       - Exit.
   #
   sub GetProfileEntry {
       my $cmd      = shift;
       my $tail     = shift;
       my $client   = shift;
       my $userinput= "$cmd:$tail";
      
       my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
       chomp($what);
       my $hashref = TieUserHash($udom, $uname, $namespace,
         &GDBM_READER());
       if ($hashref) {
           my @queries=split(/\&/,$what);
           my $qresult='';
   
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
    }
    $qresult=~s/\&$//;              # Remove trailing & from last lookup.
    if (untie(%$hashref)) {
       Reply($client, "$qresult\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting get\n", $userinput);
    }
       } else {
    if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT
       Failure($client, "error:No such file or ".
       "GDBM reported bad block error\n", $userinput);
    } else {                        # Some other undifferentiated err.
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       "while attempting get\n", $userinput);
    }
       }
       return 1;
   }
   RegisterHandler("get", \&GetProfileEntry, 0,1,0);
   #
   #  Process the encrypted get request.  Note that the request is sent
   #  in clear, but the reply is encrypted.  This is a small covert channel:
   #  information about the sensitive keys is given to the snooper.  Just not
   #  information about the values of the sensitive key.  Hmm if I wanted to
   #  know these I'd snoop for the egets. Get the profile item names from them
   #  and then issue a get for them since there's no enforcement of the
   #  requirement of an encrypted get for particular profile items.  If I
   #  were re-doing this, I'd force the request to be encrypted as well as the
   #  reply.  I'd also just enforce encrypted transactions for all gets since
   #  that would prevent any covert channel snooping.
   #
   #  Parameters:
   #     $cmd               - Command keyword of request (eget).
   #     $tail              - Tail of the command.  See GetProfileEntry #                          for more information about this.
   #     $client            - File open on the client.
   #  Returns:
   #     1      - Continue processing
   #     0      - server should exit.
   sub GetProfileEntryEncrypted {
       my $cmd       = shift;
       my $tail      = shift;
       my $client    = shift;
       my $userinput = "$cmd:$tail";
      
       my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
       chomp($what);
       my $hashref = TieUserHash($udom, $uname, $namespace,
     &GDBM_READER());
       if ($hashref) {
           my @queries=split(/\&/,$what);
           my $qresult='';
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       if ($cipher) {
    my $cmdlength=length($qresult);
    $qresult.="         ";
    my $encqresult='';
    for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
       $encqresult.= unpack("H16", 
    $cipher->encrypt(substr($qresult,
    $encidx,
    8)));
    }
    Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
       } else {
    Failure( $client, "error:no_key\n", $userinput);
       }
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting eget\n", $userinput);
    }
       } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting eget\n", $userinput);
       }
       
       return 1;
   }
   RegisterHandler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
   
   #
   #   Deletes a key in a user profile database.
   #   
   #   Parameters:
   #       $cmd                  - Command keyword (del).
   #       $tail                 - Command tail.  IN this case a colon
   #                               separated list containing:
   #                               The domain and user that identifies uniquely
   #                               the identity of the user.
   #                               The profile namespace (name of the profile
   #                               database file).
   #                               & separated list of keywords to delete.
   #       $client              - File open on client socket.
   # Returns:
   #     1   - Continue processing
   #     0   - Exit server.
   #
   #
   
   sub DeleteProfileEntry {
       my $cmd      = shift;
       my $tail     = shift;
       my $client   = shift;
       my $userinput = "cmd:$tail";
   
       my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
       chomp($what);
       my $hashref = TieUserHash($udom, $uname, $namespace,
     &GDBM_WRCREAT(),
     "D",$what);
       if ($hashref) {
           my @keys=split(/\&/,$what);
    foreach my $key (@keys) {
       delete($hashref->{$key});
    }
    if (untie(%$hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting del\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting del\n", $userinput);
       }
       return 1;
   }
   RegisterHandler("del", \&DeleteProfileEntry, 0, 1, 0);
   #
   #  List the set of keys that are defined in a profile database file.
   #  A successful reply from this will contain an & separated list of
   #  the keys. 
   # Parameters:
   #     $cmd              - Command request (keys).
   #     $tail             - Remainder of the request, a colon separated
   #                         list containing domain/user that identifies the
   #                         user being queried, and the database namespace
   #                         (database filename essentially).
   #     $client           - File open on the client.
   #  Returns:
   #    1    - Continue processing.
   #    0    - Exit the server.
   #
   sub GetProfileKeys {
       my $cmd       = shift;
       my $tail      = shift;
       my $client    = shift;
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace)=split(/:/,$tail);
       my $qresult='';
       my $hashref = TieUserHash($udom, $uname, $namespace,
     &GDBM_READER());
       if ($hashref) {
    foreach my $key (keys %$hashref) {
       $qresult.="$key&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       Reply($client, "$qresult\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting keys\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting keys\n", $userinput);
       }
      
       return 1;
   }
   RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0);
   #
   #   Dump the contents of a user profile database.
   #   Note that this constitutes a very large covert channel too since
   #   the dump will return sensitive information that is not encrypted.
   #   The naive security assumption is that the session negotiation ensures
   #   our client is trusted and I don't believe that's assured at present.
   #   Sure want badly to go to ssl or tls.  Of course if my peer isn't really
   #   a LonCAPA node they could have negotiated an encryption key too so >sigh<.
   # 
   #  Parameters:
   #     $cmd           - The command request keyword (currentdump).
   #     $tail          - Remainder of the request, consisting of a colon
   #                      separated list that has the domain/username and
   #                      the namespace to dump (database file).
   #     $client        - file open on the remote client.
   # Returns:
   #     1    - Continue processing.
   #     0    - Exit the server.
   #
   sub DumpProfileDatabase {
       my $cmd       = shift;
       my $tail      = shift;
       my $client    = shift;
       my $userinput = "$cmd:$tail";
      
       my ($udom,$uname,$namespace) = split(/:/,$tail);
       my $hashref = TieUserHash($udom, $uname, $namespace,
     &GDBM_READER());
       if ($hashref) {
    # Structure of %data:
    # $data{$symb}->{$parameter}=$value;
    # $data{$symb}->{'v.'.$parameter}=$version;
    # since $parameter will be unescaped, we do not
     # have to worry about silly parameter names...
   
           my $qresult='';
    my %data = ();                     # A hash of anonymous hashes..
    while (my ($key,$value) = each(%$hashref)) {
       my ($v,$symb,$param) = split(/:/,$key);
       next if ($v eq 'version' || $symb eq 'keys');
       next if (exists($data{$symb}) && 
        exists($data{$symb}->{$param}) &&
        $data{$symb}->{'v.'.$param} > $v);
       $data{$symb}->{$param}=$value;
       $data{$symb}->{'v.'.$param}=$v;
    }
    if (untie(%$hashref)) {
       while (my ($symb,$param_hash) = each(%data)) {
    while(my ($param,$value) = each (%$param_hash)){
       next if ($param =~ /^v\./);       # Ignore versions...
       #
       #   Just dump the symb=value pairs separated by &
       #
       $qresult.=$symb.':'.$param.'='.$value.'&';
    }
       }
       chop($qresult);
       Reply($client , "$qresult\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting currentdump\n", $userinput);
    }
       } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting currentdump\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0);
   #
   #   Dump a profile database with an optional regular expression
   #   to match against the keys.  In this dump, no effort is made
   #   to separate symb from version information. Presumably the
   #   databases that are dumped by this command are of a different
   #   structure.  Need to look at this and improve the documentation of
   #   both this and the currentdump handler.
   # Parameters:
   #    $cmd                     - The command keyword.
   #    $tail                    - All of the characters after the $cmd:
   #                               These are expected to be a colon
   #                               separated list containing:
   #                               domain/user - identifying the user.
   #                               namespace   - identifying the database.
   #                               regexp      - optional regular expression
   #                                             that is matched against
   #                                             database keywords to do
   #                                             selective dumps.
   #   $client                   - Channel open on the client.
   # Returns:
   #    1    - Continue processing.
   # Side effects:
   #    response is written to $client.
   #
   sub DumpWithRegexp {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
       if (defined($regexp)) {
    $regexp=&unescape($regexp);
       } else {
    $regexp='.';
       }
       my $hashref =TieUserHash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
           my $qresult='';
    while (my ($key,$value) = each(%$hashref)) {
       if ($regexp eq '.') {
    $qresult.=$key.'='.$value.'&';
       } else {
    my $unescapeKey = &unescape($key);
    if (eval('$unescapeKey=~/$regexp/')) {
       $qresult.="$key=$value&";
    }
       }
    }
    if (untie(%$hashref)) {
       chop($qresult);
       Reply($client, "$qresult\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting dump\n", $userinput);
    }
       } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting dump\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);
   
   #  Store an aitem in any resource meta data(?) or database with
   #  versioning?
   #
   #  Parameters:
   #    $cmd                - Request command keyword.
   #    $tail               - Tail of the request.  This is a colon
   #                          separated list containing:
   #                          domain/user - User and authentication domain.
   #                          namespace   - Name of the database being modified
   #                          rid         - Resource keyword to modify.
   #                          what        - new value associated with rid.
   #
   #    $client             - Socket open on the client.
   #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub StoreHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
    
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
   
    chomp($what);
    my @pairs=split(/\&/,$what);
    my $hashref  = TieUserHash($udom, $uname, $namespace,
          &GDBM_WRCREAT(), "P",
          "$rid:$what");
    if ($hashref) {
       my $now = time;
       my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
       my $key;
       $hashref->{"version:$rid"}++;
       my $version=$hashref->{"version:$rid"};
       my $allkeys=''; 
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $allkeys.=$key.':';
    $hashref->{"$version:$rid:$key"}=$value;
       }
       $hashref->{"$version:$rid:timestamp"}=$now;
       $allkeys.='timestamp';
       $hashref->{"$version:keys:$rid"}=$allkeys;
       if (untie($hashref)) {
    Reply($client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
       }
    } else {
       Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting store\n", $userinput);
    }
       } else {
    Failure($client, "refused\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("store", \&StoreHandler, 0, 1, 0);
   #
   #   Restore a prior version of a resource.
   #
   #  Parameters:
   #     $cmd               - Command keyword.
   #     $tail              - Remainder of the request which consists of:
   #                          domain/user   - User and auth. domain.
   #                          namespace     - name of resource database.
   #                          rid           - Resource id.
   #    $client             - socket open on the client.
   #
   # Returns:
   #      1  indicating the caller should not yet exit.
   # Side-effects:
   #   Writes a reply to the client.
   #
   sub RestoreHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
   
       my $userinput = "$cmd:$tail"; # Only used for logging purposes.
   
       my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
       $namespace=~s/\//\_/g;
       $namespace=~s/\W//g;
       chomp($rid);
       my $proname=propath($udom,$uname);
       my $qresult='';
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
       &GDBM_READER(),0640)) {
    my $version=$hash{"version:$rid"};
    $qresult.="version=$version&";
    my $scope;
    for ($scope=1;$scope<=$version;$scope++) {
       my $vkeys=$hash{"$scope:keys:$rid"};
       my @keys=split(/:/,$vkeys);
       my $key;
       $qresult.="$scope:keys=$vkeys&";
       foreach $key (@keys) {
    $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
       }                                  
    }
    if (untie(%hash)) {
       $qresult=~s/\&$//;
       Reply( $client, "$qresult\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting restore\n", $userinput);
    }
       } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting restore\n", $userinput);
       }
     
       return 1;
   
   
   }
   RegisterHandler("restore", \&RestoreHandler, 0,1,0);
   
   #
   #   Add a chat message to to a discussion board.
   #
   # Parameters:
   #    $cmd                - Request keyword.
   #    $tail               - Tail of the command. A colon separated list
   #                          containing:
   #                          cdom    - Domain on which the chat board lives
   #                          cnum    - Identifier of the discussion group.
   #                          post    - Body of the posting.
   #   $client              - Socket open on the client.
   # Returns:
   #   1    - Indicating caller should keep on processing.
   #
   # Side-effects:
   #   writes a reply to the client.
   #
   #
   sub SendChatHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
       
       my $userinput = "$cmd:$tail";
   
       my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
       &chatadd($cdom,$cnum,$newpost);
       Reply($client, "ok\n", $userinput);
   
       return 1;
   }
   RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0);
   #
   #   Retrieve the set of chat messagss from a discussion board.
   #
   #  Parameters:
   #    $cmd             - Command keyword that initiated the request.
   #    $tail            - Remainder of the request after the command
   #                       keyword.  In this case a colon separated list of
   #                       chat domain    - Which discussion board.
   #                       chat id        - Discussion thread(?)
   #                       domain/user    - Authentication domain and username
   #                                        of the requesting person.
   #   $client           - Socket open on the client program.
   # Returns:
   #    1     - continue processing
   # Side effects:
   #    Response is written to the client.
   #
   sub RetrieveChatHandler {
       my $cmd      = shift;
       my $tail     = shift;
       my $client   = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);
       my $reply='';
       foreach (&getchat($cdom,$cnum,$udom,$uname)) {
    $reply.=&escape($_).':';
       }
       $reply=~s/\:$//;
       Reply($client, $reply."\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0);
   #
   #  Initiate a query of an sql database.  SQL query repsonses get put in
   #  a file for later retrieval.  This prevents sql query results from
   #  bottlenecking the system.  Note that with loncnew, perhaps this is
   #  less of an issue since multiple outstanding requests can be concurrently
   #  serviced.
   #
   #  Parameters:
   #     $cmd       - COmmand keyword that initiated the request.
   #     $tail      - Remainder of the command after the keyword.
   #                  For this function, this consists of a query and
   #                  3 arguments that are self-documentingly labelled
   #                  in the original arg1, arg2, arg3.
   #     $client    - Socket open on the client.
   # Return:
   #    1   - Indicating processing should continue.
   # Side-effects:
   #    a reply is written to $client.
   #
   sub SendQueryHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
       $query=~s/\n*$//g;
       Reply($client, "". sqlreply("$clientname\&$query".
    "\&$arg1"."\&$arg2"."\&$arg3")."\n",
     $userinput);
       
       return 1;
   }
   RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0);
   
   #
   #   Add a reply to an sql query.  SQL queries are done asyncrhonously.
   #   The query is submitted via a "querysend" transaction.
   #   There it is passed on to the lonsql daemon, queued and issued to
   #   mysql.
   #     This transaction is invoked when the sql transaction is complete
   #   it stores the query results in flie and indicates query completion.
   #   presumably local software then fetches this response... I'm guessing
   #   the sequence is: lonc does a querysend, we ask lonsql to do it.
   #   lonsql on completion of the query interacts with the lond of our
   #   client to do a query reply storing two files:
   #    - id     - The results of the query.
   #    - id.end - Indicating the transaction completed. 
   #    NOTE: id is a unique id assigned to the query and querysend time.
   # Parameters:
   #    $cmd        - Command keyword that initiated this request.
   #    $tail       - Remainder of the tail.  In this case that's a colon
   #                  separated list containing the query Id and the 
   #                  results of the query.
   #    $client     - Socket open on the client.
   # Return:
   #    1           - Indicating that we should continue processing.
   # Side effects:
   #    ok written to the client.
   #
   sub ReplyQueryHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($cmd,$id,$reply)=split(/:/,$userinput); 
       my $store;
       my $execdir=$perlvar{'lonDaemons'};
       if ($store=IO::File->new(">$execdir/tmp/$id")) {
    $reply=~s/\&/\n/g;
    print $store $reply;
    close $store;
    my $store2=IO::File->new(">$execdir/tmp/$id.end");
    print $store2 "done\n";
    close $store2;
    Reply($client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)
    ." IO::File->new Failed ".
    "while attempting queryreply\n", $userinput);
       }
    
   
       return 1;
   }
   RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0);
   #
   #  Process the courseidput query.  Not quite sure what this means
   #  at the system level sense.  It appears a gdbm file in the 
   #  /home/httpd/lonUsers/$domain/nohist_courseids is tied and
   #  a set of entries made in that database.
   #
   # Parameters:
   #   $cmd      - The command keyword that initiated this request.
   #   $tail     - Tail of the command.  In this case consists of a colon
   #               separated list contaning the domain to apply this to and
   #               an ampersand separated list of keyword=value pairs.
   #   $client   - Socket open on the client.
   # Returns:
   #   1    - indicating that processing should continue
   #
   # Side effects:
   #   reply is written to the client.
   #
   sub PutCourseIdHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom, $what) = split(/:/, $tail);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
   
       my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       $hashref->{$key}=$value.':'.$now;
    }
    if (untie(%$hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)
        ." untie(GDBM) Failed ".
        "while attempting courseidput\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)
    ." tie(GDBM) Failed ".
    "while attempting courseidput\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0);
   
   #  Retrieves the value of a course id resource keyword pattern
   #  defined since a starting date.  Both the starting date and the
   #  keyword pattern are optional.  If the starting date is not supplied it
   #  is treated as the beginning of time.  If the pattern is not found,
   #  it is treatred as "." matching everything.
   #
   #  Parameters:
   #     $cmd     - Command keyword that resulted in us being dispatched.
   #     $tail    - The remainder of the command that, in this case, consists
   #                of a colon separated list of:
   #                 domain   - The domain in which the course database is 
   #                            defined.
   #                 since    - Optional parameter describing the minimum
   #                            time of definition(?) of the resources that
   #                            will match the dump.
   #                 description - regular expression that is used to filter
   #                            the dump.  Only keywords matching this regexp
   #                            will be used.
   #     $client  - The socket open on the client.
   # Returns:
   #    1     - Continue processing.
   # Side Effects:
   #   a reply is written to $client.
   sub DumpCourseIdHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$since,$description) =split(/:/,$tail);
       if (defined($description)) {
    $description=&unescape($description);
       } else {
    $description='.';
       }
       unless (defined($since)) { $since=0; }
       my $qresult='';
       logthis(" Looking for $description  since $since");
       my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
    while (my ($key,$value) = each(%$hashref)) {
       my ($descr,$lasttime)=split(/\:/,$value);
       logthis("Got:  key = $key descr = $descr time: $lasttime");
       if ($lasttime<$since) { 
    logthis("Skipping .. too early");
    next; 
       }
       if ($description eq '.') {
    logthis("Adding wildcard match");
    $qresult.=$key.'='.$descr.'&';
       } else {
    my $unescapeVal = &unescape($descr);
    logthis("Matching with $unescapeVal");
    if (eval('$unescapeVal=~/$description/i')) {
       logthis("Adding on match");
       $qresult.="$key=$descr&";
    }
       }
    }
    if (untie(%$hashref)) {
       chop($qresult);
       Reply($client, "$qresult\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting courseiddump\n", $userinput);
    }
       } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting courseiddump\n", $userinput);
       }
   
   
       return 1;
   }
   RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0);
   #
   #  Puts an id to a domains id database. 
   #
   #  Parameters:
   #   $cmd     - The command that triggered us.
   #   $tail    - Remainder of the request other than the command. This is a 
   #              colon separated list containing:
   #              $domain  - The domain for which we are writing the id.
   #              $pairs  - The id info to write... this is and & separated list
   #                        of keyword=value.
   #   $client  - Socket open on the client.
   #  Returns:
   #    1   - Continue processing.
   #  Side effects:
   #     reply is written to $client.
   #
   sub PutIdHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = TieDomainHash($udom, "ids", &GDBM_WRCREAT(),
    "P", $what);
       if ($hashref) {
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       $hashref->{$key}=$value;
    }
    if (untie(%$hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting idput\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting idput\n", $userinput);
       }
   
       return 1;
   }
   
   RegisterHandler("idput", \&PutIdHandler, 0, 1, 0);
   #
   #  Retrieves a set of id values from the id database.
   #  Returns an & separated list of results, one for each requested id to the
   #  client.
   #
   # Parameters:
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose id table we dump
   #               ids      Consists of an & separated list of
   #                        id keywords whose values will be fetched.
   #                        nonexisting keywords will have an empty value.
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects:
   #   An & separated list of results is written to $client.
   #
   sub GetIdHandler {
       my $cmd    = shift;
       my $tail   = shift;
       my $client = shift;
       
       my $userinput = "$client:$tail";
       
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @queries=split(/\&/,$what);
       my $qresult='';
       my $hashref = TieDomainHash($udom, "ids", &GDBM_READER());
       if ($hashref) {
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       Reply($client, "$qresult\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting idget\n",$userinput);
    }
       } else {
    Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting idget\n",$userinput);
       }
       
       return 1;
   }
   
   RegisterHandler("idget", \&GetIdHandler, 0, 1, 0);
   #
   #  Process the tmpput command I'm not sure what this does.. Seems to
   #  create a file in the lonDaemons/tmp directory of the form $id.tmp
   # where Id is the client's ip concatenated with a sequence number.
   # The file will contain some value that is passed in.  Is this e.g.
   # a login token?
   #
   # Parameters:
   #    $cmd     - The command that got us dispatched.
   #    $tail    - The remainder of the request following $cmd:
   #               In this case this will be the contents of the file.
   #    $client  - Socket connected to the client.
   # Returns:
   #    1 indicating processing can continue.
   # Side effects:
   #   A file is created in the local filesystem.
   #   A reply is sent to the client.
   sub TmpPutHandler {
       my $cmd       = shift;
       my $what      = shift;
       my $client    = shift;
   
       my $userinput = "$cmd:$what"; # Reconstruct for logging.
   
   
       my $store;
       $tmpsnum++;
       my $id=$$.'_'.$clientip.'_'.$tmpsnum;
       $id=~s/\W/\_/g;
       $what=~s/\n//g;
       my $execdir=$perlvar{'lonDaemons'};
       if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
    print $store $what;
    close $store;
    Reply($client, "$id\n", $userinput);
       } else {
    Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
    "while attempting tmpput\n", $userinput);
       }
       return 1;
     
   }
   RegisterHandler("tmpput", \&TmpPutHandler, 0, 1, 0);
   
   #   Processes the tmpget command.  This command returns the contents
   #  of a temporary resource file(?) created via tmpput.
   #
   # Paramters:
   #    $cmd      - Command that got us dispatched.
   #    $id       - Tail of the command, contain the id of the resource
   #                we want to fetch.
   #    $client   - socket open on the client.
   # Return:
   #    1         - Inidcating processing can continue.
   # Side effects:
   #   A reply is sent to the client.
   
   #
   sub TmpGetHandler {
       my $cmd       = shift;
       my $id        = shift;
       my $client    = shift;
       my $userinput = "$cmd:$id"; 
       
       chomp($id);
       $id=~s/\W/\_/g;
       my $store;
       my $execdir=$perlvar{'lonDaemons'};
       if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
    my $reply=<$store>;
    Reply( $client, "$reply\n", $userinput);
    close $store;
       } else {
    Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
    "while attempting tmpget\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("tmpget", \&TmpGetHandler, 0, 1, 0);
   #
   #  Process the tmpdel command.  This command deletes a temp resource
   #  created by the tmpput command.
   #
   # Parameters:
   #   $cmd      - Command that got us here.
   #   $id       - Id of the temporary resource created.
   #   $client   - socket open on the client process.
   #
   # Returns:
   #   1     - Indicating processing should continue.
   # Side Effects:
   #   A file is deleted
   #   A reply is sent to the client.
   sub TmpDelHandler {
       my $cmd      = shift;
       my $id       = shift;
       my $client   = shift;
       
       my $userinput= "$cmd:$id";
       
       chomp($id);
       $id=~s/\W/\_/g;
       my $execdir=$perlvar{'lonDaemons'};
       if (unlink("$execdir/tmp/$id.tmp")) {
    Reply($client, "ok\n", $userinput);
       } else {
    Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
    "while attempting tmpdel\n", $userinput);
       }
       
       return 1;
   
   }
   RegisterHandler("tmpdel", \&TmpDelHandler, 0, 1, 0);
   #
   #   ls  - list the contents of a directory.  For each file in the
   #    selected directory the filename followed by the full output of
   #    the stat function is returned.  The returned info for each
   #    file are separated by ':'.  The stat fields are separated by &'s.
   # Parameters:
   #    $cmd        - The command that dispatched us (ls).
   #    $ulsdir     - The directory path to list... I'm not sure what this
   #                  is relative as things like ls:. return e.g.
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to  $client.
   #
   sub LsHandler {
       my $cmd     = shift;
       my $ulsdir  = shift;
       my $client  = shift;
   
       my $userinput = "$cmd:$ulsdir";
   
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
    if(-d $ulsdir) {
       if (opendir(LSDIR,$ulsdir)) {
    while ($ulsfn=readdir(LSDIR)) {
       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
       $ulsout.=$ulsfn.'&'.
    join('&',@ulsstats).':';
    }
    closedir(LSDIR);
       }
    } else {
       my @ulsstats=stat($ulsdir);
       $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
    }
       } else {
    $ulsout='no_such_dir';
       }
       if ($ulsout eq '') { $ulsout='empty'; }
       Reply($client, "$ulsout\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("ls", \&LsHandler, 0, 1, 0);
   
   
   #
   #   Processes the setannounce command.  This command
   #   creates a file named announce.txt in the top directory of
   #   the documentn root and sets its contents.  The announce.txt file is
   #   printed in its entirety at the LonCAPA login page.  Note:
   #   once the announcement.txt fileis created it cannot be deleted.
   #   However, setting the contents of the file to empty removes the
   #   announcement from the login page of loncapa so who cares.
   #
   # Parameters:
   #    $cmd          - The command that got us dispatched.
   #    $announcement - The text of the announcement.
   #    $client       - Socket open on the client process.
   # Retunrns:
   #   1             - Indicating request processing should continue
   # Side Effects:
   #   The file {DocRoot}/announcement.txt is created.
   #   A reply is sent to $client.
   #
   sub SetAnnounceHandler {
       my $cmd          = shift;
       my $announcement = shift;
       my $client       = shift;
     
       my $userinput    = "$cmd:$announcement";
   
       chomp($announcement);
       $announcement=&unescape($announcement);
       if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
    '/announcement.txt')) {
    print $store $announcement;
    close $store;
    Reply($client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)."\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("setannounce", \&SetAnnounceHandler, 0, 1, 0);
   
   #
   #  Return the version of the daemon.  This can be used to determine
   #  the compatibility of cross version installations or, alternatively to
   #  simply know who's out of date and who isn't.  Note that the version
   #  is returned concatenated with the tail.
   # Parameters:
   #   $cmd        - the request that dispatched to us.
   #   $tail       - Tail of the request (client's version?).
   #   $client     - Socket open on the client.
   #Returns:
   #   1 - continue processing requests.
   # Side Effects:
   #   Replies with version to $client.
   sub GetVersionHandler {
       my $client     = shift;
       my $tail       = shift;
       my $client     = shift;
       my $userinput  = $client;
       
       Reply($client, &version($userinput)."\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("version", \&GetVersionHandler, 0, 1, 0);
   
   #  Set the current host and domain.  This is used to support
   #  multihomed systems.  Each IP of the system, or even separate daemons
   #  on the same IP can be treated as handling a separate lonCAPA virtual
   #  machine.  This command selects the virtual lonCAPA.  The client always
   #  knows the right one since it is lonc and it is selecting the domain/system
   #  from the hosts.tab file.
   # Parameters:
   #    $cmd      - Command that dispatched us.
   #    $tail     - Tail of the command (domain/host requested).
   #    $socket   - Socket open on the client.
   #
   # Returns:
   #     1   - Indicates the program should continue to process requests.
   # Side-effects:
   #     The default domain/system context is modified for this daemon.
   #     a reply is sent to the client.
   #
   sub SelectHostHandler {
       my $cmd        = shift;
       my $tail       = shift;
       my $socket     = shift;
     
       my $userinput  ="$cmd:$tail";
   
       Reply($client, &sethost($userinput)."\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("sethost", \&SelectHostHandler, 0, 1, 0);
   
   #  Process a request to exit:
   #   - "bye" is sent to the client.
   #   - The client socket is shutdown and closed.
   #   - We indicate to the caller that we should exit.
   # Formal Parameters:
   #   $cmd                - The command that got us here.
   #   $tail               - Tail of the command (empty).
   #   $client             - Socket open on the tail.
   # Returns:
   #   0      - Indicating the program should exit!!
   #
   sub ExitHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
   
       my $userinput = "$cmd:$tail";
   
       &logthis("Client $clientip ($clientname) hanging up: $userinput");
       Reply($client, "bye\n", $userinput);
       $client->shutdown(2);        # shutdown the socket forcibly.
       $client->close();
   
       return 0;
   }
   RegisterHandler("exit", \&ExitHandler, 0, 1,1);
   RegisterHandler("init", \&ExitHandler, 0, 1,1); # RE-init is like exit.
   RegisterHandler("quit", \&ExitHandler, 0, 1,1); # I like this too!
   #------------------------------------------------------------------------------------
   #
   #   Process a Request.  Takes a request from the client validates
   #   it and performs the operation requested by it.  Returns
   #   a response to the client.
   #
   #  Parameters:
   #      request      - A string containing the user's request.
   #  Returns:
   #      0            - Requested to exit, caller should shut down.
   #      1            - Accept additional requests from the client.
   #
   sub ProcessRequest {
       my $Request      = shift;
       my $KeepGoing    = 1; # Assume we're not asked to stop.
       
       my $wasenc=0;
       my $userinput = $Request;   # for compatibility with oldcode <yeach>
   
   
   # ------------------------------------------------------------ See if encrypted
      
       if($userinput =~ /^enc/) {
    $wasenc = 1;
    $userinput = Decipher($userinput);
    if(! $userinput) {
       Failure($client,"error:Encrypted data without negotiating key");
       return 0;                      # Break off with this imposter.
    }
       }
       # Split off the request keyword from the rest of the stuff.
      
       my ($command, $tail) = split(/:/, $userinput, 2);
   
       Debug("Command received: $command, encoded = $wasenc");
   
      
   # ------------------------------------------------------------- Normal commands
   
       # 
       #   If the command is in the hash, then execute it via the hash dispatch:
       #
       if(defined $Dispatcher{$command}) {
   
    my $DispatchInfo = $Dispatcher{$command};
    my $Handler      = $$DispatchInfo[0];
    my $NeedEncode   = $$DispatchInfo[1];
    my $ClientTypes  = $$DispatchInfo[2];
    Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes");
         
    #  Validate the request:
         
    my $ok = 1;
    my $requesterprivs = 0;
    if(isClient()) {
       $requesterprivs |= $CLIENT_OK;
    }
    if(isManager()) {
       $requesterprivs |= $MANAGER_OK;
    }
    if($NeedEncode && (!$wasenc)) {
       Debug("Must encode but wasn't: $NeedEncode $wasenc");
       $ok = 0;
    }
    if(($ClientTypes & $requesterprivs) == 0) {
       Debug("Client not privileged to do this operation");
       $ok = 0;
    }
   
    if($ok) {
       Debug("Dispatching to handler $command $tail");
       $KeepGoing = &$Handler($command, $tail, $client);
    } else {
       Debug("Refusing to dispatch because ok is false");
       Failure($client, "refused", $userinput);
    }
   
   
   # ------------------------------------------------------------- unknown command
   
       } else {
    # unknown command
    Failure($client, "unknown_cmd\n", $userinput);
       }
   
       return $KeepGoing;
   }
   
   
   #
   #   GetCertificate: Given a transaction that requires a certificate,
   #   this function will extract the certificate from the transaction
   #   request.  Note that at this point, the only concept of a certificate
   #   is the hostname to which we are connected.
   #
   #   Parameter:
   #      request   - The request sent by our client (this parameterization may
   #                  need to change when we really use a certificate granting
   #                  authority.
   #
   sub GetCertificate {
       my $request = shift;
   
       return $clientip;
   }
   
   
   
   #
   #   ReadManagerTable: Reads in the current manager table. For now this is
   #                     done on each manager authentication because:
   #                     - These authentications are not frequent
   #                     - This allows dynamic changes to the manager table
   #                       without the need to signal to the lond.
   #
   
   sub ReadManagerTable {
   
       #   Clean out the old table first..
   
       foreach my $key (keys %managers) {
    delete $managers{$key};
       }
   
       my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
       if (!open (MANAGERS, $tablename)) {
    logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
    return;
       }
       while(my $host = <MANAGERS>) {
    chomp($host);
    if ($host =~ "^#") {                  # Comment line.
       logthis('<font color="green"> Skipping line: '. "$host</font>\n");
       next;
    }
    if (!defined $hostip{$host}) { # This is a non cluster member
       #  The entry is of the form:
       #    cluname:hostname
       #  cluname - A 'cluster hostname' is needed in order to negotiate
       #            the host key.
       #  hostname- The dns name of the host.
       #
       my($cluname, $dnsname) = split(/:/, $host);
       
       my $ip = gethostbyname($dnsname);
       if(defined($ip)) {                 # bad names don't deserve entry.
    my $hostip = inet_ntoa($ip);
    $managers{$hostip} = $cluname;
    logthis('<font color="green"> registering manager '.
    "$dnsname as $cluname with $hostip </font>\n");
       }
    } else {
       logthis('<font color="green"> existing host'." $host</font>\n");
       $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber
    }
       }
   }
   
   #
   #  ValidManager: Determines if a given certificate represents a valid manager.
   #                in this primitive implementation, the 'certificate' is
   #                just the connecting loncapa client name.  This is checked
   #                against a valid client list in the configuration.
   #
   #                  
   sub ValidManager {
       my $certificate = shift; 
   
       return isManager;
   }
   #
   #  CopyFile:  Called as part of the process of installing a 
   #             new configuration file.  This function copies an existing
   #             file to a backup file.
   # Parameters:
   #     oldfile  - Name of the file to backup.
   #     newfile  - Name of the backup file.
   # Return:
   #     0   - Failure (errno has failure reason).
   #     1   - Success.
   #
   sub CopyFile {
       my $oldfile = shift;
       my $newfile = shift;
   
       #  The file must exist:
   
       if(-e $oldfile) {
   
    # Read the old file.
   
    my $oldfh = IO::File->new("< $oldfile");
    if(!$oldfh) {
       return 0;
    }
    my @contents = <$oldfh>;  # Suck in the entire file.
   
    # write the backup file:
   
    my $newfh = IO::File->new("> $newfile");
    if(!(defined $newfh)){
       return 0;
    }
    my $lines = scalar @contents;
    for (my $i =0; $i < $lines; $i++) {
       print $newfh ($contents[$i]);
    }
   
    $oldfh->close;
    $newfh->close;
   
    chmod(0660, $newfile);
   
    return 1;
       
       } else {
    return 0;
       }
   }
   #
   #  Host files are passed out with externally visible host IPs.
   #  If, for example, we are behind a fire-wall or NAT host, our 
   #  internally visible IP may be different than the externally
   #  visible IP.  Therefore, we always adjust the contents of the
   #  host file so that the entry for ME is the IP that we believe
   #  we have.  At present, this is defined as the entry that
   #  DNS has for us.  If by some chance we are not able to get a
   #  DNS translation for us, then we assume that the host.tab file
   #  is correct.  
   #    BUGBUGBUG - in the future, we really should see if we can
   #       easily query the interface(s) instead.
   # Parameter(s):
   #     contents    - The contents of the host.tab to check.
   # Returns:
   #     newcontents - The adjusted contents.
   #
   #
   sub AdjustHostContents {
       my $contents  = shift;
       my $adjusted;
       my $me        = $perlvar{'lonHostID'};
   
       foreach my $line (split(/\n/,$contents)) {
    if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
       chomp($line);
       my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
       if ($id eq $me) {
    my $ip = gethostbyname($name);
    my $ipnew = inet_ntoa($ip);
    $ip = $ipnew;
    #  Reconstruct the host line and append to adjusted:
   
    my $newline = "$id:$domain:$role:$name:$ip";
    if($maxcon ne "") { # Not all hosts have loncnew tuning params
       $newline .= ":$maxcon:$idleto:$mincon";
    }
    $adjusted .= $newline."\n";
   
       } else { # Not me, pass unmodified.
    $adjusted .= $line."\n";
       }
    } else {                  # Blank or comment never re-written.
       $adjusted .= $line."\n"; # Pass blanks and comments as is.
    }
       }
       return $adjusted;
   }
   #
   #   InstallFile: Called to install an administrative file:
   #       - The file is created with <name>.tmp
   #       - The <name>.tmp file is then mv'd to <name>
   #   This lugubrious procedure is done to ensure that we are never without
   #   a valid, even if dated, version of the file regardless of who crashes
   #   and when the crash occurs.
   #
   #  Parameters:
   #       Name of the file
   #       File Contents.
   #  Return:
   #      nonzero - success.
   #      0       - failure and $! has an errno.
   #
   sub InstallFile {
       my $Filename = shift;
       my $Contents = shift;
       my $TempFile = $Filename.".tmp";
   
       #  Open the file for write:
       
       my $fh = IO::File->new("> $TempFile"); # Write to temp.
       if(!(defined $fh)) {
    &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
    return 0;
       }
       #  write the contents of the file:
       
       print $fh ($Contents); 
       $fh->close; # In case we ever have a filesystem w. locking
   
       chmod(0660, $TempFile);
   
       # Now we can move install the file in position.
       
       move($TempFile, $Filename);
   
       return 1;
   }
   #
   #   ConfigFileFromSelector: converts a configuration file selector
   #                 (one of host or domain at this point) into a 
   #                 configuration file pathname.
   #
   #  Parameters:
   #      selector  - Configuration file selector.
   #  Returns:
   #      Full path to the file or undef if the selector is invalid.
   #
   sub ConfigFileFromSelector {
       my $selector   = shift;
       my $tablefile;
   
       my $tabledir = $perlvar{'lonTabDir'}.'/';
       if ($selector eq "hosts") {
    $tablefile = $tabledir."hosts.tab";
       } elsif ($selector eq "domain") {
    $tablefile = $tabledir."domain.tab";
       } else {
    return undef;
       }
       return $tablefile;
   
   }
   #
   #   PushFile:  Called to do an administrative push of a file.
   #              - Ensure the file being pushed is one we support.
   #              - Backup the old file to <filename.saved>
   #              - Separate the contents of the new file out from the
   #                rest of the request.
   #              - Write the new file.
   #  Parameter:
   #     Request - The entire user request.  This consists of a : separated
   #               string pushfile:tablename:contents.
   #     NOTE:  The contents may have :'s in it as well making things a bit
   #            more interesting... but not much.
   #  Returns:
   #     String to send to client ("ok" or "refused" if bad file).
   #
   sub PushFile {
       my $request = shift;    
       my ($command, $filename, $contents) = split(":", $request, 3);
       
       #  At this point in time, pushes for only the following tables are
       #  supported:
       #   hosts.tab  ($filename eq host).
       #   domain.tab ($filename eq domain).
       # Construct the destination filename or reject the request.
       #
       # lonManage is supposed to ensure this, however this session could be
       # part of some elaborate spoof that managed somehow to authenticate.
       #
   
   
       my $tablefile = ConfigFileFromSelector($filename);
       if(! (defined $tablefile)) {
    return "refused";
       }
       #
       # >copy< the old table to the backup table
       #        don't rename in case system crashes/reboots etc. in the time
       #        window between a rename and write.
       #
       my $backupfile = $tablefile;
       $backupfile    =~ s/\.tab$/.old/;
       if(!CopyFile($tablefile, $backupfile)) {
    &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");
    return "error:$!";
       }
       &logthis('<font color="green"> Pushfile: backed up '
        .$tablefile." to $backupfile</font>");
       
       #  If the file being pushed is the host file, we adjust the entry for ourself so that the
       #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible
       #  to conceive of conditions where we don't have a DNS entry locally.  This is possible in a 
       #  network sense but it doesn't make much sense in a LonCAPA sense so we ignore (for now)
       #  that possibilty.
   
       if($filename eq "host") {
    $contents = AdjustHostContents($contents);
       }
   
       #  Install the new file:
   
       if(!InstallFile($tablefile, $contents)) {
    &logthis('<font color="red"> Pushfile: unable to install '
    .$tablefile." $! </font>");
    return "error:$!";
       } else {
    &logthis('<font color="green"> Installed new '.$tablefile
    ."</font>");
   
       }
   
   
       #  Indicate success:
    
       return "ok";
   
   }
   
   #
   #  Called to re-init either lonc or lond.
   #
   #  Parameters:
   #    request   - The full request by the client.  This is of the form
   #                reinit:<process>  
   #                where <process> is allowed to be either of 
   #                lonc or lond
   #
   #  Returns:
   #     The string to be sent back to the client either:
   #   ok         - Everything worked just fine.
   #   error:why  - There was a failure and why describes the reason.
   #
   #
   sub ReinitProcess {
       my $request = shift;
   
   
       # separate the request (reinit) from the process identifier and
       # validate it producing the name of the .pid file for the process.
       #
       #
       my ($junk, $process) = split(":", $request);
       my $processpidfile = $perlvar{'lonDaemons'}.'/logs/';
       if($process eq 'lonc') {
    $processpidfile = $processpidfile."lonc.pid";
    if (!open(PIDFILE, "< $processpidfile")) {
       return "error:Open failed for $processpidfile";
    }
    my $loncpid = <PIDFILE>;
    close(PIDFILE);
    logthis('<font color="red"> Reinitializing lonc pid='.$loncpid
    ."</font>");
    kill("USR2", $loncpid);
       } elsif ($process eq 'lond') {
    logthis('<font color="red"> Reinitializing self (lond) </font>');
    &UpdateHosts; # Lond is us!!
       } else {
    &logthis('<font color="yellow" Invalid reinit request for '.$process
    ."</font>");
    return "error:Invalid process identifier $process";
       }
       return 'ok';
   }
   #   Validate a line in a configuration file edit script:
   #   Validation includes:
   #     - Ensuring the command is valid.
   #     - Ensuring the command has sufficient parameters
   #   Parameters:
   #     scriptline - A line to validate (\n has been stripped for what it's worth).
   #
   #   Return:
   #      0     - Invalid scriptline.
   #      1     - Valid scriptline
   #  NOTE:
   #     Only the command syntax is checked, not the executability of the
   #     command.
   #
   sub isValidEditCommand {
       my $scriptline = shift;
   
       #   Line elements are pipe separated:
   
       my ($command, $key, $newline)  = split(/\|/, $scriptline);
       &logthis('<font color="green"> isValideditCommand checking: '.
        "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
       
       if ($command eq "delete") {
    #
    #   key with no newline.
    #
    if( ($key eq "") || ($newline ne "")) {
       return 0; # Must have key but no newline.
    } else {
       return 1; # Valid syntax.
    }
       } elsif ($command eq "replace") {
    #
    #   key and newline:
    #
    if (($key eq "") || ($newline eq "")) {
       return 0;
    } else {
       return 1;
    }
       } elsif ($command eq "append") {
    if (($key ne "") && ($newline eq "")) {
       return 1;
    } else {
       return 0;
    }
       } else {
    return 0; # Invalid command.
       }
       return 0; # Should not get here!!!
   }
   #
   #   ApplyEdit - Applies an edit command to a line in a configuration 
   #               file.  It is the caller's responsiblity to validate the
   #               edit line.
   #   Parameters:
   #      $directive - A single edit directive to apply.  
   #                   Edit directives are of the form:
   #                  append|newline      - Appends a new line to the file.
   #                  replace|key|newline - Replaces the line with key value 'key'
   #                  delete|key          - Deletes the line with key value 'key'.
   #      $editor   - A config file editor object that contains the
   #                  file being edited.
   #
   sub ApplyEdit {
       my $directive   = shift;
       my $editor      = shift;
   
       # Break the directive down into its command and its parameters
       # (at most two at this point.  The meaning of the parameters, if in fact
       #  they exist depends on the command).
   
       my ($command, $p1, $p2) = split(/\|/, $directive);
   
       if($command eq "append") {
    $editor->Append($p1);          # p1 - key p2 null.
       } elsif ($command eq "replace") {
    $editor->ReplaceLine($p1, $p2);   # p1 - key p2 = newline.
       } elsif ($command eq "delete") {
    $editor->DeleteLine($p1);         # p1 - key p2 null.
       } else {          # Should not get here!!!
    die "Invalid command given to ApplyEdit $command";
       }
   }
   #
   # AdjustOurHost:
   #           Adjusts a host file stored in a configuration file editor object
   #           for the true IP address of this host. This is necessary for hosts
   #           that live behind a firewall.
   #           Those hosts have a publicly distributed IP of the firewall, but
   #           internally must use their actual IP.  We assume that a given
   #           host only has a single IP interface for now.
   # Formal Parameters:
   #     editor   - The configuration file editor to adjust.  This
   #                editor is assumed to contain a hosts.tab file.
   # Strategy:
   #    - Figure out our hostname.
   #    - Lookup the entry for this host.
   #    - Modify the line to contain our IP
   #    - Do a replace for this host.
   sub AdjustOurHost {
       my $editor        = shift;
   
       # figure out who I am.
   
       my $myHostName    = $perlvar{'lonHostID'}; # LonCAPA hostname.
   
       #  Get my host file entry.
   
       my $ConfigLine    = $editor->Find($myHostName);
       if(! (defined $ConfigLine)) {
    die "AdjustOurHost - no entry for me in hosts file $myHostName";
       }
       # figure out my IP:
       #   Use the config line to get my hostname.
       #   Use gethostbyname to translate that into an IP address.
       #
       my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
       my $BinaryIp = gethostbyname($name);
       my $ip       = inet_ntoa($ip);
       #
       #  Reassemble the config line from the elements in the list.
       #  Note that if the loncnew items were not present before, they will
       #  be now even if they would be empty
       #
       my $newConfigLine = $id;
       foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
    $newConfigLine .= ":".$item;
       }
       #  Replace the line:
   
       $editor->ReplaceLine($id, $newConfigLine);
       
   }
   #
   #   ReplaceConfigFile:
   #              Replaces a configuration file with the contents of a
   #              configuration file editor object.
   #              This is done by:
   #              - Copying the target file to <filename>.old
   #              - Writing the new file to <filename>.tmp
   #              - Moving <filename.tmp>  -> <filename>
   #              This laborious process ensures that the system is never without
   #              a configuration file that's at least valid (even if the contents
   #              may be dated).
   #   Parameters:
   #        filename   - Name of the file to modify... this is a full path.
   #        editor     - Editor containing the file.
   #
   sub ReplaceConfigFile {
       my $filename  = shift;
       my $editor    = shift;
   
       CopyFile ($filename, $filename.".old");
   
       my $contents  = $editor->Get(); # Get the contents of the file.
   
       InstallFile($filename, $contents);
   }
   #   
   #
   #   Called to edit a configuration table  file
   #   Parameters:
   #      request           - The entire command/request sent by lonc or lonManage
   #   Return:
   #      The reply to send to the client.
   #
   sub EditFile {
       my $request = shift;
   
       #  Split the command into it's pieces:  edit:filetype:script
   
       my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
   
       #  Check the pre-coditions for success:
   
       if($request != "edit") { # Something is amiss afoot alack.
    return "error:edit request detected, but request != 'edit'\n";
       }
       if( ($filetype ne "hosts")  &&
    ($filetype ne "domain")) {
    return "error:edit requested with invalid file specifier: $filetype \n";
       }
   
       #   Split the edit script and check it's validity.
   
       my @scriptlines = split(/\n/, $script);  # one line per element.
       my $linecount   = scalar(@scriptlines);
       for(my $i = 0; $i < $linecount; $i++) {
    chomp($scriptlines[$i]);
    if(!isValidEditCommand($scriptlines[$i])) {
       return "error:edit with bad script line: '$scriptlines[$i]' \n";
    }
       }
   
       #   Execute the edit operation.
       #   - Create a config file editor for the appropriate file and 
       #   - execute each command in the script:
       #
       my $configfile = ConfigFileFromSelector($filetype);
       if (!(defined $configfile)) {
    return "refused\n";
       }
       my $editor = ConfigFileEdit->new($configfile);
   
       for (my $i = 0; $i < $linecount; $i++) {
    ApplyEdit($scriptlines[$i], $editor);
       }
       # If the file is the host file, ensure that our host is
       # adjusted to have our ip:
       #
       if($filetype eq "host") {
    AdjustOurHost($editor);
       }
       #  Finally replace the current file with our file.
       #
       ReplaceConfigFile($configfile, $editor);
   
       return "ok\n";
   }
   #
   #  Convert an error return code from lcpasswd to a string value.
   #
   sub lcpasswdstrerror {
       my $ErrorCode = shift;
       if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) {
    return "lcpasswd Unrecognized error return value ".$ErrorCode;
       } else {
    return $passwderrors[$ErrorCode];
       }
   }
   
   #
   # Convert an error return code from lcuseradd to a string value:
   #
   sub lcuseraddstrerror {
       my $ErrorCode = shift;
       if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {
    return "lcuseradd - Unrecognized error code: ".$ErrorCode;
       } else {
    return $adderrors[$ErrorCode];
       }
   }
   
 # grabs exception and records it to log before exiting  # grabs exception and records it to log before exiting
 sub catchexception {  sub catchexception {
     my ($error)=@_;      my ($error)=@_;
     $SIG{'QUIT'}='DEFAULT';      $SIG{'QUIT'}='DEFAULT';
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
       &status("Catching exception");
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color=red>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $wasserver died through "       ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
     if ($client) { print $client "error: $error\n"; }      if ($client) { print $client "error: $error\n"; }
     $server->close();      $server->close();
Line 97  sub catchexception { Line 3365  sub catchexception {
 }  }
   
 sub timeout {  sub timeout {
       &status("Handling Timeout");
     &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");      &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
     &catchexception('Timeout');      &catchexception('Timeout');
 }  }
Line 106  $SIG{'QUIT'}=\&catchexception; Line 3375  $SIG{'QUIT'}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
 # ---------------------------------- Read loncapa_apache.conf and loncapa.conf  # ---------------------------------- Read loncapa_apache.conf and loncapa.conf
 &status("Read loncapa_apache.conf and loncapa.conf");  &status("Read loncapa.conf and loncapa_apache.conf");
 my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',  my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
                                                  'loncapa.conf');  %perlvar=%{$perlvarref};
 my %perlvar=%{$perlvarref};  
 undef $perlvarref;  undef $perlvarref;
   
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
 my $wwwid=getpwnam('www');  my $wwwid=getpwnam('www');
 if ($wwwid!=$<) {  if ($wwwid!=$<) {
    $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";      my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
    $subj="LON: $perlvar{'lonHostID'} User ID mismatch";      my $subj="LON: $currenthostid User ID mismatch";
    system("echo 'User ID mismatch.  lond must be run as user www.' |\      system("echo 'User ID mismatch.  lond must be run as user www.' |\
  mailto $emailto -s '$subj' > /dev/null");   mailto $emailto -s '$subj' > /dev/null");
    exit 1;      exit 1;
 }  }
   
 # --------------------------------------------- Check if other instance running  # --------------------------------------------- Check if other instance running
Line 127  if ($wwwid!=$<) { Line 3395  if ($wwwid!=$<) {
 my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";  my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
   
 if (-e $pidfile) {  if (-e $pidfile) {
    my $lfh=IO::File->new("$pidfile");      my $lfh=IO::File->new("$pidfile");
    my $pide=<$lfh>;      my $pide=<$lfh>;
    chomp($pide);      chomp($pide);
    if (kill 0 => $pide) { die "already running"; }      if (kill 0 => $pide) { die "already running"; }
 }  }
   
 $PREFORK=4; # number of children to maintain, at least four spare  
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
   
 open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  
   
 while ($configline=<CONFIG>) {  
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);  
     chomp($ip); $ip=~s/\D+$//;  
     $hostid{$ip}=$id;  
     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }  
     $PREFORK++;  
 }  
 close(CONFIG);  
   
 # establish SERVER socket, bind and listen.  # establish SERVER socket, bind and listen.
 $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},  $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Line 154  $server = IO::Socket::INET->new(LocalPor Line 3411  $server = IO::Socket::INET->new(LocalPor
                                 Proto     => 'tcp',                                  Proto     => 'tcp',
                                 Reuse     => 1,                                  Reuse     => 1,
                                 Listen    => 10 )                                  Listen    => 10 )
   or die "making socket: $@\n";      or die "making socket: $@\n";
   
 # --------------------------------------------------------- Do global variables  # --------------------------------------------------------- Do global variables
   
 # global variables  # global variables
   
 $MAX_CLIENTS_PER_CHILD  = 50;        # number of clients each child should   my %children               = ();       # keys are current child process IDs
                                     # process  my $children               = 0;        # current number of children
 %children               = ();       # keys are current child process IDs  
 $children               = 0;        # current number of children  
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
       &status("Handling child death");
     my $pid = wait;      my $pid = wait;
     if (defined($children{$pid})) {      if (defined($children{$pid})) {
  &logthis("Child $pid died");   &logthis("Child $pid died");
Line 175  sub REAPER {                        # ta Line 3431  sub REAPER {                        # ta
     } else {      } else {
  &logthis("Unknown Child $pid died");   &logthis("Unknown Child $pid died");
     }      }
       &status("Finished Handling child death");
 }  }
   
 sub HUNTSMAN {                      # signal handler for SIGINT  sub HUNTSMAN {                      # signal handler for SIGINT
       &status("Killing children (INT)");
     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children      local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
     &logthis("<font color=red>CRITICAL: Shutting down</font>");      &logthis("<font color=red>CRITICAL: Shutting down</font>");
       &status("Done killing children");
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
   
 sub HUPSMAN {                      # signal handler for SIGHUP  sub HUPSMAN {                      # signal handler for SIGHUP
     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children      local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
       &status("Killing children for restart (HUP)");
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     &logthis("<font color=red>CRITICAL: Restarting</font>");      &logthis("<font color=red>CRITICAL: Restarting</font>");
     unlink("$execdir/logs/lond.pid");  
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
       unlink("$execdir/logs/lond.pid");
       &status("Restarting self (HUP)");
     exec("$execdir/lond");         # here we go again      exec("$execdir/lond");         # here we go again
 }  }
   
   #
   #    Kill off hashes that describe the host table prior to re-reading it.
   #    Hashes affected are:
   #       %hostid, %hostdom %hostip
   #
   sub KillHostHashes {
       foreach my $key (keys %hostid) {
    delete $hostid{$key};
       }
       foreach my $key (keys %hostdom) {
    delete $hostdom{$key};
       }
       foreach my $key (keys %hostip) {
    delete $hostip{$key};
       }
   }
   #
   #   Read in the host table from file and distribute it into the various hashes:
   #
   #    - %hostid  -  Indexed by IP, the loncapa hostname.
   #    - %hostdom -  Indexed by  loncapa hostname, the domain.
   #    - %hostip  -  Indexed by hostid, the Ip address of the host.
   sub ReadHostTable {
   
       open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
       
       while (my $configline=<CONFIG>) {
    my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
    chomp($ip); $ip=~s/\D+$//;
    $hostid{$ip}=$id;
    $hostdom{$id}=$domain;
    $hostip{$id}=$ip;
    if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
       }
       close(CONFIG);
   }
   #
   #  Reload the Apache daemon's state.
   #  This is done by invoking /home/httpd/perl/apachereload
   #  a setuid perl script that can be root for us to do this job.
   #
   sub ReloadApache {
       my $execdir = $perlvar{'lonDaemons'};
       my $script  = $execdir."/apachereload";
       system($script);
   }
   
   #
   #   Called in response to a USR2 signal.
   #   - Reread hosts.tab
   #   - All children connected to hosts that were removed from hosts.tab
   #     are killed via SIGINT
   #   - All children connected to previously existing hosts are sent SIGUSR1
   #   - Our internal hosts hash is updated to reflect the new contents of
   #     hosts.tab causing connections from hosts added to hosts.tab to
   #     now be honored.
   #
   sub UpdateHosts {
       &status("Reload hosts.tab");
       logthis('<font color="blue"> Updating connections </font>');
       #
       #  The %children hash has the set of IP's we currently have children
       #  on.  These need to be matched against records in the hosts.tab
       #  Any ip's no longer in the table get killed off they correspond to
       #  either dropped or changed hosts.  Note that the re-read of the table
       #  will take care of new and changed hosts as connections come into being.
   
   
       KillHostHashes;
       ReadHostTable;
   
       foreach my $child (keys %children) {
    my $childip = $children{$child};
    if(!$hostid{$childip}) {
       logthis('<font color="blue"> UpdateHosts killing child '
       ." $child for ip $childip </font>");
       kill('INT', $child);
    } else {
       logthis('<font color="green"> keeping child for ip '
       ." $childip (pid=$child) </font>");
    }
       }
       ReloadApache;
       &status("Finished reloading hosts.tab");
   }
   
   
 sub checkchildren {  sub checkchildren {
       &status("Checking on the children (sending signals)");
     &initnewstatus();      &initnewstatus();
     &logstatus();      &logstatus();
     &logthis('Going to check on the children');      &logthis('Going to check on the children');
     $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     foreach (sort keys %children) {      foreach (sort keys %children) {
  sleep 1;   sleep 1;
         unless (kill 'USR1' => $_) {          unless (kill 'USR1' => $_) {
Line 210  sub checkchildren { Line 3559  sub checkchildren {
         }           } 
     }      }
     sleep 5;      sleep 5;
       $SIG{ALRM} = sub { die "timeout" };
       $SIG{__DIE__} = 'DEFAULT';
       &status("Checking on the children (waiting for reports)");
     foreach (sort keys %children) {      foreach (sort keys %children) {
         unless (-e "$docdir/lon-status/londchld/$_.txt") {          unless (-e "$docdir/lon-status/londchld/$_.txt") {
     &logthis('Child '.$_.' did not respond');      eval {
     kill 9 => $_;   alarm(300);
     $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";   &logthis('Child '.$_.' did not respond');
     $subj="LON: $perlvar{'lonHostID'} killed lond process $_";   kill 9 => $_;
     my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;   #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
     $execdir=$perlvar{'lonDaemons'};   #$subj="LON: $currenthostid killed lond process $_";
     $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`   #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.$_`;
    alarm(0);
       }
         }          }
     }      }
       $SIG{ALRM} = 'DEFAULT';
       $SIG{__DIE__} = \&catchexception;
       &status("Finished checking children");
 }  }
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
Line 242  sub Debug { Line 3601  sub Debug {
  &logthis($message);   &logthis($message);
     }      }
 }  }
   
   #
   #   Sub to do replies to client.. this gives a hook for some
   #   debug tracing too:
   #  Parameters:
   #     fd      - File open on client.
   #     reply   - Text to send to client.
   #     request - Original request from client.
   #
   #  Note: This increments Transactions
   #
   sub Reply {
       alarm(120);
       my $fd      = shift;
       my $reply   = shift;
       my $request = shift;
   
       print $fd $reply;
       Debug("Request was $request  Reply was $reply");
   
       $Transactions++;
       alarm(0);
   
   
   }
   #
   #    Sub to report a failure.
   #    This function:
   #     -   Increments the failure statistic counters.
   #     -   Invokes Reply to send the error message to the client.
   # Parameters:
   #    fd       - File descriptor open on the client
   #    reply    - Reply text to emit.
   #    request  - The original request message (used by Reply
   #               to debug if that's enabled.
   # Implicit outputs:
   #    $Failures- The number of failures is incremented.
   #    Reply (invoked here) sends a message to the 
   #    client:
   #
   sub Failure {
       my $fd      = shift;
       my $reply   = shift;
       my $request = shift;
      
       $Failures++;
       Reply($fd, $reply, $request);      # That's simple eh?
   }
 # ------------------------------------------------------------------ Log status  # ------------------------------------------------------------------ Log status
   
 sub logstatus {  sub logstatus {
       &status("Doing logging");
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     {      {
     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");   my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
     print $fh $$."\t".$status."\t".$lastlog."\n";   print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
     $fh->close();   $fh->close();
     }      }
       &status("Finished londstatus.txt");
     {      {
  my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");   my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
         print $fh $status."\n".$lastlog."\n".time;   print $fh $status."\n".$lastlog."\n".time;
         $fh->close();   $fh->close();
     }      }
       ResetStatistics;
       &status("Finished logging");
      
 }  }
   
 sub initnewstatus {  sub initnewstatus {
Line 265  sub initnewstatus { Line 3677  sub initnewstatus {
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "LOND status $local - parent $$\n\n";      print $fh "LOND status $local - parent $$\n\n";
     opendir(DIR,"$docdir/lon-status/londchld");      opendir(DIR,"$docdir/lon-status/londchld");
     while ($filename=readdir(DIR)) {      while (my $filename=readdir(DIR)) {
         unlink("$docdir/lon-status/londchld/$filename");          unlink("$docdir/lon-status/londchld/$filename");
     }      }
     closedir(DIR);      closedir(DIR);
Line 277  sub status { Line 3689  sub status {
     my $what=shift;      my $what=shift;
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     $status=$local.': '.$what;      my $status = "lond: $what $local ";
       if($Transactions) {
    $status .= " Transactions: $Transactions Failed; $Failures";
       }
       $0=$status;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
Line 308  sub reconlonc { Line 3724  sub reconlonc {
         if (kill 0 => $loncpid) {          if (kill 0 => $loncpid) {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
             sleep 5;  
             if (-e "$peerfile") { return; }  
             &logthis("$peerfile still not there, give it another try");  
             sleep 10;  
             if (-e "$peerfile") { return; }  
             &logthis(  
  "<font color=blue>WARNING: $peerfile still not there, giving up</font>");  
         } else {          } else {
     &logthis(      &logthis("<font color=red>CRITICAL: "
               "<font color=red>CRITICAL: "       ."lonc at pid $loncpid not responding, giving up</font>");
              ."lonc at pid $loncpid not responding, giving up</font>");  
         }          }
     } else {      } else {
       &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');   &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 333  sub subreply { Line 3741  sub subreply {
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";   or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
Line 342  sub subreply { Line 3750  sub subreply {
 }  }
   
 sub reply {  sub reply {
   my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
   my $answer;      my $answer;
   if ($server ne $perlvar{'lonHostID'}) {       if ($server ne $currenthostid) { 
     $answer=subreply($cmd,$server);   $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {   if ($answer eq 'con_lost') {
  $answer=subreply("ping",$server);      $answer=subreply("ping",$server);
         if ($answer ne $server) {      if ($answer ne $server) {
     &logthis("sub reply: answer != server");   &logthis("sub reply: answer != server answer is $answer, server is $server");
            &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc("$perlvar{'lonSockDir'}/$server");
         }      }
         $answer=subreply($cmd,$server);      $answer=subreply($cmd,$server);
     }   }
   } else {      } else {
     $answer='self_reply';   $answer='self_reply';
   }       } 
   return $answer;      return $answer;
 }  }
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
Line 376  sub subsqlreply { Line 3784  sub subsqlreply {
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";   or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
Line 388  sub subsqlreply { Line 3796  sub subsqlreply {
   
 sub propath {  sub propath {
     my ($udom,$uname)=@_;      my ($udom,$uname)=@_;
       Debug("Propath:$udom:$uname");
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
       Debug("Propath2:$udom:$uname");
     my $subdir=$uname.'__';      my $subdir=$uname.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
       Debug("Propath returning $proname");
     return $proname;      return $proname;
 }   } 
   
Line 413  sub ishome { Line 3824  sub ishome {
 # ======================================================= Continue main program  # ======================================================= Continue main program
 # ---------------------------------------------------- Fork once and dissociate  # ---------------------------------------------------- Fork once and dissociate
   
 $fpid=fork;  my $fpid=fork;
 exit if $fpid;  exit if $fpid;
 die "Couldn't fork: $!" unless defined ($fpid);  die "Couldn't fork: $!" unless defined ($fpid);
   
Line 421  POSIX::setsid() or die "Can't start new Line 3832  POSIX::setsid() or die "Can't start new
   
 # ------------------------------------------------------- Write our PID on disk  # ------------------------------------------------------- Write our PID on disk
   
 $execdir=$perlvar{'lonDaemons'};  my $execdir=$perlvar{'lonDaemons'};
 open (PIDSAVE,">$execdir/logs/lond.pid");  open (PIDSAVE,">$execdir/logs/lond.pid");
 print PIDSAVE "$$\n";  print PIDSAVE "$$\n";
 close(PIDSAVE);  close(PIDSAVE);
 &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");  &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
 &status('Starting');  &status('Starting');
   
 # ------------------------------------------------------- Now we are on our own  
       
 # Fork off our children.  
 for (1 .. $PREFORK) {  
     make_new_child();  
 }  
   
 # ----------------------------------------------------- Install signal handlers  # ----------------------------------------------------- Install signal handlers
   
 &status('Forked children');  
   
 $SIG{CHLD} = \&REAPER;  $SIG{CHLD} = \&REAPER;
 $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 $SIG{HUP}  = \&HUPSMAN;  $SIG{HUP}  = \&HUPSMAN;
 $SIG{USR1} = \&checkchildren;  $SIG{USR1} = \&checkchildren;
   $SIG{USR2} = \&UpdateHosts;
   
   #  Read the host hashes:
   
   ReadHostTable;
   
   
   # --------------------------------------------------------------
   #   Accept connections.  When a connection comes in, it is validated
   #   and if good, a child process is created to process transactions
   #   along the connection.
   
 # And maintain the population.  
 while (1) {  while (1) {
     &status('Sleeping');      &status('Starting accept');
     sleep;                          # wait for a signal (i.e., child's death)      $client = $server->accept() or next;
     &logthis('Woke up');      &status('Accepted '.$client.' off to spawn');
     &status('Woke up');      make_new_child($client);
     for ($i = $children; $i < $PREFORK; $i++) {      &status('Finished spawning');
         make_new_child();           # top up the child pool  
     }  
 }  }
   
 sub make_new_child {  sub make_new_child {
     my $pid;      my $pid;
     my $cipher;  
     my $sigset;      my $sigset;
     &logthis("Attempting to start child");      
       $client = shift;
       &status('Starting new child '.$client);
       &logthis('<font color="green"> Attempting to start child ('.$client.
        ")</font>");    
     # block signal for fork      # block signal for fork
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)      sigprocmask(SIG_BLOCK, $sigset)
         or die "Can't block SIGINT for fork: $!\n";          or die "Can't block SIGINT for fork: $!\n";
           
     die "fork: $!" unless defined ($pid = fork);      die "fork: $!" unless defined ($pid = fork);
   
       $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
                                  # connection liveness.
   
       #
       #  Figure out who we're talking to so we can record the peer in 
       #  the pid hash.
       #
       my $caller = getpeername($client);
       my ($port,$iaddr)=unpack_sockaddr_in($caller);
       $clientip=inet_ntoa($iaddr);
           
     if ($pid) {      if ($pid) {
         # Parent records the child's birth and returns.          # Parent records the child's birth and returns.
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = 1;          $children{$pid} = $clientip;
         $children++;          $children++;
         &status('Started child '.$pid);          &status('Started child '.$pid);
         return;          return;
     } else {      } else {
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before          $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
           $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns 
                                   #don't get intercepted
         $SIG{USR1}= \&logstatus;          $SIG{USR1}= \&logstatus;
         $SIG{ALRM}= \&timeout;          $SIG{ALRM}= \&timeout;
         $lastlog='Forked ';          $lastlog='Forked ';
Line 487  sub make_new_child { Line 3916  sub make_new_child {
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
   
         $tmpsnum=0;  
       
         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD          &Authen::Krb5::init_context();
         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {          &Authen::Krb5::init_ets();
             &status('Idle, waiting for connection');  
             $client = $server->accept()     or last;   &status('Accepted connection');
             &status('Accepted connection');  
 # =============================================================================  # =============================================================================
             # do something with the connection              # do something with the connection
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
             # see if we know client and check for spoof IP by challenge   # see if we know client and check for spoof IP by challenge
             my $caller=getpeername($client);  
             my ($port,$iaddr)=unpack_sockaddr_in($caller);   ReadManagerTable; # May also be a manager!!
             my $clientip=inet_ntoa($iaddr);  
             my $clientrec=($hostid{$clientip} ne undef);   my $clientrec=($hostid{$clientip}     ne undef);
             &logthis(   my $ismanager=($managers{$clientip}    ne undef);
 "<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>"   $clientname  = "[unknonwn]";
             );   if($clientrec) { # Establish client type.
             &status("Connecting $clientip ($hostid{$clientip})");       $ConnectionType = "client";
             my $clientok;      $clientname = $hostid{$clientip};
             if ($clientrec) {      if($ismanager) {
       &status("Waiting for init from $clientip ($hostid{$clientip})");   $ConnectionType = "both";
       my $remotereq=<$client>;      }
               $remotereq=~s/\W//g;   } else {
               if ($remotereq eq 'init') {      $ConnectionType = "manager";
   my $challenge="$$".time;      $clientname = $managers{$clientip};
                   print $client "$challenge\n";   }
                   &status(   my $clientok;
            "Waiting for challenge reply from $clientip ($hostid{$clientip})");    if ($clientrec || $ismanager) {
                   $remotereq=<$client>;      &status("Waiting for init from $clientip $clientname");
                   $remotereq=~s/\W//g;      &logthis('<font color="yellow">INFO: Connection, '.
                   if ($challenge eq $remotereq) {       $clientip.
       $clientok=1;       " ($clientname) connection type = $ConnectionType </font>" );
                       print $client "ok\n";      &status("Connecting $clientip  ($clientname))"); 
                   } else {      my $remotereq=<$client>;
       &logthis(      $remotereq=~s/[^\w:]//g;
  "<font color=blue>WARNING: $clientip did not reply challenge</font>");      if ($remotereq =~ /^init/) {
                       &status('No challenge reply '.$clientip);   &sethost("sethost:$perlvar{'lonHostID'}");
                   }   my $challenge="$$".time;
               } else {   print $client "$challenge\n";
   &logthis(   &status("Waiting for challenge reply from $clientip ($clientname)"); 
                     "<font color=blue>WARNING: "   $remotereq=<$client>;
                    ."$clientip failed to initialize: >$remotereq< </font>");   $remotereq=~s/\W//g;
                   &status('No init '.$clientip);   if ($challenge eq $remotereq) {
               }      $clientok=1;
       print $client "ok\n";
    } else {
       &logthis("<font color=blue>WARNING: $clientip did not reply challenge</font>");
       &status('No challenge reply '.$clientip);
    }
     } else {      } else {
               &logthis(   &logthis("<font color=blue>WARNING: "
  "<font color=blue>WARNING: Unknown client $clientip</font>");   ."$clientip failed to initialize: >$remotereq< </font>");
               &status('Hung up on '.$clientip);   &status('No init '.$clientip);
             }      }
             if ($clientok) {   } else {
       &logthis("<font color=blue>WARNING: Unknown client $clientip</font>");
       &status('Hung up on '.$clientip);
    }
    if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
       
       foreach my $id (keys(%hostip)) {
    if ($hostip{$id} ne $clientip ||
       $hostip{$currenthostid} eq $clientip) {
       # no need to try to do recon's to myself
       next;
    }
    &reconlonc("$perlvar{'lonSockDir'}/$id");
       }
       &logthis("<font color=green>Established connection: $clientname</font>");
       &status('Will listen to '.$clientname);
   
       ResetStatistics();
   
       &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}");  
               &logthis(  
        "<font color=green>Established connection: $hostid{$clientip}</font>");  
               &status('Will listen to '.$hostid{$clientip});  
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
               while (my $userinput=<$client>) {      my $KeepGoing = 1;
                 chomp($userinput);      while ((my $userinput=GetRequest) && $KeepGoing) {
  Debug("Request = $userinput\n");   $KeepGoing = ProcessRequest($userinput);
                 &status('Processing '.$hostid{$clientip}.': '.$userinput);  
                 my $wasenc=0;  
                 alarm(120);  
 # ------------------------------------------------------------ See if encrypted  
  if ($userinput =~ /^enc/) {  
   if ($cipher) {  
                     my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);  
     $userinput='';  
                     for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {  
                        $userinput.=  
    $cipher->decrypt(  
                             pack("H16",substr($encinput,$encidx,16))  
                            );  
     }  
     $userinput=substr($userinput,0,$cmdlength);  
                     $wasenc=1;  
  }  
       }  
     
 # ------------------------------------------------------------- Normal commands  
 # ------------------------------------------------------------------------ ping  
    if ($userinput =~ /^ping/) {  
                        print $client "$perlvar{'lonHostID'}\n";  
 # ------------------------------------------------------------------------ pong  
    } elsif ($userinput =~ /^pong/) {  
                        $reply=reply("ping",$hostid{$clientip});  
                        print $client "$perlvar{'lonHostID'}:$reply\n";   
 # ------------------------------------------------------------------------ ekey  
    } elsif ($userinput =~ /^ekey/) {  
                        my $buildkey=time.$$.int(rand 100000);  
                        $buildkey=~tr/1-6/A-F/;  
                        $buildkey=int(rand 100000).$buildkey.int(rand 100000);  
                        my $key=$perlvar{'lonHostID'}.$hostid{$clientip};  
                        $key=~tr/a-z/A-Z/;  
                        $key=~tr/G-P/0-9/;  
                        $key=~tr/Q-Z/0-9/;  
                        $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;  
                        $key=substr($key,0,32);  
                        my $cipherkey=pack("H32",$key);  
                        $cipher=new IDEA $cipherkey;  
                        print $client "$buildkey\n";   
 # ------------------------------------------------------------------------ load  
    } elsif ($userinput =~ /^load/) {  
                        my $loadavg;  
                        {  
                           my $loadfile=IO::File->new('/proc/loadavg');  
                           $loadavg=<$loadfile>;  
                        }  
                        $loadavg =~ s/\s.*//g;  
                        my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};  
        print $client "$loadpercent\n";  
 # ----------------------------------------------------------------- currentauth  
    } elsif ($userinput =~ /^currentauth/) {  
      if ($wasenc==1) {  
                        my ($cmd,$udom,$uname)=split(/:/,$userinput);  
        my $result = GetAuthType($udom, $uname);  
        if($result eq "nouser") {  
    print $client "unknown_user\n";  
        }  
        else {  
    print $client "$result\n"  
        }  
      } else {  
        print $client "refused\n";  
      }  
 # ------------------------------------------------------------------------ auth  
                    } elsif ($userinput =~ /^auth/) {  
      if ($wasenc==1) {  
                        my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);  
                        chomp($upass);  
                        $upass=unescape($upass);  
                        my $proname=propath($udom,$uname);  
                        my $passfilename="$proname/passwd";  
                        if (-e $passfilename) {  
                           my $pf = IO::File->new($passfilename);  
                           my $realpasswd=<$pf>;  
                           chomp($realpasswd);  
                           my ($howpwd,$contentpwd)=split(/:/,$realpasswd);  
                           my $pwdcorrect=0;  
                           if ($howpwd eq 'internal') {  
       $pwdcorrect=  
   (crypt($upass,$contentpwd) eq $contentpwd);  
                           } elsif ($howpwd eq 'unix') {  
                               $contentpwd=(getpwnam($uname))[1];  
       my $pwauth_path="/usr/local/sbin/pwauth";  
       unless ($contentpwd eq 'x') {  
   $pwdcorrect=  
                                     (crypt($upass,$contentpwd) eq $contentpwd);  
       }  
       elsif (-e $pwauth_path) {  
   open PWAUTH, "|$pwauth_path" or  
       die "Cannot invoke authentication";  
   print PWAUTH "$uname\n$upass\n";  
   close PWAUTH;  
   $pwdcorrect=!$?;  
       }  
                           } elsif ($howpwd eq 'krb4') {  
                              $null=pack("C",0);  
      unless ($upass=~/$null/) {  
                               $pwdcorrect=(  
                                  Authen::Krb4::get_pw_in_tkt($uname,"",  
                                         $contentpwd,'krbtgt',$contentpwd,1,  
      $upass) == 0);  
      } else { $pwdcorrect=0; }  
                           } elsif ($howpwd eq 'localauth') {  
     $pwdcorrect=&localauth::localauth($uname,$upass,  
       $contentpwd);  
   }  
                           if ($pwdcorrect) {  
                              print $client "authorized\n";  
                           } else {  
                              print $client "non_authorized\n";  
                           }    
        } else {  
                           print $client "unknown_user\n";  
                        }  
      } else {  
        print $client "refused\n";  
      }  
 # ---------------------------------------------------------------------- passwd  
                    } elsif ($userinput =~ /^passwd/) {  
      if ($wasenc==1) {  
                        my   
                        ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);  
                        chomp($npass);  
                        $upass=&unescape($upass);  
                        $npass=&unescape($npass);  
        &logthis("Trying to change password for $uname");  
        my $proname=propath($udom,$uname);  
                        my $passfilename="$proname/passwd";  
                        if (-e $passfilename) {  
    my $realpasswd;  
                           { my $pf = IO::File->new($passfilename);  
     $realpasswd=<$pf>; }  
                           chomp($realpasswd);  
                           my ($howpwd,$contentpwd)=split(/:/,$realpasswd);  
                           if ($howpwd eq 'internal') {  
    if (crypt($upass,$contentpwd) eq $contentpwd) {  
      my $salt=time;  
                              $salt=substr($salt,6,2);  
      my $ncpass=crypt($npass,$salt);  
                              { my $pf = IO::File->new(">$passfilename");  
           print $pf "internal:$ncpass\n"; }               
      &logthis("Result of password change for $uname: pwchange_success");  
                              print $client "ok\n";  
                            } else {  
                              print $client "non_authorized\n";  
                            }  
                           } elsif ($howpwd eq 'unix') {  
       # Unix means we have to access /etc/password  
       # one way or another.  
       # First: Make sure the current password is  
       #        correct  
       $contentpwd=(getpwnam($uname))[1];  
       my $pwdcorrect = "0";  
       my $pwauth_path="/usr/local/sbin/pwauth";  
       unless ($contentpwd eq 'x') {  
   $pwdcorrect=  
                                     (crypt($upass,$contentpwd) eq $contentpwd);  
       } elsif (-e $pwauth_path) {  
   open PWAUTH, "|$pwauth_path" or  
       die "Cannot invoke authentication";  
   print PWAUTH "$uname\n$upass\n";  
   close PWAUTH;  
   $pwdcorrect=!$?;  
       }  
      if ($pwdcorrect) {  
  my $execdir=$perlvar{'lonDaemons'};  
  my $pf = IO::File->new("|$execdir/lcpasswd");  
  print $pf "$uname\n$npass\n$npass\n";  
  close $pf;  
  my $result = ($?>0 ? 'pwchange_failure'   
        : 'ok');  
  &logthis("Result of password change for $uname: $result");  
  print $client "$result\n";  
      } else {  
  print $client "non_authorized\n";  
      }  
   } else {  
                             print $client "auth_mode_error\n";  
                           }    
        } else {  
                           print $client "unknown_user\n";  
                        }  
      } else {  
        print $client "refused\n";  
      }  
 # -------------------------------------------------------------------- makeuser  
                    } elsif ($userinput =~ /^makeuser/) {  
      Debug("Make user received");  
                 my $oldumask=umask(0077);  
      if ($wasenc==1) {  
                        my   
                        ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);  
        &Debug("cmd =".$cmd." $udom =".$udom.  
     " uname=".$uname);  
                        chomp($npass);  
                        $npass=&unescape($npass);  
                        my $proname=propath($udom,$uname);  
                        my $passfilename="$proname/passwd";  
        &Debug("Password file created will be:".  
     $passfilename);  
                        if (-e $passfilename) {  
    print $client "already_exists\n";  
                        } elsif ($udom ne $perlvar{'lonDefDomain'}) {  
                            print $client "not_right_domain\n";  
                        } else {  
                            @fpparts=split(/\//,$proname);  
                            $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];  
                            $fperror='';  
                            for ($i=3;$i<=$#fpparts;$i++) {  
                                $fpnow.='/'.$fpparts[$i];   
                                unless (-e $fpnow) {  
    unless (mkdir($fpnow,0777)) {  
                                       $fperror="error:$!";  
                                    }  
                                }  
                            }  
                            unless ($fperror) {  
      if ($umode eq 'krb4') {  
                                {   
                                  my $pf = IO::File->new(">$passfilename");  
             print $pf "krb4:$npass\n";   
                                }               
                                print $client "ok\n";  
                              } elsif ($umode eq 'internal') {  
        my $salt=time;  
                                $salt=substr($salt,6,2);  
        my $ncpass=crypt($npass,$salt);  
                                {   
  &Debug("Creating internal auth");  
  my $pf = IO::File->new(">$passfilename");  
             print $pf "internal:$ncpass\n";   
                                }  
                                print $client "ok\n";  
      } elsif ($umode eq 'localauth') {  
        {  
  my $pf = IO::File->new(">$passfilename");  
             print $pf "localauth:$npass\n";  
        }  
        print $client "ok\n";  
      } elsif ($umode eq 'unix') {  
        {  
  my $execpath="$perlvar{'lonDaemons'}/".  
               "lcuseradd";  
  {  
      &Debug("Executing external: ".  
   $execpath);  
      my $se = IO::File->new("|$execpath");  
      print $se "$uname\n";  
      print $se "$npass\n";  
      print $se "$npass\n";  
  }  
                                  my $pf = IO::File->new(">$passfilename");  
             print $pf "unix:\n";   
        }  
        print $client "ok\n";  
      } elsif ($umode eq 'none') {  
                                {   
                                  my $pf = IO::File->new(">$passfilename");  
             print $pf "none:\n";   
                                }               
                                print $client "ok\n";  
                              } else {  
                                print $client "auth_mode_error\n";  
                              }    
                            } else {  
                                print $client "$fperror\n";  
                            }  
                        }  
      } else {  
        print $client "refused\n";  
      }  
      umask($oldumask);  
 # -------------------------------------------------------------- changeuserauth  
                    } elsif ($userinput =~ /^changeuserauth/) {  
        &Debug("Changing authorization");  
       if ($wasenc==1) {  
                        my   
                        ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);  
                        chomp($npass);  
        &Debug("cmd = ".$cmd." domain= ".$udom.  
       "uname =".$uname." umode= ".$umode);  
                        $npass=&unescape($npass);  
                        my $proname=propath($udom,$uname);  
                        my $passfilename="$proname/passwd";  
        if ($udom ne $perlvar{'lonDefDomain'}) {  
                            print $client "not_right_domain\n";  
                        } else {  
    if ($umode eq 'krb4') {  
                                {   
    my $pf = IO::File->new(">$passfilename");  
    print $pf "krb4:$npass\n";   
                                }               
                                print $client "ok\n";  
    } elsif ($umode eq 'internal') {  
        my $salt=time;  
                                $salt=substr($salt,6,2);  
        my $ncpass=crypt($npass,$salt);  
                                {   
    my $pf = IO::File->new(">$passfilename");  
    print $pf "internal:$ncpass\n";   
                                }  
                                print $client "ok\n";  
    } elsif ($umode eq 'localauth') {  
        {  
    my $pf = IO::File->new(">$passfilename");  
    print $pf "localauth:$npass\n";  
        }  
        print $client "ok\n";  
    } elsif ($umode eq 'unix') {  
        {  
    my $execpath="$perlvar{'lonDaemons'}/".  
        "lcuseradd";  
    {  
        my $se = IO::File->new("|$execpath");  
        print $se "$uname\n";  
        print $se "$npass\n";  
        print $se "$npass\n";  
    }  
    my $pf = IO::File->new(">$passfilename");  
    print $pf "unix:\n";   
        }  
        print $client "ok\n";  
    } elsif ($umode eq 'none') {  
                                {   
    my $pf = IO::File->new(">$passfilename");  
    print $pf "none:\n";   
                                }               
                                print $client "ok\n";  
    } else {  
                                print $client "auth_mode_error\n";  
    }    
                        }  
      } else {  
        print $client "refused\n";  
      }  
 # ------------------------------------------------------------------------ home  
                    } elsif ($userinput =~ /^home/) {  
                        my ($cmd,$udom,$uname)=split(/:/,$userinput);  
                        chomp($uname);  
                        my $proname=propath($udom,$uname);  
                        if (-e $proname) {  
                           print $client "found\n";  
                        } else {  
   print $client "not_found\n";  
                        }  
 # ---------------------------------------------------------------------- update  
                    } elsif ($userinput =~ /^update/) {  
                        my ($cmd,$fname)=split(/:/,$userinput);  
                        my $ownership=ishome($fname);  
                        if ($ownership eq 'not_owner') {  
                         if (-e $fname) {  
                           my ($dev,$ino,$mode,$nlink,  
                               $uid,$gid,$rdev,$size,  
                               $atime,$mtime,$ctime,  
                               $blksize,$blocks)=stat($fname);  
                           $now=time;  
                           $since=$now-$atime;  
                           if ($since>$perlvar{'lonExpire'}) {  
                               $reply=  
                                     reply("unsub:$fname","$hostid{$clientip}");  
                               unlink("$fname");  
                           } else {  
      my $transname="$fname.in.transfer";  
                              my $remoteurl=  
                                     reply("sub:$fname","$hostid{$clientip}");  
                              my $response;  
                               {  
                              my $ua=new LWP::UserAgent;  
                              my $request=new HTTP::Request('GET',"$remoteurl");  
                              $response=$ua->request($request,$transname);  
       }  
                              if ($response->is_error()) {  
  unlink($transname);  
                                  my $message=$response->status_line;  
                                  &logthis(  
                                   "LWP GET: $message for $fname ($remoteurl)");  
                              } else {  
                          if ($remoteurl!~/\.meta$/) {  
                                   my $ua=new LWP::UserAgent;  
                                   my $mrequest=  
                                    new HTTP::Request('GET',$remoteurl.'.meta');  
                                   my $mresponse=  
                                    $ua->request($mrequest,$fname.'.meta');  
                                   if ($mresponse->is_error()) {  
                     unlink($fname.'.meta');  
                                   }  
                          }  
                                  rename($transname,$fname);  
      }  
                           }  
                           print $client "ok\n";  
                         } else {  
                           print $client "not_found\n";  
                         }  
        } else {  
  print $client "rejected\n";  
                        }  
 # -------------------------------------- fetch a user file from a remote server  
                    } elsif ($userinput =~ /^fetchuserfile/) {  
                       my ($cmd,$fname)=split(/:/,$userinput);  
       my ($udom,$uname,$ufile)=split(/\//,$fname);  
                       my $udir=propath($udom,$uname).'/userfiles';  
                       unless (-e $udir) { mkdir($udir,0770); }  
                        if (-e $udir) {  
                        $ufile=~s/^[\.\~]+//;  
                        $ufile=~s/\///g;  
                        my $transname=$udir.'/'.$ufile;  
                        my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;  
                              my $response;  
                               {  
                              my $ua=new LWP::UserAgent;  
                              my $request=new HTTP::Request('GET',"$remoteurl");  
                              $response=$ua->request($request,$transname);  
       }  
                              if ($response->is_error()) {  
  unlink($transname);  
                                  my $message=$response->status_line;  
                                  &logthis(  
                                   "LWP GET: $message for $fname ($remoteurl)");  
  print $client "failed\n";  
                              } else {  
                                  print $client "ok\n";  
                              }  
                      } else {  
                        print $client "not_home\n";  
                      }   
 # ------------------------------------------ authenticate access to a user file  
                    } elsif ($userinput =~ /^tokenauthuserfile/) {  
                        my ($cmd,$fname,$session)=split(/:/,$userinput);  
                        chomp($session);  
                        $reply='non_auth';  
                        if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.  
                                       $session.'.id')) {  
                         while ($line=<ENVIN>) {  
    if ($line=~/userfile\.$fname\=/) { $reply='ok'; }  
                         }  
                         close(ENVIN);  
                         print $client $reply."\n";  
        } else {  
  print $client "invalid_token\n";  
                        }  
 # ----------------------------------------------------------------- unsubscribe  
                    } elsif ($userinput =~ /^unsub/) {  
                        my ($cmd,$fname)=split(/:/,$userinput);  
                        if (-e $fname) {  
    print $client &unsub($client,$fname,$clientip);  
                        } else {  
    print $client "not_found\n";  
                        }  
 # ------------------------------------------------------------------- subscribe  
                    } elsif ($userinput =~ /^sub/) {  
        print $client &subscribe($userinput,$clientip);  
 # ------------------------------------------------------------------------- log  
                    } elsif ($userinput =~ /^log/) {  
                        my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);  
                        chomp($what);  
                        my $proname=propath($udom,$uname);  
                        my $now=time;  
                        {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/activity.log")) {   
                             print $hfh "$now:$hostid{$clientip}:$what\n";  
                             print $client "ok\n";   
  } else {  
                             print $client "error:$!\n";  
         }  
        }  
 # ------------------------------------------------------------------------- put  
                    } elsif ($userinput =~ /^put/) {  
                       my ($cmd,$udom,$uname,$namespace,$what)  
                           =split(/:/,$userinput);  
                       $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);  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {  
                            foreach $pair (@pairs) {  
        ($key,$value)=split(/=/,$pair);  
                                $hash{$key}=$value;  
                            }  
    if (untie(%hash)) {  
                               print $client "ok\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
       } else {  
                           print $client "refused\n";  
                       }  
 # -------------------------------------------------------------------- rolesput  
                    } elsif ($userinput =~ /^rolesput/) {  
        &Debug("rolesput");  
     if ($wasenc==1) {  
                        my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  
                           =split(/:/,$userinput);  
        &Debug("cmd = ".$cmd." exedom= ".$exedom.  
     "user = ".$exeuser." udom=".$udom.  
     "what = ".$what);  
                        my $namespace='roles';  
                        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);  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {  
                            foreach $pair (@pairs) {  
        ($key,$value)=split(/=/,$pair);  
        &ManagePermissions($key, $udom, $uname,  
   &GetAuthType( $udom,   
  $uname));  
                                $hash{$key}=$value;  
          
                            }  
    if (untie(%hash)) {  
                               print $client "ok\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
       } else {  
                           print $client "refused\n";  
                       }  
 # ------------------------------------------------------------------------- get  
                    } elsif ($userinput =~ /^get/) {  
                        my ($cmd,$udom,$uname,$namespace,$what)  
                           =split(/:/,$userinput);  
                        $namespace=~s/\//\_/g;  
                        $namespace=~s/\W//g;  
                        chomp($what);  
                        my @queries=split(/\&/,$what);  
                        my $proname=propath($udom,$uname);  
                        my $qresult='';  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {  
                            for ($i=0;$i<=$#queries;$i++) {  
                                $qresult.="$hash{$queries[$i]}&";  
                            }  
    if (untie(%hash)) {  
               $qresult=~s/\&$//;  
                               print $client "$qresult\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ------------------------------------------------------------------------ eget  
                    } elsif ($userinput =~ /^eget/) {  
                        my ($cmd,$udom,$uname,$namespace,$what)  
                           =split(/:/,$userinput);  
                        $namespace=~s/\//\_/g;  
                        $namespace=~s/\W//g;  
                        chomp($what);  
                        my @queries=split(/\&/,$what);  
                        my $proname=propath($udom,$uname);  
                        my $qresult='';  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {  
                            for ($i=0;$i<=$#queries;$i++) {  
                                $qresult.="$hash{$queries[$i]}&";  
                            }  
    if (untie(%hash)) {  
               $qresult=~s/\&$//;  
                               if ($cipher) {  
                                 my $cmdlength=length($qresult);  
                                 $qresult.="         ";  
                                 my $encqresult='';  
                                 for   
  (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  
                                  $encqresult.=  
                                  unpack("H16",  
                                  $cipher->encrypt(substr($qresult,$encidx,8)));  
                                 }  
                                 print $client "enc:$cmdlength:$encqresult\n";  
       } else {  
         print $client "error:no_key\n";  
                               }  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ------------------------------------------------------------------------- del  
                    } elsif ($userinput =~ /^del/) {  
                        my ($cmd,$udom,$uname,$namespace,$what)  
                           =split(/:/,$userinput);  
                        $namespace=~s/\//\_/g;  
                        $namespace=~s/\W//g;  
                        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);  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {  
                            foreach $key (@keys) {  
                                delete($hash{$key});  
                            }  
    if (untie(%hash)) {  
                               print $client "ok\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ------------------------------------------------------------------------ keys  
                    } elsif ($userinput =~ /^keys/) {  
                        my ($cmd,$udom,$uname,$namespace)  
                           =split(/:/,$userinput);  
                        $namespace=~s/\//\_/g;  
                        $namespace=~s/\W//g;  
                        my $proname=propath($udom,$uname);  
                        my $qresult='';  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {  
                            foreach $key (keys %hash) {  
                                $qresult.="$key&";  
                            }  
    if (untie(%hash)) {  
               $qresult=~s/\&$//;  
                               print $client "$qresult\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ------------------------------------------------------------------------ dump  
                    } elsif ($userinput =~ /^dump/) {  
                        my ($cmd,$udom,$uname,$namespace,$regexp)  
                           =split(/:/,$userinput);  
                        $namespace=~s/\//\_/g;  
                        $namespace=~s/\W//g;  
                        if (defined($regexp)) {  
                           $regexp=&unescape($regexp);  
        } else {  
                           $regexp='.';  
        }  
                        my $proname=propath($udom,$uname);  
                        my $qresult='';  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {  
                            foreach $key (keys %hash) {  
                                if (eval('$key=~/$regexp/')) {  
                                   $qresult.="$key=$hash{$key}&";  
        }  
                            }  
    if (untie(%hash)) {  
               $qresult=~s/\&$//;  
                               print $client "$qresult\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ----------------------------------------------------------------------- store  
                    } elsif ($userinput =~ /^store/) {  
                       my ($cmd,$udom,$uname,$namespace,$rid,$what)  
                           =split(/:/,$userinput);  
                       $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:$rid:$what\n"; }  
        }  
                        my @pairs=split(/\&/,$what);  
                            
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) {  
                            my @previouskeys=split(/&/,$hash{"keys:$rid"});  
                            my $key;  
                            $hash{"version:$rid"}++;  
                            my $version=$hash{"version:$rid"};  
                            my $allkeys='';   
                            foreach $pair (@pairs) {  
        ($key,$value)=split(/=/,$pair);  
                                $allkeys.=$key.':';  
                                $hash{"$version:$rid:$key"}=$value;  
                            }  
                            $hash{"$version:$rid:timestamp"}=$now;  
                            $allkeys.='timestamp';  
                            $hash{"$version:keys:$rid"}=$allkeys;  
    if (untie(%hash)) {  
                               print $client "ok\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
       } else {  
                           print $client "refused\n";  
                       }  
 # --------------------------------------------------------------------- restore  
                    } elsif ($userinput =~ /^restore/) {  
                        my ($cmd,$udom,$uname,$namespace,$rid)  
                           =split(/:/,$userinput);  
                        $namespace=~s/\//\_/g;  
                        $namespace=~s/\W//g;  
                        chomp($rid);  
                        my $proname=propath($udom,$uname);  
                        my $qresult='';  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) {  
                   my $version=$hash{"version:$rid"};  
                            $qresult.="version=$version&";  
                            my $scope;  
                            for ($scope=1;$scope<=$version;$scope++) {  
       my $vkeys=$hash{"$scope:keys:$rid"};  
                               my @keys=split(/:/,$vkeys);  
                               my $key;  
                               $qresult.="$scope:keys=$vkeys&";  
                               foreach $key (@keys) {  
      $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";  
                               }                                    
                            }  
    if (untie(%hash)) {  
               $qresult=~s/\&$//;  
                               print $client "$qresult\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # -------------------------------------------------------------------- chatsend  
                    } elsif ($userinput =~ /^chatsend/) {  
                        my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);  
                        &chatadd($cdom,$cnum,$newpost);  
                        print $client "ok\n";  
 # -------------------------------------------------------------------- chatretr  
                    } elsif ($userinput =~ /^chatretr/) {  
                        my ($cmd,$cdom,$cnum)=split(/\:/,$userinput);  
                        my $reply='';  
                        foreach (&getchat($cdom,$cnum)) {  
    $reply.=&escape($_).':';  
                        }  
                        $reply=~s/\:$//;  
                        print $client $reply."\n";  
 # ------------------------------------------------------------------- querysend  
                    } elsif ($userinput =~ /^querysend/) {  
                        my ($cmd,$query,  
    $arg1,$arg2,$arg3)=split(/\:/,$userinput);  
        $query=~s/\n*$//g;  
        print $client "".  
        sqlreply("$hostid{$clientip}\&$query".  
  "\&$arg1"."\&$arg2"."\&$arg3")."\n";  
 # ------------------------------------------------------------------ queryreply  
                    } elsif ($userinput =~ /^queryreply/) {  
                        my ($cmd,$id,$reply)=split(/:/,$userinput);   
        my $store;  
                        my $execdir=$perlvar{'lonDaemons'};  
                        if ($store=IO::File->new(">$execdir/tmp/$id")) {  
    $reply=~s/\&/\n/g;  
    print $store $reply;  
    close $store;  
    my $store2=IO::File->new(">$execdir/tmp/$id.end");  
    print $store2 "done\n";  
    close $store2;  
    print $client "ok\n";  
        }  
        else {  
    print $client "error:$!\n";  
        }  
 # ----------------------------------------------------------------------- idput  
                    } elsif ($userinput =~ /^idput/) {  
                        my ($cmd,$udom,$what)=split(/:/,$userinput);  
                        chomp($what);  
                        $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);  
                  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) {  
                            foreach $pair (@pairs) {  
        ($key,$value)=split(/=/,$pair);  
                                $hash{$key}=$value;  
                            }  
    if (untie(%hash)) {  
                               print $client "ok\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ----------------------------------------------------------------------- idget  
                    } elsif ($userinput =~ /^idget/) {  
                        my ($cmd,$udom,$what)=split(/:/,$userinput);  
                        chomp($what);  
                        $udom=~s/\W//g;  
                        my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
                        my @queries=split(/\&/,$what);  
                        my $qresult='';  
                  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) {  
                            for ($i=0;$i<=$#queries;$i++) {  
                                $qresult.="$hash{$queries[$i]}&";  
                            }  
    if (untie(%hash)) {  
               $qresult=~s/\&$//;  
                               print $client "$qresult\n";  
                            } else {  
                               print $client "error:$!\n";  
                            }  
                        } else {  
                            print $client "error:$!\n";  
                        }  
 # ---------------------------------------------------------------------- tmpput  
                    } elsif ($userinput =~ /^tmpput/) {  
                        my ($cmd,$what)=split(/:/,$userinput);  
        my $store;  
                        $tmpsnum++;  
                        my $id=$$.'_'.$clientip.'_'.$tmpsnum;  
                        $id=~s/\W/\_/g;  
                        $what=~s/\n//g;  
                        my $execdir=$perlvar{'lonDaemons'};  
                        if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {  
    print $store $what;  
    close $store;  
    print $client "$id\n";  
        }  
        else {  
    print $client "error:$!\n";  
        }  
   
 # ---------------------------------------------------------------------- tmpget  
                    } elsif ($userinput =~ /^tmpget/) {  
                        my ($cmd,$id)=split(/:/,$userinput);  
                        chomp($id);  
                        $id=~s/\W/\_/g;  
                        my $store;  
                        my $execdir=$perlvar{'lonDaemons'};  
                        if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {  
                            my $reply=<$store>;  
    print $client "$reply\n";  
                            close $store;  
        }  
        else {  
    print $client "error:$!\n";  
        }  
   
 # -------------------------------------------------------------------------- ls  
                    } elsif ($userinput =~ /^ls/) {  
                        my ($cmd,$ulsdir)=split(/:/,$userinput);  
                        my $ulsout='';  
                        my $ulsfn;  
                        if (-e $ulsdir) {  
                            if(-d $ulsdir) {  
                                if (opendir(LSDIR,$ulsdir)) {  
                                    while ($ulsfn=readdir(LSDIR)) {  
                                        my @ulsstats=stat($ulsdir.'/'.$ulsfn);  
                                        $ulsout.=$ulsfn.'&'.  
                                                 join('&',@ulsstats).':';  
                                    }  
                                    closedir(LSDIR);  
                                }  
                            } else {  
                                my @ulsstats=stat($ulsdir);  
                                $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';  
                            }  
                        } else {  
                           $ulsout='no_such_dir';  
                        }  
                        if ($ulsout eq '') { $ulsout='empty'; }  
                        print $client "$ulsout\n";  
 # ------------------------------------------------------------------ Hanging up  
                    } elsif (($userinput =~ /^exit/) ||  
                             ($userinput =~ /^init/)) {  
                        &logthis(  
       "Client $clientip ($hostid{$clientip}) hanging up: $userinput");  
                        print $client "bye\n";  
                        $client->close();  
        last;  
 # ------------------------------------------------------------- unknown command  
                    } else {  
                        # unknown command  
                        print $client "unknown_cmd\n";  
                    }  
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
    alarm(0);  
                    &status('Listening to '.$hostid{$clientip});  
        }  
 # --------------------------------------------- client unknown or fishy, refuse  
             } else {  
         print $client "refused\n";  
                 $client->close();  
                 &logthis("<font color=blue>WARNING: "  
                 ."Rejected client $clientip, closing connection</font>");  
             }  
  }                
   
    &status('Listening to '.$clientname);
       }
   # --------------------------------------------- client unknown or fishy, refuse
    } else {
       print $client "refused\n";
       $client->close();
       &logthis("<font color=blue>WARNING: "
        ."Rejected client $clientip, closing connection</font>");
    }
       }             
       
 # =============================================================================  # =============================================================================
              
  &logthis("<font color=red>CRITICAL: "      &logthis("<font color=red>CRITICAL: "
  ."Disconnect from $clientip ($hostid{$clientip})</font>");           ."Disconnect from $clientip ($clientname)</font>");    
         # tidy up gracefully and finish      
           
         $server->close();      # this exit is VERY important, otherwise the child will become
       # a producer of more and more children, forking yourself into
         # this exit is VERY important, otherwise the child will become      # process death.
         # a producer of more and more children, forking yourself into      exit;
         # process death.      
         exit;  
     }  
 }  }
   
   
Line 1500  sub make_new_child { Line 4032  sub make_new_child {
 #    user      - Name of the user for which the role is being put.  #    user      - Name of the user for which the role is being put.
 #    authtype  - The authentication type associated with the user.  #    authtype  - The authentication type associated with the user.
 #  #
 sub ManagePermissions  sub ManagePermissions {
 {  
     my $request = shift;      my $request = shift;
     my $domain  = shift;      my $domain  = shift;
     my $user    = shift;      my $user    = shift;
     my $authtype= shift;      my $authtype= shift;
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
       &logthis("ruequest is $request");
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
  Debug("system $execdir/lchtmldir $userhome $system $authtype");   &logthis("system $execdir/lchtmldir $userhome $user $authtype");
  system("$execdir/lchtmldir $userhome $user $authtype");   system("$execdir/lchtmldir $userhome $user $authtype");
     }      }
 }  }
   
   #
   #  Return the full path of a user password file, whether it exists or not.
   # Parameters:
   #   domain     - Domain in which the password file lives.
   #   user       - name of the user.
   # Returns:
   #    Full passwd path:
   #
   sub PasswordPath {
       my $domain = shift;
       my $user   = shift;
   
       my $path   = &propath($domain, $user);
       $path  .= "/passwd";
   
       return $path;
   }
   
   #   Password Filename
   #   Returns the path to a passwd file given domain and user... only if
   #  it exists.
   # Parameters:
   #   domain    - Domain in which to search.
   #   user      - username.
   # Returns:
   #   - If the password file exists returns its path.
   #   - If the password file does not exist, returns undefined.
   #
   sub PasswordFilename {
       my $domain    = shift;
       my $user      = shift;
   
       Debug ("PasswordFilename called: dom = $domain user = $user");
   
       my $path  = PasswordPath($domain, $user);
       Debug("PasswordFilename got path: $path");
       if(-e $path) {
    return $path;
       } else {
    return undef;
       }
   }
   
   #
   #   Rewrite the contents of the user's passwd file.
   #  Parameters:
   #    domain    - domain of the user.
   #    name      - User's name.
   #    contents  - New contents of the file.
   # Returns:
   #   0    - Failed.
   #   1    - Success.
   #
   sub RewritePwFile {
       my $domain   = shift;
       my $user     = shift;
       my $contents = shift;
   
       my $file = PasswordFilename($domain, $user);
       if (defined $file) {
    my $pf = IO::File->new(">$file");
    if($pf) {
       print $pf "$contents\n";
       return 1;
    } else {
       return 0;
    }
       } else {
    return 0;
       }
   
   }
 #  #
 #   GetAuthType - Determines the authorization type of a user in a domain.  #   GetAuthType - Determines the authorization type of a user in a domain.
   
 #     Returns the authorization type or nouser if there is no such user.  #     Returns the authorization type or nouser if there is no such user.
 #  #
 sub GetAuthType   sub GetAuthType {
 {  
     my $domain = shift;      my $domain = shift;
     my $user   = shift;      my $user   = shift;
   
     Debug("GetAuthType( $domain, $user ) \n");      Debug("GetAuthType( $domain, $user ) \n");
     my $proname    = &propath($domain, $user);       my $passwdfile = PasswordFilename($domain, $user);
     my $passwdfile = "$proname/passwd";      if( defined $passwdfile ) {
     if( -e $passwdfile ) {  
  my $pf = IO::File->new($passwdfile);   my $pf = IO::File->new($passwdfile);
  my $realpassword = <$pf>;   my $realpassword = <$pf>;
  chomp($realpassword);   chomp($realpassword);
  Debug("Password info = $realpassword\n");   Debug("Password info = $realpassword\n");
  my ($authtype, $contentpwd) = split(/:/, $realpassword);   return $realpassword;
  Debug("Authtype = $authtype, content = $contentpwd\n");      } else {
  my $availinfo = '';  
  if($authtype eq 'krb4') {  
     $availinfo = $contentpwd;  
  }  
   
  return "$authtype:$availinfo";  
     }  
     else {  
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
     }      }
 }  }
   
   #
   #  Validate a user given their domain, name and password.  This utility
   #  function is used by both  AuthenticateHandler and ChangePasswordHandler
   #  to validate the login credentials of a user.
   # Parameters:
   #    $domain    - The domain being logged into (this is required due to
   #                 the capability for multihomed systems.
   #    $user      - The name of the user being validated.
   #    $password  - The user's propoposed password.
   #
   # Returns:
   #     1        - The domain,user,pasword triplet corresponds to a valid
   #                user.
   #     0        - The domain,user,password triplet is not a valid user.
   #
   sub ValidateUser {
       my $domain  = shift;
       my $user    = shift;
       my $password= shift;
   
       # Why negative ~pi you may well ask?  Well this function is about
       # authentication, and therefore very important to get right.
       # I've initialized the flag that determines whether or not I've 
       # validated correctly to a value it's not supposed to get.
       # At the end of this function. I'll ensure that it's not still that
       # value so we don't just wind up returning some accidental value
       # as a result of executing an unforseen code path that
       # did not set $validated.
   
       my $validated = -3.14159;
   
       #  How we authenticate is determined by the type of authentication
       #  the user has been assigned.  If the authentication type is
       #  "nouser", the user does not exist so we will return 0.
   
       my $contents = GetAuthType($domain, $user);
       my ($howpwd, $contentpwd) = split(/:/, $contents);
   
       my $null = pack("C",0); # Used by kerberos auth types.
   
       if ($howpwd ne 'nouser') {
   
    if($howpwd eq "internal") { # Encrypted is in local password file.
       $validated = (crypt($password, $contentpwd) eq $contentpwd);
    }
    elsif ($howpwd eq "unix") { # User is a normal unix user.
       $contentpwd = (getpwnam($user))[1];
       if($contentpwd) {
    if($contentpwd eq 'x') { # Shadow password file...
       my $pwauth_path = "/usr/local/sbin/pwauth";
       open PWAUTH,  "|$pwauth_path" or
    die "Cannot invoke authentication";
       print PWAUTH "$user\n$password\n";
       close PWAUTH;
       $validated = ! $?;
   
    } else {         # Passwords in /etc/passwd. 
       $validated = (crypt($password,
    $contentpwd) eq $contentpwd);
    }
       } else {
    $validated = 0;
       }
    }
    elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
       if(! ($password =~ /$null/) ) {
    my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
      "",
      $contentpwd,,
      'krbtgt',
      $contentpwd,
      1,
      $password);
    if(!$k4error) {
       $validated = 1;
    }
    else {
       $validated = 0;
       &logthis('krb4: '.$user.', '.$contentpwd.', '.
        &Authen::Krb4::get_err_txt($Authen::Krb4::error));
    }
       }
       else {
    $validated = 0; # Password has a match with null.
       }
    }
    elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
       if(!($password =~ /$null/)) { # Null password not allowed.
    my $krbclient = &Authen::Krb5::parse_name($user.'@'
     .$contentpwd);
    my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
    my $krbserver  = &Authen::Krb5::parse_name($krbservice);
    my $credentials= &Authen::Krb5::cc_default();
    $credentials->initialize($krbclient);
    my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,
    $krbserver,
    $password,
    $credentials);
    $validated = ($krbreturn == 1);
       }
       else {
    $validated = 0;
       }
    }
    elsif ($howpwd eq "localauth") { 
       #  Authenticate via installation specific authentcation method:
       $validated = &localauth::localauth($user, 
          $password, 
          $contentpwd);
    }
    else { # Unrecognized auth is also bad.
       $validated = 0;
    }
       } else {
    $validated = 0;
       }
       #
       #  $validated has the correct stat of the authentication:
       #
   
       unless ($validated != -3.14159) {
    die "ValidateUser - failed to set the value of validated";
       }
       return $validated;
   }
   
   #
   #    Add a line to the subscription list?
   #
 sub addline {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
     my $contents;      my $contents;
     my $found=0;      my $found=0;
     my $expr='^'.$hostid.':'.$ip.':';      my $expr='^'.$hostid.':'.$ip.':';
     $expr =~ s/\./\\\./g;      $expr =~ s/\./\\\./g;
       my $sh;
     if ($sh=IO::File->new("$fname.subscription")) {      if ($sh=IO::File->new("$fname.subscription")) {
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
     if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}      if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}
Line 1567  sub addline { Line 4291  sub addline {
     $sh->close();      $sh->close();
     return $found;      return $found;
 }  }
   #
   #    Get chat messages.
   #
 sub getchat {  sub getchat {
     my ($cdom,$cname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
     my @entries=();      my @entries=();
Line 1578  sub getchat { Line 4304  sub getchat {
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;   @entries=map { $_.':'.$hash{$_} } sort keys %hash;
  untie %hash;   untie %hash;
     }      }
     return @entries;      my @participants=();
       my $cutoff=time-60;
       if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",
       &GDBM_WRCREAT(),0640)) {
           $hash{$uname.':'.$udom}=time;
           foreach (sort keys %hash) {
       if ($hash{$_}>$cutoff) {
    $participants[$#participants+1]='active_participant:'.$_;
               }
           }
           untie %hash;
       }
       return (@participants,@entries);
 }  }
   #
   #   Add a chat message
   #
 sub chatadd {  sub chatadd {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
     my @entries=();      my @entries=();
       my $time=time;
     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",      if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",
     &GDBM_WRCREAT(),0640)) {      &GDBM_WRCREAT(),0640)) {
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;   @entries=map { $_.':'.$hash{$_} } sort keys %hash;
  my $time=time;  
  my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);   my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
  my ($thentime,$idnum)=split(/\_/,$lastid);   my ($thentime,$idnum)=split(/\_/,$lastid);
  my $newid=$time.'_000000';   my $newid=$time.'_000000';
Line 1609  sub chatadd { Line 4349  sub chatadd {
  }   }
  untie %hash;   untie %hash;
     }      }
       {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/chatroom.log")) { 
       print $hfh "$time:".&unescape($newchat)."\n";
    }
       }
 }  }
   
 sub unsub {  sub unsub {
     my ($fname,$clientip)=@_;      my ($fname,$clientip)=@_;
     my $result;      my $result;
     if (unlink("$fname.$hostid{$clientip}")) {      if (unlink("$fname.$clientname")) {
  $result="ok\n";   $result="ok\n";
     } else {      } else {
  $result="not_subscribed\n";   $result="not_subscribed\n";
     }      }
     if (-e "$fname.subscription") {      if (-e "$fname.subscription") {
  my $found=&addline($fname,$hostid{$clientip},$clientip,'');   my $found=&addline($fname,$clientname,$clientip,'');
  if ($found) { $result="ok\n"; }   if ($found) { $result="ok\n"; }
     } else {      } else {
  if ($result != "ok\n") { $result="not_subscribed\n"; }   if ($result != "ok\n") { $result="not_subscribed\n"; }
Line 1628  sub unsub { Line 4374  sub unsub {
     return $result;      return $result;
 }  }
   
   sub currentversion {
       my $fname=shift;
       my $version=-1;
       my $ulsdir='';
       if ($fname=~/^(.+)\/[^\/]+$/) {
    $ulsdir=$1;
       }
       my ($fnamere1,$fnamere2);
       # remove version if already specified
       $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/;
       # get the bits that go before and after the version number
       if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) {
    $fnamere1=$1;
    $fnamere2='.'.$2;
       }
       if (-e $fname) { $version=1; }
       if (-e $ulsdir) {
    if(-d $ulsdir) {
       if (opendir(LSDIR,$ulsdir)) {
    my $ulsfn;
    while ($ulsfn=readdir(LSDIR)) {
   # see if this is a regular file (ignore links produced earlier)
       my $thisfile=$ulsdir.'/'.$ulsfn;
       unless (-l $thisfile) {
    if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E$/) {
       if ($1>$version) { $version=$1; }
    }
       }
    }
    closedir(LSDIR);
    $version++;
       }
    }
       }
       return $version;
   }
   
   sub thisversion {
       my $fname=shift;
       my $version=-1;
       if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) {
    $version=$1;
       }
       return $version;
   }
   
 sub subscribe {  sub subscribe {
     my ($userinput,$clientip)=@_;      my ($userinput,$clientip)=@_;
     my $result;      my $result;
     my ($cmd,$fname)=split(/:/,$userinput);      my ($cmd,$fname)=split(/:/,$userinput);
     my $ownership=&ishome($fname);      my $ownership=&ishome($fname);
     if ($ownership eq 'owner') {      if ($ownership eq 'owner') {
   # explitly asking for the current version?
           unless (-e $fname) {
               my $currentversion=&currentversion($fname);
       if (&thisversion($fname)==$currentversion) {
                   if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
       my $root=$1;
                       my $extension=$2;
                       symlink($root.'.'.$extension,
                               $root.'.'.$currentversion.'.'.$extension);
                       unless ($extension=~/\.meta$/) {
    symlink($root.'.'.$extension.'.meta',
    $root.'.'.$currentversion.'.'.$extension.'.meta');
       }
                   }
               }
           }
  if (-e $fname) {   if (-e $fname) {
     if (-d $fname) {      if (-d $fname) {
  $result="directory\n";   $result="directory\n";
     } else {      } else {
  if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);}   if (-e "$fname.$clientname") {&unsub($fname,$clientip);}
  $now=time;   my $now=time;
  my $found=&addline($fname,$hostid{$clientip},$clientip,   my $found=&addline($fname,$clientname,$clientip,
    "$hostid{$clientip}:$clientip:$now\n");     "$clientname:$clientip:$now\n");
  if ($found) { $result="$fname\n"; }   if ($found) { $result="$fname\n"; }
  # if they were subscribed to only meta data, delete that   # if they were subscribed to only meta data, delete that
                 # subscription, when you subscribe to a file you also get                  # subscription, when you subscribe to a file you also get
Line 1659  sub subscribe { Line 4467  sub subscribe {
     }      }
     return $result;      return $result;
 }  }
   
   sub make_passwd_file {
       my ($uname, $umode,$npass,$passfilename)=@_;
       my $result="ok\n";
       if ($umode eq 'krb4' or $umode eq 'krb5') {
    {
       my $pf = IO::File->new(">$passfilename");
       print $pf "$umode:$npass\n";
    }
       } elsif ($umode eq 'internal') {
    my $salt=time;
    $salt=substr($salt,6,2);
    my $ncpass=crypt($npass,$salt);
    {
       &Debug("Creating internal auth");
       my $pf = IO::File->new(">$passfilename");
       print $pf "internal:$ncpass\n"; 
    }
       } elsif ($umode eq 'localauth') {
    {
       my $pf = IO::File->new(">$passfilename");
       print $pf "localauth:$npass\n";
    }
       } elsif ($umode eq 'unix') {
    #
    #  Don't allow the creation of privileged accounts!!! that would
    #  be real bad!!!
    #
    my $uid = getpwnam($uname);
    if((defined $uid) && ($uid == 0)) {
       &logthis(">>>Attempted add of privileged account blocked<<<");
       return "no_priv_account_error\n";
    }
   
    #
    my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
   
    &Debug("Executing external: ".$execpath);
    &Debug("user  = ".$uname.", Password =". $npass);
    my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
    print $se "$uname\n";
    print $se "$npass\n";
    print $se "$npass\n";
   
    my $useraddok = $?;
    if($useraddok > 0) {
       my $lcstring = lcuseraddstrerror($useraddok);
       &logthis("Failed lcuseradd: $lcstring");
       return "error: lcuseradd failed: $lcstring\n";
    }
    my $pf = IO::File->new(">$passfilename");
    print $pf "unix:\n";
    
       } elsif ($umode eq 'none') {
    {
       my $pf = IO::File->new(">$passfilename");
       print $pf "none:\n";
    }
       } else {
    $result="auth_mode_error\n";
       }
       return $result;
   }
   
   sub sethost {
       my ($remotereq) = @_;
       my (undef,$hostid)=split(/:/,$remotereq);
       if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
       if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
    $currenthostid=$hostid;
    $currentdomainid=$hostdom{$hostid};
    &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
       } else {
    &logthis("Requested host id $hostid not an alias of ".
    $perlvar{'lonHostID'}." refusing connection");
    return 'unable_to_set';
       }
       return 'ok';
   }
   
   sub version {
       my ($userinput)=@_;
       $remoteVERSION=(split(/:/,$userinput))[1];
       return "version:$VERSION";
   }
   ############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<<
   #There is a copy of this in lonnet.pm
   #   Can we hoist these lil' things out into common places?
   #
   sub userload {
       my $numusers=0;
       {
    opendir(LONIDS,$perlvar{'lonIDsDir'});
    my $filename;
    my $curtime=time;
    while ($filename=readdir(LONIDS)) {
       if ($filename eq '.' || $filename eq '..') {next;}
       my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
       if ($curtime-$mtime < 1800) { $numusers++; }
    }
    closedir(LONIDS);
       }
       my $userloadpercent=0;
       my $maxuserload=$perlvar{'lonUserLoadLim'};
       if ($maxuserload) {
    $userloadpercent=100*$numusers/$maxuserload;
       }
       $userloadpercent=sprintf("%.2f",$userloadpercent);
       return $userloadpercent;
   }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
 =head1 NAME  =head1 NAME
Line 1768  each connection is logged. Line 4687  each connection is logged.
   
 =item *  =item *
   
   SIGUSR2
   
   Parent Signal assignment:
       $SIG{USR2} = \&UpdateHosts
   
   Child signal assignment:
       NONE
   
   
   =item *
   
 SIGCHLD  SIGCHLD
   
 Parent signal assignment:  Parent signal assignment:
Line 1928  Send along temporarily stored informatio Line 4858  Send along temporarily stored informatio
   
 List part of a user's directory.  List part of a user's directory.
   
   =item pushtable
   
   Pushes a file in /home/httpd/lonTab directory.  Currently limited to:
   hosts.tab and domain.tab. The old file is copied to  *.tab.backup but
   must be restored manually in case of a problem with the new table file.
   pushtable requires that the request be encrypted and validated via
   ValidateManager.  The form of the command is:
   enc:pushtable tablename <tablecontents> \n
   where pushtable, tablename and <tablecontents> will be encrypted, but \n is a 
   cleartext newline.
   
 =item Hanging up (exit or init)  =item Hanging up (exit or init)
   
 What to do when a client tells the server that they (the client)  What to do when a client tells the server that they (the client)
Line 1938  are leaving the network. Line 4879  are leaving the network.
 If B<lond> is sent an unknown command (not in the list above),  If B<lond> is sent an unknown command (not in the list above),
 it replys to the client "unknown_cmd".  it replys to the client "unknown_cmd".
   
   
 =item UNKNOWN CLIENT  =item UNKNOWN CLIENT
   
 If the anti-spoofing algorithm cannot verify the client,  If the anti-spoofing algorithm cannot verify the client,
Line 1957  Crypt::IDEA Line 4899  Crypt::IDEA
 LWP::UserAgent()  LWP::UserAgent()
 GDBM_File  GDBM_File
 Authen::Krb4  Authen::Krb4
   Authen::Krb5
   
 =head1 COREQUISITES  =head1 COREQUISITES
   

Removed from v.1.89  
changed lines
  Added in v.1.178.2.18


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>