[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.178.2.16 and 1.220

version 1.178.2.16, 2004/04/15 11:26:34 version 1.220, 2004/08/02 11:02:02
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
 #  #
Line 45  use Authen::Krb4; Line 45  use Authen::Krb4;
 use Authen::Krb5;  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
   use localenroll;
 use File::Copy;  use File::Copy;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
   use LONCAPA::lonlocal;
   use LONCAPA::lonssl;
   
 my $DEBUG = 1;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
   
 my $VERSION='$Revision$'; #' stupid emacs  my $VERSION='$Revision$'; #' stupid emacs
 my $remoteVERSION;  my $remoteVERSION;
 my $currenthostid;  my $currenthostid="default";
 my $currentdomainid;  my $currentdomainid;
   
 my $client;  my $client;
 my $clientip;  my $clientip; # IP address of client.
 my $clientname;  my $clientdns; # DNS name of client.
   my $clientname; # LonCAPA name of client.
 my $cipher; # Cipher key negotiated with client.  
 my $tmpsnum = 0;; # Id of tmpputs.  
   
 my $server;  my $server;
 my $thisserver;  my $thisserver; # DNS of us.
   
   my $keymode;
   
   my $cipher; # Cipher key negotiated with client
   my $tmpsnum = 0; # Id of tmpputs.
   
 #   # 
 #   Connection type is:  #   Connection type is:
Line 77  my $thisserver; Line 83  my $thisserver;
   
 my $ConnectionType;  my $ConnectionType;
   
 my %hostid;  my %hostid; # ID's for hosts in cluster by ip.
 my %hostdom;  my %hostdom; # LonCAPA domain for hosts in cluster.
 my %hostip;  my %hostip; # IPs for hosts in cluster.
   my %hostdns; # ID's of hosts looked up by DNS name.
   
 my %managers; # Ip -> manager names  my %managers; # Ip -> manager names
   
Line 98  my $CLIENT_OK  = 1; Line 105  my $CLIENT_OK  = 1;
 my $MANAGER_OK = 2;  my $MANAGER_OK = 2;
 my %Dispatcher;  my %Dispatcher;
   
   
 #  #
 #  The array below are password error strings."  #  The array below are password error strings."
 #  #
Line 135  my @adderrors    = ("ok", Line 143  my @adderrors    = ("ok",
     "lcuseradd Could not add user.",      "lcuseradd Could not add user.",
     "lcuseradd Password mismatch");      "lcuseradd Password mismatch");
   
   
   
 #  #
 #   Statistics that are maintained and dislayed in the status line.  #   Statistics that are maintained and dislayed in the status line.
 #  #
 my $Transactions; # Number of attempted transactions.  my $Transactions = 0; # Number of attempted transactions.
 my $Failures; # Number of transcations failed.  my $Failures     = 0; # Number of transcations failed.
   
 #   ResetStatistics:   #   ResetStatistics: 
 #      Resets the statistics counters:  #      Resets the statistics counters:
Line 149  sub ResetStatistics { Line 159  sub ResetStatistics {
     $Failures     = 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  #   LocalConnection
 #  Parameters:  #     Completes the formation of a locally authenticated connection.
 #     input      - Encoded data.  #     This function will ensure that the 'remote' client is really the
 #  Returns:  #     local host.  If not, the connection is closed, and the function fails.
 #     Decoded data or undef if encryption key was not yet negotiated.  #     If so, initcmd is parsed for the name of a file containing the
 #  Implicit input:  #     IDEA session key.  The fie is opened, read, deleted and the session
 #     cipher  - This global holds the negotiated encryption key.  #     key returned to the caller.
 #  #
 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:  # Parameters:
 #      $cmd    - the actual keyword that invoked us.  #   $Socket      - Socket open on client.
 #      $tail   - the tail of the request that invoked us.  #   $initcmd     - The full text of the init command.
 #      $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:  # Implicit inputs:
 #     whatever the userload() function requires.  #    $clientdns  - The DNS name of the remote client.
 #  Implicit outputs:  #    $thisserver - Our DNS name.
 #     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   # Returns:
 #   to us.  We pick apart the command and pass it on to the subs  #     IDEA session key on success.
 #   that already exist to do this.  #     undef on failure.
 #  #
 # Parameters:  sub LocalConnection {
 #      $cmd    - the actual keyword that invoked us.      my ($Socket, $initcmd) = @_;
 #      $tail   - the tail of the request that invoked us.      Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");
 #      $client - File descriptor connected to the client      if($clientdns ne $thisserver) {
 #  Returns:   &logthis('<font color="red"> LocalConnection rejecting non local: '
 #      1       - Ok to continue processing.   ."$clientdns ne $thisserver </font>");
 #      0       - Program should exit   close $Socket;
 # Implicit Output:   return undef;
 #    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 {      else {
  Reply( $client, "non_authorized\n", $userinput);   chomp($initcmd); # Get rid of \n in filename.
     }   my ($init, $type, $name) = split(/:/, $initcmd);
    Debug(" Init command: $init $type $name ");
     return 1;  
 }   # Require that $init = init, and $type = local:  Otherwise
 RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);   # the caller is insane:
   
 #   if(($init ne "init") && ($type ne "local")) {
 #   Create a new user.  User in this case means a lon-capa user.      &logthis('<font color = "red"> LocalConnection: caller is insane! '
 #   The user must either already exist in some authentication realm       ."init = $init, and type = $type </font>");
 #   like kerberos or the /etc/passwd.  If not, a user completely local to      close($Socket);;
 #   this loncapa system is created.      return undef;
 #  
 # 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 {   #  Now get the key filename:
  Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
  "while attempting dump\n", $userinput);  
     }  
   
     return 1;   my $IDEAKey = lonlocal::ReadKeyFile($name);
 }   return $IDEAKey;
 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.  #  SSLConnection
 #  #   Completes the formation of an ssh authenticated connection. The
 #  Parameters:  #   socket is promoted to an ssl socket.  If this promotion and the associated
 #     $cmd               - Command keyword.  #   certificate exchange are successful, the IDEA key is generated and sent
 #     $tail              - Remainder of the request which consists of:  #   to the remote peer via the SSL tunnel. The IDEA key is also returned to
 #                          domain/user   - User and auth. domain.  #   the caller after the SSL tunnel is torn down.
 #                          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:  # Parameters:
 #    $cmd                - Request keyword.  #   Name              Type             Purpose
 #    $tail               - Tail of the command. A colon separated list  #   $Socket          IO::Socket::INET  Plaintext socket.
 #                          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:  # Returns:
 #    1     - continue processing  #    IDEA key on success.
 # Side effects:  #    undef on failure.
 #    Response is written to the client.  
 #  #
 sub RetrieveChatHandler {  sub SSLConnection {
     my $cmd      = shift;      my $Socket   = shift;
     my $tail     = shift;  
     my $client   = shift;  
   
     my $userinput = "$cmd:$tail";  
   
     my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);      Debug("SSLConnection: ");
     my $reply='';      my $KeyFile         = lonssl::KeyFile();
     foreach (&getchat($cdom,$cnum,$udom,$uname)) {      if(!$KeyFile) {
  $reply.=&escape($_).':';   my $err = lonssl::LastError();
    &logthis("<font color=\"red\"> CRITICAL"
    ."Can't get key file $err </font>");
    return undef;
     }      }
     $reply=~s/\:$//;      my ($CACertificate,
     Reply($client, $reply."\n", $userinput);   $Certificate) = lonssl::CertificateFile();
   
   
     return 1;      # If any of the key, certificate or certificate authority 
 }      # certificate filenames are not defined, this can't work.
 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";      if((!$Certificate) || (!$CACertificate)) {
    my $err = lonssl::LastError();
     my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);   &logthis("<font color=\"red\"> CRITICAL"
     $query=~s/\n*$//g;   ."Can't get certificates: $err </font>");
     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);    return undef;
     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);  
     }      }
        Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");
   
     return 1;      # Indicate to our peer that we can procede with
 }      # a transition to ssl authentication:
 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";      print $Socket "ok:ssl\n";
   
     my ($udom, $what) = split(/:/, $tail);  
     chomp($what);  
     my $now=time;  
     my @pairs=split(/\&/,$what);  
   
     my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());      Debug("Approving promotion -> ssl");
     if ($hashref) {      #  And do so:
  foreach my $pair (@pairs) {  
     my ($key,$value)=split(/=/,$pair);      my $SSLSocket = lonssl::PromoteServerSocket($Socket,
     $hashref->{$key}=$value.':'.$now;   $CACertificate,
  }   $Certificate,
  if (untie(%$hashref)) {   $KeyFile);
     Reply($client, "ok\n", $userinput);      if(! ($SSLSocket) ) { # SSL socket promotion failed.
  } else {   my $err = lonssl::LastError();
     Failure( $client, "error: ".($!+0)   &logthis("<font color=\"red\"> CRITICAL "
      ." untie(GDBM) Failed ".   ."SSL Socket promotion failed: $err </font>");
      "while attempting courseidput\n", $userinput);   return undef;
  }  
     } else {  
  Failure( $client, "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting courseidput\n", $userinput);  
     }      }
       Debug("SSL Promotion successful");
   
     return 1;      # 
 }      #  The only thing we'll use the socket for is to send the IDEA key
 RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0);      #  to the peer:
   
 #  Retrieves the value of a course id resource keyword pattern      my $Key = lonlocal::CreateCipherKey();
 #  defined since a starting date.  Both the starting date and the      print $SSLSocket "$Key\n";
 #  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";      lonssl::Close($SSLSocket); 
   
     my ($udom,$since,$description) =split(/:/,$tail);      Debug("Key exchange complete: $Key");
     if (defined($description)) {  
  $description=&unescape($description);  
     } else {  
  $description='.';  
     }  
     unless (defined($since)) { $since=0; }  
     my $qresult='';  
   
     my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());      return $Key;
     if ($hashref) {  
  while (my ($key,$value) = each(%$hashref)) {  
     my ($descr,$lasttime)=split(/\:/,$value);  
     if ($lasttime<$since) {   
  next;   
     }  
     if ($description eq '.') {  
  $qresult.=$key.'='.$descr.'&';  
     } else {  
  my $unescapeVal = &unescape($descr);  
  if (eval('$unescapeVal=~/$description/i')) {  
     $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.   #     InsecureConnection: 
   #        If insecure connections are allowd,
   #        exchange a challenge with the client to 'validate' the
   #        client (not really, but that's the protocol):
   #        We produce a challenge string that's sent to the client.
   #        The client must then echo the challenge verbatim to us.
 #  #
 #  Parameters:  #  Parameter:
 #   $cmd     - The command that triggered us.  #      Socket      - Socket open on the client.
 #   $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:  #  Returns:
 #    1   - Continue processing.  #      1           - success.
 #  Side effects:  #      0           - failure (e.g.mismatch or insecure not allowed).
 #     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 {  sub InsecureConnection {
     my $cmd    = shift;      my $Socket  =  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.  
   
       #   Don't even start if insecure connections are not allowed.
   
     my $store;      if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed.
     $tmpsnum++;   return 0;
     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);  
   
       #   Fabricate a challenge string and send it..
   
     return 1;      my $challenge = "$$".time; # pid + time.
 }      print $Socket "$challenge\n";
 RegisterHandler("ls", \&LsHandler, 0, 1, 0);      &status("Waiting for challenge reply");
   
       my $answer = <$Socket>;
 #      $answer    =~s/\W//g;
 #   Processes the setannounce command.  This command      if($challenge eq $answer) {
 #   creates a file named announce.txt in the top directory of   return 1;
 #   the documentn root and sets its contents.  The announce.txt file is      } 
 #   printed in its entirety at the LonCAPA login page.  Note:      else {
 #   once the announcement.txt fileis created it cannot be deleted.   logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
 #   However, setting the contents of the file to empty removes the   &status("No challenge reqply");
 #   announcement from the login page of loncapa so who cares.   return 0;
 #  
 # 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,  #   GetCertificate: Given a transaction that requires a certificate,
 #   this function will extract the certificate from the transaction  #   this function will extract the certificate from the transaction
Line 2751  sub GetCertificate { Line 350  sub GetCertificate {
     return $clientip;      return $clientip;
 }  }
   
   #
   #   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"));
   }
   
   
 #  #
Line 2765  sub ReadManagerTable { Line 376  sub ReadManagerTable {
   
     #   Clean out the old table first..      #   Clean out the old table first..
   
     foreach my $key (keys %managers) {     foreach my $key (keys %managers) {
  delete $managers{$key};        delete $managers{$key};
     }     }
   
     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
     if (!open (MANAGERS, $tablename)) {     if (!open (MANAGERS, $tablename)) {
  logthis('<font color="red">No manager table.  Nobody can manage!!</font>');        logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
  return;        return;
     }     }
     while(my $host = <MANAGERS>) {     while(my $host = <MANAGERS>) {
  chomp($host);        chomp($host);
  if ($host =~ "^#") {                  # Comment line.        if ($host =~ "^#") {                  # Comment line.
     logthis('<font color="green"> Skipping line: '. "$host</font>\n");           next;
     next;        }
  }        if (!defined $hostip{$host}) { # This is a non cluster member
  if (!defined $hostip{$host}) { # This is a non cluster member  
     #  The entry is of the form:      #  The entry is of the form:
     #    cluname:hostname      #    cluname:hostname
     #  cluname - A 'cluster hostname' is needed in order to negotiate      #  cluname - A 'cluster hostname' is needed in order to negotiate
     #            the host key.      #            the host key.
     #  hostname- The dns name of the host.      #  hostname- The dns name of the host.
     #      #
     my($cluname, $dnsname) = split(/:/, $host);            my($cluname, $dnsname) = split(/:/, $host);
                 
     my $ip = gethostbyname($dnsname);            my $ip = gethostbyname($dnsname);
     if(defined($ip)) {                 # bad names don't deserve entry.            if(defined($ip)) {                 # bad names don't deserve entry.
  my $hostip = inet_ntoa($ip);              my $hostip = inet_ntoa($ip);
  $managers{$hostip} = $cluname;              $managers{$hostip} = $cluname;
  logthis('<font color="green"> registering manager '.              logthis('<font color="green"> registering manager '.
  "$dnsname as $cluname with $hostip </font>\n");                      "$dnsname as $cluname with $hostip </font>\n");
     }           }
  } else {        } else {
     logthis('<font color="green"> existing host'." $host</font>\n");           logthis('<font color="green"> existing host'." $host</font>\n");
     $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber           $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber
  }        }
     }     }
 }  }
   
 #  #
