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

Diff for /loncom/lond between versions 1.177 and 1.178.2.19

version 1.177, 2004/02/18 10:35:56 version 1.178.2.19, 2004/04/26 10:37:47
Line 48  use localauth; Line 48  use localauth;
 use File::Copy;  use File::Copy;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 1;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
Line 161  sub isManager { Line 161  sub isManager {
 sub isClient {  sub isClient {
     return (($ConnectionType eq "client") || ($ConnectionType eq "both"));      return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
 }  }
   #
   #  Ties a domain level resource file to a hash.
   #  If requested a history entry is created in the associated hist file.
   #
   #  Parameters:
   #     domain    - Name of the domain in which the resource file lives.
   #     namespace - Name of the hash within that domain.
   #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
   #     loghead   - Optional parameter, if present a log entry is created
   #                 in the associated history file and this is the first part
   #                  of that entry.
   #     logtail   - Goes along with loghead,  The actual logentry is of the
   #                 form $loghead:<timestamp>:logtail.
   # Returns:
   #    Reference to a hash bound to the db file or alternatively undef
   #    if the tie failed.
   #
   sub TieDomainHash {
       my $domain    = shift;
       my $namespace = shift;
       my $how       = shift;
       
       # Filter out any whitespace in the domain name:
       
       $domain =~ s/\W//g;
       
       # We have enough to go on to tie the hash:
       
       my $UserTopDir   = $perlvar{'lonUsersDir'};
       my $DomainDir    = $UserTopDir."/$domain";
       my $ResourceFile = $DomainDir."/$namespace.db";
       my %hash;
       if(tie(%hash, 'GDBM_File', $ResourceFile, $how, 0640)) {
    if (scalar @_) { # Need to log the operation.
       my $logFh = IO::File->new(">>$DomainDir/$namespace.hist");
       if($logFh) {
    my $TimeStamp = time;
    my ($loghead, $logtail) = @_;
    print $logFh "$loghead:$TimeStamp:$logtail\n";
       }
    }
    return \%hash; # Return the tied hash.
       }
       else {
    return undef; # Tie failed.
       }
   }
   
   #
   #   Ties a user's resource file to a hash.  
   #   If necessary, an appropriate history
   #   log file entry is made as well.
   #   This sub factors out common code from the subs that manipulate
   #   the various gdbm files that keep keyword value pairs.
   # Parameters:
   #   domain       - Name of the domain the user is in.
   #   user         - Name of the 'current user'.
   #   namespace    - Namespace representing the file to tie.
   #   how          - What the tie is done to (e.g. GDBM_WRCREAT().
   #   loghead      - Optional first part of log entry if there may be a
   #                  history file.
   #   what         - Optional tail of log entry if there may be a history
   #                  file.
   # Returns:
   #   hash to which the database is tied.  It's up to the caller to untie.
   #   undef if the has could not be tied.
   #
   sub TieUserHash {
       my $domain      = shift;
       my $user        = shift;
       my $namespace   = shift;
       my $how         = shift;
       
       $namespace=~s/\//\_/g; # / -> _
       $namespace=~s/\W//g; # whitespace eliminated.
       my $proname     = propath($domain, $user);
      
       # If this is a namespace for which a history is kept,
       # make the history log entry:
       
       
       unless ($namespace =~/^nohist\_/ && (scalar @_ > 0)) {
    my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
    if($hfh) {
       my $now = time;
       my $loghead  = shift;
       my $what    = shift;
       print $hfh "$loghead:$now:$what\n";
    }
       }
       #  Tie the database.
       
       my %hash;
       if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
      $how, 0640)) {
    return \%hash;
       }
       else {
    return undef;
       }
       
   }
   
 #  #
 #   Get a Request:  #   Get a Request:
Line 189  sub GetRequest { Line 290  sub GetRequest {
 #     cipher  - This global holds the negotiated encryption key.  #     cipher  - This global holds the negotiated encryption key.
 #  #
 sub Decipher {  sub Decipher {
    my $input  = shift;      my $input  = shift;
    my $output = '';      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;  
    }  
         
       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;
       }
 }  }
   
 #  #
