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

Diff for /loncom/lond between versions 1.178.2.2 and 1.181

version 1.178.2.2, 2004/02/23 10:25:52 version 1.181, 2004/03/08 21:00:15
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 48  use localauth; Line 48  use localauth;
 use File::Copy;  use File::Copy;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
   
 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='';
Line 62  my $client; Line 62  my $client;
 my $clientip;  my $clientip;
 my $clientname;  my $clientname;
   
 my $cipher; # Cipher key negotiated with client.  
 my $tmpsnum = 0;; # Id of tmpputs.  
   
 my $server;  my $server;
 my $thisserver;  my $thisserver;
   
Line 86  my %managers;   # Ip -> manager names Line 83  my %managers;   # Ip -> manager names
 my %perlvar; # Will have the apache conf defined perl vars.  my %perlvar; # Will have the apache conf defined perl vars.
   
 #  #
 #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.  
 #    Each element of the hash contains a reference to an array that contains:  
 #          A reference to a sub that executes the request corresponding to the keyword.  
 #          A flag that is true if the request must be encoded to be acceptable.  
 #          A mask with bits as follows:  
 #                      CLIENT_OK    - Set when the function is allowed by ordinary clients  
 #                      MANAGER_OK   - Set when the function is allowed to manager clients.  
 #  
 my $CLIENT_OK  = 1;  
 my $MANAGER_OK = 2;  
 my %Dispatcher;  
   
 #  
 #  The array below are password error strings."  #  The array below are password error strings."
 #  #
 my $lastpwderror    = 13; # Largest error number from lcpasswd.  my $lastpwderror    = 13; # Largest error number from lcpasswd.