Line 2827  sub ValidManager { Line 437  sub ValidManager {
 #     1   - Success.  #     1   - Success.
 #  #
 sub CopyFile {  sub CopyFile {
     my $oldfile = shift;  
     my $newfile = shift;      my ($oldfile, $newfile) = @_;
   
     #  The file must exist:      #  The file must exist:
   
     if(-e $oldfile) {      if(-e $oldfile) {
   
  # Read the old file.   # Read the old file.
   
  my $oldfh = IO::File->new("< $oldfile");   my $oldfh = IO::File->new("< $oldfile");
  if(!$oldfh) {   if(!$oldfh) {
Line 2887  sub AdjustHostContents { Line 497  sub AdjustHostContents {
     my $adjusted;      my $adjusted;
     my $me        = $perlvar{'lonHostID'};      my $me        = $perlvar{'lonHostID'};
   
     foreach my $line (split(/\n/,$contents)) {   foreach my $line (split(/\n/,$contents)) {
  if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {   if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
     chomp($line);      chomp($line);
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);      my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
     if ($id eq $me) {      if ($id eq $me) {
  my $ip = gethostbyname($name);            my $ip = gethostbyname($name);
  my $ipnew = inet_ntoa($ip);            my $ipnew = inet_ntoa($ip);
  $ip = $ipnew;           $ip = $ipnew;
  #  Reconstruct the host line and append to adjusted:   #  Reconstruct the host line and append to adjusted:
   
  my $newline = "$id:$domain:$role:$name:$ip";     my $newline = "$id:$domain:$role:$name:$ip";
  if($maxcon ne "") { # Not all hosts have loncnew tuning params     if($maxcon ne "") { # Not all hosts have loncnew tuning params
     $newline .= ":$maxcon:$idleto:$mincon";       $newline .= ":$maxcon:$idleto:$mincon";
  }     }
  $adjusted .= $newline."\n";     $adjusted .= $newline."\n";
   
     } else { # Not me, pass unmodified.        } else { # Not me, pass unmodified.
  $adjusted .= $line."\n";     $adjusted .= $line."\n";
     }        }
  } else {                  # Blank or comment never re-written.   } else {                  # Blank or comment never re-written.
     $adjusted .= $line."\n"; # Pass blanks and comments as is.      $adjusted .= $line."\n"; # Pass blanks and comments as is.
  }   }
     }   }
     return $adjusted;   return $adjusted;
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
Line 2928  sub AdjustHostContents { Line 538  sub AdjustHostContents {
 #      0       - failure and $! has an errno.  #      0       - failure and $! has an errno.
 #  #
 sub InstallFile {  sub InstallFile {
     my $Filename = shift;  
     my $Contents = shift;      my ($Filename, $Contents) = @_;
     my $TempFile = $Filename.".tmp";      my $TempFile = $Filename.".tmp";
   
     #  Open the file for write:      #  Open the file for write:
       
     my $fh = IO::File->new("> $TempFile"); # Write to temp.      my $fh = IO::File->new("> $TempFile"); # Write to temp.
     if(!(defined $fh)) {      if(!(defined $fh)) {
  &logthis('<font color="red"> Unable to create '.$TempFile."</font>");   &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
  return 0;   return 0;
     }      }
     #  write the contents of the file:      #  write the contents of the file:
       
     print $fh ($Contents);       print $fh ($Contents); 
     $fh->close; # In case we ever have a filesystem w. locking      $fh->close; # In case we ever have a filesystem w. locking
   
Line 2952  sub InstallFile { Line 562  sub InstallFile {
   
     return 1;      return 1;
 }  }
   
   
 #  #
 #   ConfigFileFromSelector: converts a configuration file selector  #   ConfigFileFromSelector: converts a configuration file selector
 #                 (one of host or domain at this point) into a   #                 (one of host or domain at this point) into a 
Line 3023  sub PushFile { Line 635  sub PushFile {
  return "error:$!";   return "error:$!";
     }      }
     &logthis('<font color="green"> Pushfile: backed up '      &logthis('<font color="green"> Pushfile: backed up '
      .$tablefile." to $backupfile</font>");      .$tablefile." to $backupfile</font>");
           
     #  If the file being pushed is the host file, we adjust the entry for ourself so that the      #  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      #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible
Line 3039  sub PushFile { Line 651  sub PushFile {
   
     if(!InstallFile($tablefile, $contents)) {      if(!InstallFile($tablefile, $contents)) {
  &logthis('<font color="red"> Pushfile: unable to install '   &logthis('<font color="red"> Pushfile: unable to install '
  .$tablefile." $! </font>");   .$tablefile." $! </font>");
  return "error:$!";   return "error:$!";
     } else {      }
       else {
  &logthis('<font color="green"> Installed new '.$tablefile   &logthis('<font color="green"> Installed new '.$tablefile
  ."</font>");   ."</font>");
   
     }      }
   
   
Line 3165  sub isValidEditCommand { Line 778  sub isValidEditCommand {
 #                  file being edited.  #                  file being edited.
 #  #
 sub ApplyEdit {  sub ApplyEdit {
     my $directive   = shift;  
     my $editor      = shift;      my ($directive, $editor) = @_;
   
     # Break the directive down into its command and its parameters      # Break the directive down into its command and its parameters
     # (at most two at this point.  The meaning of the parameters, if in fact      # (at most two at this point.  The meaning of the parameters, if in fact
Line 3181  sub ApplyEdit { Line 794  sub ApplyEdit {
     } elsif ($command eq "delete") {      } elsif ($command eq "delete") {
  $editor->DeleteLine($p1);         # p1 - key p2 null.   $editor->DeleteLine($p1);         # p1 - key p2 null.
     } else {          # Should not get here!!!      } else {          # Should not get here!!!
  die "Invalid command given to ApplyEdit $command";   die "Invalid command given to ApplyEdit $command"
     }      }
 }  }
 #  #
Line 3250  sub AdjustOurHost { Line 863  sub AdjustOurHost {
 #        editor     - Editor containing the file.  #        editor     - Editor containing the file.
 #  #
 sub ReplaceConfigFile {  sub ReplaceConfigFile {
     my $filename  = shift;      
     my $editor    = shift;      my ($filename, $editor) = @_;
   
     CopyFile ($filename, $filename.".old");      CopyFile ($filename, $filename.".old");
   
Line 3320  sub EditFile { Line 933  sub EditFile {
   
     return "ok\n";      return "ok\n";
 }  }
   
   #---------------------------------------------------------------
   #
   # Manipulation of hash based databases (factoring out common code
   # for later use as we refactor.
   #
   #  Ties a domain level resource file to a hash.
   #  If requested a history entry is created in the associated hist file.
   #
   #  Parameters:
   #     domain    - Name of the domain in which the resource file lives.
   #     namespace - Name of the hash within that domain.
   #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
   #     loghead   - Optional parameter, if present a log entry is created
   #                 in the associated history file and this is the first part
   #                  of that entry.
   #     logtail   - Goes along with loghead,  The actual logentry is of the
   #                 form $loghead:<timestamp>:logtail.
   # Returns:
   #    Reference to a hash bound to the db file or alternatively undef
   #    if the tie failed.
   #
   sub tie_domain_hash {
       my ($domain,$namespace,$how,$loghead,$logtail) = @_;
       
       # Filter out any whitespace in the domain name:
       
       $domain =~ s/\W//g;
       
       # We have enough to go on to tie the hash:
       
       my $user_top_dir   = $perlvar{'lonUsersDir'};
       my $domain_dir     = $user_top_dir."/$domain";
       my $resource_file  = $domain_dir."/$namespace.db";
       my %hash;
       if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {
    if (defined($loghead)) { # Need to log the operation.
       my $logFh = IO::File->new(">>$domain_dir/$namespace.hist");
       if($logFh) {
    my $timestamp = time;
    print $logFh "$loghead:$timestamp:$logtail\n";
       }
       $logFh->close;
    }
    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 tie_user_hash {
       my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
   
       $namespace=~s/\//\_/g; # / -> _
       $namespace=~s/\W//g; # whitespace eliminated.
       my $proname     = propath($domain, $user);
      
       #  Tie the database.
       
       my %hash;
       if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
      $how, 0640)) {
    # If this is a namespace for which a history is kept,
    # make the history log entry:    
    if (($namespace =~/^nohist\_/) && (defined($loghead))) {
       my $args = scalar @_;
       Debug(" Opening history: $namespace $args");
       my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
       if($hfh) {
    my $now = time;
    print $hfh "$loghead:$now:$what\n";
       }
       $hfh->close;
    }
    return \%hash;
       } else {
    return undef;
       }
       
   }
   
   #--------------------- 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 ping_handler {
       my ($cmd, $tail, $client) = @_;
       Debug("$cmd $tail $client .. $currenthostid:");
      
       Reply( $client,"$currenthostid\n","$cmd:$tail");
      
       return 1;
   }
   &register_handler("ping", \&ping_handler, 0, 1, 1);       # Ping unencoded, client or manager.
   
   #++
   #
   # Handles pong requests.  Pong replies with our current host id, and
   #                         the results of a ping sent to us via our lonc.
   #
   # 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 pong_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
       my $reply=&reply("ping",$clientname);
       &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
       return 1;
   }
   &register_handler("pong", \&pong_handler, 0, 1, 1);       # Pong unencoded, client or manager
   
   #++
   #      Called to establish an encrypted session key with the remote client.
   #      Note that with secure lond, in most cases this function is never
   #      invoked.  Instead, the secure session key is established either
   #      via a local file that's locked down tight and only lives for a short
   #      time, or via an ssl tunnel...and is generated from a bunch-o-random
   #      bits from /dev/urandom, rather than the predictable pattern used by
   #      by this sub.  This sub is only used in the old-style insecure
   #      key negotiation.
   # 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 establish_key_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
       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;
   
   }
   &register_handler("ekey", \&establish_key_handler, 0, 1,1);
   
   
   #     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 load_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
      # 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;
   }
   register_handler("load", \&load_handler, 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 user_load_handler {
       my ($cmd, $tail, $replyfd) = @_;
   
       my $userloadpercent=&userload();
       &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
       
       return 1;
   }
   register_handler("userload", \&user_load_handler, 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 user_authorization_type {
       my ($cmd, $tail, $replyfd) = @_;
      
       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;
   }
   &register_handler("currentauth", \&user_authorization_type, 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 push_file_handler {
       my ($cmd, $tail, $client) = @_;
   
       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);
       } 
       return 1;
   }
   &register_handler("pushfile", \&push_file_handler, 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 reinit_process_handler {
       my ($cmd, $tail, $client) = @_;
      
       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;
   }
   
   &register_handler("reinit", \&reinit_process_handler, 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 edit_table_handler {
       my ($command, $tail, $client) = @_;
      
       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;
   }
   register_handler("edit", \&edit_table_handler, 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 authenticate_handler {
       my ($cmd, $tail, $client) = @_;
   
       
       #  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 = &validate_user($udom, $uname, $upass);
       if($pwdcorrect) {
    &Reply( $client, "authorized\n", $userinput);
    #
    #  Bad credentials: Failed to authorize
    #
       } else {
    &Failure( $client, "non_authorized\n", $userinput);
       }
   
       return 1;
   }
   
   register_handler("auth", \&authenticate_handler, 1, 1, 0);
   
   #---------------------------------------------------------------
   #
   #   Getting, decoding and dispatching requests:
   #
   
   #
   #   Get a Request:
   #   Gets a Request message from the client.  The transaction
   #   is defined as a 'line' of text.  We remove the new line
   #   from the text line.  
   #   
   sub get_request {
       my $input = <$client>;
       chomp($input);
   
       Debug("get_request: Request = $input\n");
   
       &status('Processing '.$clientname.':'.$input);
   
       return $input;
   }
   #---------------------------------------------------------------
   #
   #  Process a request.  This sub should shrink as each action
   #  gets farmed out into a separat sub that is registered 
   #  with the dispatch hash.  
   #
   # Parameters:
   #    user_input   - The request received from the client (lonc).
   # Returns:
   #    true to keep processing, false if caller should exit.
   #
   sub process_request {
       my ($userinput) = @_;      # Easier for now to break style than to
                                   # fix all the userinput -> user_input.
       my $wasenc    = 0; # True if request was encrypted.
   # ------------------------------------------------------------ See if encrypted
       if ($userinput =~ /^enc/) {
    $userinput = decipher($userinput);
    $wasenc=1;
    if(!$userinput) { # Cipher not defined.
       &Failure($client, "error: Encrypted data without negotated key");
       return 0;
    }
       }
       Debug("process_request: $userinput\n");
       
       #  
       #   The 'correct way' to add a command to lond is now to
       #   write a sub to execute it and Add it to the command dispatch
       #   hash via a call to register_handler..  The comments to that
       #   sub should give you enough to go on to show how to do this
       #   along with the examples that are building up as this code
       #   is getting refactored.   Until all branches of the
       #   if/elseif monster below have been factored out into
       #   separate procesor subs, if the dispatch hash is missing
       #   the command keyword, we will fall through to the remainder
       #   of the if/else chain below in order to keep this thing in 
       #   working order throughout the transmogrification.
   
       my ($command, $tail) = split(/:/, $userinput, 2);
       chomp($command);
       chomp($tail);
       $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
       $command =~ s/(\r)//; # And this too for parameterless commands.
       if(!$tail) {
    $tail =""; # defined but blank.
       }
   
       &Debug("Command received: $command, encoded = $wasenc");
   
       if(defined $Dispatcher{$command}) {
   
    my $dispatch_info = $Dispatcher{$command};
    my $handler       = $$dispatch_info[0];
    my $need_encode   = $$dispatch_info[1];
    my $client_types  = $$dispatch_info[2];
    Debug("Matched dispatch hash: mustencode: $need_encode "
         ."ClientType $client_types");
         
    #  Validate the request:
         
    my $ok = 1;
    my $requesterprivs = 0;
    if(&isClient()) {
       $requesterprivs |= $CLIENT_OK;
    }
    if(&isManager()) {
       $requesterprivs |= $MANAGER_OK;
    }
    if($need_encode && (!$wasenc)) {
       Debug("Must encode but wasn't: $need_encode $wasenc");
       $ok = 0;
    }
    if(($client_types & $requesterprivs) == 0) {
       Debug("Client not privileged to do this operation");
       $ok = 0;
    }
   
    if($ok) {
       Debug("Dispatching to handler $command $tail");
       my $keep_going = &$handler($command, $tail, $client);
       return $keep_going;
    } else {
       Debug("Refusing to dispatch because client did not match requirements");
       Failure($client, "refused\n", $userinput);
       return 1;
    }
   
       }    
   
   #------------------- Commands not yet in spearate handlers. --------------
   
   
   # ---------------------------------------------------------------------- passwd
       if ($userinput =~ /^passwd/) { # encoded and client
    if (($wasenc==1) && isClient) {
       my 
    ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);
       chomp($npass);
       $upass=&unescape($upass);
       $npass=&unescape($npass);
       &Debug("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') {
       &Debug("internal auth");
       if (crypt($upass,$contentpwd) eq $contentpwd) {
    my $salt=time;
    $salt=substr($salt,6,2);
    my $ncpass=crypt($npass,$salt);
    {
       my $pf;
       if ($pf = IO::File->new(">$passfilename")) {
    print $pf "internal:$ncpass\n";
    &logthis("Result of password change for $uname: pwchange_success");
    print $client "ok\n";
       } else {
    &logthis("Unable to open $uname passwd to change password");
    print $client "non_authorized\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
       &Debug("auth is unix");
       $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;
    &Debug("exited pwauth with $? ($uname,$upass) ");
    $pwdcorrect=($? == 0);
       }
       if ($pwdcorrect) {
    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($?));
    print $client "$result\n";
       } else {
    print $client "non_authorized\n";
       }
    } else {
       print $client "auth_mode_error\n";
    }  
       } else {
    print $client "unknown_user\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # -------------------------------------------------------------------- makeuser
       } elsif ($userinput =~ /^makeuser/) { # encoded and client.
    &Debug("Make user received");
    my $oldumask=umask(0077);
    if (($wasenc==1) && isClient) {
       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 $currentdomainid) {
    print $client "not_right_domain\n";
       } else {
    my @fpparts=split(/\//,$proname);
    my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
    my $fperror='';
    for (my $i=3;$i<=$#fpparts;$i++) {
       $fpnow.='/'.$fpparts[$i]; 
       unless (-e $fpnow) {
    unless (mkdir($fpnow,0777)) {
       $fperror="error: ".($!+0)
    ." mkdir failed while attempting "
    ."makeuser";
    }
       }
    }
    unless ($fperror) {
       my $result=&make_passwd_file($uname, $umode,$npass,
    $passfilename);
       print $client $result;
    } else {
       print $client "$fperror\n";
    }
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
    umask($oldumask);
   # -------------------------------------------------------------- changeuserauth
       } elsif ($userinput =~ /^changeuserauth/) { # encoded & client
    &Debug("Changing authorization");
    if (($wasenc==1) && isClient) {
       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 $currentdomainid) {
    print $client "not_right_domain\n";
       } else {
    my $result=&make_passwd_file($uname, $umode,$npass,
        $passfilename);
    print $client $result;
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------ home
       } elsif ($userinput =~ /^home/) { # client clear or encoded
    if(isClient) {
       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";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ---------------------------------------------------------------------- update
       } elsif ($userinput =~ /^update/) { # client clear or encoded.
    if(isClient) {
       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);
       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;
    {
       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";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # -------------------------------------- fetch a user file from a remote server
       } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
    if(isClient) {
       my ($cmd,$fname)=split(/:/,$userinput);
       my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
       my $udir=propath($udom,$uname).'/userfiles';
       unless (-e $udir) { mkdir($udir,0770); }
       if (-e $udir) {
    $ufile=~s/^[\.\~]+//;
    my $path = $udir;
    if ($ufile =~m|(.+)/([^/]+)$|) {
       my @parts=split('/',$1);
       foreach my $part (@parts) {
    $path .= '/'.$part;
    if ((-e $path)!=1) {
       mkdir($path,0770);
    }
       }
    }
    my $destname=$udir.'/'.$ufile;
    my $transname=$udir.'/'.$ufile.'.in.transit';
    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 {
       if (!rename($transname,$destname)) {
    &logthis("Unable to move $transname to $destname");
    unlink($transname);
    print $client "failed\n";
       } else {
    print $client "ok\n";
       }
    }
       } else {
    print $client "not_home\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
    }
   # --------------------------------------------------------- remove a user file 
       } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
    if(isClient) {
       my ($cmd,$fname)=split(/:/,$userinput);
       my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
       &logthis("$udom - $uname - $ufile");
       if ($ufile =~m|/\.\./|) {
    # any files paths with /../ in them refuse 
    # to deal with
    print $client "refused\n";
       } else {
    my $udir=propath($udom,$uname);
    if (-e $udir) {
       my $file=$udir.'/userfiles/'.$ufile;
       if (-e $file) {
    unlink($file);
    if (-e $file) {
       print $client "failed\n";
    } else {
       print $client "ok\n";
    }
       } else {
    print $client "not_found\n";
       }
    } else {
       print $client "not_home\n";
    }
       }
    } else {
       Reply($client, "refused\n", $userinput);
    }
   # ------------------------------------------ authenticate access to a user file
       } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
    if(isClient) {
       my ($cmd,$fname,$session)=split(/:/,$userinput);
       chomp($session);
       my $reply='non_auth';
       if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
        $session.'.id')) {
    while (my $line=<ENVIN>) {
       if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
       }
    close(ENVIN);
    print $client $reply."\n";
       } else {
    print $client "invalid_token\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------- unsubscribe
       } elsif ($userinput =~ /^unsub/) {
    if(isClient) {
       my ($cmd,$fname)=split(/:/,$userinput);
       if (-e $fname) {
    print $client &unsub($fname,$clientip);
       } else {
    print $client "not_found\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------- subscribe
       } elsif ($userinput =~ /^sub/) {
    if(isClient) {
       print $client &subscribe($userinput,$clientip);
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------- current version
       } elsif ($userinput =~ /^currentversion/) {
    if(isClient) {
       my ($cmd,$fname)=split(/:/,$userinput);
       print $client &currentversion($fname)."\n";
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------- log
       } elsif ($userinput =~ /^log/) {
    if(isClient) {
       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:$clientname:$what\n";
       print $client "ok\n"; 
    } else {
       print $client "error: ".($!+0)
    ." IO::File->new Failed "
    ."while attempting log\n";
    }
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------- put
       } elsif ($userinput =~ /^put/) {
    if(isClient) {
       my ($cmd,$udom,$uname,$namespace,$what)
    =split(/:/,$userinput,5);
       $namespace=~s/\//\_/g;
       $namespace=~s/\W//g;
       if ($namespace ne 'roles') {
    chomp($what);
    my $proname=propath($udom,$uname);
    my $now=time;
    my @pairs=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',
    "$proname/$namespace.db",
    &GDBM_WRCREAT(),0640)) {
       unless ($namespace=~/^nohist\_/) {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
       }
       
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $hash{$key}=$value;
       }
       if (untie(%hash)) {
    print $client "ok\n";
       } else {
    print $client "error: ".($!+0)
       ." untie(GDBM) failed ".
       "while attempting put\n";
       }
    } else {
       print $client "error: ".($!)
    ." tie(GDBM) Failed ".
    "while attempting put\n";
    }
       } else {
    print $client "refused\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------- inc
       } elsif ($userinput =~ /^inc:/) {
    if(isClient) {
       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;
    my @pairs=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',
    "$proname/$namespace.db",
    &GDBM_WRCREAT(),0640)) {
       unless ($namespace=~/^nohist\_/) {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }
       }
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    # We could check that we have a number...
    if (! defined($value) || $value eq '') {
       $value = 1;
    }
    $hash{$key}+=$value;
       }
       if (untie(%hash)) {
    print $client "ok\n";
       } else {
    print $client "error: ".($!+0)
       ." untie(GDBM) failed ".
       "while attempting inc\n";
       }
    } else {
       print $client "error: ".($!)
    ." tie(GDBM) Failed ".
    "while attempting inc\n";
    }
       } else {
    print $client "refused\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # -------------------------------------------------------------------- rolesput
       } elsif ($userinput =~ /^rolesput/) {
    if(isClient) {
       &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 @pairs=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
       {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
       print $hfh "P:$now:$exedom:$exeuser:$what\n";
    }
       }
       
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    &ManagePermissions($key, $udom, $uname,
      &GetAuthType( $udom, 
    $uname));
    $hash{$key}=$value;
       }
       if (untie(%hash)) {
    print $client "ok\n";
       } else {
    print $client "error: ".($!+0)
       ." untie(GDBM) Failed ".
       "while attempting rolesput\n";
       }
    } else {
       print $client "error: ".($!+0)
    ." tie(GDBM) Failed ".
    "while attempting rolesput\n";
       }
       } else {
    print $client "refused\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # -------------------------------------------------------------------- rolesdel
       } elsif ($userinput =~ /^rolesdel/) {
    if(isClient) {
       &Debug("rolesdel");
       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 @rolekeys=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
       {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
       print $hfh "D:$now:$exedom:$exeuser:$what\n";
    }
       }
       foreach my $key (@rolekeys) {
    delete $hash{$key};
       }
       if (untie(%hash)) {
    print $client "ok\n";
       } else {
    print $client "error: ".($!+0)
       ." untie(GDBM) Failed ".
       "while attempting rolesdel\n";
       }
    } else {
       print $client "error: ".($!+0)
    ." tie(GDBM) Failed ".
    "while attempting rolesdel\n";
    }
       } else {
    print $client "refused\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------- get
       } elsif ($userinput =~ /^get/) {
    if(isClient) {
       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='';
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hash{$queries[$i]}&";
    }
    if (untie(%hash)) {
       $qresult=~s/\&$//;
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting get\n";
    }
       } else {
    if ($!+0 == 2) {
       print $client "error:No such file or ".
    "GDBM reported bad block error\n";
    } else {
       print $client "error: ".($!+0)
    ." tie(GDBM) Failed ".
    "while attempting get\n";
    }
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------ eget
       } elsif ($userinput =~ /^eget/) {
    if (isClient) {
       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='';
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
    for (my $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: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting eget\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting eget\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------- del
       } elsif ($userinput =~ /^del/) {
    if(isClient) {
       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;
       my @keys=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
    unless ($namespace=~/^nohist\_/) {
       my $hfh;
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }
    }
    foreach my $key (@keys) {
       delete($hash{$key});
    }
    if (untie(%hash)) {
       print $client "ok\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting del\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting del\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------------ keys
       } elsif ($userinput =~ /^keys/) {
    if(isClient) {
       my ($cmd,$udom,$uname,$namespace)
    =split(/:/,$userinput);
       $namespace=~s/\//\_/g;
       $namespace=~s/\W//g;
       my $proname=propath($udom,$uname);
       my $qresult='';
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
    foreach my $key (keys %hash) {
       $qresult.="$key&";
    }
    if (untie(%hash)) {
       $qresult=~s/\&$//;
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting keys\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting keys\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------- dumpcurrent
       } elsif ($userinput =~ /^currentdump/) {
    if (isClient) {
       my ($cmd,$udom,$uname,$namespace)
    =split(/:/,$userinput);
       $namespace=~s/\//\_/g;
       $namespace=~s/\W//g;
       my $qresult='';
       my $proname=propath($udom,$uname);
       my %hash;
       if (tie(%hash,'GDBM_File',
       "$proname/$namespace.db",
       &GDBM_READER(),0640)) {
       # 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 %data = ();
    while (my ($key,$value) = each(%hash)) {
       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(%hash)) {
       while (my ($symb,$param_hash) = each(%data)) {
    while(my ($param,$value) = each (%$param_hash)){
       next if ($param =~ /^v\./);
       $qresult.=$symb.':'.$param.'='.$value.'&';
    }
       }
       chop($qresult);
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting currentdump\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting currentdump\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
    }
   # ------------------------------------------------------------------------ dump
       } elsif ($userinput =~ /^dump/) {
    if(isClient) {
       my ($cmd,$udom,$uname,$namespace,$regexp)
    =split(/:/,$userinput);
       $namespace=~s/\//\_/g;
       $namespace=~s/\W//g;
       if (defined($regexp)) {
    $regexp=&unescape($regexp);
       } else {
    $regexp='.';
       }
       my $qresult='';
       my $proname=propath($udom,$uname);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
    while (my ($key,$value) = each(%hash)) {
       if ($regexp eq '.') {
    $qresult.=$key.'='.$value.'&';
       } else {
    my $unescapeKey = &unescape($key);
    if (eval('$unescapeKey=~/$regexp/')) {
       $qresult.="$key=$value&";
    }
       }
    }
    if (untie(%hash)) {
       chop($qresult);
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting dump\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting dump\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------------- store
       } elsif ($userinput =~ /^store/) {
    if(isClient) {
       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;
    my @pairs=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
       unless ($namespace=~/^nohist\_/) {
    my $hfh;
    if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
       print $hfh "P:$now:$rid:$what\n";
    }
       }
       my @previouskeys=split(/&/,$hash{"keys:$rid"});
       my $key;
       $hash{"version:$rid"}++;
       my $version=$hash{"version:$rid"};
       my $allkeys=''; 
       foreach my $pair (@pairs) {
    my ($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: ".($!+0)
       ." untie(GDBM) Failed ".
       "while attempting store\n";
    }
    } else {
       print $client "error: ".($!+0)
    ." tie(GDBM) Failed ".
    "while attempting store\n";
    }
       } else {
    print $client "refused\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # --------------------------------------------------------------------- restore
       } elsif ($userinput =~ /^restore/) {
    if(isClient) {
       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/\&$//;
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting restore\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting restore\n";
       }
    } else  {
       Reply($client, "refused\n", $userinput);
       
    }
   # -------------------------------------------------------------------- chatsend
       } elsif ($userinput =~ /^chatsend/) {
    if(isClient) {
       my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
       &chatadd($cdom,$cnum,$newpost);
       print $client "ok\n";
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # -------------------------------------------------------------------- chatretr
       } elsif ($userinput =~ /^chatretr/) {
    if(isClient) {
       my 
    ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);
       my $reply='';
       foreach (&getchat($cdom,$cnum,$udom,$uname)) {
    $reply.=&escape($_).':';
       }
       $reply=~s/\:$//;
       print $client $reply."\n";
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------- querysend
       } elsif ($userinput =~ /^querysend/) {
    if (isClient) {
       my ($cmd,$query,
    $arg1,$arg2,$arg3)=split(/\:/,$userinput);
       $query=~s/\n*$//g;
       print $client "".
    sqlreply("$clientname\&$query".
    "\&$arg1"."\&$arg2"."\&$arg3")."\n";
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------ queryreply
       } elsif ($userinput =~ /^queryreply/) {
    if(isClient) {
       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: ".($!+0)
       ." IO::File->new Failed ".
       "while attempting queryreply\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------- courseidput
       } elsif ($userinput =~ /^courseidput/) {
    if(isClient) {
       my ($cmd,$udom,$what)=split(/:/,$userinput);
       chomp($what);
    $udom=~s/\W//g;
       my $proname=
    "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
       my $now=time;
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
    foreach my $pair (@pairs) {
       my ($key,$descr,$inst_code)=split(/=/,$pair);
       $hash{$key}=$descr.':'.$inst_code.':'.$now;
    }
    if (untie(%hash)) {
       print $client "ok\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting courseidput\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting courseidput\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ---------------------------------------------------------------- courseiddump
       } elsif ($userinput =~ /^courseiddump/) {
    if(isClient) {
       my ($cmd,$udom,$since,$description)
    =split(/:/,$userinput);
       if (defined($description)) {
    $description=&unescape($description);
       } else {
    $description='.';
       }
       unless (defined($since)) { $since=0; }
       my $qresult='';
       my $proname=
    "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
    while (my ($key,$value) = each(%hash)) {
       my ($descr,$lasttime,$inst_code);
       if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {
    ($descr,$inst_code,$lasttime)=($1,$2,$3);
       } else {
    ($descr,$lasttime) = split(/\:/,$value);
       }
       if ($lasttime<$since) { next; }
       if ($description eq '.') {
    $qresult.=$key.'='.$descr.':'.$inst_code.'&';
       } else {
    my $unescapeVal = &unescape($descr);
    if (eval('$unescapeVal=~/\Q$description\E/i')) {
       $qresult.=$key.'='.$descr.':'.$inst_code.'&';
    }
       }
    }
    if (untie(%hash)) {
       chop($qresult);
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting courseiddump\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting courseiddump\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------------- idput
       } elsif ($userinput =~ /^idput/) {
    if(isClient) {
       my ($cmd,$udom,$what)=split(/:/,$userinput);
       chomp($what);
       $udom=~s/\W//g;
       my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
       my $now=time;
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
    {
       my $hfh;
       if ($hfh=IO::File->new(">>$proname.hist")) {
    print $hfh "P:$now:$what\n";
       }
    }
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       $hash{$key}=$value;
    }
    if (untie(%hash)) {
       print $client "ok\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting idput\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting idput\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------------- idget
       } elsif ($userinput =~ /^idget/) {
    if(isClient) {
       my ($cmd,$udom,$what)=split(/:/,$userinput);
       chomp($what);
       $udom=~s/\W//g;
       my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
       my @queries=split(/\&/,$what);
       my $qresult='';
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hash{$queries[$i]}&";
    }
    if (untie(%hash)) {
       $qresult=~s/\&$//;
       print $client "$qresult\n";
    } else {
       print $client "error: ".($!+0)
    ." untie(GDBM) Failed ".
    "while attempting idget\n";
    }
       } else {
    print $client "error: ".($!+0)
       ." tie(GDBM) Failed ".
       "while attempting idget\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ---------------------------------------------------------------------- tmpput
       } elsif ($userinput =~ /^tmpput/) {
    if(isClient) {
       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: ".($!+0)
       ."IO::File->new Failed ".
       "while attempting tmpput\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   
   # ---------------------------------------------------------------------- tmpget
       } elsif ($userinput =~ /^tmpget/) {
    if(isClient) {
       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: ".($!+0)
       ."IO::File->new Failed ".
       "while attempting tmpget\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ---------------------------------------------------------------------- tmpdel
       } elsif ($userinput =~ /^tmpdel/) {
    if(isClient) {
       my ($cmd,$id)=split(/:/,$userinput);
       chomp($id);
       $id=~s/\W/\_/g;
       my $execdir=$perlvar{'lonDaemons'};
       if (unlink("$execdir/tmp/$id.tmp")) {
    print $client "ok\n";
       } else {
    print $client "error: ".($!+0)
       ."Unlink tmp Failed ".
       "while attempting tmpdel\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------- portfolio directory list (portls)
       } elsif ($userinput =~ /^portls/) {
    if(isClient) {
       my ($cmd,$uname,$udom)=split(/:/,$userinput);
       my $udir=propath($udom,$uname).'/userfiles/portfolio';
       my $dirLine='';
       my $dirContents='';
       if (opendir(LSDIR,$udir.'/')){
    while ($dirLine = readdir(LSDIR)){
       $dirContents = $dirContents.$dirLine.'<br />';
    }
       } else {
    $dirContents = "No directory found\n";
       }
       print $client $dirContents."\n";
    } else {
       Reply($client, "refused\n", $userinput);
    }
   # -------------------------------------------------------------------------- ls
       } elsif ($userinput =~ /^ls/) {
    if(isClient) {
       my $obs;
       my $rights;
       my ($cmd,$ulsdir)=split(/:/,$userinput);
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
    if(-d $ulsdir) {
       if (opendir(LSDIR,$ulsdir)) {
    while ($ulsfn=readdir(LSDIR)) {
       undef $obs, $rights; 
       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
       #We do some obsolete checking here
       if(-e $ulsdir.'/'.$ulsfn.".meta") { 
    open(FILE, $ulsdir.'/'.$ulsfn.".meta");
    my @obsolete=<FILE>;
    foreach my $obsolete (@obsolete) {
       if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } 
       if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
    }
       }
       $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
       if($obs eq '1') { $ulsout.="&1"; }
       else { $ulsout.="&0"; }
       if($rights eq '1') { $ulsout.="&1:"; }
       else { $ulsout.="&0:"; }
    }
    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";
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ----------------------------------------------------------------- setannounce
       } elsif ($userinput =~ /^setannounce/) {
    if (isClient) {
       my ($cmd,$announcement)=split(/:/,$userinput);
       chomp($announcement);
       $announcement=&unescape($announcement);
       if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
    '/announcement.txt')) {
    print $store $announcement;
    close $store;
    print $client "ok\n";
       } else {
    print $client "error: ".($!+0)."\n";
       }
    } else {
       Reply($client, "refused\n", $userinput);
       
    }
   # ------------------------------------------------------------------ Hanging up
       } elsif (($userinput =~ /^exit/) ||
        ($userinput =~ /^init/)) { # no restrictions.
    &logthis(
    "Client $clientip ($clientname) hanging up: $userinput");
    print $client "bye\n";
    $client->shutdown(2);        # shutdown the socket forcibly.
    $client->close();
    return 0;
   
   # ---------------------------------- set current host/domain
       } elsif ($userinput =~ /^sethost:/) {
    if (isClient) {
       print $client &sethost($userinput)."\n";
    } else {
       print $client "refused\n";
    }
   #---------------------------------- request file (?) version.
       } elsif ($userinput =~/^version:/) {
    if (isClient) {
       print $client &version($userinput)."\n";
    } else {
       print $client "refused\n";
    }
   #------------------------------- is auto-enrollment enabled?
       } elsif ($userinput =~/^autorun:/) {
    if (isClient) {
       my ($cmd,$cdom) = split(/:/,$userinput);
       my $outcome = &localenroll::run($cdom);
       print $client "$outcome\n";
    } else {
       print $client "0\n";
    }
   #------------------------------- get official sections (for auto-enrollment).
       } elsif ($userinput =~/^autogetsections:/) {
    if (isClient) {
       my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
       my @secs = &localenroll::get_sections($coursecode,$cdom);
       my $seclist = &escape(join(':',@secs));
       print $client "$seclist\n";
    } else {
       print $client "refused\n";
    }
   #----------------------- validate owner of new course section (for auto-enrollment).
       } elsif ($userinput =~/^autonewcourse:/) {
    if (isClient) {
       my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
       my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
       print $client "$outcome\n";
    } else {
       print $client "refused\n";
    }
   #-------------- validate course section in schedule of classes (for auto-enrollment).
       } elsif ($userinput =~/^autovalidatecourse:/) {
    if (isClient) {
       my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
       my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
       print $client "$outcome\n";
    } else {
       print $client "refused\n";
    }
   #--------------------------- create password for new user (for auto-enrollment).
       } elsif ($userinput =~/^autocreatepassword:/) {
    if (isClient) {
       my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
       my ($create_passwd,$authchk);
       ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
       print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
    } else {
       print $client "refused\n";
    }
   #---------------------------  read and remove temporary files (for auto-enrollment).
       } elsif ($userinput =~/^autoretrieve:/) {
    if (isClient) {
       my ($cmd,$filename) = split(/:/,$userinput);
       my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
       if ( (-e $source) && ($filename ne '') ) {
    my $reply = '';
    if (open(my $fh,$source)) {
       while (<$fh>) {
    chomp($_);
    $_ =~ s/^\s+//g;
    $_ =~ s/\s+$//g;
    $reply .= $_;
       }
       close($fh);
       print $client &escape($reply)."\n";
   #                                unlink($source);
    } else {
       print $client "error\n";
    }
       } else {
    print $client "error\n";
       }
    } else {
       print $client "refused\n";
    }
   #---------------------  read and retrieve institutional code format (for support form).
       } elsif ($userinput =~/^autoinstcodeformat:/) {
    if (isClient) {
       my $reply;
       my($cmd,$cdom,$course) = split(/:/,$userinput);
       my @pairs = split/\&/,$course;
       my %instcodes = ();
       my %codes = ();
       my @codetitles = ();
       my %cat_titles = ();
       my %cat_order = ();
       foreach (@pairs) {
    my ($key,$value) = split/=/,$_;
    $instcodes{&unescape($key)} = &unescape($value);
       }
       my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);
       if ($formatreply eq 'ok') {
    my $codes_str = &hash2str(%codes);
    my $codetitles_str = &array2str(@codetitles);
    my $cat_titles_str = &hash2str(%cat_titles);
    my $cat_order_str = &hash2str(%cat_order);
    print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";
       }
    } else {
       print $client "refused\n";
    }
   # ------------------------------------------------------------- unknown command
   
       } else {
    # unknown command
    print $client "unknown_cmd\n";
       }
   # -------------------------------------------------------------------- complete
       Debug("process_request - returning 1");
       return 1;
   }
   #
   #   Decipher encoded traffic
   #  Parameters:
   #     input      - Encoded data.
   #  Returns:
   #     Decoded data or undef if encryption key was not yet negotiated.
   #  Implicit input:
   #     cipher  - This global holds the negotiated encryption key.
   #
   sub decipher {
       my ($input)  = @_;
       my $output = '';
       
       
       if($cipher) {
    my($enc, $enclength, $encinput) = split(/:/, $input);
    for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
       $output .= 
    $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
    }
    return substr($output, 0, $enclength);
       } else {
    return undef;
       }
   }
   
   #
   #   Register a command processor.  This function is invoked to register a sub
   #   to process a request.  Once registered, the ProcessRequest sub can automatically
   #   dispatch requests to an appropriate sub, and do the top level validity checking
   #   as well:
   #    - Is the keyword recognized.
   #    - Is the proper client type attempting the request.
   #    - Is the request encrypted if it has to be.
   #   Parameters:
   #    $request_name         - Name of the request being registered.
   #                           This is the command request that will match
   #                           against the hash keywords to lookup the information
   #                           associated with the dispatch information.
   #    $procedure           - Reference to a sub to call to process the request.
   #                           All subs get called as follows:
   #                             Procedure($cmd, $tail, $replyfd, $key)
   #                             $cmd    - the actual keyword that invoked us.
   #                             $tail   - the tail of the request that invoked us.
   #                             $replyfd- File descriptor connected to the client
   #    $must_encode          - True if the request must be encoded to be good.
   #    $client_ok            - True if it's ok for a client to request this.
   #    $manager_ok           - True if it's ok for a manager to request this.
   # Side effects:
   #      - On success, the Dispatcher hash has an entry added for the key $RequestName
   #      - On failure, the program will die as it's a bad internal bug to try to 
   #        register a duplicate command handler.
   #
   sub register_handler {
       my ($request_name,$procedure,$must_encode, $client_ok,$manager_ok)   = @_;
   
       #  Don't allow duplication#
      
       if (defined $Dispatcher{$request_name}) {
    die "Attempting to define a duplicate request handler for $request_name\n";
       }
       #   Build the client type mask:
       
       my $client_type_mask = 0;
       if($client_ok) {
    $client_type_mask  |= $CLIENT_OK;
       }
       if($manager_ok) {
    $client_type_mask  |= $MANAGER_OK;
       }
      
       #  Enter the hash:
         
       my @entry = ($procedure, $must_encode, $client_type_mask);
      
       $Dispatcher{$request_name} = \@entry;
      
      
   }
   
   
   #------------------------------------------------------------------
   
   
   
   
 #  #
 #  Convert an error return code from lcpasswd to a string value.  #  Convert an error return code from lcpasswd to a string value.
 #  #
Line 3350  sub catchexception { Line 3035  sub catchexception {
     $SIG{'QUIT'}='DEFAULT';      $SIG{'QUIT'}='DEFAULT';
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &status("Catching exception");      &status("Catching exception");
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $thisserver 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 3361  sub catchexception { Line 3046  sub catchexception {
   
 sub timeout {  sub timeout {
     &status("Handling Timeout");      &status("Handling Timeout");
     &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");      &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
     &catchexception('Timeout');      &catchexception('Timeout');
 }  }
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
Line 3378  undef $perlvarref; Line 3063  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!=$<) {
     my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";     my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
     my $subj="LON: $currenthostid 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 3390  if ($wwwid!=$<) { Line 3075  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"; }
 }  }
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
Line 3406  $server = IO::Socket::INET->new(LocalPor Line 3091  $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
   
 my %children               = ();       # keys are current child process IDs  my %children               = ();       # keys are current child process IDs
 my $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");      &status("Handling child death");
     my $pid = wait;      my $pid;
     if (defined($children{$pid})) {      do {
  &logthis("Child $pid died");   $pid = waitpid(-1,&WNOHANG());
  $children --;   if (defined($children{$pid})) {
  delete $children{$pid};      &logthis("Child $pid died");
     } else {      delete($children{$pid});
  &logthis("Unknown Child $pid died");   } elsif ($pid > 0) {
       &logthis("Unknown Child $pid died");
    }
       } while ( $pid > 0 );
       foreach my $child (keys(%children)) {
    $pid = waitpid($child,&WNOHANG());
    if ($pid > 0) {
       &logthis("Child $child - $pid looks like we missed it's death");
       delete($children{$pid});
    }
     }      }
     &status("Finished Handling child death");      &status("Finished Handling child death");
 }  }
Line 3436  sub HUNTSMAN {                      # si Line 3129  sub HUNTSMAN {                      # si
     &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");      &status("Done killing children");
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
Line 3446  sub HUPSMAN {                      # sig Line 3139  sub HUPSMAN {                      # sig
     &status("Killing children for restart (HUP)");      &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>");
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
     &status("Restarting self (HUP)");      &status("Restarting self (HUP)");
Line 3456  sub HUPSMAN {                      # sig Line 3149  sub HUPSMAN {                      # sig
 #  #
 #    Kill off hashes that describe the host table prior to re-reading it.  #    Kill off hashes that describe the host table prior to re-reading it.
 #    Hashes affected are:  #    Hashes affected are:
 #       %hostid, %hostdom %hostip  #       %hostid, %hostdom %hostip %hostdns.
 #  #
 sub KillHostHashes {  sub KillHostHashes {
     foreach my $key (keys %hostid) {      foreach my $key (keys %hostid) {
Line 3468  sub KillHostHashes { Line 3161  sub KillHostHashes {
     foreach my $key (keys %hostip) {      foreach my $key (keys %hostip) {
  delete $hostip{$key};   delete $hostip{$key};
     }      }
       foreach my $key (keys %hostdns) {
    delete $hostdns{$key};
       }
 }  }
 #  #
 #   Read in the host table from file and distribute it into the various hashes:  #   Read in the host table from file and distribute it into the various hashes:
Line 3478  sub KillHostHashes { Line 3174  sub KillHostHashes {
 sub ReadHostTable {  sub ReadHostTable {
   
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";      open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
           my $myloncapaname = $perlvar{'lonHostID'};
       Debug("My loncapa name is : $myloncapaname");
     while (my $configline=<CONFIG>) {      while (my $configline=<CONFIG>) {
  my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);   if (!($configline =~ /^\s*\#/)) {
  chomp($ip); $ip=~s/\D+$//;      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
  $hostid{$ip}=$id;      chomp($ip); $ip=~s/\D+$//;
  $hostdom{$id}=$domain;      $hostid{$ip}=$id;         # LonCAPA name of host by IP.
  $hostip{$id}=$ip;      $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
  if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      $hostip{$id}=$ip;      # IP address of host.
       $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
   
       if ($id eq $perlvar{'lonHostID'}) { 
    Debug("Found me in the host table: $name");
    $thisserver=$name; 
       }
    }
     }      }
     close(CONFIG);      close(CONFIG);
 }  }
Line 3554  sub checkchildren { Line 3258  sub checkchildren {
         }           } 
     }      }
     sleep 5;      sleep 5;
     $SIG{ALRM} = sub { die "timeout" };      $SIG{ALRM} = sub { Debug("timeout"); 
          die "timeout";  };
     $SIG{__DIE__} = 'DEFAULT';      $SIG{__DIE__} = 'DEFAULT';
     &status("Checking on the children (waiting for reports)");      &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") {
     eval {            eval {
  alarm(300);              alarm(300);
  &logthis('Child '.$_.' did not respond');      &logthis('Child '.$_.' did not respond');
  kill 9 => $_;      kill 9 => $_;
  #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";      #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
  #$subj="LON: $currenthostid killed lond process $_";      #$subj="LON: $currenthostid killed lond process $_";
  #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;      #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
  #$execdir=$perlvar{'lonDaemons'};      #$execdir=$perlvar{'lonDaemons'};
  #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;      #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
  alarm(0);      alarm(0);
     }    }
         }          }
     }      }
     $SIG{ALRM} = 'DEFAULT';      $SIG{ALRM} = 'DEFAULT';
Line 3605  sub Debug { Line 3310  sub Debug {
 #     reply   - Text to send to client.  #     reply   - Text to send to client.
 #     request - Original request from client.  #     request - Original request from client.
 #  #
 #  Note: This increments Transactions  
 #  
 sub Reply {  sub Reply {
     alarm(120);      my ($fd, $reply, $request) = @_;
     my $fd      = shift;  
     my $reply   = shift;  
     my $request = shift;  
   
     print $fd $reply;      print $fd $reply;
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
     $Transactions++;      $Transactions++;
     alarm(0);  
   
   
 }  }
   
   
 #  #
 #    Sub to report a failure.  #    Sub to report a failure.
 #    This function:  #    This function:
Line 3650  sub logstatus { Line 3350  sub logstatus {
     &status("Doing logging");      &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".$currenthostid."\t".$status."\t".$lastlog."\n";      print $fh $$."\t".$clientname."\t".$currenthostid."\t"
  $fh->close();   .$status."\t".$lastlog."\t $keymode\n";
       $fh->close();
     }      }
     &status("Finished londstatus.txt");      &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."\n$keymode";
  $fh->close();          $fh->close();
     }      }
     ResetStatistics;  
     &status("Finished logging");      &status("Finished logging");
      
 }  }
   
 sub initnewstatus {  sub initnewstatus {
Line 3684  sub status { Line 3383  sub status {
     my $what=shift;      my $what=shift;
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     my $status = "lond: $what $local ";      $status=$local.': '.$what;
     if($Transactions) {      $0='lond: '.$what.' '.$local;
  $status .= " Transactions: $Transactions Failed; $Failures";  
     }  
     $0=$status;  
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
Line 3720  sub reconlonc { Line 3416  sub reconlonc {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
         } else {          } else {
     &logthis("<font color=red>CRITICAL: "      &logthis(
      ."lonc at pid $loncpid not responding, giving up</font>");                "<font color='red'>CRITICAL: "
                ."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 3736  sub subreply { Line 3433  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 3745  sub subreply { Line 3442  sub subreply {
 }  }
   
 sub reply {  sub reply {
     my ($cmd,$server)=@_;    my ($cmd,$server)=@_;
     my $answer;    my $answer;
     if ($server ne $currenthostid) {     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 answer is $answer, server is $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 3779  sub subsqlreply { Line 3476  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 3791  sub subsqlreply { Line 3488  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 3831  my $execdir=$perlvar{'lonDaemons'}; Line 3525  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');
   
   
Line 3849  $SIG{USR2} = \&UpdateHosts; Line 3543  $SIG{USR2} = \&UpdateHosts;
   
 ReadHostTable;  ReadHostTable;
   
   
 # --------------------------------------------------------------  # --------------------------------------------------------------
 #   Accept connections.  When a connection comes in, it is validated  #   Accept connections.  When a connection comes in, it is validated
 #   and if good, a child process is created to process transactions  #   and if good, a child process is created to process transactions
Line 3865  while (1) { Line 3558  while (1) {
   
 sub make_new_child {  sub make_new_child {
     my $pid;      my $pid;
   #    my $cipher;     # Now global
     my $sigset;      my $sigset;
   
     $client = shift;      $client = shift;
Line 3875  sub make_new_child { Line 3569  sub make_new_child {
     $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      $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
Line 3886  sub make_new_child { Line 3580  sub make_new_child {
     #  the pid hash.      #  the pid hash.
     #      #
     my $caller = getpeername($client);      my $caller = getpeername($client);
     my ($port,$iaddr)=unpack_sockaddr_in($caller);      my ($port,$iaddr);
     $clientip=inet_ntoa($iaddr);      if (defined($caller) && length($caller) > 0) {
    ($port,$iaddr)=unpack_sockaddr_in($caller);
       } else {
    &logthis("Unable to determine who caller was, getpeername returned nothing");
       }
       if (defined($iaddr)) {
    $clientip  = inet_ntoa($iaddr);
    Debug("Connected with $clientip");
    $clientdns = gethostbyaddr($iaddr, AF_INET);
    Debug("Connected with $clientdns by name");
       } else {
    &logthis("Unable to determine clientip");
    $clientip='Unavailable';
       }
           
     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} = $clientip;          $children{$pid} = $clientip;
         $children++;  
         &status('Started child '.$pid);          &status('Started child '.$pid);
         return;          return;
     } else {      } else {
Line 3911  sub make_new_child { Line 3617  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";
   
   #        my $tmpsnum=0;            # Now global
   #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();          &Authen::Krb5::init_ets();
   
  &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 ineffective challenge
   
  ReadManagerTable; # May also be a manager!!   ReadManagerTable; # May also be a manager!!
   
Line 3938  sub make_new_child { Line 3644  sub make_new_child {
     $clientname = $managers{$clientip};      $clientname = $managers{$clientip};
  }   }
  my $clientok;   my $clientok;
   
  if ($clientrec || $ismanager) {   if ($clientrec || $ismanager) {
     &status("Waiting for init from $clientip $clientname");      &status("Waiting for init from $clientip $clientname");
     &logthis('<font color="yellow">INFO: Connection, '.      &logthis('<font color="yellow">INFO: Connection, '.
      $clientip.       $clientip.
      " ($clientname) connection type = $ConnectionType </font>" );    " ($clientname) connection type = $ConnectionType </font>" );
     &status("Connecting $clientip  ($clientname))");       &status("Connecting $clientip  ($clientname))"); 
     my $remotereq=<$client>;      my $remotereq=<$client>;
     $remotereq=~s/[^\w:]//g;      chomp($remotereq);
       Debug("Got init: $remotereq");
       my $inikeyword = split(/:/, $remotereq);
     if ($remotereq =~ /^init/) {      if ($remotereq =~ /^init/) {
  &sethost("sethost:$perlvar{'lonHostID'}");   &sethost("sethost:$perlvar{'lonHostID'}");
  my $challenge="$$".time;   #
  print $client "$challenge\n";   #  If the remote is attempting a local init... give that a try:
  &status("Waiting for challenge reply from $clientip ($clientname)");    #
  $remotereq=<$client>;   my ($i, $inittype) = split(/:/, $remotereq);
  $remotereq=~s/\W//g;  
  if ($challenge eq $remotereq) {   # If the connection type is ssl, but I didn't get my
     $clientok=1;   # certificate files yet, then I'll drop  back to 
     print $client "ok\n";   # insecure (if allowed).
   
    if($inittype eq "ssl") {
       my ($ca, $cert) = lonssl::CertificateFile;
       my $kfile       = lonssl::KeyFile;
       if((!$ca)   || 
          (!$cert) || 
          (!$kfile)) {
    $inittype = ""; # This forces insecure attempt.
    &logthis("<font color=\"blue\"> Certificates not "
    ."installed -- trying insecure auth</font>");
       }
       else { # SSL certificates are in place so
       } # Leave the inittype alone.
    }
   
    if($inittype eq "local") {
       my $key = LocalConnection($client, $remotereq);
       if($key) {
    Debug("Got local key $key");
    $clientok     = 1;
    my $cipherkey = pack("H32", $key);
    $cipher       = new IDEA($cipherkey);
    print $client "ok:local\n";
    &logthis('<font color="green"'
    . "Successful local authentication </font>");
    $keymode = "local"
       } else {
    Debug("Failed to get local key");
    $clientok = 0;
    shutdown($client, 3);
    close $client;
       }
    } elsif ($inittype eq "ssl") {
       my $key = SSLConnection($client);
       if ($key) {
    $clientok = 1;
    my $cipherkey = pack("H32", $key);
    $cipher       = new IDEA($cipherkey);
    &logthis('<font color="green">'
    ."Successfull ssl authentication with $clientname </font>");
    $keymode = "ssl";
        
       } else {
    $clientok = 0;
    close $client;
       }
      
  } else {   } else {
     &logthis("<font color=blue>WARNING: $clientip did not reply challenge</font>");      my $ok = InsecureConnection($client);
     &status('No challenge reply '.$clientip);      if($ok) {
    $clientok = 1;
    &logthis('<font color="green">'
    ."Successful insecure authentication with $clientname </font>");
    print $client "ok\n";
    $keymode = "insecure";
       } else {
    &logthis('<font color="yellow">'
     ."Attempted insecure connection disallowed </font>");
    close $client;
    $clientok = 0;
   
       }
  }   }
     } else {      } else {
  &logthis("<font color=blue>WARNING: "   &logthis(
    "<font color='blue'>WARNING: "
  ."$clientip failed to initialize: >$remotereq< </font>");   ."$clientip failed to initialize: >$remotereq< </font>");
  &status('No init '.$clientip);   &status('No init '.$clientip);
     }      }
       
  } else {   } else {
     &logthis("<font color=blue>WARNING: Unknown client $clientip</font>");      &logthis(
        "<font color='blue'>WARNING: Unknown client $clientip</font>");
     &status('Hung up on '.$clientip);      &status('Hung up on '.$clientip);
  }   }
    
  if ($clientok) {   if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
           
Line 3980  sub make_new_child { Line 3752  sub make_new_child {
  }   }
  &reconlonc("$perlvar{'lonSockDir'}/$id");   &reconlonc("$perlvar{'lonSockDir'}/$id");
     }      }
     &logthis("<font color=green>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
   
     ResetStatistics();  
   
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     my $KeepGoing = 1;      my $keep_going = 1;
     while ((my $userinput=GetRequest) && $KeepGoing) {      my $user_input;
  $KeepGoing = ProcessRequest($userinput);      while(($user_input = get_request) && $keep_going) {
 # -------------------------------------------------------------------- complete   alarm(120);
    Debug("Main: Got $user_input\n");
  &status('Listening to '.$clientname);   $keep_going = &process_request($user_input);
    alarm(0);
    &status('Listening to '.$clientname." ($keymode)");   
     }      }
   
 # --------------------------------------------- client unknown or fishy, refuse  # --------------------------------------------- client unknown or fishy, refuse
  } else {   }  else {
     print $client "refused\n";      print $client "refused\n";
     $client->close();      $client->close();
     &logthis("<font color=blue>WARNING: "      &logthis("<font color='blue'>WARNING: "
      ."Rejected client $clientip, closing connection</font>");       ."Rejected client $clientip, closing connection</font>");
  }   }
     }                   }            
           
 # =============================================================================  # =============================================================================
           
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."Disconnect from $clientip ($clientname)</font>");           ."Disconnect from $clientip ($clientname)</font>");    
           
           
Line 4027  sub make_new_child { Line 3799  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 $domain  = shift;  
     my $user    = shift;      my ($request, $domain, $user, $authtype) = @_;
     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" ;
Line 4042  sub ManagePermissions { Line 3812  sub ManagePermissions {
  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 $user   = shift;  
       my ($domain, $user)  = @_;
   
     Debug("GetAuthType( $domain, $user ) \n");      Debug("GetAuthType( $domain, $user ) \n");
     my $passwdfile = PasswordFilename($domain, $user);      my $proname    = &propath($domain, $user); 
     if( defined $passwdfile ) {      my $passwdfile = "$proname/passwd";
       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");
  return $realpassword;   my ($authtype, $contentpwd) = split(/:/, $realpassword);
     } else {   Debug("Authtype = $authtype, content = $contentpwd\n");
    my $availinfo = '';
    if($authtype eq 'krb4' or $authtype eq 'krb5') {
       $availinfo = $contentpwd;
    }
   
    return "$authtype:$availinfo";
       }
       else {
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
     }      }
Line 4153  sub GetAuthType { Line 3860  sub GetAuthType {
 #                user.  #                user.
 #     0        - The domain,user,password triplet is not a valid user.  #     0        - The domain,user,password triplet is not a valid user.
 #  #
 sub ValidateUser {  sub validate_user {
     my $domain  = shift;      my ($domain, $user, $password) = @_;
     my $user    = shift;  
     my $password= shift;  
   
     # Why negative ~pi you may well ask?  Well this function is about      # Why negative ~pi you may well ask?  Well this function is about
     # authentication, and therefore very important to get right.      # authentication, and therefore very important to get right.
Line 4173  sub ValidateUser { Line 3879  sub ValidateUser {
     #  the user has been assigned.  If the authentication type is      #  the user has been assigned.  If the authentication type is
     #  "nouser", the user does not exist so we will return 0.      #  "nouser", the user does not exist so we will return 0.
   
     my $contents = GetAuthType($domain, $user);      my $contents = &GetAuthType($domain, $user);
     my ($howpwd, $contentpwd) = split(/:/, $contents);      my ($howpwd, $contentpwd) = split(/:/, $contents);
   
     my $null = pack("C",0); # Used by kerberos auth types.      my $null = pack("C",0); # Used by kerberos auth types.
Line 4264  sub ValidateUser { Line 3970  sub ValidateUser {
     return $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;
Line 4286  sub addline { Line 3990  sub addline {
     $sh->close();      $sh->close();
     return $found;      return $found;
 }  }
 #  
 #    Get chat messages.  
 #  
 sub getchat {  sub getchat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
Line 4313  sub getchat { Line 4015  sub getchat {
     }      }
     return (@participants,@entries);      return (@participants,@entries);
 }  }
 #  
 #   Add a chat message  
 #  
 sub chatadd {  sub chatadd {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
     my %hash;      my %hash;
Line 4355  sub chatadd { Line 4055  sub chatadd {
 sub unsub {  sub unsub {
     my ($fname,$clientip)=@_;      my ($fname,$clientip)=@_;
     my $result;      my $result;
       my $unsubs = 0; # Number of successful unsubscribes:
   
   
       # An old way subscriptions were handled was to have a 
       # subscription marker file:
   
       Debug("Attempting unlink of $fname.$clientname");
     if (unlink("$fname.$clientname")) {      if (unlink("$fname.$clientname")) {
  $result="ok\n";   $unsubs++; # Successful unsub via marker file.
     } else {      } 
  $result="not_subscribed\n";  
     }      # The more modern way to do it is to have a subscription list
       # file:
   
     if (-e "$fname.subscription") {      if (-e "$fname.subscription") {
  my $found=&addline($fname,$clientname,$clientip,'');   my $found=&addline($fname,$clientname,$clientip,'');
  if ($found) { $result="ok\n"; }   if ($found) { 
       $unsubs++;
    }
       } 
   
       #  If either or both of these mechanisms succeeded in unsubscribing a 
       #  resource we can return ok:
   
       if($unsubs) {
    $result = "ok\n";
     } else {      } else {
  if ($result != "ok\n") { $result="not_subscribed\n"; }   $result = "not_subscribed\n";
     }      }
   
     return $result;      return $result;
 }  }
   
Line 4374  sub currentversion { Line 4093  sub currentversion {
     my $version=-1;      my $version=-1;
     my $ulsdir='';      my $ulsdir='';
     if ($fname=~/^(.+)\/[^\/]+$/) {      if ($fname=~/^(.+)\/[^\/]+$/) {
  $ulsdir=$1;         $ulsdir=$1;
     }      }
     my ($fnamere1,$fnamere2);      my ($fnamere1,$fnamere2);
     # remove version if already specified      # remove version if already specified
Line 4431  sub subscribe { Line 4150  sub subscribe {
                     symlink($root.'.'.$extension,                      symlink($root.'.'.$extension,
                             $root.'.'.$currentversion.'.'.$extension);                              $root.'.'.$currentversion.'.'.$extension);
                     unless ($extension=~/\.meta$/) {                      unless ($extension=~/\.meta$/) {
  symlink($root.'.'.$extension.'.meta',                         symlink($root.'.'.$extension.'.meta',
  $root.'.'.$currentversion.'.'.$extension.'.meta');                              $root.'.'.$currentversion.'.'.$extension.'.meta');
     }      }
                 }                  }
             }              }
Line 4486  sub make_passwd_file { Line 4205  sub make_passwd_file {
     print $pf "localauth:$npass\n";      print $pf "localauth:$npass\n";
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  #   {
  #  Don't allow the creation of privileged accounts!!! that would      #
  #  be real bad!!!      #  Don't allow the creation of privileged accounts!!! that would
  #      #  be real bad!!!
  my $uid = getpwnam($uname);      #
  if((defined $uid) && ($uid == 0)) {      my $uid = getpwnam($uname);
     &logthis(">>>Attempted add of privileged account blocked<<<");      if((defined $uid) && ($uid == 0)) {
     return "no_priv_account_error\n";   &logthis(">>>Attempted to create privilged account blocked");
  }   return "no_priv_account_error\n";
       }
   
  #      my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
  my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";      {
    &Debug("Executing external: ".$execpath);
  &Debug("Executing external: ".$execpath);   &Debug("user  = ".$uname.", Password =". $npass);
  &Debug("user  = ".$uname.", Password =". $npass);   my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
  my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");   print $se "$uname\n";
  print $se "$uname\n";   print $se "$npass\n";
  print $se "$npass\n";   print $se "$npass\n";
  print $se "$npass\n";      }
       my $useraddok = $?;
  my $useraddok = $?;      if($useraddok > 0) {
  if($useraddok > 0) {   &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
     my $lcstring = lcuseraddstrerror($useraddok);      }
     &logthis("Failed lcuseradd: $lcstring");      my $pf = IO::File->new(">$passfilename");
     return "error: lcuseradd failed: $lcstring\n";      print $pf "unix:\n";
  }   }
  my $pf = IO::File->new(">$passfilename");  
  print $pf "unix:\n";  
    
     } elsif ($umode eq 'none') {      } elsif ($umode eq 'none') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
Line 4531  sub sethost { Line 4248  sub sethost {
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
  $currenthostid=$hostid;   $currenthostid  =$hostid;
  $currentdomainid=$hostdom{$hostid};   $currentdomainid=$hostdom{$hostid};
  &logthis("Setting hostid to $hostid, and domain to $currentdomainid");   &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
Line 4547  sub version { Line 4264  sub version {
     $remoteVERSION=(split(/:/,$userinput))[1];      $remoteVERSION=(split(/:/,$userinput))[1];
     return "version:$VERSION";      return "version:$VERSION";
 }  }
 ############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<<  
 #There is a copy of this in lonnet.pm  #There is a copy of this in lonnet.pm
 #   Can we hoist these lil' things out into common places?  
 #  
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
     {      {
Line 4573  sub userload { Line 4288  sub userload {
     return $userloadpercent;      return $userloadpercent;
 }  }
   
   # Routines for serializing arrays and hashes (copies from lonnet)
   
   sub array2str {
     my (@array) = @_;
     my $result=&arrayref2str(\@array);
     $result=~s/^__ARRAY_REF__//;
     $result=~s/__END_ARRAY_REF__$//;
     return $result;
   }
                                                                                    
   sub arrayref2str {
     my ($arrayref) = @_;
     my $result='__ARRAY_REF__';
     foreach my $elem (@$arrayref) {
       if(ref($elem) eq 'ARRAY') {
         $result.=&arrayref2str($elem).'&';
       } elsif(ref($elem) eq 'HASH') {
         $result.=&hashref2str($elem).'&';
       } elsif(ref($elem)) {
         #print("Got a ref of ".(ref($elem))." skipping.");
       } else {
         $result.=&escape($elem).'&';
       }
     }
     $result=~s/\&$//;
     $result .= '__END_ARRAY_REF__';
     return $result;
   }
                                                                                    
   sub hash2str {
     my (%hash) = @_;
     my $result=&hashref2str(\%hash);
     $result=~s/^__HASH_REF__//;
     $result=~s/__END_HASH_REF__$//;
     return $result;
   }
                                                                                    
   sub hashref2str {
     my ($hashref)=@_;
     my $result='__HASH_REF__';
     foreach (sort(keys(%$hashref))) {
       if (ref($_) eq 'ARRAY') {
         $result.=&arrayref2str($_).'=';
       } elsif (ref($_) eq 'HASH') {
         $result.=&hashref2str($_).'=';
       } elsif (ref($_)) {
         $result.='=';
         #print("Got a ref of ".(ref($_))." skipping.");
       } else {
           if ($_) {$result.=&escape($_).'=';} else { last; }
       }
   
       if(ref($hashref->{$_}) eq 'ARRAY') {
         $result.=&arrayref2str($hashref->{$_}).'&';
       } elsif(ref($hashref->{$_}) eq 'HASH') {
         $result.=&hashref2str($hashref->{$_}).'&';
       } elsif(ref($hashref->{$_})) {
          $result.='&';
         #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
       } else {
         $result.=&escape($hashref->{$_}).'&';
       }
     }
     $result=~s/\&$//;
     $result .= '__END_HASH_REF__';
     return $result;
   }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
 =head1 NAME  =head1 NAME
Removed from v.1.178.2.16  
changed lines
  Added in v.1.220

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