Line 234  sub Decipher { Line 334  sub Decipher {
 #        register a duplicate command handler.  #        register a duplicate command handler.
 #  #
 sub RegisterHandler {  sub RegisterHandler {
    my $RequestName    = shift;      my $RequestName    = shift;
    my $Procedure      = shift;      my $Procedure      = shift;
    my $MustEncode     = shift;      my $MustEncode     = shift;
    my $ClientOk       = shift;      my $ClientOk       = shift;
    my $ManagerOk      = shift;      my $ManagerOk      = shift;
         
    #  Don't allow duplication#      #  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:      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);      my @entry = ($Procedure, $MustEncode, $ClientTypeMask);
         
    $Dispatcher{$RequestName} = \@entry;      $Dispatcher{$RequestName} = \@entry;
         
         
 }  }
Line 284  sub RegisterHandler { Line 384  sub RegisterHandler {
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
   
 sub PingHandler {  sub PingHandler {
    my $cmd    = shift;      my $cmd    = shift;
    my $tail   = shift;      my $tail   = shift;
    my $client = shift;      my $client = shift;
         
    Reply( $client,"$currenthostid\n","$cmd:$tail");      Reply( $client,"$currenthostid\n","$cmd:$tail");
         
    return 1;      return 1;
 }  }
 RegisterHandler("ping", \&PingHandler, 0, 1, 1);       # Ping unencoded, client or manager.  RegisterHandler("ping", \&PingHandler, 0, 1, 1);       # Ping unencoded, client or manager.
 #  #
Line 309  RegisterHandler("ping", \&PingHandler, 0 Line 409  RegisterHandler("ping", \&PingHandler, 0
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
   
 sub PongHandler {  sub PongHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $replyfd = shift;      my $replyfd = shift;
   
    my $reply=&reply("ping",$clientname);      my $reply=&reply("ping",$clientname);
    Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");       Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
    return 1;      return 1;
 }  }
 RegisterHandler("pong", \&PongHandler, 0, 1, 1);       # Pong unencoded, client or manager  RegisterHandler("pong", \&PongHandler, 0, 1, 1);       # Pong unencoded, client or manager
   
Line 339  RegisterHandler("pong", \&PongHandler, 0 Line 439  RegisterHandler("pong", \&PongHandler, 0
 #      $cipher is set with a reference to a new IDEA encryption object.  #      $cipher is set with a reference to a new IDEA encryption object.
 #  #
 sub EstablishKeyHandler {  sub EstablishKeyHandler {
    my $cmd      = shift;      my $cmd      = shift;
    my $tail     = shift;      my $tail     = shift;
    my $replyfd  = shift;      my $replyfd  = shift;
   
    my $buildkey=time.$$.int(rand 100000);      my $buildkey=time.$$.int(rand 100000);
    $buildkey=~tr/1-6/A-F/;      $buildkey=~tr/1-6/A-F/;
    $buildkey=int(rand 100000).$buildkey.int(rand 100000);      $buildkey=int(rand 100000).$buildkey.int(rand 100000);
    my $key=$currenthostid.$clientname;      my $key=$currenthostid.$clientname;
    $key=~tr/a-z/A-Z/;      $key=~tr/a-z/A-Z/;
    $key=~tr/G-P/0-9/;      $key=~tr/G-P/0-9/;
    $key=~tr/Q-Z/0-9/;      $key=~tr/Q-Z/0-9/;
    $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;      $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
    $key=substr($key,0,32);      $key=substr($key,0,32);
    my $cipherkey=pack("H32",$key);      my $cipherkey=pack("H32",$key);
    $cipher=new IDEA $cipherkey;      $cipher=new IDEA $cipherkey;
    Reply($replyfd, "$buildkey\n", "$cmd:$tail");       Reply($replyfd, "$buildkey\n", "$cmd:$tail"); 
         
    return 1;      return 1;
   
 }  }
 RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1);  RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1);
Line 379  RegisterHandler("ekey", \&EstablishKeyHa Line 479  RegisterHandler("ekey", \&EstablishKeyHa
 #  Side effects:  #  Side effects:
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
 sub LoadHandler {  sub LoadHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $replyfd = shift;      my $replyfd = shift;
   
    # Get the load average from /proc/loadavg and calculate it as a percentage of     # 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     # the allowed load limit as set by the perl global variable lonLoadLim
   
    my $loadavg;      my $loadavg;
    my $loadfile=IO::File->new('/proc/loadavg');      my $loadfile=IO::File->new('/proc/loadavg');
         
    $loadavg=<$loadfile>;      $loadavg=<$loadfile>;
    $loadavg =~ s/\s.*//g;                       # Extract the first field only.      $loadavg =~ s/\s.*//g;                      # Extract the first field only.
         
    my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};      my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
   
    Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");      Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");
         
    return 1;      return 1;
 }  }
 RegisterHandler("load", \&LoadHandler, 0, 1, 0);  RegisterHandler("load", \&LoadHandler, 0, 1, 0);
   
Line 422  RegisterHandler("load", \&LoadHandler, 0 Line 522  RegisterHandler("load", \&LoadHandler, 0
 #     the reply is written to the client.  #     the reply is written to the client.
 #  #
 sub UserLoadHandler {  sub UserLoadHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $replyfd = shift;      my $replyfd = shift;
   
    my $userloadpercent=&userload();      my $userloadpercent=&userload();
    Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");      Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
       
    return 1;      return 1;
 }  }
 RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);  RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);
   
Line 447  RegisterHandler("userload", \&UserLoadHa Line 547  RegisterHandler("userload", \&UserLoadHa
 #    The user authorization type is written to the client.  #    The user authorization type is written to the client.
 #  #
 sub UserAuthorizationType {  sub UserAuthorizationType {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $replyfd = shift;      my $replyfd = shift;
         
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
    #  Pull the domain and username out of the command tail.      #  Pull the domain and username out of the command tail.
    # and call GetAuthType to determine the authentication type.      # and call GetAuthType to determine the authentication type.
         
    my ($udom,$uname)=split(/:/,$tail);      my ($udom,$uname)=split(/:/,$tail);
    my $result = GetAuthType($udom, $uname);      my $result = GetAuthType($udom, $uname);
    if($result eq "nouser") {      if($result eq "nouser") {
       Failure( $replyfd, "unknown_user\n", $userinput);   Failure( $replyfd, "unknown_user\n", $userinput);
    } else {      } else {
       Reply( $replyfd, "$result\n", $userinput);   #
    }   # We only want to pass the second field from GetAuthType
    # for ^krb.. otherwise we'll be handing out the encrypted
    # password for internals e.g.
    #
    my ($type,$otherinfo) = split(/:/,$result);
    if($type =~ /^krb/) {
       $type = $result;
    }
    Reply( $replyfd, "$type\n", $userinput);
       }
       
    return 1;      return 1;
 }  }
 RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0);  RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0);
 #  #
Line 483  RegisterHandler("currentauth", \&UserAut Line 592  RegisterHandler("currentauth", \&UserAut
 #    a reply is written to the client.  #    a reply is written to the client.
   
 sub PushFileHandler {  sub PushFileHandler {
    my $cmd    = shift;      my $cmd    = shift;
    my $tail   = shift;      my $tail   = shift;
    my $client = shift;      my $client = shift;
   
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
    # At this time we only know that the IP of our partner is a valid manager      # 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      # the code below is a hook to do further authentication (e.g. to resolve
    # spoofing).      # spoofing).
   
    my $cert = GetCertificate($userinput);      my $cert = GetCertificate($userinput);
    if(ValidManager($cert)) {       if(ValidManager($cert)) { 
   
       # Now presumably we have the bona fides of both the peer host and the   # Now presumably we have the bona fides of both the peer host and the
       # process making the request.   # process making the request.
               
       my $reply = PushFile($userinput);   my $reply = PushFile($userinput);
       Reply($client, "$reply\n", $userinput);   Reply($client, "$reply\n", $userinput);
   
    } else {      } else {
       Failure( $client, "refused\n", $userinput);   Failure( $client, "refused\n", $userinput);
    }       } 
 }  }
 RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1);  RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1);
   
Line 525  RegisterHandler("pushfile", \&PushFileHa Line 634  RegisterHandler("pushfile", \&PushFileHa
 #     a reply is sent to the client.  #     a reply is sent to the client.
 #  #
 sub ReinitProcessHandler {  sub ReinitProcessHandler {
    my $cmd    = shift;      my $cmd    = shift;
    my $tail   = shift;      my $tail   = shift;
    my $client = shift;      my $client = shift;
         
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
    my $cert = GetCertificate($userinput);      my $cert = GetCertificate($userinput);
    if(ValidManager($cert)) {      if(ValidManager($cert)) {
       chomp($userinput);   chomp($userinput);
       my $reply = ReinitProcess($userinput);   my $reply = ReinitProcess($userinput);
       Reply( $client,  "$reply\n", $userinput);   Reply( $client,  "$reply\n", $userinput);
    } else {      } else {
       Failure( $client, "refused\n", $userinput);   Failure( $client, "refused\n", $userinput);
  }      }
    return 1;      return 1;
 }  }
   
 RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1);  RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1);
Line 559  RegisterHandler("reinit", \&ReinitProces Line 668  RegisterHandler("reinit", \&ReinitProces
 #     a reply is sent to the client.  #     a reply is sent to the client.
 #  #
 sub EditTableHandler {  sub EditTableHandler {
    my $command    = shift;      my $command    = shift;
    my $tail       = shift;      my $tail       = shift;
    my $client     = shift;      my $client     = shift;
         
    my $userinput = "$command:$tail";      my $userinput = "$command:$tail";
   
    my $cert = GetCertificate($userinput);      my $cert = GetCertificate($userinput);
    if(ValidManager($cert)) {      if(ValidManager($cert)) {
       my($filetype, $script) = split(/:/, $tail);   my($filetype, $script) = split(/:/, $tail);
       if (($filetype eq "hosts") ||    if (($filetype eq "hosts") || 
           ($filetype eq "domain")) {      ($filetype eq "domain")) {
          if($script ne "") {      if($script ne "") {
             Reply($client,            # BUGBUG - EditFile   Reply($client,              # BUGBUG - EditFile
                   EditFile($userinput), #   could fail.        EditFile($userinput), #   could fail.
                   $userinput);        $userinput);
          } else {      } else {
             Failure($client,"refused\n",$userinput);   Failure($client,"refused\n",$userinput);
          }      }
       } else {   } else {
          Failure($client,"refused\n",$userinput);      Failure($client,"refused\n",$userinput);
       }   }
    } else {      } else {
       Failure($client,"refused\n",$userinput);   Failure($client,"refused\n",$userinput);
    }      }
    return 1;      return 1;
 }  }
 RegisterHandler("edit", \&EditTableHandler, 1, 0, 1);  RegisterHandler("edit", \&EditTableHandler, 1, 0, 1);
   
Line 598  RegisterHandler("edit", \&EditTableHandl Line 707  RegisterHandler("edit", \&EditTableHandl
 #                internal per user password file.  #                internal per user password file.
 #   - kerberos - The user can be authenticated against either a kerb4 or kerb5  #   - kerberos - The user can be authenticated against either a kerb4 or kerb5
 #                ticket granting authority.  #                ticket granting authority.
 #   - user     - The person tailoring LonCAPA can supply a user authentication mechanism  #   - user     - The person tailoring LonCAPA can supply a user authentication
 #                that is per system.  #                mechanism that is per system.
 #  #
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
Line 613  RegisterHandler("edit", \&EditTableHandl Line 722  RegisterHandler("edit", \&EditTableHandl
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
 #  #
 sub AuthenticateHandler {  sub AuthenticateHandler {
    my $cmd        = shift;      my $cmd        = shift;
    my $tail       = shift;      my $tail       = shift;
    my $client     = shift;      my $client     = shift;
          
    #  Regenerate the full input line       #  Regenerate the full input line 
          
    my $userinput  = $cmd.":".$tail;      my $userinput  = $cmd.":".$tail;
       
    #  udom    - User's domain.      #  udom    - User's domain.
    #  uname   - Username.      #  uname   - Username.
    #  upass   - User's password.      #  upass   - User's password.
          
    my ($udom,$uname,$upass)=split(/:/,$tail);      my ($udom,$uname,$upass)=split(/:/,$tail);
    chomp($upass);      Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
    $upass=unescape($upass);      chomp($upass);
    my $proname=propath($udom,$uname);      $upass=unescape($upass);
    my $passfilename="$proname/passwd";  
          my $pwdcorrect = ValidateUser($udom, $uname, $upass);
    #   The user's 'personal' loncapa passworrd file describes how to authenticate:      if($pwdcorrect) {
       Reply( $client, "authorized\n", $userinput);
    if (-e $passfilename) {   #
       my $pf = IO::File->new($passfilename);   #  Bad credentials: Failed to authorize
       my $realpasswd=<$pf>;   #
       chomp($realpasswd);      } else {
       my ($howpwd,$contentpwd)=split(/:/,$realpasswd);   Failure( $client, "non_authorized\n", $userinput);
       my $pwdcorrect=0;      }
       #  
       #   Authenticate against password stored in the internal file.      return 1;
       #  
       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);  RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);
   
Line 761  RegisterHandler("auth", \&AuthenticateHa Line 775  RegisterHandler("auth", \&AuthenticateHa
 #    The authentication systems describe above have their own forms of implicit  #    The authentication systems describe above have their own forms of implicit
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
 sub ChangePasswordHandler {  sub ChangePasswordHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $client  = shift;      my $client  = shift;
         
    my $userinput = $cmd.":".$tail;           # Reconstruct client's string.      my $userinput = $cmd.":".$tail;           # Reconstruct client's string.
   
    #      #
    #  udom  - user's domain.      #  udom  - user's domain.
    #  uname - Username.      #  uname - Username.
    #  upass - Current password.      #  upass - Current password.
    #  npass - New password.      #  npass - New password.
         
    my ($udom,$uname,$upass,$npass)=split(/:/,$tail);      my ($udom,$uname,$upass,$npass)=split(/:/,$tail);
    chomp($npass);      chomp($npass);
    $upass=&unescape($upass);      $upass=&unescape($upass);
    $npass=&unescape($npass);      $npass=&unescape($npass);
    &Debug("Trying to change password for $uname");      &Debug("Trying to change password for $uname");
    my $proname=propath($udom,$uname);  
    my $passfilename="$proname/passwd";      # First require that the user can be authenticated with their
    if (-e $passfilename) {      # old password:
       my $realpasswd;  
       {       my $validated = ValidateUser($udom, $uname, $upass);
          my $pf = IO::File->new($passfilename);      if($validated) {
          $realpasswd=<$pf>;    my $realpasswd  = GetAuthType($udom, $uname); # Defined since authd.
       }  
       chomp($realpasswd);   my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
       my ($howpwd,$contentpwd)=split(/:/,$realpasswd);   if ($howpwd eq 'internal') {
       if ($howpwd eq 'internal') {      &Debug("internal auth");
          &Debug("internal auth");      my $salt=time;
          if (crypt($upass,$contentpwd) eq $contentpwd) {      $salt=substr($salt,6,2);
             my $salt=time;      my $ncpass=crypt($npass,$salt);
             $salt=substr($salt,6,2);      if(RewritePwFile($udom, $uname, "internal:$ncpass")) {
             my $ncpass=crypt($npass,$salt);   &logthis("Result of password change for "
                {   ."$uname: pwchange_success");
                   my $pf = IO::File->new(">$passfilename");   Reply($client, "ok\n", $userinput);
                   if ($pf) {      } else {
                      print $pf "internal:$ncpass\n";   &logthis("Unable to open $uname passwd "               
                      &logthis("Result of password change for "   ."to change password");
                               ."$uname: pwchange_success");   Failure( $client, "non_authorized\n",$userinput);
                      Reply($client, "ok\n", $userinput);      }
                   } else {   } elsif ($howpwd eq 'unix') {
                      &logthis("Unable to open $uname passwd "                     # Unix means we have to access /etc/password
                               ."to change password");      &Debug("auth is unix");
                      Failure( $client, "non_authorized\n",$userinput);      my $execdir=$perlvar{'lonDaemons'};
                   }      &Debug("Opening lcpasswd pipeline");
                }                   my $pf = IO::File->new("|$execdir/lcpasswd > "
          } else {     ."$perlvar{'lonDaemons'}"
             Failure($client, "non_authorized\n", $userinput);     ."/logs/lcpasswd.log");
          }      print $pf "$uname\n$npass\n$npass\n";
       } elsif ($howpwd eq 'unix') {      close $pf;
          # Unix means we have to access /etc/password      my $err = $?;
          # one way or another.      my $result = ($err>0 ? 'pwchange_failure' : 'ok');
          # First: Make sure the current password is      &logthis("Result of password change for $uname: ".
          #        correct       &lcpasswdstrerror($?));
          &Debug("auth is unix");      Reply($client, "$result\n", $userinput);
          $contentpwd=(getpwnam($uname))[1];   } else {
          my $pwdcorrect = "0";      # this just means that the current password mode is not
          my $pwauth_path="/usr/local/sbin/pwauth";      # one we know how to change (e.g the kerberos auth modes or
          unless ($contentpwd eq 'x') {      # locally written auth handler).
             $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);      #
          } elsif (-e $pwauth_path) {      Reply( $client, "auth_mode_error\n", $userinput);
             open PWAUTH, "|$pwauth_path" or   }  
                die "Cannot invoke authentication";  
             print PWAUTH "$uname\n$upass\n";      }
             close PWAUTH;      else {
             &Debug("exited pwauth with $? ($uname,$upass) ");   Reply( $client, "non_authorized\n", $userinput);
             $pwdcorrect=($? == 0);      }
          }  
          if ($pwdcorrect) {      return 1;
             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);  RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);
   
Line 872  RegisterHandler("passwd", \&ChangePasswo Line 864  RegisterHandler("passwd", \&ChangePasswo
 #    The authentication systems describe above have their own forms of implicit  #    The authentication systems describe above have their own forms of implicit
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
 sub AddUserHandler {  sub AddUserHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $client  = shift;      my $client  = shift;
      
    my $userinput = $cmd.":".$tail;         my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
       my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
    my $oldumask=umask(0077);  
    my ($udom,$uname,$umode,$npass)=split(/:/,$tail);      &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
    &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);  
    chomp($npass);  
    $npass=&unescape($npass);      if($udom eq $currentdomainid) { # Reject new users for other domains...
    my $proname=propath($udom,$uname);  
    my $passfilename="$proname/passwd";   my $oldumask=umask(0077);
    &Debug("Password file created will be:".$passfilename);   chomp($npass);
    if (-e $passfilename) {   $npass=&unescape($npass);
       Failure( $client, "already_exists\n", $userinput);   my $passfilename  = PasswordPath($udom, $uname);
    } elsif ($udom ne $currentdomainid) {   &Debug("Password file created will be:".$passfilename);
       Failure($client, "not_right_domain\n", $userinput);   if (-e $passfilename) {
    } else {      Failure( $client, "already_exists\n", $userinput);
       my @fpparts=split(/\//,$proname);   } else {
       my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];      my @fpparts=split(/\//,$passfilename);
       my $fperror='';      my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
       for (my $i=3;$i<=$#fpparts;$i++) {      my $fperror='';
          $fpnow.='/'.$fpparts[$i];       for (my $i=3;$i<= ($#fpparts-1);$i++) {
          unless (-e $fpnow) {   $fpnow.='/'.$fpparts[$i]; 
             unless (mkdir($fpnow,0777)) {   unless (-e $fpnow) {
                $fperror="error: ".($!+0)." mkdir failed while attempting "      &logthis("mkdir $fpnow");
                        ."makeuser";      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      unless ($fperror) {
       } else {   my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
          Failure($client, "$fperror\n", $userinput);   Reply($client, $result, $userinput);     #BUGBUG - could be fail
       }      } else {
    }   Failure($client, "$fperror\n", $userinput);
    umask($oldumask);      }
    return 1;   }
    umask($oldumask);
       }  else {
    Failure($client, "not_right_domain\n",
    $userinput); # Even if we are multihomed.
       
       }
       return 1;
   
 }  }
 RegisterHandler("makeuser", \&AddUserHandler, 1, 1, 0);  RegisterHandler("makeuser", \&AddUserHandler, 1, 1, 0);
Line 939  RegisterHandler("makeuser", \&AddUserHan Line 938  RegisterHandler("makeuser", \&AddUserHan
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
 #  #
 sub ChangeAuthenticationHandler {  sub ChangeAuthenticationHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $client  = shift;      my $client  = shift;
         
    my $userinput  = "$cmd:$tail";              # Reconstruct user input.      my $userinput  = "$cmd:$tail";              # Reconstruct user input.
   
    my ($udom,$uname,$umode,$npass)=split(/:/,$tail);      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
    chomp($npass);      &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
    &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);      if ($udom ne $currentdomainid) {
    $npass=&unescape($npass);   Failure( $client, "not_right_domain\n", $client);
    my $proname=&propath($udom,$uname);      } else {
    my $passfilename="$proname/passwd";  
    if ($udom ne $currentdomainid) {   chomp($npass);
       Failure( $client, "not_right_domain\n", $client);  
    } else {   $npass=&unescape($npass);
       my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);   my $passfilename = PasswordPath($udom, $uname);
       Reply($client, $result, $userinput);   if ($passfilename) { # Not allowed to create a new user!!
    }      my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
    return 1;      Reply($client, $result, $userinput);
    } else {       
       Failure($client, "non_authorized", $userinput); # Fail the user now.
    }
       }
       return 1;
 }  }
 RegisterHandler("changeuserauth", \&ChangeAuthenticationHandler, 1,1, 0);  RegisterHandler("changeuserauth", \&ChangeAuthenticationHandler, 1,1, 0);
   
Line 978  RegisterHandler("changeuserauth", \&Chan Line 982  RegisterHandler("changeuserauth", \&Chan
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
 #  #
 sub IsHomeHandler {  sub IsHomeHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $client  = shift;      my $client  = shift;
         
    my $userinput  = "$cmd:$tail";      my $userinput  = "$cmd:$tail";
         
    my ($udom,$uname)=split(/:/,$tail);      my ($udom,$uname)=split(/:/,$tail);
    chomp($uname);      chomp($uname);
    my $proname=propath($udom,$uname);      my $passfile = PasswordFilename($udom, $uname);
    if (-e $proname) {      if($passfile) {
       Reply( $client, "found\n", $userinput);   Reply( $client, "found\n", $userinput);
    } else {      } else {
       Failure($client, "not_found\n", $userinput);   Failure($client, "not_found\n", $userinput);
    }      }
    return 1;      return 1;
 }  }
 RegisterHandler("home", \&IsHomeHandler, 0,1,0);  RegisterHandler("home", \&IsHomeHandler, 0,1,0);
 #  #
Line 1018  RegisterHandler("home", \&IsHomeHandler, Line 1022  RegisterHandler("home", \&IsHomeHandler,
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
 #  #
 sub UpdateResourceHandler {  sub UpdateResourceHandler {
    my $cmd    = shift;      my $cmd    = shift;
    my $tail   = shift;      my $tail   = shift;
    my $client = shift;      my $client = shift;
         
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
    my $fname=$tail;      my $fname=$tail;
    my $ownership=ishome($fname);      my $ownership=ishome($fname);
    if ($ownership eq 'not_owner') {      if ($ownership eq 'not_owner') {
       if (-e $fname) {   if (-e $fname) {
          my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
              $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
          my $now=time;      my $now=time;
          my $since=$now-$atime;      my $since=$now-$atime;
          if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
             my $reply=&reply("unsub:$fname","$clientname");   my $reply=&reply("unsub:$fname","$clientname");
             unlink("$fname");   unlink("$fname");
          } else {      } else {
             my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
             my $remoteurl=&reply("sub:$fname","$clientname");   my $remoteurl=&reply("sub:$fname","$clientname");
             my $response;   my $response;
             alarm(120);   alarm(120);
             {   {
                my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
                my $request=new HTTP::Request('GET',"$remoteurl");      my $request=new HTTP::Request('GET',"$remoteurl");
                $response=$ua->request($request,$transname);      $response=$ua->request($request,$transname);
             }   }
             alarm(0);   alarm(0);
             if ($response->is_error()) {   if ($response->is_error()) {
                unlink($transname);      unlink($transname);
                my $message=$response->status_line;      my $message=$response->status_line;
                &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
             } else {   } else {
                if ($remoteurl!~/\.meta$/) {      if ($remoteurl!~/\.meta$/) {
                   alarm(120);   alarm(120);
                   {   {
                      my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
                      my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');      my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                      my $mresponse=$ua->request($mrequest,$fname.'.meta');      my $mresponse=$ua->request($mrequest,$fname.'.meta');
                      if ($mresponse->is_error()) {      if ($mresponse->is_error()) {
                         unlink($fname.'.meta');   unlink($fname.'.meta');
                      }      }
                   }   }
                   alarm(0);   alarm(0);
                }      }
                rename($transname,$fname);      rename($transname,$fname);
             }   }
          }      }
                Reply( $client, "ok\n", $userinput);      Reply( $client, "ok\n", $userinput);
       } else {   } else {
          Failure($client, "not_found\n", $userinput);      Failure($client, "not_found\n", $userinput);
       }   }
    } else {      } else {
       Failure($client, "rejected\n", $userinput);   Failure($client, "rejected\n", $userinput);
    }      }
    return 1;      return 1;
 }  }
 RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0);  RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0);
   
Line 1088  RegisterHandler("update", \&UpdateResour Line 1092  RegisterHandler("update", \&UpdateResour
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub FetchUserFileHandler {  sub FetchUserFileHandler {
    my $cmd     = shift;      my $cmd     = shift;
    my $tail    = shift;      my $tail    = shift;
    my $client  = shift;      my $client  = shift;
         
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
    my $fname           = $tail;      my $fname           = $tail;
    my ($udom,$uname,$ufile)=split(/\//,$fname);      my ($udom,$uname,$ufile)=split(/\//,$fname);
    my $udir=propath($udom,$uname).'/userfiles';      my $udir=propath($udom,$uname).'/userfiles';
    unless (-e $udir) {      unless (-e $udir) {
       mkdir($udir,0770);    mkdir($udir,0770); 
    }      }
    if (-e $udir) {      if (-e $udir) {
       $ufile=~s/^[\.\~]+//;   $ufile=~s/^[\.\~]+//;
       $ufile=~s/\///g;   $ufile=~s/\///g;
       my $destname=$udir.'/'.$ufile;   my $destname=$udir.'/'.$ufile;
       my $transname=$udir.'/'.$ufile.'.in.transit';   my $transname=$udir.'/'.$ufile.'.in.transit';
       my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;   my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
       my $response;   my $response;
       alarm(120);   alarm(120);
       {   {
          my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
          my $request=new HTTP::Request('GET',"$remoteurl");      my $request=new HTTP::Request('GET',"$remoteurl");
          $response=$ua->request($request,$transname);      $response=$ua->request($request,$transname);
       }   }
       alarm(0);   alarm(0);
       if ($response->is_error()) {   if ($response->is_error()) {
          unlink($transname);      unlink($transname);
          my $message=$response->status_line;      my $message=$response->status_line;
          &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
          Failure($client, "failed\n", $userinput);      Failure($client, "failed\n", $userinput);
       } else {   } else {
          if (!rename($transname,$destname)) {      if (!rename($transname,$destname)) {
             &logthis("Unable to move $transname to $destname");   &logthis("Unable to move $transname to $destname");
             unlink($transname);   unlink($transname);
             Failure($client, "failed\n", $userinput);   Failure($client, "failed\n", $userinput);
          } else {      } else {
             Reply($client, "ok\n", $userinput);   Reply($client, "ok\n", $userinput);
          }      }
       }      }   
    } else {      } else {
       Failure($client, "not_home\n", $userinput);   Failure($client, "not_home\n", $userinput);
    }      }
    return 1;      return 1;
 }  }
 RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);  RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);
 #  #
 #   Authenticate access to a user file.  Question?   The token for athentication  #   Authenticate access to a user file. 
 #   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:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
Line 1146  RegisterHandler("fetchuserfile", \&Fetch Line 1148  RegisterHandler("fetchuserfile", \&Fetch
 #     0        - Requested to exit, caller should shut down.  #     0        - Requested to exit, caller should shut down.
 #     1        - Continue processing.  #     1        - Continue processing.
 sub AuthenticateUserFileAccess {  sub AuthenticateUserFileAccess {
    my $cmd   = shift;      my $cmd       = shift;
    my $tail    = shift;      my $tail      = shift;
    my $client = shift;      my $client    = shift;
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
    my ($fname,$session)=split(/:/,$tail);      my ($fname,$session)=split(/:/,$tail);
    chomp($session);      chomp($session);
    my $reply='non_auth';      my $reply='non_auth';
    if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.$session.'.id')) {      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.$session.'.id')) {
       while (my $line=<ENVIN>) {   while (my $line=<ENVIN>) {
          if ($line=~/userfile\.$fname\=/) {       if ($line=~/userfile\.$fname\=/) { 
             $reply='ok';    $reply='ok'; 
          }      }
       }   }
       close(ENVIN);   close(ENVIN);
       Reply($client, $reply."\n", $userinput);   Reply($client, $reply."\n", $userinput);
    } else {      } else {
       Failure($client, "invalid_token\n", $userinput);   Failure($client, "invalid_token\n", $userinput);
    }      }
    return 1;      return 1;
         
 }  }
 RegisterHandler("tokenauthuserfile", \&AuthenticateUserFileAccess, 0, 1, 0);  RegisterHandler("tokenauthuserfile", \&AuthenticateUserFileAccess, 0, 1, 0);
Line 1181  RegisterHandler("tokenauthuserfile", \&A Line 1183  RegisterHandler("tokenauthuserfile", \&A
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub UnsubscribeHandler {  sub UnsubscribeHandler {
    my $cmd      = shift;      my $cmd      = shift;
    my $tail     = shift;      my $tail     = shift;
    my $client   = shift;      my $client   = shift;
    my $userinput= "$cmd:$tail";      my $userinput= "$cmd:$tail";
       
    my $fname = $tail;      my $fname = $tail;
    if (-e $fname) {      if (-e $fname) {
       Reply($client, &unsub($client,$fname,$clientip), $userinput);   Reply($client, &unsub($client,$fname,$clientip), $userinput);
    } else {      } else {
       Failure($client, "not_found\n", $userinput);   Failure($client, "not_found\n", $userinput);
    }      }
    return 1;      return 1;
 }  }
 RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);  RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);
   
 #   Subscribe to a resource.  #   Subscribe to a resource
 #  #
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
Line 1207  RegisterHandler("unusb", \&UnsubscribeHa Line 1209  RegisterHandler("unusb", \&UnsubscribeHa
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub SubscribeHandler {  sub SubscribeHandler {
    my $cmd        = shift;      my $cmd        = shift;
    my $tail       = shift;      my $tail       = shift;
    my $client     = shift;      my $client     = shift;
    my $userinput  = "$cmd:$tail";      my $userinput  = "$cmd:$tail";
   
    Reply( $client, &subscribe($userinput,$clientip), $userinput);      Reply( $client, &subscribe($userinput,$clientip), $userinput);
    
    return 1;      return 1;
 }  }
 RegisterHandler("sub", \&SubscribeHandler, 0, 1, 0);  RegisterHandler("sub", \&SubscribeHandler, 0, 1, 0);
   
Line 1232  RegisterHandler("sub", \&SubscribeHandle Line 1234  RegisterHandler("sub", \&SubscribeHandle
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub CurrentVersionHandler {  sub CurrentVersionHandler {
    my $cmd      = shift;      my $cmd      = shift;
    my $tail     = shift;      my $tail     = shift;
    my $client   = shift;      my $client   = shift;
    my $userinput= "$cmd:$tail";      my $userinput= "$cmd:$tail";
         
    my $fname   = $tail;      my $fname   = $tail;
    Reply( $client, &currentversion($fname)."\n", $userinput);      Reply( $client, &currentversion($fname)."\n", $userinput);
    return 1;      return 1;
   
 }  }
 RegisterHandler("currentversion", \&CurrentVersionHandler, 0, 1, 0);  RegisterHandler("currentversion", \&CurrentVersionHandler, 0, 1, 0);
Line 1256  RegisterHandler("currentversion", \&Curr Line 1258  RegisterHandler("currentversion", \&Curr
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub ActivityLogEntryHandler {  sub ActivityLogEntryHandler {
    my $cmd      = shift;      my $cmd      = shift;
    my $tail     = shift;      my $tail     = shift;
    my $client   = shift;      my $client   = shift;
    my $userinput= "$cmd:$tail";      my $userinput= "$cmd:$tail";
   
    my ($udom,$uname,$what)=split(/:/,$tail);      my ($udom,$uname,$what)=split(/:/,$tail);
    chomp($what);      chomp($what);
    my $proname=propath($udom,$uname);      my $proname=propath($udom,$uname);
    my $now=time;      my $now=time;
    my $hfh;      my $hfh;
    if ($hfh=IO::File->new(">>$proname/activity.log")) {       if ($hfh=IO::File->new(">>$proname/activity.log")) { 
       print $hfh "$now:$clientname:$what\n";   print $hfh "$now:$clientname:$what\n";
       Reply( $client, "ok\n", $userinput);    Reply( $client, "ok\n", $userinput); 
    } else {      } else {
       Reply($client, "error: ".($!+0)." IO::File->new Failed "   Failure($client, "error: ".($!+0)." IO::File->new Failed "
             ."while attempting log\n",         ."while attempting log\n", 
             $userinput);        $userinput);
    }      }
   
    return 1;      return 1;
 }  }
 RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0);  RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0);
 #  #
Line 1293  RegisterHandler("log", \&ActivityLogEntr Line 1295  RegisterHandler("log", \&ActivityLogEntr
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub PutUserProfileEntry {  sub PutUserProfileEntry {
    my $cmd       = shift;      my $cmd       = shift;
    my $tail      = shift;      my $tail      = shift;
    my $client    = shift;      my $client    = shift;
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
       
    my ($udom,$uname,$namespace,$what) =split(/:/,$tail);      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
    $namespace=~s/\//\_/g;      if ($namespace ne 'roles') {
    $namespace=~s/\W//g;   chomp($what);
    if ($namespace ne 'roles') {   my $hashref = TieUserHash($udom, $uname, $namespace,
       chomp($what);    &GDBM_WRCREAT(),"P",$what);
       my $proname=propath($udom,$uname);   if($hashref) {
       my $now=time;      my @pairs=split(/\&/,$what);
       unless ($namespace=~/^nohist\_/) {      foreach my $pair (@pairs) {
          my $hfh;   my ($key,$value)=split(/=/,$pair);
          if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {    $hashref->{$key}=$value;
             print $hfh "P:$now:$what\n";       }
          }      if (untie(%$hashref)) {
       }   Reply( $client, "ok\n", $userinput);
       my @pairs=split(/\&/,$what);      } else {
       my %hash;   Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",   "while attempting put\n", 
                   &GDBM_WRCREAT(),0640)) {   $userinput);
          foreach my $pair (@pairs) {      }
             my ($key,$value)=split(/=/,$pair);   } else {
             $hash{$key}=$value;      Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
          }       "while attempting put\n", $userinput);
          if (untie(%hash)) {   }
             Reply( $client, "ok\n", $userinput);      } else {
          } else {          Failure( $client, "refused\n", $userinput);
             Failure($client, "error: ".($!+0)." untie(GDBM) failed ".      }
                   "while attempting put\n",       
                   $userinput);      return 1;
          }  
       } 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);  RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);
   
Line 1354  RegisterHandler("put", \&PutUserProfileE Line 1346  RegisterHandler("put", \&PutUserProfileE
 #     1        - Continue processing.  #     1        - Continue processing.
 #  #
 sub IncrementUserValueHandler {  sub IncrementUserValueHandler {
    my $cmd         = shift;      my $cmd         = shift;
    my $tail        = shift;      my $tail        = shift;
    my $client      = shift;      my $client      = shift;
    my $userinput   = shift;      my $userinput   = "$cmd:$tail";
   
    my ($udom,$uname,$namespace,$what) =split(/:/,$tail);      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
    $namespace=~s/\//\_/g;      if ($namespace ne 'roles') {
    $namespace=~s/\W//g;          chomp($what);
    if ($namespace ne 'roles') {   my $hashref = TieUserHash($udom, $uname,
       chomp($what);    $namespace, &GDBM_WRCREAT(),
       my $proname=propath($udom,$uname);    "P",$what);
       my $now=time;   if ($hashref) {
       unless ($namespace=~/^nohist\_/) {      my @pairs=split(/\&/,$what);
          my $hfh;      foreach my $pair (@pairs) {
          if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {    my ($key,$value)=split(/=/,$pair);
             print $hfh "P:$now:$what\n";   # We could check that we have a number...
          }   if (! defined($value) || $value eq '') {
       }      $value = 1;
       my @pairs=split(/\&/,$what);   }
       my %hash;   $hashref->{$key}+=$value;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),      }
                0640)) {      if (untie(%$hashref)) {
          foreach my $pair (@pairs) {   Reply( $client, "ok\n", $userinput);
             my ($key,$value)=split(/=/,$pair);      } else {
             # We could check that we have a number...   Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
             if (! defined($value) || $value eq '') {   "while attempting inc\n", $userinput);
                $value = 1;      }
             }   } else {
             $hash{$key}+=$value;      Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
          }      "while attempting inc\n", $userinput);
          if (untie(%hash)) {   }
             Reply( $client, "ok\n", $userinput);      } else {
          } else {   Failure($client, "refused\n", $userinput);
             Failure($client, "error: ".($!+0)." untie(GDBM) failed ".      }
                      "while attempting put\n", $userinput);      
          }      return 1;
       } 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);  RegisterHandler("inc", \&IncrementUserValueHandler, 0, 1, 0);
 #  #
Line 1422  RegisterHandler("inc", \&IncrementUserVa Line 1405  RegisterHandler("inc", \&IncrementUserVa
 #  #
 #  #
 sub RolesPutHandler {  sub RolesPutHandler {
    my $cmd        = shift;      my $cmd        = shift;
    my $tail       = shift;      my $tail       = shift;
    my $client     = shift;      my $client     = shift;
    my $userinput  = "$cmd:$tail";      my $userinput  = "$cmd:$tail";
      
    my ($exedom,$exeuser,$udom,$uname,$what)   =split(/:/,$tail);      my ( $exedom, $exeuser, $udom, $uname,  $what) = split(/:/,$tail);
    &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.      
           "what = ".$what);  
    my $namespace='roles';      my $namespace='roles';
    chomp($what);      chomp($what);
    my $proname=propath($udom,$uname);      my $hashref = TieUserHash($udom, $uname, $namespace,
    my $now=time;        &GDBM_WRCREAT(), "P",
    #        "$exedom:$exeuser:$what");
    #  Log the attempt to set a role.  The {}'s here ensure that the file       #
    #  handle is open for the minimal amount of time.  Since the flush      #  Log the attempt to set a role.  The {}'s here ensure that the file 
    #  is done on close this improves the chances the log will be an un-      #  handle is open for the minimal amount of time.  Since the flush
    #  corrupted ordered thing.      #  is done on close this improves the chances the log will be an un-
    {      #  corrupted ordered thing.
       my $hfh;      if ($hashref) {
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {    my @pairs=split(/\&/,$what);
          print $hfh "P:$now:$exedom:$exeuser:$what\n";   foreach my $pair (@pairs) {
       }      my ($key,$value)=split(/=/,$pair);
    }      &ManagePermissions($key, $udom, $uname,
    my @pairs=split(/\&/,$what);         &GetAuthType( $udom, $uname));
    my %hash;      $hashref->{$key}=$value;
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) {   }
       foreach my $pair (@pairs) {   if (untie($hashref)) {
          my ($key,$value)=split(/=/,$pair);      Reply($client, "ok\n", $userinput);
             &ManagePermissions($key, $udom, $uname,   } else {
                                &GetAuthType( $udom, $uname));      Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
             $hash{$key}=$value;       "while attempting rolesput\n", $userinput);
       }   }
       if (untie(%hash)) {      } else {
          Reply($client, "ok\n", $userinput);   Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
       } else {   "while attempting rolesput\n", $userinput);
          Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      }
                          "while attempting rolesput\n", $userinput);      return 1;
       }  
    } else {  
       Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".  
                         "while attempting rolesput\n", $userinput);  
    }  
    return 1;  
 }  }
 RegisterHandler("rolesput", \&RolesPutHandler, 1,1,0);  # Encoded client only.  RegisterHandler("rolesput", \&RolesPutHandler, 1,1,0);  # Encoded client only.
 #  #
Line 1485  RegisterHandler("rolesput", \&RolesPutHa Line 1462  RegisterHandler("rolesput", \&RolesPutHa
 #     0                    - Exit.  #     0                    - Exit.
 #  #
 sub RolesDeleteHandler {  sub RolesDeleteHandler {
    my $cmd          = shift;      my $cmd          = shift;
    my $tail         = shift;      my $tail         = shift;
    my $client       = shift;      my $client       = shift;
    my $userinput    = "$cmd:$tail";      my $userinput    = "$cmd:$tail";
         
    my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);      my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
    &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.      &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
           "what = ".$what);     "what = ".$what);
    my $namespace='roles';      my $namespace='roles';
    chomp($what);      chomp($what);
    my $proname=propath($udom,$uname);      my $hashref = TieUserHash($udom, $uname, $namespace,
    my $now=time;        &GDBM_WRCREAT(), "D",
    #        "$exedom:$exeuser:$what");
    #   Log the attempt. This {}'ing is done to ensure that the      
    #   logfile is flushed and closed as quickly as possible.  Hopefully      if ($hashref) {
    #   this preserves both time ordering and reduces the probability that   my @rolekeys=split(/\&/,$what);
    #   messages will be interleaved.  
    #   foreach my $key (@rolekeys) {
    {      delete $hashref->{$key};
       my $hfh;   }
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {    if (untie(%$hashref)) {
          print $hfh "D:$now:$exedom:$exeuser:$what\n";      Reply($client, "ok\n", $userinput);
       }   } else {
    }      Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
    my @rolekeys=split(/\&/,$what);       "while attempting rolesdel\n", $userinput);
    my %hash;   }
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) {      } else {
       foreach my $key (@rolekeys) {          Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
          delete $hash{$key};   "while attempting rolesdel\n", $userinput);
       }      }
       if (untie(%hash)) {      
          Reply($client, "ok\n", $userinput);      return 1;
       } 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  RegisterHandler("rolesdel", \&RolesDeleteHandler, 1,1, 0); # Encoded client only
   
Line 1550  RegisterHandler("rolesdel", \&RolesDelet Line 1517  RegisterHandler("rolesdel", \&RolesDelet
 #   0       - Exit.  #   0       - Exit.
 #  #
 sub GetProfileEntry {  sub GetProfileEntry {
    my $cmd      = shift;      my $cmd      = shift;
    my $tail     = shift;      my $tail     = shift;
    my $client   = shift;      my $client   = shift;
    my $userinput= "$cmd:$tail";      my $userinput= "$cmd:$tail";
         
    my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
    $namespace=~s/\//\_/g;      chomp($what);
    $namespace=~s/\W//g;      my $hashref = TieUserHash($udom, $uname, $namespace,
    chomp($what);        &GDBM_READER());
    my @queries=split(/\&/,$what);      if ($hashref) {
    my $proname=propath($udom,$uname);          my @queries=split(/\&/,$what);
    my $qresult='';          my $qresult='';
    my %hash;  
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) {   for (my $i=0;$i<=$#queries;$i++) {
       for (my $i=0;$i<=$#queries;$i++) {      $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
          $qresult.="$hash{$queries[$i]}&";    # Presumably failure gives empty string.   }
       }   $qresult=~s/\&$//;              # Remove trailing & from last lookup.
       if (untie(%hash)) {   if (untie(%$hashref)) {
          $qresult=~s/\&$//;              # Remove trailing & from last lookup.      Reply($client, "$qresult\n", $userinput);
          Reply($client, "$qresult\n", $userinput);   } else {
       } else {      Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
          Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      "while attempting get\n", $userinput);
                           "while attempting get\n", $userinput);   }
       }      } else {
    } else {   if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT
       if ($!+0 == 2) {                # +0 coerces errno -> number 2 is ENOENT      Failure($client, "error:No such file or ".
          Failure($client, "error:No such file or ".      "GDBM reported bad block error\n", $userinput);
                           "GDBM reported bad block error\n", $userinput);   } else {                        # Some other undifferentiated err.
       } else {                        # Some other undifferentiated err.      Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
          Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".      "while attempting get\n", $userinput);
                            "while attempting get\n", $userinput);   }
       }      }
    }      return 1;
    return 1;  
 }  }
 RegisterHandler("get", \&GetProfileEntry, 0,1,0);  RegisterHandler("get", \&GetProfileEntry, 0,1,0);
 #  #
Line 1606  RegisterHandler("get", \&GetProfileEntry Line 1572  RegisterHandler("get", \&GetProfileEntry
 #     1      - Continue processing  #     1      - Continue processing
 #     0      - server should exit.  #     0      - server should exit.
 sub GetProfileEntryEncrypted {  sub GetProfileEntryEncrypted {
    my $cmd       = shift;      my $cmd       = shift;
    my $tail      = shift;      my $tail      = shift;
    my $client    = shift;      my $client    = shift;
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
    my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);      my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
    $namespace=~s/\//\_/g;      chomp($what);
    $namespace=~s/\W//g;      my $hashref = TieUserHash($udom, $uname, $namespace,
    chomp($what);    &GDBM_READER());
    my @queries=split(/\&/,$what);      if ($hashref) {
    my $proname=propath($udom,$uname);          my @queries=split(/\&/,$what);
    my $qresult='';          my $qresult='';
    my %hash;   for (my $i=0;$i<=$#queries;$i++) {
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {      $qresult.="$hashref->{$queries[$i]}&";
       for (my $i=0;$i<=$#queries;$i++) {   }
          $qresult.="$hash{$queries[$i]}&";   if (untie(%$hashref)) {
       }      $qresult=~s/\&$//;
       if (untie(%hash)) {      if ($cipher) {
          $qresult=~s/\&$//;   my $cmdlength=length($qresult);
          if ($cipher) {   $qresult.="         ";
             my $cmdlength=length($qresult);   my $encqresult='';
             $qresult.="         ";   for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
             my $encqresult='';      $encqresult.= unpack("H16", 
             for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {   $cipher->encrypt(substr($qresult,
                $encqresult.= unpack("H16", $cipher->encrypt(substr($qresult,   $encidx,
                                                                    $encidx,   8)));
                                                                    8)));   }
             }   Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
             Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);      } else {
          } else {   Failure( $client, "error:no_key\n", $userinput);
             Failure( $client, "error:no_key\n", $userinput);      }
          }   } else {
       } else {      Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
          Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      "while attempting eget\n", $userinput);
                               "while attempting eget\n", $userinput);   }
       }      } else {
    } else {   Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   "while attempting eget\n", $userinput);
                        "while attempting eget\n", $userinput);      }
    }      
                return 1;
    return 1;  
 }  }
 RegisterHandler("eget", \&GetProfileEncrypted, 0, 1, 0);  RegisterHandler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
   
 #  #
 #   Deletes a key in a user profile database.  #   Deletes a key in a user profile database.