Line 135  my @adderrors    = ("ok", Line 119  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.  
 #  
 my $Transactions; # Number of attempted transactions.  
 my $Failures; # Number of transcations failed.  
   
 #   ResetStatistics:   
 #      Resets the statistics counters:  
 #  
 sub ResetStatistics {  
     $Transactions = 0;  
     $Failures     = 0;  
 }  
   
 #  
 #   Return true if client is a manager.  
 #  
 sub isManager {  
     return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));  
 }  
 #  
 #   Return tru if client can do client functions  
 #  
 sub isClient {  
     return (($ConnectionType eq "client") || ($ConnectionType eq "both"));  
 }  
   
   
 #  
 #   Get a Request:  
 #   Gets a Request message from the client.  The transaction  
 #   is defined as a 'line' of text.  We remove the new line  
 #   from the text line.    
 #     
 sub GetRequest {  
     my $input = <$client>;  
     chomp($input);  
   
     Debug("Request = $input\n");  
   
     &status('Processing '.$clientname.':'.$input);  
   
     return $input;  
 }  
 #  
 #   Decipher encoded traffic  
 #  Parameters:  
 #     input      - Encoded data.  
 #  Returns:  
 #     Decoded data or undef if encryption key was not yet negotiated.  
 #  Implicit input:  
 #     cipher  - This global holds the negotiated encryption key.  
 #  
 sub Decipher {  
    my $input  = shift;  
    my $output = '';  
      
      
    if($cipher) {  
       my($enc, $enclength, $encinput) = split(/:/, $input);  
       for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {  
          $output .=   
             $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));  
       }  
       return substr($output, 0, $enclength);  
    } else {  
       return undef;  
    }  
      
 }  
   
 #  
 #   Register a command processor.  This function is invoked to register a sub  
 #   to process a request.  Once registered, the ProcessRequest sub can automatically  
 #   dispatch requests to an appropriate sub, and do the top level validity checking  
 #   as well:  
 #    - Is the keyword recognized.  
 #    - Is the proper client type attempting the request.  
 #    - Is the request encrypted if it has to be.  
 #   Parameters:  
 #    $RequestName         - Name of the request being registered.  
 #                           This is the command request that will match  
 #                           against the hash keywords to lookup the information  
 #                           associated with the dispatch information.  
 #    $Procedure           - Reference to a sub to call to process the request.  
 #                           All subs get called as follows:  
 #                             Procedure($cmd, $tail, $replyfd, $key)  
 #                             $cmd    - the actual keyword that invoked us.  
 #                             $tail   - the tail of the request that invoked us.  
 #                             $replyfd- File descriptor connected to the client  
 #    $MustEncode          - True if the request must be encoded to be good.  
 #    $ClientOk            - True if it's ok for a client to request this.  
 #    $ManagerOk           - True if it's ok for a manager to request this.  
 # Side effects:  
 #      - On success, the Dispatcher hash has an entry added for the key $RequestName  
 #      - On failure, the program will die as it's a bad internal bug to try to   
 #        register a duplicate command handler.  
 #  
 sub RegisterHandler {  
    my $RequestName    = shift;  
    my $Procedure      = shift;  
    my $MustEncode     = shift;  
    my $ClientOk       = shift;  
    my $ManagerOk      = shift;  
      
    #  Don't allow duplication#  
      
    if (defined $Dispatcher{$RequestName}) {  
       die "Attempting to define a duplicate request handler for $RequestName\n";  
    }  
    #   Build the client type mask:  
      
    my $ClientTypeMask = 0;  
    if($ClientOk) {  
       $ClientTypeMask  |= $CLIENT_OK;  
    }  
    if($ManagerOk) {  
       $ClientTypeMask  |= $MANAGER_OK;  
    }  
      
    #  Enter the hash:  
         
    my @entry = ($Procedure, $MustEncode, $ClientTypeMask);  
      
    $Dispatcher{$RequestName} = \@entry;  
      
      
 }  
   
 #--------------------- Request Handlers --------------------------------------------  
 #  
 #   By convention each request handler registers itself prior to the sub declaration:  
 #  
   
 #  Handles ping requests.  
 #  Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $replyfd- File descriptor connected to the client  
 #  Implicit Inputs:  
 #      $currenthostid - Global variable that carries the name of the host we are  
 #                       known as.  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit.  
 #  Side effects:  
 #      Reply information is sent to the client.  
   
 sub PingHandler {  
    my $cmd    = shift;  
    my $tail   = shift;  
    my $client = shift;  
      
    Reply( $client,"$currenthostid\n","$cmd:$tail");  
      
    return 1;  
 }  
 RegisterHandler("ping", \&PingHandler, 0, 1, 1);       # Ping unencoded, client or manager.  
 #  
 # Handles pong reequests:  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $replyfd- File descriptor connected to the client  
 #  Implicit Inputs:  
 #      $currenthostid - Global variable that carries the name of the host we are  
 #                       connected to.  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit.  
 #  Side effects:  
 #      Reply information is sent to the client.  
   
 sub PongHandler {  
    my $cmd     = shift;  
    my $tail    = shift;  
    my $replyfd = shift;  
   
    my $reply=&reply("ping",$clientname);  
    Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");   
    return 1;  
 }  
 RegisterHandler("pong", \&PongHandler, 0, 1, 1);       # Pong unencoded, client or manager  
   
 #  
 #   EstablishKeyHandler:  
 #      Called to establish an encrypted session key with the remote client.  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $replyfd- File descriptor connected to the client  
 #  Implicit Inputs:  
 #      $currenthostid - Global variable that carries the name of the host  
 #                       known as.  
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit.  
 #  Implicit Outputs:  
 #      Reply information is sent to the client.  
 #      $cipher is set with a reference to a new IDEA encryption object.  
 #  
 sub EstablishKeyHandler {  
    my $cmd      = shift;  
    my $tail     = shift;  
    my $replyfd  = shift;  
   
    my $buildkey=time.$$.int(rand 100000);  
    $buildkey=~tr/1-6/A-F/;  
    $buildkey=int(rand 100000).$buildkey.int(rand 100000);  
    my $key=$currenthostid.$clientname;  
    $key=~tr/a-z/A-Z/;  
    $key=~tr/G-P/0-9/;  
    $key=~tr/Q-Z/0-9/;  
    $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;  
    $key=substr($key,0,32);  
    my $cipherkey=pack("H32",$key);  
    $cipher=new IDEA $cipherkey;  
    Reply($replyfd, "$buildkey\n", "$cmd:$tail");   
      
    return 1;  
   
 }  
 RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1);  
   
 #  LoadHandler:  
 #     Handler for the load command.  Returns the current system load average  
 #     to the requestor.  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $replyfd- File descriptor connected to the client  
 #  Implicit Inputs:  
 #      $currenthostid - Global variable that carries the name of the host  
 #                       known as.  
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit.  
 #  Side effects:  
 #      Reply information is sent to the client.  
 sub LoadHandler {  
    my $cmd     = shift;  
    my $tail    = shift;  
    my $replyfd = shift;  
   
    # Get the load average from /proc/loadavg and calculate it as a percentage of  
    # the allowed load limit as set by the perl global variable lonLoadLim  
   
    my $loadavg;  
    my $loadfile=IO::File->new('/proc/loadavg');  
      
    $loadavg=<$loadfile>;  
    $loadavg =~ s/\s.*//g;                       # Extract the first field only.  
      
    my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};  
   
    Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");  
      
    return 1;  
 }  
 RegisterHandler("load", \&LoadHandler, 0, 1, 0);  
   
   
 #  
 #   Process the userload request.  This sub returns to the client the current  
 #  user load average.  It can be invoked either by clients or managers.  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $replyfd- File descriptor connected to the client  
 #  Implicit Inputs:  
 #      $currenthostid - Global variable that carries the name of the host  
 #                       known as.  
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit  
 # Implicit inputs:  
 #     whatever the userload() function requires.  
 #  Implicit outputs:  
 #     the reply is written to the client.  
 #  
 sub UserLoadHandler {  
    my $cmd     = shift;  
    my $tail    = shift;  
    my $replyfd = shift;  
   
    my $userloadpercent=&userload();  
    Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");  
   
    return 1;  
 }  
 RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);  
   
 #   Process a request for the authorization type of a user:  
 #   (userauth).  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $replyfd- File descriptor connected to the client  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit  
 # Implicit outputs:  
 #    The user authorization type is written to the client.  
 #  
 sub UserAuthorizationType {  
    my $cmd     = shift;  
    my $tail    = shift;  
    my $replyfd = shift;  
      
    my $userinput = "$cmd:$tail";  
      
    #  Pull the domain and username out of the command tail.  
    # and call GetAuthType to determine the authentication type.  
      
    my ($udom,$uname)=split(/:/,$tail);  
    my $result = GetAuthType($udom, $uname);  
    if($result eq "nouser") {  
       Failure( $replyfd, "unknown_user\n", $userinput);  
    } else {  
       Reply( $replyfd, "$result\n", $userinput);  
    }  
     
    return 1;  
 }  
 RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0);  
 #  
 #   Process a request by a manager to push a hosts or domain table   
 #   to us.  We pick apart the command and pass it on to the subs  
 #   that already exist to do this.  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $client - File descriptor connected to the client  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit  
 # Implicit Output:  
 #    a reply is written to the client.  
   
 sub PushFileHandler {  
    my $cmd    = shift;  
    my $tail   = shift;  
    my $client = shift;  
   
    my $userinput = "$cmd:$tail";  
   
    # At this time we only know that the IP of our partner is a valid manager  
    # the code below is a hook to do further authentication (e.g. to resolve  
    # spoofing).  
   
    my $cert = GetCertificate($userinput);  
    if(ValidManager($cert)) {   
   
       # Now presumably we have the bona fides of both the peer host and the  
       # process making the request.  
         
       my $reply = PushFile($userinput);  
       Reply($client, "$reply\n", $userinput);  
   
    } else {  
       Failure( $client, "refused\n", $userinput);  
    }   
 }  
 RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1);  
   
   
   
 #   Process a reinit request.  Reinit requests that either  
 #   lonc or lond be reinitialized so that an updated   
 #   host.tab or domain.tab can be processed.  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $client - File descriptor connected to the client  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit  
 #  Implicit output:  
 #     a reply is sent to the client.  
 #  
 sub ReinitProcessHandler {  
    my $cmd    = shift;  
    my $tail   = shift;  
    my $client = shift;  
      
    my $userinput = "$cmd:$tail";  
      
    my $cert = GetCertificate($userinput);  
    if(ValidManager($cert)) {  
       chomp($userinput);  
       my $reply = ReinitProcess($userinput);  
       Reply( $client,  "$reply\n", $userinput);  
    } else {  
       Failure( $client, "refused\n", $userinput);  
  }  
    return 1;  
 }  
   
 RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1);  
   
 #  Process the editing script for a table edit operation.  
 #  the editing operation must be encrypted and requested by  
 #  a manager host.  
 #  
 # Parameters:  
 #      $cmd    - the actual keyword that invoked us.  
 #      $tail   - the tail of the request that invoked us.  
 #      $client - File descriptor connected to the client  
 #  Returns:  
 #      1       - Ok to continue processing.  
 #      0       - Program should exit  
 #  Implicit output:  
 #     a reply is sent to the client.  
 #  
 sub EditTableHandler {  
    my $command    = shift;  
    my $tail       = shift;  
    my $client     = shift;  
      
    my $userinput = "$command:$tail";  
   
    my $cert = GetCertificate($userinput);  
    if(ValidManager($cert)) {  
       my($filetype, $script) = split(/:/, $tail);  
       if (($filetype eq "hosts") ||   
           ($filetype eq "domain")) {  
          if($script ne "") {  
             Reply($client,            # BUGBUG - EditFile  
                   EditFile($userinput), #   could fail.  
                   $userinput);  
          } else {  
             Failure($client,"refused\n",$userinput);  
          }  
       } else {  
          Failure($client,"refused\n",$userinput);  
       }  
    } else {  
       Failure($client,"refused\n",$userinput);  
    }  
    return 1;  
 }  
 RegisterHandler("edit", \&EditTableHandler, 1, 0, 1);  
   
   
 #  
 #   Authenticate a user against the LonCAPA authentication  
 #   database.  Note that there are several authentication  
 #   possibilities:  
 #   - unix     - The user can be authenticated against the unix  
 #                password file.  
 #   - internal - The user can be authenticated against a purely   
 #                internal per user password file.  
 #   - kerberos - The user can be authenticated against either a kerb4 or kerb5  
 #                ticket granting authority.  
 #   - user     - The person tailoring LonCAPA can supply a user authentication mechanism  
 #                that is per system.  
 #  
 # Parameters:  
 #    $cmd      - The command that got us here.  
 #    $tail     - Tail of the command (remaining parameters).  
 #    $client   - File descriptor connected to client.  
 # Returns  
 #     0        - Requested to exit, caller should shut down.  
 #     1        - Continue processing.  
 # Implicit inputs:  
 #    The authentication systems describe above have their own forms of implicit  
 #    input into the authentication process that are described above.  
 #  
 sub AuthenticateHandler {  
    my $cmd        = shift;  
    my $tail       = shift;  
    my $client     = shift;  
      
    #  Regenerate the full input line   
      
    my $userinput  = $cmd.":".$tail;  
   
    #  udom    - User's domain.  
    #  uname   - Username.  
    #  upass   - User's password.  
      
    my ($udom,$uname,$upass)=split(/:/,$tail);  
    Debug(" Authenticate domain = $udom, user = $uname, password = $upass");  
    chomp($upass);  
    $upass=unescape($upass);  
    my $proname=propath($udom,$uname);  
    my $passfilename="$proname/passwd";  
      
    #   The user's 'personal' loncapa passworrd file describes how to authenticate:  
      
    if (-e $passfilename) {  
      Debug("Located password file: $passfilename");  
   
       my $pf = IO::File->new($passfilename);  
       my $realpasswd=<$pf>;  
       chomp($realpasswd);  
       my ($howpwd,$contentpwd)=split(/:/,$realpasswd);  
       my $pwdcorrect=0;  
       #  
       #   Authenticate against password stored in the internal file.  
       #  
      Debug("Authenticating via $howpwd");  
       if ($howpwd eq 'internal') {  
          &Debug("Internal auth");  
          $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);  
       #  
       #   Authenticate against the unix password file.  
       #  
       } elsif ($howpwd eq 'unix') {  
          &Debug("Unix auth");  
          if((getpwnam($uname))[1] eq "") { #no such user!  
             $pwdcorrect = 0;  
          } else {  
             $contentpwd=(getpwnam($uname))[1];  
             my $pwauth_path="/usr/local/sbin/pwauth";  
             unless ($contentpwd eq 'x') {  
                $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);  
             } elsif (-e $pwauth_path) {  
                open PWAUTH, "|$pwauth_path" or  
                   die "Cannot invoke authentication";  
                print PWAUTH "$uname\n$upass\n";  
                close PWAUTH;  
                $pwdcorrect=!$?;  
             }  
          }  
       #  
       #   Authenticate against a Kerberos 4 server:  
       #  
       } elsif ($howpwd eq 'krb4') {  
          my $null=pack("C",0);  
          unless ($upass=~/$null/) {  
             my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname,  
                                                           "",  
                                                           $contentpwd,  
                                                           'krbtgt',  
                                                          $contentpwd,  
                                                          1,  
                                                          $upass);  
             if (!$krb4_error) {  
                $pwdcorrect = 1;  
             } else {   
                $pwdcorrect=0;   
                # log error if it is not a bad password  
                if ($krb4_error != 62) {  
                   &logthis('krb4:'.$uname.','.$contentpwd.','.  
                            &Authen::Krb4::get_err_txt($Authen::Krb4::error));  
                }  
             }  
          }  
       #  
       #   Authenticate against a Kerberos 5 server:  
       #  
       } elsif ($howpwd eq 'krb5') {  
          my $null=pack("C",0);  
          unless ($upass=~/$null/) {  
             my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);  
             my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;  
             my $krbserver=&Authen::Krb5::parse_name($krbservice);  
             my $credentials=&Authen::Krb5::cc_default();  
             $credentials->initialize($krbclient);  
             my $krbreturn = &Authen::Krb5::get_in_tkt_with_password(  
                                                                     $krbclient,  
                                                                     $krbserver,  
                                                                     $upass,  
                                                                     $credentials);  
             $pwdcorrect = ($krbreturn == 1);  
          } else {   
             $pwdcorrect=0;   
          }  
       #  
       #  Finally, the user may have written in an authentication module.  
       #  in that case, if requested, authenticate against it.  
       #  
       } elsif ($howpwd eq 'localauth') {  
          $pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd);  
       }  
       #  
       #   Successfully authorized.  
       #  
       if ($pwdcorrect) {  
          Reply( $client, "authorized\n", $userinput);  
       #  
       #  Bad credentials: Failed to authorize  
       #  
       } else {  
          Failure( $client, "non_authorized\n", $userinput);  
       }  
    #  
    #  User bad... note it may be bad security practice to differntiate to the  
    #  caller a bad user from a  bad passwd... since that supplies covert channel  
    #  information (you have a good user but bad password e.g.) to guessers.  
    #  
    } else {  
       Failure( $client, "unknown_user\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");  
    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 = IO::File->new(">$passfilename");  
                   if ($pf) {  
                      print $pf "internal:$ncpass\n";  
                      &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);  
                   }  
                }               
          } else {  
             Failure($client, "non_authorized\n", $userinput);  
          }  
       } 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($?));  
             Reply($client, "$result\n", $userinput);  
          } else {  
             Reply($client, "non_authorized\n", $userinput);  
          }  
       } else {  
          Reply( $client, "auth_mode_error\n", $userinput);  
       }    
    } else {  
             Reply( $client, "unknown_user\n", $userinput);  
    }  
    return 1;  
 }  
 RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);  
   
 #  
 #   Create a new user.  User in this case means a lon-capa user.  
 #   The user must either already exist in some authentication realm  
 #   like kerberos or the /etc/passwd.  If not, a user completely local to  
 #   this loncapa system is created.  
 #  
 # Parameters:  
 #    $cmd      - The command that got us here.  
 #    $tail     - Tail of the command (remaining parameters).  
 #    $client   - File descriptor connected to client.  
 # Returns  
 #     0        - Requested to exit, caller should shut down.  
 #     1        - Continue processing.  
 # Implicit inputs:  
 #    The authentication systems describe above have their own forms of implicit  
 #    input into the authentication process that are described above.  
 sub AddUserHandler {  
    my $cmd     = shift;  
    my $tail    = shift;  
    my $client  = shift;  
      
    my $userinput = $cmd.":".$tail;     
   
    my $oldumask=umask(0077);  
    my ($udom,$uname,$umode,$npass)=split(/:/,$tail);  
    &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) {  
       Failure( $client, "already_exists\n", $userinput);  
    } elsif ($udom ne $currentdomainid) {  
       Failure($client, "not_right_domain\n", $userinput);  
    } 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);  
          Reply($client, $result, $userinput);     #BUGBUG - could be fail  
       } else {  
          Failure($client, "$fperror\n", $userinput);  
       }  
    }  
    umask($oldumask);  
    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);  
    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) {  
       Failure( $client, "not_right_domain\n", $client);  
    } else {  
       my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);  
       Reply($client, $result, $userinput);  
    }  
    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 $proname=propath($udom,$uname);  
    if (-e $proname) {  
       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.  Question?   The token for athentication  
 #   is allowed to be sent as cleartext is this really what we want?  This token  
 #   represents the user's session id.  Once it is forged does this allow too much access??  
 #  
 # 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 {  
       Reply($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);  
    $namespace=~s/\//\_/g;  
    $namespace=~s/\W//g;  
    if ($namespace ne 'roles') {  
       chomp($what);  
       my $proname=propath($udom,$uname);  
       my $now=time;  
       unless ($namespace=~/^nohist\_/) {  
          my $hfh;  
          if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
             print $hfh "P:$now:$what\n";   
          }  
       }  
       my @pairs=split(/\&/,$what);  
       my %hash;  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",  
                   &GDBM_WRCREAT(),0640)) {  
          foreach my $pair (@pairs) {  
             my ($key,$value)=split(/=/,$pair);  
             $hash{$key}=$value;  
          }  
          if (untie(%hash)) {  
             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   = shift;  
   
    my ($udom,$uname,$namespace,$what) =split(/:/,$tail);  
    $namespace=~s/\//\_/g;  
    $namespace=~s/\W//g;  
    if ($namespace ne 'roles') {  
       chomp($what);  
       my $proname=propath($udom,$uname);  
       my $now=time;  
       unless ($namespace=~/^nohist\_/) {  
          my $hfh;  
          if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
             print $hfh "P:$now:$what\n";  
          }  
       }  
       my @pairs=split(/\&/,$what);  
       my %hash;  
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),  
                0640)) {  
          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)) {  
             Reply( $client, "ok\n", $userinput);  
          } else {  
             Failure($client, "error: ".($!+0)." untie(GDBM) failed ".  
                      "while attempting put\n", $userinput);  
          }  
       } else {  
          Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
                   "while attempting put\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 $proname=propath($udom,$uname);  
    my $now=time;  
    #  
    #  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.  
    {  
       my $hfh;  
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
          print $hfh "P:$now:$exedom:$exeuser:$what\n";  
       }  
    }  
    my @pairs=split(/\&/,$what);  
    my %hash;  
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) {  
       foreach my $pair (@pairs) {  
          my ($key,$value)=split(/=/,$pair);  
             &ManagePermissions($key, $udom, $uname,  
                                &GetAuthType( $udom, $uname));  
             $hash{$key}=$value;  
       }  
       if (untie(%hash)) {  
          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 $proname=propath($udom,$uname);  
    my $now=time;  
    #  
    #   Log the attempt. This {}'ing is done to ensure that the  
    #   logfile is flushed and closed as quickly as possible.  Hopefully  
    #   this preserves both time ordering and reduces the probability that  
    #   messages will be interleaved.  
    #  
    {  
       my $hfh;  
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
          print $hfh "D:$now:$exedom:$exeuser:$what\n";  
       }  
    }  
    my @rolekeys=split(/\&/,$what);  
    my %hash;  
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) {  
       foreach my $key (@rolekeys) {  
          delete $hash{$key};  
       }  
       if (untie(%hash)) {  
          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);  
    $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]}&";    # Presumably failure gives empty string.  
       }  
       if (untie(%hash)) {  
          $qresult=~s/\&$//;              # Remove trailing & from last lookup.  
          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);  
    $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)));  
             }  
             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", \&GetProfileEncrypted, 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 DeletProfileEntry {  
    my $cmd      = shift;  
    my $tail     = shift;  
    my $client   = shift;  
    my $userinput = "cmd:$tail";  
   
    my ($udom,$uname,$namespace,$what) = split(/:/,$tail);  
    $namespace=~s/\//\_/g;  
    $namespace=~s/\W//g;  
    chomp($what);  
    my $proname=propath($udom,$uname);  
    my $now=time;  
    unless ($namespace=~/^nohist\_/) {  
       my $hfh;  
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
          print $hfh "D:$now:$what\n";   
       }  
    }  
    my @keys=split(/\&/,$what);  
    my %hash;  
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
       foreach my $key (@keys) {  
          delete($hash{$key});  
       }  
       if (untie(%hash)) {  
          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);  
    $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/\&$//;  
          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);  
    $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 = ();                     # A hash of anonymous hashes..  
       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\./);       # 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);  
   $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)) {  
     study($regexp);  
     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);  
       Reply($client, "$qresult\n", $userinput);  
     } else {  
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".  
        "while attempting dump\n", $userinput);  
     }  
   } else {  
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
     "while attempting dump\n", $userinput);  
   }  
   
     return 1;  
 }  
 RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);  
   
 #  Store an aitem in any database but the roles database.  
 #  
 #  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);  
   $namespace=~s/\//\_/g;  
   $namespace=~s/\W//g;  
   if ($namespace ne 'roles') {  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     unless ($namespace=~/^nohist\_/) {  
       my $hfh;  
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {  
  print $hfh "P:$now:$rid:$what\n";   
       }  
     }  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",  
     &GDBM_WRCREAT(),0640)) {  
       my @previouskeys=split(/&/,$hash{"keys:$rid"});  
       my $key;  
       $hash{"version:$rid"}++;  
       my $version=$hash{"version:$rid"};  
       my $allkeys='';   
       foreach 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)) {  
  Reply($client, "ok\n", $userinput);  
       } else {  
  Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".  
  "while attempting store\n", $userinput);  
       }  
     } else {  
       Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".  
        "while attempting store\n", $userinput);  
     }  
   } else {  
     Failure($client, "refused\n", $userinput);  
   }  
   
   return 1;  
 }  
 RegisterHandler("store", \&StoreHandler, 0, 1, 0);  
 #  
 #   Restore a prior version of a resource.  
 #  
 #  Parameters:  
 #     $cmd               - Command keyword.  
 #     $tail              - Remainder of the request which consists of:  
 #                          domain/user   - User and auth. domain.  
 #                          namespace     - name of resource database.  
 #                          rid           - Resource id.  
 #    $client             - socket open on the client.  
 #  
 # Returns:  
 #      1  indicating the caller should not yet exit.  
 # Side-effects:  
 #   Writes a reply to the client.  
 #  
 sub RestoreHandler {  
   my $cmd     = shift;  
   my $tail    = shift;  
   my $client  = shift;  
   
   my $userinput = "$cmd:$tail"; # Only used for logging purposes.  
   
   my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);  
   $namespace=~s/\//\_/g;  
   $namespace=~s/\W//g;  
   chomp($rid);  
   my $proname=propath($udom,$uname);  
   my $qresult='';  
   my %hash;  
   if (tie(%hash,'GDBM_File',"$proname/$namespace.db",  
   &GDBM_READER(),0640)) {  
     my $version=$hash{"version:$rid"};  
     $qresult.="version=$version&";  
     my $scope;  
     for ($scope=1;$scope<=$version;$scope++) {  
       my $vkeys=$hash{"$scope:keys:$rid"};  
  my @keys=split(/:/,$vkeys);  
       my $key;  
       $qresult.="$scope:keys=$vkeys&";  
       foreach $key (@keys) {  
  $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";  
       }                                    
     }  
      if (untie(%hash)) {  
        $qresult=~s/\&$//;  
        Reply( $client, "$qresult\n", $userinput);  
      } else {  
        Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".  
        "while attempting restore\n", $userinput);  
      }  
   } else {  
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
     "while attempting restore\n", $userinput);  
   }  
     
   return 1;  
   
   
 }  
 RegisterHandler("restor", \&RestoreHandler, 0,1,0);  
   
 #  
 #   Add a chat message to to a discussion board.  
 #  
 # Parameters:  
 #    $cmd                - Request keyword.  
 #    $tail               - Tail of the command. A colon separated list  
 #                          containing:  
 #                          cdom    - Domain on which the chat board lives  
 #                          cnum    - Identifier of the discussion group.  
 #                          post    - Body of the posting.  
 #   $client              - Socket open on the client.  
 # Returns:  
 #   1    - Indicating caller should keep on processing.  
 #  
 # Side-effects:  
 #   writes a reply to the client.  
 #  
 #  
 sub SendChatHandler {  
   my $cmd     = shift;  
   my $tail    = shift;  
   my $client  = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($cdom,$cnum,$newpost)=split(/\:/,$tail);  
   &chatadd($cdom,$cnum,$newpost);  
   Reply($client, "ok\n", $userinput);  
   
   return 1;  
 }  
 RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0);  
 #  
 #   Retrieve the set of chat messagss from a discussion board.  
 #  
 #  Parameters:  
 #    $cmd             - Command keyword that initiated the request.  
 #    $tail            - Remainder of the request after the command  
 #                       keyword.  In this case a colon separated list of  
 #                       chat domain    - Which discussion board.  
 #                       chat id        - Discussion thread(?)  
 #                       domain/user    - Authentication domain and username  
 #                                        of the requesting person.  
 #   $client           - Socket open on the client program.  
 # Returns:  
 #    1     - continue processing  
 # Side effects:  
 #    Response is written to the client.  
 #  
 sub RetrieveChatHandler {  
   my $cmd      = shift;  
   my $tail     = shift;  
   my $client   = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);  
   my $reply='';  
   foreach (&getchat($cdom,$cnum,$udom,$uname)) {  
     $reply.=&escape($_).':';  
   }  
   $reply=~s/\:$//;  
   Reply($client, $reply."\n", $userinput);  
   
   
   return 1;  
 }  
 RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0);  
 #  
 #  Initiate a query of an sql database.  SQL query repsonses get put in  
 #  a file for later retrieval.  This prevents sql query results from  
 #  bottlenecking the system.  Note that with loncnew, perhaps this is  
 #  less of an issue since multiple outstanding requests can be concurrently  
 #  serviced.  
 #  
 #  Parameters:  
 #     $cmd       - COmmand keyword that initiated the request.  
 #     $tail      - Remainder of the command after the keyword.  
 #                  For this function, this consists of a query and  
 #                  3 arguments that are self-documentingly labelled  
 #                  in the original arg1, arg2, arg3.  
 #     $client    - Socket open on the client.  
 # Return:  
 #    1   - Indicating processing should continue.  
 # Side-effects:  
 #    a reply is written to $client.  
 #  
 sub SendQueryHandler {  
   my $cmd     = shift;  
   my $tail    = shift;  
   my $client  = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);  
   $query=~s/\n*$//g;  
   Reply($client, "". sqlreply("$clientname\&$query".  
       "\&$arg1"."\&$arg2"."\&$arg3")."\n",  
  $userinput);  
   
   return 1;  
 }  
 RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0);  
   
 #  
 #   Add a reply to an sql query.  SQL queries are done asyncrhonously.  
 #   The query is submitted via a "querysend" transaction.  
 #   There it is passed on to the lonsql daemon, queued and issued to  
 #   mysql.  
 #     This transaction is invoked when the sql transaction is complete  
 #   it stores the query results in flie and indicates query completion.  
 #   presumably local software then fetches this response... I'm guessing  
 #   the sequence is: lonc does a querysend, we ask lonsql to do it.  
 #   lonsql on completion of the query interacts with the lond of our  
 #   client to do a query reply storing two files:  
 #    - id     - The results of the query.  
 #    - id.end - Indicating the transaction completed.   
 #    NOTE: id is a unique id assigned to the query and querysend time.  
 # Parameters:  
 #    $cmd        - Command keyword that initiated this request.  
 #    $tail       - Remainder of the tail.  In this case that's a colon  
 #                  separated list containing the query Id and the   
 #                  results of the query.  
 #    $client     - Socket open on the client.  
 # Return:  
 #    1           - Indicating that we should continue processing.  
 # Side effects:  
 #    ok written to the client.  
 #  
 sub ReplyQueryHandler {  
   my $cmd    = shift;  
   my $tail   = shift;  
   my $client = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($cmd,$id,$reply)=split(/:/,$userinput);   
   my $store;  
   my $execdir=$perlvar{'lonDaemons'};  
   if ($store=IO::File->new(">$execdir/tmp/$id")) {  
     $reply=~s/\&/\n/g;  
          print $store $reply;  
     close $store;  
     my $store2=IO::File->new(">$execdir/tmp/$id.end");  
     print $store2 "done\n";  
     close $store2;  
     Reply($client, "ok\n", $userinput);  
   }  
   else {  
     Failure($client, "error: ".($!+0)  
     ." IO::File->new Failed ".  
     "while attempting queryreply\n", $userinput);  
   }  
    
   
   return 1;  
 }  
 RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0);  
 #  
 #  Process the courseidput query.  Not quite sure what this means  
 #  at the system level sense.  It appears a gdbm file in the   
 #  /home/httpd/lonUsers/$domain/nohist_courseids is tied and  
 #  a set of entries made in that database.  
 #  
 # Parameters:  
 #   $cmd      - The command keyword that initiated this request.  
 #   $tail     - Tail of the command.  In this case consists of a colon  
 #               separated list contaning the domain to apply this to and  
 #               an ampersand separated list of keyword=value pairs.  
 #   $client   - Socket open on the client.  
 # Returns:  
 #   1    - indicating that processing should continue  
 #  
 # Side effects:  
 #   reply is written to the client.  
 #  
 sub PutCourseIdHandler {  
   my $cmd    = shift;  
   my $tail   = shift;  
   my $client = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($udom,$what)=split(/:/,$tail);  
   chomp($what);  
   $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,$value)=split(/=/,$pair);  
       $hash{$key}=$value.':'.$now;  
     }  
     if (untie(%hash)) {  
       Reply($client, "ok\n", $userinput);  
     } else {  
       Failure( $client, "error: ".($!+0)  
        ." untie(GDBM) Failed ".  
        "while attempting courseidput\n", $userinput);  
     }  
   } else {  
     Failure( $client, "error: ".($!+0)  
      ." tie(GDBM) Failed ".  
      "while attempting courseidput\n", $userinput);  
   }  
   
   return 1;  
 }  
 RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0);  
   
 #  Retrieves the value of a course id resource keyword pattern  
 #  defined since a starting date.  Both the starting date and the  
 #  keyword pattern are optional.  If the starting date is not supplied it  
 #  is treated as the beginning of time.  If the pattern is not found,  
 #  it is treatred as "." matching everything.  
 #  
 #  Parameters:  
 #     $cmd     - Command keyword that resulted in us being dispatched.  
 #     $tail    - The remainder of the command that, in this case, consists  
 #                of a colon separated list of:  
 #                 domain   - The domain in which the course database is   
 #                            defined.  
 #                 since    - Optional parameter describing the minimum  
 #                            time of definition(?) of the resources that  
 #                            will match the dump.  
 #                 description - regular expression that is used to filter  
 #                            the dump.  Only keywords matching this regexp  
 #                            will be used.  
 #     $client  - The socket open on the client.  
 # Returns:  
 #    1     - Continue processing.  
 # Side Effects:  
 #   a reply is written to $client.  
 sub DumpCourseIdHandler {  
   my $cmd    = shift;  
   my $tail   = shift;  
   my $client = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($udom,$since,$description) =split(/:/,$tail);  
   if (defined($description)) {  
     $description=&unescape($description);  
   } else {  
     $description='.';  
   }  
   unless (defined($since)) { $since=0; }  
   my $qresult='';  
   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)=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(%hash)) {  
       chop($qresult);  
       Reply($client, "$qresult\n", $userinput);  
     } else {  
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".  
       "while attempting courseiddump\n", $userinput);  
     }  
   } else {  
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
     "while attempting courseiddump\n", $userinput);  
   }  
   
   
   return 1;  
 }  
 RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0);  
 #  
 #  Puts an id to a domains id database.   
 #  
 #  Parameters:  
 #   $cmd     - The command that triggered us.  
 #   $tail    - Remainder of the request other than the command. This is a   
 #              colon separated list containing:  
 #              $domain  - The domain for which we are writing the id.  
 #              $pairs  - The id info to write... this is and & separated list  
 #                        of keyword=value.  
 #   $client  - Socket open on the client.  
 #  Returns:  
 #    1   - Continue processing.  
 #  Side effects:  
 #     reply is written to $client.  
 #  
 sub PutIdHandler {  
   my $cmd    = shift;  
   my $tail   = shift;  
   my $client = shift;  
   
   my $userinput = "$cmd:$tail";  
   
   my ($udom,$what)=split(/:/,$tail);  
   chomp($what);  
   $udom=~s/\W//g;  
   my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
   my $now=time;  
   {  
     my $hfh;  
     if ($hfh=IO::File->new(">>$proname.hist")) {   
       print $hfh "P:$now:$what\n";   
     }  
   }  
   my @pairs=split(/\&/,$what);  
   my %hash;  
   if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  
     foreach my $pair (@pairs) {  
       my ($key,$value)=split(/=/,$pair);  
       $hash{$key}=$value;  
     }  
     if (untie(%hash)) {  
       Reply($client, "ok\n", $userinput);  
     } else {  
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".  
       "while attempting idput\n", $userinput);  
     }  
   } else {  
     Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".  
      "while attempting idput\n", $userinput);  
   }  
   
   return 1;  
 }  
   
 RegisterHandler("idput", \&PutIdHandler, 0, 1, 0);  
 #  
 #  Retrieves a set of id values from the id database.  
 #  Returns an & separated list of results, one for each requested id to the  
 #  client.  
 #  
 # Parameters:  
 #   $cmd       - Command keyword that caused us to be dispatched.  
 #   $tail      - Tail of the command.  Consists of a colon separated:  
 #               domain - the domain whose id table we dump  
 #               ids      Consists of an & separated list of  
 #                        id keywords whose values will be fetched.  
 #                        nonexisting keywords will have an empty value.  
 #   $client    - Socket open on the client.  
 #  
 # Returns:  
 #    1 - indicating processing should continue.  
 # Side effects:  
 #   An & separated list of results is written to $client.  
 #  
 sub GetIdHandler {  
   my $cmd    = shift;  
   my $tail   = shift;  
   my $client = shift;  
   
   my $userinput = "$client:$tail";  
   
   my ($udom,$what)=split(/:/,$tail);  
   chomp($what);  
   $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/\&$//;  
       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 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);  
       }  
   
   
   
   
   
 # ---------------------------------------------------------------------- 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;  
             Reply($client, "$id\n", $userinput);  
          }  
          else {  
             Failure( $client, "error: ".($!+0)."IO::File->new Failed ".  
                            "while attempting tmpput\n", $userinput);  
          }  
       } else {  
          Failure($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>;  
             Reply( $client, "$reply\n", $userinput);  
             close $store;  
          }  
          else {  
             Failure( $client, "error: ".($!+0)."IO::File->new Failed ".  
                                "while attempting tmpget\n", $userinput);  
          }  
       } else {  
          Failure($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")) {  
             Reply($client, "ok\n", $userinput);  
          } else {  
             Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".  
                                  "while attempting tmpdel\n", $userinput);  
          }  
       } else {  
          Failure($client, "refused\n", $userinput);  
       }  
 # -------------------------------------------------------------------------- ls  
    } elsif ($userinput =~ /^ls/) {  
       if(isClient) {  
          my ($cmd,$ulsdir)=split(/:/,$userinput);  
          my $ulsout='';  
          my $ulsfn;  
          if (-e $ulsdir) {  
             if(-d $ulsdir) {  
                if (opendir(LSDIR,$ulsdir)) {  
                   while ($ulsfn=readdir(LSDIR)) {  
                      my @ulsstats=stat($ulsdir.'/'.$ulsfn);  
                      $ulsout.=$ulsfn.'&'.  
                      join('&',@ulsstats).':';  
                   }  
                   closedir(LSDIR);  
                }  
             } else {  
                my @ulsstats=stat($ulsdir);  
                $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';  
             }  
          } else {  
             $ulsout='no_such_dir';  
          }  
          if ($ulsout eq '') { $ulsout='empty'; }  
          Reply($client, "$ulsout\n", $userinput);  
       } else {  
          Failure($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;  
             Reply($client, "ok\n", $userinput);  
          } else {  
             Failure($client, "error: ".($!+0)."\n", $userinput);  
          }  
       } else {  
          Failure($client, "refused\n", $userinput);  
       
       }  
 # ------------------------------------------------------------------ Hanging up  
    } elsif (($userinput =~ /^exit/) ||  
          ($userinput =~ /^init/)) { # no restrictions.  
       &logthis("Client $clientip ($clientname) hanging up: $userinput");  
       Reply($client, "bye\n", $userinput);  
       $client->shutdown(2);        # shutdown the socket forcibly.  
       $client->close();  
       $KeepGoing = 0; # Flag to exit the program.  
   
 # ---------------------------------- set current host/domain  
    } elsif ($userinput =~ /^sethost:/) {  
       if (isClient) {  
          Reply($client, &sethost($userinput)."\n", $userinput);  
       } else {  
          Failure($client, "refused\n", $userinput);  
       }  
 #---------------------------------- request file (?) version.  
     } elsif ($userinput =~/^version:/) {  
  if (isClient) {  
     Reply($client, &version($userinput)."\n", $userinput);  
  } else {  
     Reply( $client, "refused\n", $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,
Line 2664  sub GetCertificate { Line 137  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 3327  $server = IO::Socket::INET->new(LocalPor Line 812  $server = IO::Socket::INET->new(LocalPor
 # 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");   } else {
       &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 3394  sub ReadHostTable { Line 887  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";
           
     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;
  $hostip{$id}=$ip;      $hostdom{$id}=$domain;
  if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      $hostip{$id}=$ip;
       if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
    }
     }      }
     close(CONFIG);      close(CONFIG);
 }  }
Line 3519  sub Debug { Line 1014  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      = shift;      my $fd      = shift;
     my $reply   = shift;      my $reply   = shift;
     my $request = shift;      my $request = shift;
Line 3530  sub Reply { Line 1022  sub Reply {
     print $fd $reply;      print $fd $reply;
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
     $Transactions++;  
     alarm(0);  
   
   
 }  
 #  
 #    Sub to report a failure.  
 #    This function:  
 #     -   Increments the failure statistic counters.  
 #     -   Invokes Reply to send the error message to the client.  
 # Parameters:  
 #    fd       - File descriptor open on the client  
 #    reply    - Reply text to emit.  
 #    request  - The original request message (used by Reply  
 #               to debug if that's enabled.  
 # Implicit outputs:  
 #    $Failures- The number of failures is incremented.  
 #    Reply (invoked here) sends a message to the   
 #    client:  
 #  
 sub Failure {  
    my $fd      = shift;  
    my $reply   = shift;  
    my $request = shift;  
      
    $Failures++;  
    Reply($fd, $reply, $request);      # That's simple eh?  
 }  }
 # ------------------------------------------------------------------ Log status  # ------------------------------------------------------------------ Log status
   
 sub logstatus {  sub logstatus {
    &status("Doing logging");      &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".$status."\t".$lastlog."\n";
       $fh->close();      $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;
       $fh->close();          $fh->close();
    }      }
    ResetStatistics;      &status("Finished logging");
    &status("Finished logging");  
      
 }  }
   
 sub initnewstatus {  sub initnewstatus {
Line 3598  sub status { Line 1061  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 3761  $SIG{USR2} = \&UpdateHosts; Line 1221  $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 3777  while (1) { Line 1236  while (1) {
   
 sub make_new_child {  sub make_new_child {
     my $pid;      my $pid;
       my $cipher;
     my $sigset;      my $sigset;
   
     $client = shift;      $client = shift;
Line 3798  sub make_new_child { Line 1258  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);
       } else {
    &logthis("Unable to determine clinetip");
    $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 3823  sub make_new_child { Line 1292  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;
   #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();          &Authen::Krb5::init_ets();
   
Line 3898  sub make_new_child { Line 1367  sub make_new_child {
     }      }
     &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);
   # ------------------------------------------------------------ Process requests
       while (my $userinput=<$client>) {
                   chomp($userinput);
    Debug("Request = $userinput\n");
                   &status('Processing '.$clientname.': '.$userinput);
                   my $wasenc=0;
                   alarm(120);
   # ------------------------------------------------------------ See if encrypted
    if ($userinput =~ /^enc/) {
       if ($cipher) {
    my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);
    $userinput='';
    for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {
       $userinput.=
    $cipher->decrypt(
    pack("H16",substr($encinput,$encidx,16))
    );
    }
    $userinput=substr($userinput,0,$cmdlength);
    $wasenc=1;
       }
    }
   
   # ------------------------------------------------------------- Normal commands
   # ------------------------------------------------------------------------ ping
    if ($userinput =~ /^ping/) { # client only
       if(isClient) {
    print $client "$currenthostid\n";
       } else {
    Reply($client, "refused\n", $userinput);
       }
   # ------------------------------------------------------------------------ pong
    }elsif ($userinput =~ /^pong/) { # client only
       if(isClient) {
    my $reply=&reply("ping",$clientname);
    print $client "$currenthostid:$reply\n"; 
       } else {
    Reply($client, "refused\n", $userinput);
       }
   # ------------------------------------------------------------------------ ekey
    } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs
       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;
       print $client "$buildkey\n"; 
   # ------------------------------------------------------------------------ load
    } elsif ($userinput =~ /^load/) { # client only
       if (isClient) {
    my $loadavg;
    {
       my $loadfile=IO::File->new('/proc/loadavg');
       $loadavg=<$loadfile>;
    }
    $loadavg =~ s/\s.*//g;
    my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
    print $client "$loadpercent\n";
       } else {
    Reply($client, "refused\n", $userinput);
          
       }
   # -------------------------------------------------------------------- userload
    } elsif ($userinput =~ /^userload/) { # client only
       if(isClient) {
    my $userloadpercent=&userload();
    print $client "$userloadpercent\n";
       } else {
    Reply($client, "refused\n", $userinput);
        
       }
   #
   #        Transactions requiring encryption:
   #
   # ----------------------------------------------------------------- currentauth
    } elsif ($userinput =~ /^currentauth/) {
       if (($wasenc==1)  && isClient) { # Encoded & client only.
    my ($cmd,$udom,$uname)=split(/:/,$userinput);
    my $result = GetAuthType($udom, $uname);
    if($result eq "nouser") {
       print $client "unknown_user\n";
    }
    else {
       print $client "$result\n"
       }
       } else {
    Reply($client, "refused\n", $userinput);
   
       }
   #--------------------------------------------------------------------- pushfile
    } elsif($userinput =~ /^pushfile/) { # encoded & manager.
       if(($wasenc == 1) && isManager) {
    my $cert = GetCertificate($userinput);
    if(ValidManager($cert)) {
       my $reply = PushFile($userinput);
       print $client "$reply\n";
    } else {
       print $client "refused\n";
    } 
       } else {
    Reply($client, "refused\n", $userinput);
   
       }
   #--------------------------------------------------------------------- reinit
    } elsif($userinput =~ /^reinit/) { # Encoded and manager
    if (($wasenc == 1) && isManager) {
    my $cert = GetCertificate($userinput);
    if(ValidManager($cert)) {
    chomp($userinput);
    my $reply = ReinitProcess($userinput);
    print $client  "$reply\n";
    } else {
    print $client "refused\n";
    }
    } else {
    Reply($client, "refused\n", $userinput);
    }
   #------------------------------------------------------------------------- edit
       } elsif ($userinput =~ /^edit/) {    # encoded and manager:
    if(($wasenc ==1) && (isManager)) {
       my $cert = GetCertificate($userinput);
       if(ValidManager($cert)) {
                  my($command, $filetype, $script) = split(/:/, $userinput);
                  if (($filetype eq "hosts") || ($filetype eq "domain")) {
                     if($script ne "") {
         Reply($client, EditFile($userinput));
                     } else {
                        Reply($client,"refused\n",$userinput);
                     }
                  } else {
                     Reply($client,"refused\n",$userinput);
                  }
               } else {
                  Reply($client,"refused\n",$userinput);
               }
            } else {
        Reply($client,"refused\n",$userinput);
    }
   # ------------------------------------------------------------------------ auth
       } elsif ($userinput =~ /^auth/) { # Encoded and client only.
       if (($wasenc==1) && isClient) {
    my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
    chomp($upass);
    $upass=unescape($upass);
    my $proname=propath($udom,$uname);
    my $passfilename="$proname/passwd";
    if (-e $passfilename) {
       my $pf = IO::File->new($passfilename);
       my $realpasswd=<$pf>;
       chomp($realpasswd);
       my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
       my $pwdcorrect=0;
       if ($howpwd eq 'internal') {
    &Debug("Internal auth");
    $pwdcorrect=
       (crypt($upass,$contentpwd) eq $contentpwd);
       } elsif ($howpwd eq 'unix') {
    &Debug("Unix auth");
    if((getpwnam($uname))[1] eq "") { #no such user!
       $pwdcorrect = 0;
    } else {
       $contentpwd=(getpwnam($uname))[1];
       my $pwauth_path="/usr/local/sbin/pwauth";
       unless ($contentpwd eq 'x') {
    $pwdcorrect=
       (crypt($upass,$contentpwd) eq 
        $contentpwd);
       }
       
       elsif (-e $pwauth_path) {
    open PWAUTH, "|$pwauth_path" or
       die "Cannot invoke authentication";
    print PWAUTH "$uname\n$upass\n";
    close PWAUTH;
    $pwdcorrect=!$?;
       }
    }
       } elsif ($howpwd eq 'krb4') {
    my $null=pack("C",0);
    unless ($upass=~/$null/) {
       my $krb4_error = &Authen::Krb4::get_pw_in_tkt
    ($uname,"",$contentpwd,'krbtgt',
    $contentpwd,1,$upass);
       if (!$krb4_error) {
    $pwdcorrect = 1;
       } else { 
    $pwdcorrect=0; 
    # log error if it is not a bad password
    if ($krb4_error != 62) {
       &logthis('krb4:'.$uname.','.$contentpwd.','.
        &Authen::Krb4::get_err_txt($Authen::Krb4::error));
    }
       }
    }
       } elsif ($howpwd eq 'krb5') {
    my $null=pack("C",0);
    unless ($upass=~/$null/) {
       my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
       my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
       my $krbserver=&Authen::Krb5::parse_name($krbservice);
       my $credentials=&Authen::Krb5::cc_default();
       $credentials->initialize($krbclient);
       my $krbreturn = 
    &Authen::Krb5::get_in_tkt_with_password(
    $krbclient,$krbserver,$upass,$credentials);
   #  unless ($krbreturn) {
   #      &logthis("Krb5 Error: ".
   #       &Authen::Krb5::error());
   #  }
       $pwdcorrect = ($krbreturn == 1);
    } else { $pwdcorrect=0; }
       } elsif ($howpwd eq 'localauth') {
    $pwdcorrect=&localauth::localauth($uname,$upass,
     $contentpwd);
       }
       if ($pwdcorrect) {
    print $client "authorized\n";
       } else {
    print $client "non_authorized\n";
       }  
    } else {
       print $client "unknown_user\n";
    }
       } else {
    Reply($client, "refused\n", $userinput);
          
       }
   # ---------------------------------------------------------------------- passwd
    } elsif ($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);
   
     ResetStatistics();      }
   # ---------------------------------------------------------------------- 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);
   
 # ------------------------------------------------------------ Process requests      }
     my $KeepGoing = 1;  # -------------------------------------- fetch a user file from a remote server
     while ((my $userinput=GetRequest) && $KeepGoing) {   } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
  $KeepGoing = ProcessRequest($userinput);      if(isClient) {
 # -------------------------------------------------------------------- complete   my ($cmd,$fname)=split(/:/,$userinput);
    my ($udom,$uname,$ufile)=split(/\//,$fname);
    my $udir=propath($udom,$uname).'/userfiles';
    unless (-e $udir) { mkdir($udir,0770); }
    if (-e $udir) {
       $ufile=~s/^[\.\~]+//;
       $ufile=~s/\///g;
       my $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);
   
       }
   # ------------------------------------------ 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=~/userfile\.$fname\=/) { $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($client,$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);
    $namespace=~s/\//\_/g;
    $namespace=~s/\W//g;
    if ($namespace ne 'roles') {
       chomp($what);
       my $proname=propath($udom,$uname);
       my $now=time;
       unless ($namespace=~/^nohist\_/) {
    my $hfh;
    if (
       $hfh=IO::File->new(">>$proname/$namespace.hist")
       ) { print $hfh "P:$now:$what\n"; }
       }
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',
       "$proname/$namespace.db",
       &GDBM_WRCREAT(),0640)) {
    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;
       unless ($namespace=~/^nohist\_/) {
    my $hfh;
    if (
       $hfh=IO::File->new(">>$proname/$namespace.hist")
       ) { print $hfh "P:$now:$what\n"; }
       }
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',
       "$proname/$namespace.db",
       &GDBM_WRCREAT(),0640)) {
    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 $hfh;
    if (
       $hfh=IO::File->new(">>$proname/$namespace.hist")
       ) { 
       print $hfh "P:$now:$exedom:$exeuser:$what\n";
    }
       }
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
    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 $hfh;
    if (
       $hfh=IO::File->new(">>$proname/$namespace.hist")
       ) { 
       print $hfh "D:$now:$exedom:$exeuser:$what\n";
    }
       }
       my @rolekeys=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
    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;
    unless ($namespace=~/^nohist\_/) {
       my $hfh;
       if (
    $hfh=IO::File->new(">>$proname/$namespace.hist")
    ) { print $hfh "D:$now:$what\n"; }
    }
    my @keys=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
       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;
       unless ($namespace=~/^nohist\_/) {
    my $hfh;
    if (
       $hfh=IO::File->new(">>$proname/$namespace.hist")
       ) { print $hfh "P:$now:$rid:$what\n"; }
       }
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
    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,$value)=split(/=/,$pair);
    $hash{$key}=$value.':'.$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)=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(%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 $hfh;
       if (
    $hfh=IO::File->new(">>$proname.hist")
    ) { print $hfh "P:$now:$what\n"; }
    }
    my @pairs=split(/\&/,$what);
    my %hash;
    if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
       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);
        
       }
   # -------------------------------------------------------------------------- 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();
       last;
   
   # ---------------------------------- 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";
       }
   # ------------------------------------------------------------- unknown command
   
    } else {
       # unknown command
       print $client "unknown_cmd\n";
    }
   # -------------------------------------------------------------------- complete
    alarm(0);
  &status('Listening to '.$clientname);   &status('Listening to '.$clientname);
     }      }
 # --------------------------------------------- client unknown or fishy, refuse  # --------------------------------------------- client unknown or fishy, refuse
Line 3951  sub ManagePermissions Line 2877  sub ManagePermissions
     my $authtype= shift;      my $authtype= shift;
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     &logthis("ruequest is $request");  
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
Line 4256  sub version { Line 3181  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;
     {      {
Removed from v.1.178.2.2  
changed lines
  Added in v.1.181

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