Line 1669  RegisterHandler("eget", \&GetProfileEncr Line 1634  RegisterHandler("eget", \&GetProfileEncr
 #     0   - Exit server.  #     0   - Exit server.
 #  #
 #  #
 sub DeletProfileEntry {  
    my $cmd      = shift;  sub DeleteProfileEntry {
    my $tail     = shift;      my $cmd      = shift;
    my $client   = shift;      my $tail     = shift;
    my $userinput = "cmd:$tail";      my $client   = shift;
       my $userinput = "cmd:$tail";
    my ($udom,$uname,$namespace,$what) = split(/:/,$tail);  
    $namespace=~s/\//\_/g;      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
    $namespace=~s/\W//g;      chomp($what);
    chomp($what);      my $hashref = TieUserHash($udom, $uname, $namespace,
    my $proname=propath($udom,$uname);    &GDBM_WRCREAT(),
    my $now=time;    "D",$what);
    unless ($namespace=~/^nohist\_/) {      if ($hashref) {
       my $hfh;          my @keys=split(/\&/,$what);
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {    foreach my $key (@keys) {
          print $hfh "D:$now:$what\n";       delete($hashref->{$key});
       }   }
    }   if (untie(%$hashref)) {
    my @keys=split(/\&/,$what);      Reply($client, "ok\n", $userinput);
    my %hash;   } else {
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {      Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       foreach my $key (@keys) {      "while attempting del\n", $userinput);
          delete($hash{$key});   }
       }      } else {
       if (untie(%hash)) {   Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
          Reply($client, "ok\n", $userinput);   "while attempting del\n", $userinput);
       } else {      }
          Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      return 1;
                            "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);  RegisterHandler("del", \&DeleteProfileEntry, 0, 1, 0);
 #  #
Line 1722  RegisterHandler("del", \&DeleteProfileEn Line 1680  RegisterHandler("del", \&DeleteProfileEn
 #    0    - Exit the server.  #    0    - Exit the server.
 #  #
 sub GetProfileKeys {  sub GetProfileKeys {
    my $cmd       = shift;      my $cmd       = shift;
    my $tail      = shift;      my $tail      = shift;
    my $client    = shift;      my $client    = shift;
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
    my ($udom,$uname,$namespace)=split(/:/,$tail);      my ($udom,$uname,$namespace)=split(/:/,$tail);
    $namespace=~s/\//\_/g;      my $qresult='';
    $namespace=~s/\W//g;      my $hashref = TieUserHash($udom, $uname, $namespace,
    my $proname=propath($udom,$uname);    &GDBM_READER());
    my $qresult='';      if ($hashref) {
    my %hash;   foreach my $key (keys %$hashref) {
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {      $qresult.="$key&";
       foreach my $key (keys %hash) {   }
           $qresult.="$key&";   if (untie(%$hashref)) {
       }      $qresult=~s/\&$//;
       if (untie(%hash)) {      Reply($client, "$qresult\n", $userinput);
          $qresult=~s/\&$//;   } else {
          Reply($client, "$qresult\n", $userinput);      Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       } else {      "while attempting keys\n", $userinput);
          Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".   }
                           "while attempting keys\n", $userinput);      } else {
       }   Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    } else {   "while attempting keys\n", $userinput);
       Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".      }
                         "while attempting keys\n", $userinput);  
    }  
         
    return 1;      return 1;
 }  }
 RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0);  RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0);
 #  #
Line 1772  RegisterHandler("keys", \&GetProfileKeys Line 1728  RegisterHandler("keys", \&GetProfileKeys
 #     0    - Exit the server.  #     0    - Exit the server.
 #  #
 sub DumpProfileDatabase {  sub DumpProfileDatabase {
    my $cmd       = shift;      my $cmd       = shift;
    my $tail      = shift;      my $tail      = shift;
    my $client    = shift;      my $client    = shift;
    my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
    my ($udom,$uname,$namespace) = split(/:/,$tail);      my ($udom,$uname,$namespace) = split(/:/,$tail);
    $namespace=~s/\//\_/g;      my $hashref = TieUserHash($udom, $uname, $namespace,
    $namespace=~s/\W//g;    &GDBM_READER());
    my $qresult='';      if ($hashref) {
    my $proname=propath($udom,$uname);   # Structure of %data:
    my %hash;   # $data{$symb}->{$parameter}=$value;
    if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) {   # $data{$symb}->{'v.'.$parameter}=$version;
       # Structure of %data:   # since $parameter will be unescaped, we do not
       # $data{$symb}->{$parameter}=$value;    # have to worry about silly parameter names...
       # $data{$symb}->{'v.'.$parameter}=$version;  
       # since $parameter will be unescaped, we do not          my $qresult='';
       # have to worry about silly parameter names...   my %data = ();                     # A hash of anonymous hashes..
       my %data = ();                     # A hash of anonymous hashes..   while (my ($key,$value) = each(%$hashref)) {
       while (my ($key,$value) = each(%hash)) {      my ($v,$symb,$param) = split(/:/,$key);
          my ($v,$symb,$param) = split(/:/,$key);      next if ($v eq 'version' || $symb eq 'keys');
          next if ($v eq 'version' || $symb eq 'keys');      next if (exists($data{$symb}) && 
          next if (exists($data{$symb}) &&        exists($data{$symb}->{$param}) &&
                   exists($data{$symb}->{$param}) &&       $data{$symb}->{'v.'.$param} > $v);
                   $data{$symb}->{'v.'.$param} > $v);      $data{$symb}->{$param}=$value;
          $data{$symb}->{$param}=$value;      $data{$symb}->{'v.'.$param}=$v;
          $data{$symb}->{'v.'.$param}=$v;   }
       }   if (untie(%$hashref)) {
       if (untie(%hash)) {      while (my ($symb,$param_hash) = each(%data)) {
          while (my ($symb,$param_hash) = each(%data)) {   while(my ($param,$value) = each (%$param_hash)){
             while(my ($param,$value) = each (%$param_hash)){      next if ($param =~ /^v\./);       # Ignore versions...
                next if ($param =~ /^v\./);       # Ignore versions...      #
                #      #   Just dump the symb=value pairs separated by &
                #   Just dump the symb=value pairs separated by &      #
                #      $qresult.=$symb.':'.$param.'='.$value.'&';
                $qresult.=$symb.':'.$param.'='.$value.'&';   }
             }      }
          }      chop($qresult);
          chop($qresult);      Reply($client , "$qresult\n", $userinput);
          Reply($client , "$qresult\n", $userinput);   } else {
       } else {      Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
          Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".       "while attempting currentdump\n", $userinput);
                            "while attempting currentdump\n", $userinput);   }
       }      } else {
    } else {   Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   "while attempting currentdump\n", $userinput);
                         "while attempting currentdump\n", $userinput);      }
    }  
   
    return 1;      return 1;
 }  }
 RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0);  RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0);
 #  #
Line 1848  RegisterHandler("currentdump", \&DumpPro Line 1803  RegisterHandler("currentdump", \&DumpPro
 #    response is written to $client.  #    response is written to $client.
 #  #
 sub DumpWithRegexp {  sub DumpWithRegexp {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = shift;      my $client = shift;
   
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);      my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
   $namespace=~s/\//\_/g;      if (defined($regexp)) {
   $namespace=~s/\W//g;   $regexp=&unescape($regexp);
   if (defined($regexp)) {      } else {
     $regexp=&unescape($regexp);   $regexp='.';
   } else {      }
     $regexp='.';      my $hashref =TieUserHash($udom, $uname, $namespace,
   }   &GDBM_READER());
   my $qresult='';      if ($hashref) {
   my $proname=propath($udom,$uname);          my $qresult='';
   my %hash;   while (my ($key,$value) = each(%$hashref)) {
   if (tie(%hash,'GDBM_File',"$proname/$namespace.db",      if ($regexp eq '.') {
   &GDBM_READER(),0640)) {   $qresult.=$key.'='.$value.'&';
     study($regexp);      } else {
     while (my ($key,$value) = each(%hash)) {   my $unescapeKey = &unescape($key);
       if ($regexp eq '.') {   if (eval('$unescapeKey=~/$regexp/')) {
  $qresult.=$key.'='.$value.'&';      $qresult.="$key=$value&";
       } else {   }
  my $unescapeKey = &unescape($key);      }
  if (eval('$unescapeKey=~/$regexp/')) {   }
   $qresult.="$key=$value&";   if (untie(%$hashref)) {
  }      chop($qresult);
       }      Reply($client, "$qresult\n", $userinput);
     }   } else {
     if (untie(%hash)) {      Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
       chop($qresult);       "while attempting dump\n", $userinput);
       Reply($client, "$qresult\n", $userinput);   }
     } else {      } else {
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".   Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting dump\n", $userinput);   "while attempting dump\n", $userinput);
     }      }
   } else {  
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
     "while attempting dump\n", $userinput);  
   }  
   
     return 1;      return 1;
 }  }
 RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);  RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);
   
 #  Store an aitem in any database but the roles database.  #  Store an aitem in any resource meta data(?) or database with
   #  versioning?
 #  #
 #  Parameters:  #  Parameters:
 #    $cmd                - Request command keyword.  #    $cmd                - Request command keyword.
Line 1913  RegisterHandler("dump", \&DumpWithRegexp Line 1865  RegisterHandler("dump", \&DumpWithRegexp
 #  Side-Effects:  #  Side-Effects:
 #    Writes to the client  #    Writes to the client
 sub StoreHandler {  sub StoreHandler {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = shift;      my $client = shift;
     
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);      my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
   $namespace=~s/\//\_/g;      if ($namespace ne 'roles') {
   $namespace=~s/\W//g;  
   if ($namespace ne 'roles') {   chomp($what);
     chomp($what);   my @pairs=split(/\&/,$what);
     my $proname=propath($udom,$uname);   my $hashref  = TieUserHash($udom, $uname, $namespace,
     my $now=time;         &GDBM_WRCREAT(), "P",
     unless ($namespace=~/^nohist\_/) {         "$rid:$what");
       my $hfh;   if ($hashref) {
       if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {      my $now = time;
  print $hfh "P:$now:$rid:$what\n";       my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
       }      my $key;
       $hashref->{"version:$rid"}++;
       my $version=$hashref->{"version:$rid"};
       my $allkeys=''; 
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $allkeys.=$key.':';
    $hashref->{"$version:$rid:$key"}=$value;
       }
       $hashref->{"$version:$rid:timestamp"}=$now;
       $allkeys.='timestamp';
       $hashref->{"$version:keys:$rid"}=$allkeys;
       if (untie($hashref)) {
    Reply($client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
       }
    } else {
       Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting store\n", $userinput);
    }
       } else {
    Failure($client, "refused\n", $userinput);
     }      }
     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;      return 1;
 }  }
 RegisterHandler("store", \&StoreHandler, 0, 1, 0);  RegisterHandler("store", \&StoreHandler, 0, 1, 0);
 #  #
Line 1983  RegisterHandler("store", \&StoreHandler, Line 1928  RegisterHandler("store", \&StoreHandler,
 #   Writes a reply to the client.  #   Writes a reply to the client.
 #  #
 sub RestoreHandler {  sub RestoreHandler {
   my $cmd     = shift;      my $cmd     = shift;
   my $tail    = shift;      my $tail    = shift;
   my $client  = shift;      my $client  = shift;
   
   my $userinput = "$cmd:$tail"; # Only used for logging purposes.      my $userinput = "$cmd:$tail"; # Only used for logging purposes.
   
   my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);      my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
   $namespace=~s/\//\_/g;      $namespace=~s/\//\_/g;
   $namespace=~s/\W//g;      $namespace=~s/\W//g;
   chomp($rid);      chomp($rid);
   my $proname=propath($udom,$uname);      my $proname=propath($udom,$uname);
   my $qresult='';      my $qresult='';
   my %hash;      my %hash;
   if (tie(%hash,'GDBM_File',"$proname/$namespace.db",      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
   &GDBM_READER(),0640)) {      &GDBM_READER(),0640)) {
     my $version=$hash{"version:$rid"};   my $version=$hash{"version:$rid"};
     $qresult.="version=$version&";   $qresult.="version=$version&";
     my $scope;   my $scope;
     for ($scope=1;$scope<=$version;$scope++) {   for ($scope=1;$scope<=$version;$scope++) {
       my $vkeys=$hash{"$scope:keys:$rid"};      my $vkeys=$hash{"$scope:keys:$rid"};
  my @keys=split(/:/,$vkeys);      my @keys=split(/:/,$vkeys);
       my $key;      my $key;
       $qresult.="$scope:keys=$vkeys&";      $qresult.="$scope:keys=$vkeys&";
       foreach $key (@keys) {      foreach $key (@keys) {
  $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";   $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
       }                                        }                                  
     }   }
      if (untie(%hash)) {   if (untie(%hash)) {
        $qresult=~s/\&$//;      $qresult=~s/\&$//;
        Reply( $client, "$qresult\n", $userinput);      Reply( $client, "$qresult\n", $userinput);
      } else {   } else {
        Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting restore\n", $userinput);      "while attempting restore\n", $userinput);
      }   }
   } else {      } else {
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
     "while attempting restore\n", $userinput);   "while attempting restore\n", $userinput);
   }      }
       
   return 1;      return 1;
   
   
 }  }
 RegisterHandler("restor", \&RestoreHandler, 0,1,0);  RegisterHandler("restore", \&RestoreHandler, 0,1,0);
   
 #  #
 #   Add a chat message to to a discussion board.  #   Add a chat message to to a discussion board.
Line 2047  RegisterHandler("restor", \&RestoreHandl Line 1992  RegisterHandler("restor", \&RestoreHandl
 #  #
 #  #
 sub SendChatHandler {  sub SendChatHandler {
   my $cmd     = shift;      my $cmd     = shift;
   my $tail    = shift;      my $tail    = shift;
   my $client  = shift;      my $client  = shift;
       
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($cdom,$cnum,$newpost)=split(/\:/,$tail);      my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
   &chatadd($cdom,$cnum,$newpost);      &chatadd($cdom,$cnum,$newpost);
   Reply($client, "ok\n", $userinput);      Reply($client, "ok\n", $userinput);
   
   return 1;      return 1;
 }  }
 RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0);  RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0);
 #  #
Line 2078  RegisterHandler("chatsend", \&SendChatHa Line 2023  RegisterHandler("chatsend", \&SendChatHa
 #    Response is written to the client.  #    Response is written to the client.
 #  #
 sub RetrieveChatHandler {  sub RetrieveChatHandler {
   my $cmd      = shift;      my $cmd      = shift;
   my $tail     = shift;      my $tail     = shift;
   my $client   = shift;      my $client   = shift;
   
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);      my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);
   my $reply='';      my $reply='';
   foreach (&getchat($cdom,$cnum,$udom,$uname)) {      foreach (&getchat($cdom,$cnum,$udom,$uname)) {
     $reply.=&escape($_).':';   $reply.=&escape($_).':';
   }      }
   $reply=~s/\:$//;      $reply=~s/\:$//;
   Reply($client, $reply."\n", $userinput);      Reply($client, $reply."\n", $userinput);
   
   
   return 1;      return 1;
 }  }
 RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0);  RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0);
 #  #
Line 2116  RegisterHandler("chatretr", \&RetrieveCh Line 2061  RegisterHandler("chatretr", \&RetrieveCh
 #    a reply is written to $client.  #    a reply is written to $client.
 #  #
 sub SendQueryHandler {  sub SendQueryHandler {
   my $cmd     = shift;      my $cmd     = shift;
   my $tail    = shift;      my $tail    = shift;
   my $client  = shift;      my $client  = shift;
   
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);      my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
   $query=~s/\n*$//g;      $query=~s/\n*$//g;
   Reply($client, "". sqlreply("$clientname\&$query".      Reply($client, "". sqlreply("$clientname\&$query".
       "\&$arg1"."\&$arg2"."\&$arg3")."\n",   "\&$arg1"."\&$arg2"."\&$arg3")."\n",
  $userinput);    $userinput);
       
   return 1;      return 1;
 }  }
 RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0);  RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0);
   
Line 2158  RegisterHandler("querysend", \&SendQuery Line 2103  RegisterHandler("querysend", \&SendQuery
 #    ok written to the client.  #    ok written to the client.
 #  #
 sub ReplyQueryHandler {  sub ReplyQueryHandler {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = shift;      my $client = shift;
   
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($cmd,$id,$reply)=split(/:/,$userinput);       my ($cmd,$id,$reply)=split(/:/,$userinput); 
   my $store;      my $store;
   my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
   if ($store=IO::File->new(">$execdir/tmp/$id")) {      if ($store=IO::File->new(">$execdir/tmp/$id")) {
     $reply=~s/\&/\n/g;   $reply=~s/\&/\n/g;
          print $store $reply;   print $store $reply;
     close $store;   close $store;
     my $store2=IO::File->new(">$execdir/tmp/$id.end");   my $store2=IO::File->new(">$execdir/tmp/$id.end");
     print $store2 "done\n";   print $store2 "done\n";
     close $store2;   close $store2;
     Reply($client, "ok\n", $userinput);   Reply($client, "ok\n", $userinput);
   }      } else {
   else {   Failure($client, "error: ".($!+0)
     Failure($client, "error: ".($!+0)   ." IO::File->new Failed ".
     ." IO::File->new Failed ".   "while attempting queryreply\n", $userinput);
     "while attempting queryreply\n", $userinput);      }
   }  
     
   
   return 1;      return 1;
 }  }
 RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0);  RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0);
 #  #
Line 2205  RegisterHandler("queryreply", \&ReplyQue Line 2149  RegisterHandler("queryreply", \&ReplyQue
 #   reply is written to the client.  #   reply is written to the client.
 #  #
 sub PutCourseIdHandler {  sub PutCourseIdHandler {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = 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;      my $userinput = "$cmd:$tail";
   
       my ($udom, $what) = split(/:/, $tail);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
   
       my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       $hashref->{$key}=$value.':'.$now;
    }
    if (untie(%$hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure( $client, "error: ".($!+0)
        ." untie(GDBM) Failed ".
        "while attempting courseidput\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)
    ." tie(GDBM) Failed ".
    "while attempting courseidput\n", $userinput);
       }
   
       return 1;
 }  }
 RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0);  RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0);
   
Line 2265  RegisterHandler("courseidput", \&PutCour Line 2207  RegisterHandler("courseidput", \&PutCour
 # Side Effects:  # Side Effects:
 #   a reply is written to $client.  #   a reply is written to $client.
 sub DumpCourseIdHandler {  sub DumpCourseIdHandler {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = shift;      my $client = shift;
   
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($udom,$since,$description) =split(/:/,$tail);      my ($udom,$since,$description) =split(/:/,$tail);
   if (defined($description)) {      if (defined($description)) {
     $description=&unescape($description);   $description=&unescape($description);
   } else {      } else {
     $description='.';   $description='.';
   }      }
   unless (defined($since)) { $since=0; }      unless (defined($since)) { $since=0; }
   my $qresult='';      my $qresult='';
   my $proname = "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";      logthis(" Looking for $description  since $since");
   my %hash;      my $hashref = TieDomainHash($udom, "nohist_courseids", &GDBM_WRCREAT());
   if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {      if ($hashref) {
     while (my ($key,$value) = each(%hash)) {   while (my ($key,$value) = each(%$hashref)) {
       my ($descr,$lasttime)=split(/\:/,$value);      my ($descr,$lasttime)=split(/\:/,$value);
       if ($lasttime<$since) {       logthis("Got:  key = $key descr = $descr time: $lasttime");
  next;       if ($lasttime<$since) { 
       }   logthis("Skipping .. too early");
       if ($description eq '.') {   next; 
  $qresult.=$key.'='.$descr.'&';      }
       } else {      if ($description eq '.') {
  my $unescapeVal = &unescape($descr);   logthis("Adding wildcard match");
  if (eval('$unescapeVal=~/$description/i')) {   $qresult.=$key.'='.$descr.'&';
   $qresult.="$key=$descr&";      } else {
  }   my $unescapeVal = &unescape($descr);
       }   logthis("Matching with $unescapeVal");
     }   if (eval('$unescapeVal=~/$description/i')) {
     if (untie(%hash)) {      logthis("Adding on match");
       chop($qresult);      $qresult.="$key=$descr&";
       Reply($client, "$qresult\n", $userinput);   }
     } else {      }
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".   }
       "while attempting courseiddump\n", $userinput);   if (untie(%$hashref)) {
     }      chop($qresult);
   } else {      Reply($client, "$qresult\n", $userinput);
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   } else {
     "while attempting courseiddump\n", $userinput);      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;      return 1;
 }  }
 RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0);  RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0);
 #  #
Line 2329  RegisterHandler("courseiddump", \&DumpCo Line 2276  RegisterHandler("courseiddump", \&DumpCo
 #     reply is written to $client.  #     reply is written to $client.
 #  #
 sub PutIdHandler {  sub PutIdHandler {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = shift;      my $client = shift;
   
   my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
   my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
   chomp($what);      chomp($what);
   $udom=~s/\W//g;      my @pairs=split(/\&/,$what);
   my $proname="$perlvar{'lonUsersDir'}/$udom/ids";      my $hashref = TieDomainHash($udom, "ids", &GDBM_WRCREAT(),
   my $now=time;   "P", $what);
   {      if ($hashref) {
     my $hfh;   foreach my $pair (@pairs) {
     if ($hfh=IO::File->new(">>$proname.hist")) {       my ($key,$value)=split(/=/,$pair);
       print $hfh "P:$now:$what\n";       $hashref->{$key}=$value;
    }
    if (untie(%$hashref)) {
       Reply($client, "ok\n", $userinput);
    } else {
       Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting idput\n", $userinput);
    }
       } else {
    Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting idput\n", $userinput);
     }      }
   }  
   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;      return 1;
 }  }
   
 RegisterHandler("idput", \&PutIdHandler, 0, 1, 0);  RegisterHandler("idput", \&PutIdHandler, 0, 1, 0);
Line 2388  RegisterHandler("idput", \&PutIdHandler, Line 2327  RegisterHandler("idput", \&PutIdHandler,
 #   An & separated list of results is written to $client.  #   An & separated list of results is written to $client.
 #  #
 sub GetIdHandler {  sub GetIdHandler {
   my $cmd    = shift;      my $cmd    = shift;
   my $tail   = shift;      my $tail   = shift;
   my $client = shift;      my $client = shift;
       
   my $userinput = "$client:$tail";      my $userinput = "$client:$tail";
       
   my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
   chomp($what);      chomp($what);
   $udom=~s/\W//g;      my @queries=split(/\&/,$what);
   my $proname="$perlvar{'lonUsersDir'}/$udom/ids";      my $qresult='';
   my @queries=split(/\&/,$what);      my $hashref = TieDomainHash($udom, "ids", &GDBM_READER());
   my $qresult='';      if ($hashref) {
   my %hash;   for (my $i=0;$i<=$#queries;$i++) {
   if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {      $qresult.="$hashref->{$queries[$i]}&";
     for (my $i=0;$i<=$#queries;$i++) {   }
       $qresult.="$hash{$queries[$i]}&";   if (untie(%$hashref)) {
     }      $qresult=~s/\&$//;
     if (untie(%hash)) {      Reply($client, "$qresult\n", $userinput);
       $qresult=~s/\&$//;   } else {
       Reply($client, "$qresult\n", $userinput);      Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
     } else {       "while attempting idget\n",$userinput);
       Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".   }
        "while attempting idget\n",$userinput);      } else {
     }   Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
   } else {   "while attempting idget\n",$userinput);
     Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".      }
                         "while attempting idget\n",$userinput);      
   }      return 1;
   
   return 1;  
 }  }
   
 RegisterHandler("idget", \&GetIdHandler, 0, 1, 0);  RegisterHandler("idget", \&GetIdHandler, 0, 1, 0);
   #
   #  Process the tmpput command I'm not sure what this does.. Seems to
   #  create a file in the lonDaemons/tmp directory of the form $id.tmp
   # where Id is the client's ip concatenated with a sequence number.
   # The file will contain some value that is passed in.  Is this e.g.
   # a login token?
   #
   # Parameters:
   #    $cmd     - The command that got us dispatched.
   #    $tail    - The remainder of the request following $cmd:
   #               In this case this will be the contents of the file.
   #    $client  - Socket connected to the client.
   # Returns:
   #    1 indicating processing can continue.
   # Side effects:
   #   A file is created in the local filesystem.
   #   A reply is sent to the client.
   sub TmpPutHandler {
       my $cmd       = shift;
       my $what      = shift;
       my $client    = shift;
   
       my $userinput = "$cmd:$what"; # Reconstruct for logging.
   
   
       my $store;
       $tmpsnum++;
       my $id=$$.'_'.$clientip.'_'.$tmpsnum;
       $id=~s/\W/\_/g;
       $what=~s/\n//g;
       my $execdir=$perlvar{'lonDaemons'};
       if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
    print $store $what;
    close $store;
    Reply($client, "$id\n", $userinput);
       } else {
    Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
    "while attempting tmpput\n", $userinput);
       }
       return 1;
     
   }
   RegisterHandler("tmpput", \&TmpPutHandler, 0, 1, 0);
   
   #   Processes the tmpget command.  This command returns the contents
   #  of a temporary resource file(?) created via tmpput.
   #
   # Paramters:
   #    $cmd      - Command that got us dispatched.
   #    $id       - Tail of the command, contain the id of the resource
   #                we want to fetch.
   #    $client   - socket open on the client.
   # Return:
   #    1         - Inidcating processing can continue.
   # Side effects:
   #   A reply is sent to the client.
   
   #
   sub TmpGetHandler {
       my $cmd       = shift;
       my $id        = shift;
       my $client    = shift;
       my $userinput = "$cmd:$id"; 
       
       chomp($id);
       $id=~s/\W/\_/g;
       my $store;
       my $execdir=$perlvar{'lonDaemons'};
       if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
    my $reply=<$store>;
    Reply( $client, "$reply\n", $userinput);
    close $store;
       } else {
    Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
    "while attempting tmpget\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("tmpget", \&TmpGetHandler, 0, 1, 0);
   #
   #  Process the tmpdel command.  This command deletes a temp resource
   #  created by the tmpput command.
   #
   # Parameters:
   #   $cmd      - Command that got us here.
   #   $id       - Id of the temporary resource created.
   #   $client   - socket open on the client process.
   #
   # Returns:
   #   1     - Indicating processing should continue.
   # Side Effects:
   #   A file is deleted
   #   A reply is sent to the client.
   sub TmpDelHandler {
       my $cmd      = shift;
       my $id       = shift;
       my $client   = shift;
       
       my $userinput= "$cmd:$id";
       
       chomp($id);
       $id=~s/\W/\_/g;
       my $execdir=$perlvar{'lonDaemons'};
       if (unlink("$execdir/tmp/$id.tmp")) {
    Reply($client, "ok\n", $userinput);
       } else {
    Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
    "while attempting tmpdel\n", $userinput);
       }
       
       return 1;
   
   }
   RegisterHandler("tmpdel", \&TmpDelHandler, 0, 1, 0);
   #
   #   ls  - list the contents of a directory.  For each file in the
   #    selected directory the filename followed by the full output of
   #    the stat function is returned.  The returned info for each
   #    file are separated by ':'.  The stat fields are separated by &'s.
   # Parameters:
   #    $cmd        - The command that dispatched us (ls).
   #    $ulsdir     - The directory path to list... I'm not sure what this
   #                  is relative as things like ls:. return e.g.
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to  $client.
   #
   sub LsHandler {
       my $cmd     = shift;
       my $ulsdir  = shift;
       my $client  = shift;
   
       my $userinput = "$cmd:$ulsdir";
   
       chomp($ulsdir);
   
       my $ulsout='';
       my $ulsfn;
       logthis("ls for '$ulsdir'");
       if (-e $ulsdir) {
    logthis("ls - directory exists");
    if(-d $ulsdir) {
       logthis("ls  $ulsdir is a file");
       if (opendir(LSDIR,$ulsdir)) {
    while ($ulsfn=readdir(LSDIR)) {
       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
       $ulsout.=$ulsfn.'&'.
    join('&',@ulsstats).':';
    }
    closedir(LSDIR);
       }
    } else {
       my @ulsstats=stat($ulsdir);
       $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
    }
       } else {
    $ulsout='no_such_dir';
       }
       if ($ulsout eq '') { $ulsout='empty'; }
       Reply($client, "$ulsout\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("ls", \&LsHandler, 0, 1, 0);
   
   
   #
   #   Processes the setannounce command.  This command
   #   creates a file named announce.txt in the top directory of
   #   the documentn root and sets its contents.  The announce.txt file is
   #   printed in its entirety at the LonCAPA login page.  Note:
   #   once the announcement.txt fileis created it cannot be deleted.
   #   However, setting the contents of the file to empty removes the
   #   announcement from the login page of loncapa so who cares.
   #
   # Parameters:
   #    $cmd          - The command that got us dispatched.
   #    $announcement - The text of the announcement.
   #    $client       - Socket open on the client process.
   # Retunrns:
   #   1             - Indicating request processing should continue
   # Side Effects:
   #   The file {DocRoot}/announcement.txt is created.
   #   A reply is sent to $client.
   #
   sub SetAnnounceHandler {
       my $cmd          = shift;
       my $announcement = shift;
       my $client       = shift;
     
       my $userinput    = "$cmd:$announcement";
   
       chomp($announcement);
       $announcement=&unescape($announcement);
       if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
    '/announcement.txt')) {
    print $store $announcement;
    close $store;
    Reply($client, "ok\n", $userinput);
       } else {
    Failure($client, "error: ".($!+0)."\n", $userinput);
       }
   
       return 1;
   }
   RegisterHandler("setannounce", \&SetAnnounceHandler, 0, 1, 0);
   
   #
   #  Return the version of the daemon.  This can be used to determine
   #  the compatibility of cross version installations or, alternatively to
   #  simply know who's out of date and who isn't.  Note that the version
   #  is returned concatenated with the tail.
   # Parameters:
   #   $cmd        - the request that dispatched to us.
   #   $tail       - Tail of the request (client's version?).
   #   $client     - Socket open on the client.
   #Returns:
   #   1 - continue processing requests.
   # Side Effects:
   #   Replies with version to $client.
   sub GetVersionHandler {
       my $client     = shift;
       my $tail       = shift;
       my $client     = shift;
       my $userinput  = $client;
       
       Reply($client, &version($userinput)."\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("version", \&GetVersionHandler, 0, 1, 0);
   
   #  Set the current host and domain.  This is used to support
   #  multihomed systems.  Each IP of the system, or even separate daemons
   #  on the same IP can be treated as handling a separate lonCAPA virtual
   #  machine.  This command selects the virtual lonCAPA.  The client always
   #  knows the right one since it is lonc and it is selecting the domain/system
   #  from the hosts.tab file.
   # Parameters:
   #    $cmd      - Command that dispatched us.
   #    $tail     - Tail of the command (domain/host requested).
   #    $socket   - Socket open on the client.
   #
   # Returns:
   #     1   - Indicates the program should continue to process requests.
   # Side-effects:
   #     The default domain/system context is modified for this daemon.
   #     a reply is sent to the client.
   #
   sub SelectHostHandler {
       my $cmd        = shift;
       my $tail       = shift;
       my $socket     = shift;
     
       my $userinput  ="$cmd:$tail";
   
       Reply($client, &sethost($userinput)."\n", $userinput);
   
   
       return 1;
   }
   RegisterHandler("sethost", \&SelectHostHandler, 0, 1, 0);
   
   #  Process a request to exit:
   #   - "bye" is sent to the client.
   #   - The client socket is shutdown and closed.
   #   - We indicate to the caller that we should exit.
   # Formal Parameters:
   #   $cmd                - The command that got us here.
   #   $tail               - Tail of the command (empty).
   #   $client             - Socket open on the tail.
   # Returns:
   #   0      - Indicating the program should exit!!
   #
   sub ExitHandler {
       my $cmd     = shift;
       my $tail    = shift;
       my $client  = shift;
   
       my $userinput = "$cmd:$tail";
   
       &logthis("Client $clientip ($clientname) hanging up: $userinput");
       Reply($client, "bye\n", $userinput);
       $client->shutdown(2);        # shutdown the socket forcibly.
       $client->close();
   
       return 0;
   }
   RegisterHandler("exit", \&ExitHandler, 0, 1,1);
   RegisterHandler("init", \&ExitHandler, 0, 1,1); # RE-init is like exit.
   RegisterHandler("quit", \&ExitHandler, 0, 1,1); # I like this too!
 #------------------------------------------------------------------------------------  #------------------------------------------------------------------------------------
 #  #
 #   Process a Request.  Takes a request from the client validates  #   Process a Request.  Takes a request from the client validates
Line 2433  RegisterHandler("idget", \&GetIdHandler, Line 2668  RegisterHandler("idget", \&GetIdHandler,
 #      1            - Accept additional requests from the client.  #      1            - Accept additional requests from the client.
 #  #
 sub ProcessRequest {  sub ProcessRequest {
    my $Request      = shift;      my $Request      = shift;
    my $KeepGoing    = 1; # Assume we're not asked to stop.      my $KeepGoing    = 1; # Assume we're not asked to stop.
           
    my $wasenc=0;      my $wasenc=0;
    my $userinput = $Request;   # for compatibility with oldcode <yeach>      my $userinput = $Request;   # for compatibility with oldcode <yeach>
   
   
 # ------------------------------------------------------------ See if encrypted  # ------------------------------------------------------------ See if encrypted
         
    if($userinput =~ /^enc/) {      if($userinput =~ /^enc/) {
       $wasenc = 1;   $wasenc = 1;
       $userinput = Decipher($userinput);   $userinput = Decipher($userinput);
       if(! $userinput) {   if(! $userinput) {
          Failure($client,"error:Encrypted data without negotiating key");      Failure($client,"error:Encrypted data without negotiating key");
          return 0;                      # Break off with this imposter.      return 0;                      # Break off with this imposter.
       }   }
    }      }
    # Split off the request keyword from the rest of the stuff.      # Split off the request keyword from the rest of the stuff.
      
    my ($command, $tail) = split(/:/, $userinput, 2);  
         
       my ($command, $tail) = split(/:/, $userinput, 2);
       chomp($command);
       chomp($tail);
   
       Debug("Command received: $command, encoded = $wasenc");
   
         
 # ------------------------------------------------------------- Normal commands  # ------------------------------------------------------------- Normal commands
   
    #       # 
    #   If the command is in the hash, then execute it via the hash dispatch:      #   If the command is in the hash, then execute it via the hash dispatch:
    #      #
    if(defined $Dispatcher{$command}) {      if(defined $Dispatcher{$command}) {
   
       my $DispatchInfo = $Dispatcher{$command};   my $DispatchInfo = $Dispatcher{$command};
       my $Handler      = $$DispatchInfo[0];   my $Handler      = $$DispatchInfo[0];
       my $NeedEncode   = $$DispatchInfo[1];   my $NeedEncode   = $$DispatchInfo[1];
       my $ClientTypes  = $$DispatchInfo[2];   my $ClientTypes  = $$DispatchInfo[2];
    Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes");
               
       #  Validate the request:   #  Validate the request:
               
       my $ok = 1;   my $ok = 1;
       if($NeedEncode && (!$wasenc)) {   my $requesterprivs = 0;
          Reply($client, "refused\n", $userinput);   if(isClient()) {
          $ok = 0;      $requesterprivs |= $CLIENT_OK;
       }   }
       if(isClient && (($ClientTypes & $CLIENT_OK) == 0)) {   if(isManager()) {
          Reply($client, "refused\n", $userinput);      $requesterprivs |= $MANAGER_OK;
          $ok = 0;   }
       }   if($NeedEncode && (!$wasenc)) {
       if(isManager && (($ClientTypes & $MANAGER_OK) == 0)) {      Debug("Must encode but wasn't: $NeedEncode $wasenc");
          Reply($client, "refused\n", $userinput);      $ok = 0;
          $ok = 0;   }
       }   if(($ClientTypes & $requesterprivs) == 0) {
       if($ok) {      Debug("Client not privileged to do this operation");
          $KeepGoing = &$Handler($command, $tail, $client);      $ok = 0;
       }   }
   
   
   
   
   
 # ---------------------------------------------------------------------- tmpput   if($ok) {
    } elsif ($userinput =~ /^tmpput/) {      Debug("Dispatching to handler $command $tail");
       if(isClient) {      $KeepGoing = &$Handler($command, $tail, $client);
          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 {   } else {
     Reply( $client, "refused\n", $userinput);      Debug("Refusing to dispatch because ok is false");
       Failure($client, "refused\n", $userinput);
  }   }
   
   
 # ------------------------------------------------------------- unknown command  # ------------------------------------------------------------- unknown command
   
    } else {      } else {
  # unknown command   # unknown command
       Failure($client, "unknown_cmd\n", $userinput);   Failure($client, "unknown_cmd\n", $userinput);
    }      }
   
     return $KeepGoing;      return $KeepGoing;
 }  }
Line 2663  sub ReadManagerTable { Line 2777  sub ReadManagerTable {
   
     #   Clean out the old table first..      #   Clean out the old table first..
   
    foreach my $key (keys %managers) {      foreach my $key (keys %managers) {
       delete $managers{$key};   delete $managers{$key};
    }      }
   
    my $tablename = $perlvar{'lonTabDir'}."/managers.tab";      my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
    if (!open (MANAGERS, $tablename)) {      if (!open (MANAGERS, $tablename)) {
       logthis('<font color="red">No manager table.  Nobody can manage!!</font>');   logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
       return;   return;
    }      }
    while(my $host = <MANAGERS>) {      while(my $host = <MANAGERS>) {
       chomp($host);   chomp($host);
       if ($host =~ "^#") {                  # Comment line.   if ($host =~ "^#") {                  # Comment line.
          logthis('<font color="green"> Skipping line: '. "$host</font>\n");      logthis('<font color="green"> Skipping line: '. "$host</font>\n");
          next;      next;
       }   }
       if (!defined $hostip{$host}) { # This is a non cluster member   if (!defined $hostip{$host}) { # This is a non cluster member
     #  The entry is of the form:      #  The entry is of the form:
     #    cluname:hostname      #    cluname:hostname
     #  cluname - A 'cluster hostname' is needed in order to negotiate      #  cluname - A 'cluster hostname' is needed in order to negotiate
     #            the host key.      #            the host key.
     #  hostname- The dns name of the host.      #  hostname- The dns name of the host.
     #      #
           my($cluname, $dnsname) = split(/:/, $host);      my($cluname, $dnsname) = split(/:/, $host);
                 
           my $ip = gethostbyname($dnsname);      my $ip = gethostbyname($dnsname);
           if(defined($ip)) {                 # bad names don't deserve entry.      if(defined($ip)) {                 # bad names don't deserve entry.
             my $hostip = inet_ntoa($ip);   my $hostip = inet_ntoa($ip);
             $managers{$hostip} = $cluname;   $managers{$hostip} = $cluname;
             logthis('<font color="green"> registering manager '.   logthis('<font color="green"> registering manager '.
                     "$dnsname as $cluname with $hostip </font>\n");   "$dnsname as $cluname with $hostip </font>\n");
          }      }
       } else {   } else {
          logthis('<font color="green"> existing host'." $host</font>\n");      logthis('<font color="green"> existing host'." $host</font>\n");
          $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber      $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber
       }   }
    }      }
 }  }
   
 #  #
Line 2732  sub CopyFile { Line 2846  sub CopyFile {
   
     if(-e $oldfile) {      if(-e $oldfile) {
   
  # Read the old file.   # Read the old file.
   
  my $oldfh = IO::File->new("< $oldfile");   my $oldfh = IO::File->new("< $oldfile");
  if(!$oldfh) {   if(!$oldfh) {
Line 2785  sub AdjustHostContents { Line 2899  sub AdjustHostContents {
     my $adjusted;      my $adjusted;
     my $me        = $perlvar{'lonHostID'};      my $me        = $perlvar{'lonHostID'};
   
  foreach my $line (split(/\n/,$contents)) {      foreach my $line (split(/\n/,$contents)) {
  if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {   if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
     chomp($line);      chomp($line);
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);      my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
     if ($id eq $me) {      if ($id eq $me) {
           my $ip = gethostbyname($name);   my $ip = gethostbyname($name);
           my $ipnew = inet_ntoa($ip);   my $ipnew = inet_ntoa($ip);
          $ip = $ipnew;   $ip = $ipnew;
  #  Reconstruct the host line and append to adjusted:   #  Reconstruct the host line and append to adjusted:
   
    my $newline = "$id:$domain:$role:$name:$ip";   my $newline = "$id:$domain:$role:$name:$ip";
    if($maxcon ne "") { # Not all hosts have loncnew tuning params   if($maxcon ne "") { # Not all hosts have loncnew tuning params
      $newline .= ":$maxcon:$idleto:$mincon";      $newline .= ":$maxcon:$idleto:$mincon";
    }   }
    $adjusted .= $newline."\n";   $adjusted .= $newline."\n";
   
       } else { # Not me, pass unmodified.      } else { # Not me, pass unmodified.
    $adjusted .= $line."\n";   $adjusted .= $line."\n";
       }      }
  } else {                  # Blank or comment never re-written.   } else {                  # Blank or comment never re-written.
     $adjusted .= $line."\n"; # Pass blanks and comments as is.      $adjusted .= $line."\n"; # Pass blanks and comments as is.
  }   }
  }      }
  return $adjusted;      return $adjusted;
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
Line 2831  sub InstallFile { Line 2945  sub InstallFile {
     my $TempFile = $Filename.".tmp";      my $TempFile = $Filename.".tmp";
   
     #  Open the file for write:      #  Open the file for write:
       
     my $fh = IO::File->new("> $TempFile"); # Write to temp.      my $fh = IO::File->new("> $TempFile"); # Write to temp.
     if(!(defined $fh)) {      if(!(defined $fh)) {
  &logthis('<font color="red"> Unable to create '.$TempFile."</font>");   &logthis('<font color="red"> Unable to create '.$TempFile."</font>");
  return 0;   return 0;
     }      }
     #  write the contents of the file:      #  write the contents of the file:
       
     print $fh ($Contents);       print $fh ($Contents); 
     $fh->close; # In case we ever have a filesystem w. locking      $fh->close; # In case we ever have a filesystem w. locking
   
Line 2921  sub PushFile { Line 3035  sub PushFile {
  return "error:$!";   return "error:$!";
     }      }
     &logthis('<font color="green"> Pushfile: backed up '      &logthis('<font color="green"> Pushfile: backed up '
     .$tablefile." to $backupfile</font>");       .$tablefile." to $backupfile</font>");
           
     #  If the file being pushed is the host file, we adjust the entry for ourself so that the      #  If the file being pushed is the host file, we adjust the entry for ourself so that the
     #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible      #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible
Line 2937  sub PushFile { Line 3051  sub PushFile {
   
     if(!InstallFile($tablefile, $contents)) {      if(!InstallFile($tablefile, $contents)) {
  &logthis('<font color="red"> Pushfile: unable to install '   &logthis('<font color="red"> Pushfile: unable to install '
  .$tablefile." $! </font>");   .$tablefile." $! </font>");
  return "error:$!";   return "error:$!";
     }      } else {
     else {  
  &logthis('<font color="green"> Installed new '.$tablefile   &logthis('<font color="green"> Installed new '.$tablefile
  ."</font>");   ."</font>");
   
     }      }
   
   
Line 3080  sub ApplyEdit { Line 3193  sub ApplyEdit {
     } elsif ($command eq "delete") {      } elsif ($command eq "delete") {
  $editor->DeleteLine($p1);         # p1 - key p2 null.   $editor->DeleteLine($p1);         # p1 - key p2 null.
     } else {          # Should not get here!!!      } else {          # Should not get here!!!
  die "Invalid command given to ApplyEdit $command"   die "Invalid command given to ApplyEdit $command";
     }      }
 }  }
 #  #
Line 3250  sub catchexception { Line 3363  sub catchexception {
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &status("Catching exception");      &status("Catching exception");
     &logthis("<font color=red>CRITICAL: "      &logthis("<font color=red>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "       ."ABNORMAL EXIT. Child $$ for server $thisserver died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
     if ($client) { print $client "error: $error\n"; }      if ($client) { print $client "error: $error\n"; }
     $server->close();      $server->close();
Line 3277  undef $perlvarref; Line 3390  undef $perlvarref;
 # ----------------------------- Make sure this process is running from user=www  # ----------------------------- Make sure this process is running from user=www
 my $wwwid=getpwnam('www');  my $wwwid=getpwnam('www');
 if ($wwwid!=$<) {  if ($wwwid!=$<) {
    my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";      my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
    my $subj="LON: $currenthostid User ID mismatch";      my $subj="LON: $currenthostid User ID mismatch";
    system("echo 'User ID mismatch.  lond must be run as user www.' |\      system("echo 'User ID mismatch.  lond must be run as user www.' |\
  mailto $emailto -s '$subj' > /dev/null");   mailto $emailto -s '$subj' > /dev/null");
    exit 1;      exit 1;
 }  }
   
 # --------------------------------------------- Check if other instance running  # --------------------------------------------- Check if other instance running
Line 3289  if ($wwwid!=$<) { Line 3402  if ($wwwid!=$<) {
 my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";  my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid";
   
 if (-e $pidfile) {  if (-e $pidfile) {
    my $lfh=IO::File->new("$pidfile");      my $lfh=IO::File->new("$pidfile");
    my $pide=<$lfh>;      my $pide=<$lfh>;
    chomp($pide);      chomp($pide);
    if (kill 0 => $pide) { die "already running"; }      if (kill 0 => $pide) { die "already running"; }
 }  }
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
Line 3305  $server = IO::Socket::INET->new(LocalPor Line 3418  $server = IO::Socket::INET->new(LocalPor
                                 Proto     => 'tcp',                                  Proto     => 'tcp',
                                 Reuse     => 1,                                  Reuse     => 1,
                                 Listen    => 10 )                                  Listen    => 10 )
   or die "making socket: $@\n";      or die "making socket: $@\n";
   
 # --------------------------------------------------------- Do global variables  # --------------------------------------------------------- Do global variables
   
Line 3458  sub checkchildren { Line 3571  sub checkchildren {
     &status("Checking on the children (waiting for reports)");      &status("Checking on the children (waiting for reports)");
     foreach (sort keys %children) {      foreach (sort keys %children) {
         unless (-e "$docdir/lon-status/londchld/$_.txt") {          unless (-e "$docdir/lon-status/londchld/$_.txt") {
           eval {      eval {
             alarm(300);   alarm(300);
     &logthis('Child '.$_.' did not respond');   &logthis('Child '.$_.' did not respond');
     kill 9 => $_;   kill 9 => $_;
     #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";   #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
     #$subj="LON: $currenthostid killed lond process $_";   #$subj="LON: $currenthostid killed lond process $_";
     #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;   #my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`;
     #$execdir=$perlvar{'lonDaemons'};   #$execdir=$perlvar{'lonDaemons'};
     #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;   #$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`;
     alarm(0);   alarm(0);
   }      }
         }          }
     }      }
     $SIG{ALRM} = 'DEFAULT';      $SIG{ALRM} = 'DEFAULT';
Line 3536  sub Reply { Line 3649  sub Reply {
 #    client:  #    client:
 #  #
 sub Failure {  sub Failure {
    my $fd      = shift;      my $fd      = shift;
    my $reply   = shift;      my $reply   = shift;
    my $request = shift;      my $request = shift;
         
    $Failures++;      $Failures++;
    Reply($fd, $reply, $request);      # That's simple eh?      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".$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;      ResetStatistics;
    &status("Finished logging");      &status("Finished logging");
         
 }  }
   
Line 3585  sub status { Line 3698  sub status {
     my $local=localtime($now);      my $local=localtime($now);
     my $status = "lond: $what $local ";      my $status = "lond: $what $local ";
     if($Transactions) {      if($Transactions) {
        $status .= " Transactions: $Transactions Failed; $Failures";   $status .= " Transactions: $Transactions Failed; $Failures";
     }      }
     $0=$status;      $0=$status;
 }  }
Line 3619  sub reconlonc { Line 3732  sub reconlonc {
     &logthis("lonc at pid $loncpid responding, sending USR1");      &logthis("lonc at pid $loncpid responding, sending USR1");
             kill USR1 => $loncpid;              kill USR1 => $loncpid;
         } else {          } else {
     &logthis(      &logthis("<font color=red>CRITICAL: "
               "<font color=red>CRITICAL: "       ."lonc at pid $loncpid not responding, giving up</font>");
              ."lonc at pid $loncpid not responding, giving up</font>");  
         }          }
     } else {      } else {
       &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');   &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
     }      }
 }  }
   
Line 3636  sub subreply { Line 3748  sub subreply {
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";   or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
Line 3645  sub subreply { Line 3757  sub subreply {
 }  }
   
 sub reply {  sub reply {
   my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
   my $answer;      my $answer;
   if ($server ne $currenthostid) {       if ($server ne $currenthostid) { 
     $answer=subreply($cmd,$server);   $answer=subreply($cmd,$server);
     if ($answer eq 'con_lost') {   if ($answer eq 'con_lost') {
  $answer=subreply("ping",$server);      $answer=subreply("ping",$server);
         if ($answer ne $server) {      if ($answer ne $server) {
     &logthis("sub reply: answer != server answer is $answer, server is $server");   &logthis("sub reply: answer != server answer is $answer, server is $server");
            &reconlonc("$perlvar{'lonSockDir'}/$server");   &reconlonc("$perlvar{'lonSockDir'}/$server");
         }      }
         $answer=subreply($cmd,$server);      $answer=subreply($cmd,$server);
     }   }
   } else {      } else {
     $answer='self_reply';   $answer='self_reply';
   }       } 
   return $answer;      return $answer;
 }  }
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
Line 3679  sub subsqlreply { Line 3791  sub subsqlreply {
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";   or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
Line 3691  sub subsqlreply { Line 3803  sub subsqlreply {
   
 sub propath {  sub propath {
     my ($udom,$uname)=@_;      my ($udom,$uname)=@_;
       Debug("Propath:$udom:$uname");
     $udom=~s/\W//g;      $udom=~s/\W//g;
     $uname=~s/\W//g;      $uname=~s/\W//g;
       Debug("Propath2:$udom:$uname");
     my $subdir=$uname.'__';      my $subdir=$uname.'__';
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;      $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";      my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
       Debug("Propath returning $proname");
     return $proname;      return $proname;
 }   } 
   
Line 3772  sub make_new_child { Line 3887  sub make_new_child {
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)      sigprocmask(SIG_BLOCK, $sigset)
         or die "Can't block SIGINT for fork: $!\n";          or die "Can't block SIGINT for fork: $!\n";
       
     die "fork: $!" unless defined ($pid = fork);      die "fork: $!" unless defined ($pid = fork);
   
     $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of      $client->sockopt(SO_KEEPALIVE, 1); # Enable monitoring of
Line 3812  sub make_new_child { Line 3927  sub make_new_child {
   
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();          &Authen::Krb5::init_ets();
   
  &status('Accepted connection');   &status('Accepted connection');
 # =============================================================================  # =============================================================================
             # do something with the connection              # do something with the connection
Line 3839  sub make_new_child { Line 3954  sub make_new_child {
     &status("Waiting for init from $clientip $clientname");      &status("Waiting for init from $clientip $clientname");
     &logthis('<font color="yellow">INFO: Connection, '.      &logthis('<font color="yellow">INFO: Connection, '.
      $clientip.       $clientip.
   " ($clientname) connection type = $ConnectionType </font>" );       " ($clientname) connection type = $ConnectionType </font>" );
     &status("Connecting $clientip  ($clientname))");       &status("Connecting $clientip  ($clientname))"); 
     my $remotereq=<$client>;      my $remotereq=<$client>;
     $remotereq=~s/[^\w:]//g;      $remotereq=~s/[^\w:]//g;
Line 3847  sub make_new_child { Line 3962  sub make_new_child {
  &sethost("sethost:$perlvar{'lonHostID'}");   &sethost("sethost:$perlvar{'lonHostID'}");
  my $challenge="$$".time;   my $challenge="$$".time;
  print $client "$challenge\n";   print $client "$challenge\n";
  &status(   &status("Waiting for challenge reply from $clientip ($clientname)"); 
  "Waiting for challenge reply from $clientip ($clientname)");   
  $remotereq=<$client>;   $remotereq=<$client>;
  $remotereq=~s/\W//g;   $remotereq=~s/\W//g;
  if ($challenge eq $remotereq) {   if ($challenge eq $remotereq) {
     $clientok=1;      $clientok=1;
     print $client "ok\n";      print $client "ok\n";
  } else {   } else {
     &logthis(      &logthis("<font color=blue>WARNING: $clientip did not reply challenge</font>");
      "<font color=blue>WARNING: $clientip did not reply challenge</font>");  
     &status('No challenge reply '.$clientip);      &status('No challenge reply '.$clientip);
  }   }
     } else {      } else {
  &logthis(   &logthis("<font color=blue>WARNING: "
  "<font color=blue>WARNING: "  
  ."$clientip failed to initialize: >$remotereq< </font>");   ."$clientip failed to initialize: >$remotereq< </font>");
  &status('No init '.$clientip);   &status('No init '.$clientip);
     }      }
  } else {   } else {
     &logthis(      &logthis("<font color=blue>WARNING: Unknown client $clientip</font>");
      "<font color=blue>WARNING: Unknown client $clientip</font>");  
     &status('Hung up on '.$clientip);      &status('Hung up on '.$clientip);
  }   }
  if ($clientok) {   if ($clientok) {
Line 3928  sub make_new_child { Line 4039  sub make_new_child {
 #    user      - Name of the user for which the role is being put.  #    user      - Name of the user for which the role is being put.
 #    authtype  - The authentication type associated with the user.  #    authtype  - The authentication type associated with the user.
 #  #
 sub ManagePermissions  sub ManagePermissions {
 {  
     my $request = shift;      my $request = shift;
     my $domain  = shift;      my $domain  = shift;
     my $user    = shift;      my $user    = shift;
     my $authtype= shift;      my $authtype= shift;
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     &logthis("ruequest is $request");      &logthis("request 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 3944  sub ManagePermissions Line 4054  sub ManagePermissions
  system("$execdir/lchtmldir $userhome $user $authtype");   system("$execdir/lchtmldir $userhome $user $authtype");
     }      }
 }  }
   
   #
   #  Return the full path of a user password file, whether it exists or not.
   # Parameters:
   #   domain     - Domain in which the password file lives.
   #   user       - name of the user.
   # Returns:
   #    Full passwd path:
   #
   sub PasswordPath {
       my $domain = shift;
       my $user   = shift;
   
       my $path   = &propath($domain, $user);
       $path  .= "/passwd";
   
       return $path;
   }
   
   #   Password Filename
   #   Returns the path to a passwd file given domain and user... only if
   #  it exists.
   # Parameters:
   #   domain    - Domain in which to search.
   #   user      - username.
   # Returns:
   #   - If the password file exists returns its path.
   #   - If the password file does not exist, returns undefined.
   #
   sub PasswordFilename {
       my $domain    = shift;
       my $user      = shift;
   
       Debug ("PasswordFilename called: dom = $domain user = $user");
   
       my $path  = PasswordPath($domain, $user);
       Debug("PasswordFilename got path: $path");
       if(-e $path) {
    return $path;
       } else {
    return undef;
       }
   }
   
   #
   #   Rewrite the contents of the user's passwd file.
   #  Parameters:
   #    domain    - domain of the user.
   #    name      - User's name.
   #    contents  - New contents of the file.
   # Returns:
   #   0    - Failed.
   #   1    - Success.
   #
   sub RewritePwFile {
       my $domain   = shift;
       my $user     = shift;
       my $contents = shift;
   
       my $file = PasswordFilename($domain, $user);
       if (defined $file) {
    my $pf = IO::File->new(">$file");
    if($pf) {
       print $pf "$contents\n";
       return 1;
    } else {
       return 0;
    }
       } else {
    return 0;
       }
   
   }
 #  #
 #   GetAuthType - Determines the authorization type of a user in a domain.  #   GetAuthType - Determines the authorization type of a user in a domain.
   
 #     Returns the authorization type or nouser if there is no such user.  #     Returns the authorization type or nouser if there is no such user.
 #  #
 sub GetAuthType   sub GetAuthType {
 {  
     my $domain = shift;      my $domain = shift;
     my $user   = shift;      my $user   = shift;
   
     Debug("GetAuthType( $domain, $user ) \n");      Debug("GetAuthType( $domain, $user ) \n");
     my $proname    = &propath($domain, $user);       my $passwdfile = PasswordFilename($domain, $user);
     my $passwdfile = "$proname/passwd";      if( defined $passwdfile ) {
     if( -e $passwdfile ) {  
  my $pf = IO::File->new($passwdfile);   my $pf = IO::File->new($passwdfile);
  my $realpassword = <$pf>;   my $realpassword = <$pf>;
  chomp($realpassword);   chomp($realpassword);
  Debug("Password info = $realpassword\n");   Debug("Password info = $realpassword\n");
  my ($authtype, $contentpwd) = split(/:/, $realpassword);   return $realpassword;
  Debug("Authtype = $authtype, content = $contentpwd\n");      } else {
  my $availinfo = '';  
  if($authtype eq 'krb4' or $authtype eq 'krb5') {  
     $availinfo = $contentpwd;  
  }  
   
  return "$authtype:$availinfo";  
     }  
     else {  
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
     }      }
 }  }
   
   #
   #  Validate a user given their domain, name and password.  This utility
   #  function is used by both  AuthenticateHandler and ChangePasswordHandler
   #  to validate the login credentials of a user.
   # Parameters:
   #    $domain    - The domain being logged into (this is required due to
   #                 the capability for multihomed systems.
   #    $user      - The name of the user being validated.
   #    $password  - The user's propoposed password.
   #
   # Returns:
   #     1        - The domain,user,pasword triplet corresponds to a valid
   #                user.
   #     0        - The domain,user,password triplet is not a valid user.
   #
   sub ValidateUser {
       my $domain  = shift;
       my $user    = shift;
       my $password= shift;
   
       # Why negative ~pi you may well ask?  Well this function is about
       # authentication, and therefore very important to get right.
       # I've initialized the flag that determines whether or not I've 
       # validated correctly to a value it's not supposed to get.
       # At the end of this function. I'll ensure that it's not still that
       # value so we don't just wind up returning some accidental value
       # as a result of executing an unforseen code path that
       # did not set $validated.
   
       my $validated = -3.14159;
   
       #  How we authenticate is determined by the type of authentication
       #  the user has been assigned.  If the authentication type is
       #  "nouser", the user does not exist so we will return 0.
   
       my $contents = GetAuthType($domain, $user);
       my ($howpwd, $contentpwd) = split(/:/, $contents);
   
       my $null = pack("C",0); # Used by kerberos auth types.
   
       if ($howpwd ne 'nouser') {
   
    if($howpwd eq "internal") { # Encrypted is in local password file.
       $validated = (crypt($password, $contentpwd) eq $contentpwd);
    }
    elsif ($howpwd eq "unix") { # User is a normal unix user.
       $contentpwd = (getpwnam($user))[1];
       if($contentpwd) {
    if($contentpwd eq 'x') { # Shadow password file...
       my $pwauth_path = "/usr/local/sbin/pwauth";
       open PWAUTH,  "|$pwauth_path" or
    die "Cannot invoke authentication";
       print PWAUTH "$user\n$password\n";
       close PWAUTH;
       $validated = ! $?;
   
    } else {         # Passwords in /etc/passwd. 
       $validated = (crypt($password,
    $contentpwd) eq $contentpwd);
    }
       } else {
    $validated = 0;
       }
    }
    elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
       if(! ($password =~ /$null/) ) {
    my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
      "",
      $contentpwd,,
      'krbtgt',
      $contentpwd,
      1,
      $password);
    if(!$k4error) {
       $validated = 1;
    }
    else {
       $validated = 0;
       &logthis('krb4: '.$user.', '.$contentpwd.', '.
        &Authen::Krb4::get_err_txt($Authen::Krb4::error));
    }
       }
       else {
    $validated = 0; # Password has a match with null.
       }
    }
    elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
       if(!($password =~ /$null/)) { # Null password not allowed.
    my $krbclient = &Authen::Krb5::parse_name($user.'@'
     .$contentpwd);
    my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
    my $krbserver  = &Authen::Krb5::parse_name($krbservice);
    my $credentials= &Authen::Krb5::cc_default();
    $credentials->initialize($krbclient);
    my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,
    $krbserver,
    $password,
    $credentials);
    $validated = ($krbreturn == 1);
       }
       else {
    $validated = 0;
       }
    }
    elsif ($howpwd eq "localauth") { 
       #  Authenticate via installation specific authentcation method:
       $validated = &localauth::localauth($user, 
          $password, 
          $contentpwd);
    }
    else { # Unrecognized auth is also bad.
       $validated = 0;
    }
       } else {
    $validated = 0;
       }
       #
       #  $validated has the correct stat of the authentication:
       #
   
       unless ($validated != -3.14159) {
    die "ValidateUser - failed to set the value of validated";
       }
       return $validated;
   }
   
   #
   #    Add a line to the subscription list?
   #
 sub addline {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
     my $contents;      my $contents;
Line 3996  sub addline { Line 4298  sub addline {
     $sh->close();      $sh->close();
     return $found;      return $found;
 }  }
   #
   #    Get chat messages.
   #
 sub getchat {  sub getchat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
Line 4021  sub getchat { Line 4325  sub getchat {
     }      }
     return (@participants,@entries);      return (@participants,@entries);
 }  }
   #
   #   Add a chat message
   #
 sub chatadd {  sub chatadd {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
     my %hash;      my %hash;
Line 4080  sub currentversion { Line 4386  sub currentversion {
     my $version=-1;      my $version=-1;
     my $ulsdir='';      my $ulsdir='';
     if ($fname=~/^(.+)\/[^\/]+$/) {      if ($fname=~/^(.+)\/[^\/]+$/) {
        $ulsdir=$1;   $ulsdir=$1;
     }      }
     my ($fnamere1,$fnamere2);      my ($fnamere1,$fnamere2);
     # remove version if already specified      # remove version if already specified
Line 4137  sub subscribe { Line 4443  sub subscribe {
                     symlink($root.'.'.$extension,                      symlink($root.'.'.$extension,
                             $root.'.'.$currentversion.'.'.$extension);                              $root.'.'.$currentversion.'.'.$extension);
                     unless ($extension=~/\.meta$/) {                      unless ($extension=~/\.meta$/) {
                        symlink($root.'.'.$extension.'.meta',   symlink($root.'.'.$extension.'.meta',
                             $root.'.'.$currentversion.'.'.$extension.'.meta');   $root.'.'.$currentversion.'.'.$extension.'.meta');
     }      }
                 }                  }
             }              }
Line 4192  sub make_passwd_file { Line 4498  sub make_passwd_file {
     print $pf "localauth:$npass\n";      print $pf "localauth:$npass\n";
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   #
     my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";   #  Don't allow the creation of privileged accounts!!! that would
     {   #  be real bad!!!
  &Debug("Executing external: ".$execpath);   #
  &Debug("user  = ".$uname.", Password =". $npass);   my $uid = getpwnam($uname);
  my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");   if((defined $uid) && ($uid == 0)) {
  print $se "$uname\n";      &logthis(">>>Attempted add of privileged account blocked<<<");
  print $se "$npass\n";      return "no_priv_account_error\n";
  print $se "$npass\n";  
     }  
     my $useraddok = $?;  
     if($useraddok > 0) {  
  &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));  
     }  
     my $pf = IO::File->new(">$passfilename");  
     print $pf "unix:\n";  
  }   }
   
    #
    my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
   
    &Debug("Executing external: ".$execpath);
    &Debug("user  = ".$uname.", Password =". $npass);
    my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
    print $se "$uname\n";
    print $se "$npass\n";
    print $se "$npass\n";
   
    my $useraddok = $?;
    if($useraddok > 0) {
       my $lcstring = lcuseraddstrerror($useraddok);
       &logthis("Failed lcuseradd: $lcstring");
       return "error: lcuseradd failed: $lcstring\n";
    }
    my $pf = IO::File->new(">$passfilename");
    print $pf "unix:\n";
    
     } elsif ($umode eq 'none') {      } elsif ($umode eq 'none') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
Line 4222  sub make_passwd_file { Line 4540  sub make_passwd_file {
   
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
       Debug("sethost got $remotereq");
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
       Debug("sethost attempting to set host $hostid");
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
  $currenthostid=$hostid;   $currenthostid=$hostid;
  $currentdomainid=$hostdom{$hostid};   $currentdomainid=$hostdom{$hostid};
Removed from v.1.177  
changed lines
  Added in v.1.178.2.19

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

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

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

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