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

Diff for /loncom/lond between versions 1.178.2.2 and 1.178.2.23

version 1.178.2.2, 2004/02/23 10:25:52 version 1.178.2.23, 2004/05/07 17:57:18
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:
       
       
       if (($namespace =~/^nohist\_/) && (scalar @_ > 0)) {
    my $args = scalar @_;
    Debug(" Opening history: $namespace $args");
    my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
    if($hfh) {
       my $now = time;
       my $loghead  = shift;
       my $what    = shift;
       print $hfh "$loghead:$now:$what\n";
    }
       }
       #  Tie the database.
       
       my %hash;
       if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",
      $how, 0640)) {
    return \%hash;
       }
       else {
    return undef;
       }
       
   }
   
 #  #
 #   Get a Request:  #   Get a Request:
Line 189  sub GetRequest { Line 292  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) {      if($cipher) {
       my($enc, $enclength, $encinput) = split(/:/, $input);   my($enc, $enclength, $encinput) = split(/:/, $input);
       for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {   for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
          $output .=       $output .= 
             $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));   $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
       }   }
       return substr($output, 0, $enclength);   return substr($output, 0, $enclength);
    } else {      } else {
       return undef;   return undef;
    }      }
      
 }  }
   
 #  #
Line 234  sub Decipher { Line 336  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#  
      
    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:      #  Don't allow duplication#
      
       if (defined $Dispatcher{$RequestName}) {
    die "Attempting to define a duplicate request handler for $RequestName\n";
       }
       #   Build the client type mask:
       
       my $ClientTypeMask = 0;
       if($ClientOk) {
    $ClientTypeMask  |= $CLIENT_OK;
       }
       if($ManagerOk) {
    $ClientTypeMask  |= $MANAGER_OK;
       }
      
       #  Enter the hash:
               
    my @entry = ($Procedure, $MustEncode, $ClientTypeMask);      my @entry = ($Procedure, $MustEncode, $ClientTypeMask);
         
    $Dispatcher{$RequestName} = \@entry;      $Dispatcher{$RequestName} = \@entry;
         
         
 }  }
Line 284  sub RegisterHandler { Line 386  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 411  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 441  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 481  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 524  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();  
    Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");  
   
    return 1;      my $userloadpercent=&userload();
       Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
       
       return 1;
 }  }
 RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);  RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);
   
Line 447  RegisterHandler("userload", \&UserLoadHa Line 549  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 594  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 636  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 670  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 709  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 724  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);
    Debug(" Authenticate domain = $udom, user = $uname, password = $upass");      Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
    chomp($upass);      chomp($upass);
    $upass=unescape($upass);      $upass=unescape($upass);
    my $proname=propath($udom,$uname);  
    my $passfilename="$proname/passwd";      my $pwdcorrect = ValidateUser($udom, $uname, $upass);
          if($pwdcorrect) {
    #   The user's 'personal' loncapa passworrd file describes how to authenticate:   Reply( $client, "authorized\n", $userinput);
       #
    if (-e $passfilename) {   #  Bad credentials: Failed to authorize
      Debug("Located password file: $passfilename");   #
       } else {
       my $pf = IO::File->new($passfilename);   Failure( $client, "non_authorized\n", $userinput);
       my $realpasswd=<$pf>;      }
       chomp($realpasswd);  
       my ($howpwd,$contentpwd)=split(/:/,$realpasswd);      return 1;
       my $pwdcorrect=0;  
       #  
       #   Authenticate against password stored in the internal file.  
       #  
      Debug("Authenticating via $howpwd");  
       if ($howpwd eq 'internal') {  
          &Debug("Internal auth");  
          $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);  
       #  
       #   Authenticate against the unix password file.  
       #  
       } elsif ($howpwd eq 'unix') {  
          &Debug("Unix auth");  
          if((getpwnam($uname))[1] eq "") { #no such user!  
             $pwdcorrect = 0;  
          } else {  
             $contentpwd=(getpwnam($uname))[1];  
             my $pwauth_path="/usr/local/sbin/pwauth";  
             unless ($contentpwd eq 'x') {  
                $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);  
             } elsif (-e $pwauth_path) {  
                open PWAUTH, "|$pwauth_path" or  
                   die "Cannot invoke authentication";  
                print PWAUTH "$uname\n$upass\n";  
                close PWAUTH;  
                $pwdcorrect=!$?;  
             }  
          }  
       #  
       #   Authenticate against a Kerberos 4 server:  
       #  
       } elsif ($howpwd eq 'krb4') {  
          my $null=pack("C",0);  
          unless ($upass=~/$null/) {  
             my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname,  
                                                           "",  
                                                           $contentpwd,  
                                                           'krbtgt',  
                                                          $contentpwd,  
                                                          1,  
                                                          $upass);  
             if (!$krb4_error) {  
                $pwdcorrect = 1;  
             } else {   
                $pwdcorrect=0;   
                # log error if it is not a bad password  
                if ($krb4_error != 62) {  
                   &logthis('krb4:'.$uname.','.$contentpwd.','.  
                            &Authen::Krb4::get_err_txt($Authen::Krb4::error));  
                }  
             }  
          }  
       #  
       #   Authenticate against a Kerberos 5 server:  
       #  
       } elsif ($howpwd eq 'krb5') {  
          my $null=pack("C",0);  
          unless ($upass=~/$null/) {  
             my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);  
             my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;  
             my $krbserver=&Authen::Krb5::parse_name($krbservice);  
             my $credentials=&Authen::Krb5::cc_default();  
             $credentials->initialize($krbclient);  
             my $krbreturn = &Authen::Krb5::get_in_tkt_with_password(  
                                                                     $krbclient,  
                                                                     $krbserver,  
                                                                     $upass,  
                                                                     $credentials);  
             $pwdcorrect = ($krbreturn == 1);  
          } else {   
             $pwdcorrect=0;   
          }  
       #  
       #  Finally, the user may have written in an authentication module.  
       #  in that case, if requested, authenticate against it.  
       #  
       } elsif ($howpwd eq 'localauth') {  
          $pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd);  
       }  
       #  
       #   Successfully authorized.  
       #  
       if ($pwdcorrect) {  
          Reply( $client, "authorized\n", $userinput);  
       #  
       #  Bad credentials: Failed to authorize  
       #  
       } else {  
          Failure( $client, "non_authorized\n", $userinput);  
       }  
    #  
    #  User bad... note it may be bad security practice to differntiate to the  
    #  caller a bad user from a  bad passwd... since that supplies covert channel  
    #  information (you have a good user but bad password e.g.) to guessers.  
    #  
    } else {  
       Failure( $client, "unknown_user\n", $userinput);  
    }  
    return 1;  
 }  }
 RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);  RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);
   
Line 765  RegisterHandler("auth", \&AuthenticateHa Line 777  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);  
    $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 876  RegisterHandler("passwd", \&ChangePasswo Line 866  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 943  RegisterHandler("makeuser", \&AddUserHan Line 940  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 982  RegisterHandler("changeuserauth", \&Chan Line 984  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 1022  RegisterHandler("home", \&IsHomeHandler, Line 1024  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; # This allows interactive testing
    my $ownership=ishome($fname);  
    if ($ownership eq 'not_owner') {  
       if (-e $fname) {      my $ownership=ishome($fname);
          my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,      if ($ownership eq 'not_owner') {
              $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);   if (-e $fname) {
          my $now=time;      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
          my $since=$now-$atime;   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
          if ($since>$perlvar{'lonExpire'}) {      my $now=time;
             my $reply=&reply("unsub:$fname","$clientname");      my $since=$now-$atime;
             unlink("$fname");      if ($since>$perlvar{'lonExpire'}) {
          } else {   my $reply=&reply("unsub:$fname","$clientname");
             my $transname="$fname.in.transfer";   unlink("$fname");
             my $remoteurl=&reply("sub:$fname","$clientname");      } else {
             my $response;   my $transname="$fname.in.transfer";
             alarm(120);   my $remoteurl=&reply("sub:$fname","$clientname");
             {   my $response;
                my $ua=new LWP::UserAgent;   alarm(120);
                my $request=new HTTP::Request('GET',"$remoteurl");   {
                $response=$ua->request($request,$transname);      my $ua=new LWP::UserAgent;
             }      my $request=new HTTP::Request('GET',"$remoteurl");
             alarm(0);      $response=$ua->request($request,$transname);
             if ($response->is_error()) {   }
                unlink($transname);   alarm(0);
                my $message=$response->status_line;   if ($response->is_error()) {
                &logthis("LWP GET: $message for $fname ($remoteurl)");      unlink($transname);
             } else {      my $message=$response->status_line;
                if ($remoteurl!~/\.meta$/) {      &logthis("LWP GET: $message for $fname ($remoteurl)");
                   alarm(120);   } else {
                   {      if ($remoteurl!~/\.meta$/) {
                      my $ua=new LWP::UserAgent;   alarm(120);
                      my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');   {
                      my $mresponse=$ua->request($mrequest,$fname.'.meta');      my $ua=new LWP::UserAgent;
                      if ($mresponse->is_error()) {      my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                         unlink($fname.'.meta');      my $mresponse=$ua->request($mrequest,$fname.'.meta');
                      }      if ($mresponse->is_error()) {
                   }   unlink($fname.'.meta');
                   alarm(0);      }
                }   }
                rename($transname,$fname);   alarm(0);
             }      }
          }      rename($transname,$fname);
                Reply( $client, "ok\n", $userinput);   }
       } else {      }
          Failure($client, "not_found\n", $userinput);      Reply( $client, "ok\n", $userinput);
       }   } else {
    } else {      Failure($client, "not_found\n", $userinput);
       Failure($client, "rejected\n", $userinput);   }
    }      } else {
    return 1;   Failure($client, "rejected\n", $userinput);
       }
       return 1;
 }  }
 RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0);  RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0);
   
Line 1092  RegisterHandler("update", \&UpdateResour Line 1096  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 1150  RegisterHandler("fetchuserfile", \&Fetch Line 1152  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 1185  RegisterHandler("tokenauthuserfile", \&A Line 1187  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) {  
       Reply($client, &unsub($client,$fname,$clientip), $userinput);      Debug("Unsubscribing $fname");
    } else {      if (-e $fname) {
       Failure($client, "not_found\n", $userinput);   Debug("Exists");
    }   Reply($client, &unsub($fname,$clientip), $userinput);
    return 1;      } else {
    Failure($client, "not_found\n", $userinput);
       }
       return 1;
 }  }
 RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);  RegisterHandler("unsub", \&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 1211  RegisterHandler("unusb", \&UnsubscribeHa Line 1216  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 1236  RegisterHandler("sub", \&SubscribeHandle Line 1241  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 1260  RegisterHandler("currentversion", \&Curr Line 1265  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);  
    chomp($what);  
    my $proname=propath($udom,$uname);  
    my $now=time;  
    my $hfh;  
    if ($hfh=IO::File->new(">>$proname/activity.log")) {   
       print $hfh "$now:$clientname:$what\n";  
       Reply( $client, "ok\n", $userinput);   
    } else {  
       Reply($client, "error: ".($!+0)." IO::File->new Failed "  
             ."while attempting log\n",   
             $userinput);  
    }  
   
    return 1;      my ($udom,$uname,$what)=split(/:/,$tail);
       chomp($what);
       my $proname=propath($udom,$uname);
       my $now=time;
       my $hfh;
       if ($hfh=IO::File->new(">>$proname/activity.log")) { 
    print $hfh "$now:$clientname:$what\n";
    Reply( $client, "ok\n", $userinput); 
       } else {
    Failure($client, "error: ".($!+0)." IO::File->new Failed "
         ."while attempting log\n", 
         $userinput);
       }
   
       return 1;
 }  }
 RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0);  RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0);
 #  #
Line 1297  RegisterHandler("log", \&ActivityLogEntr Line 1302  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 1358  RegisterHandler("put", \&PutUserProfileE Line 1353  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 1426  RegisterHandler("inc", \&IncrementUserVa Line 1412  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 1489  RegisterHandler("rolesput", \&RolesPutHa Line 1469  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 1554  RegisterHandler("rolesdel", \&RolesDelet Line 1524  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 1610  RegisterHandler("get", \&GetProfileEntry Line 1579  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 1673  RegisterHandler("eget", \&GetProfileEncr Line 1641  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 1726  RegisterHandler("del", \&DeleteProfileEn Line 1687  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 1776  RegisterHandler("keys", \&GetProfileKeys Line 1735  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 1852  RegisterHandler("currentdump", \&DumpPro Line 1810  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 a set of key=value pairs associated with a versioned name.
 #  #
 #  Parameters:  #  Parameters:
 #    $cmd                - Request command keyword.  #    $cmd                - Request command keyword.
Line 1917  RegisterHandler("dump", \&DumpWithRegexp Line 1871  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);
 #  #
 #   Restore a prior version of a resource.  #  Dump out all versions of a resource that has key=value pairs associated
   # with it for each version.  These resources are built up via the store
   # command.
 #  #
 #  Parameters:  #  Parameters:
 #     $cmd               - Command keyword.  #     $cmd               - Command keyword.
Line 1985  RegisterHandler("store", \&StoreHandler, Line 1934  RegisterHandler("store", \&StoreHandler,
 #      1  indicating the caller should not yet exit.  #      1  indicating the caller should not yet exit.
 # Side-effects:  # Side-effects:
 #   Writes a reply to the client.  #   Writes a reply to the client.
   #   The reply is a string of the following shape:
   #   version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2...
   #    Where the 1 above represents version 1.
   #    this continues for all pairs of keys in all versions.
   #
   #
   #    
 #  #
 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 2051  RegisterHandler("restor", \&RestoreHandl Line 2007  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 2082  RegisterHandler("chatsend", \&SendChatHa Line 2038  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 2120  RegisterHandler("chatretr", \&RetrieveCh Line 2076  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 2162  RegisterHandler("querysend", \&SendQuery Line 2118  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 2209  RegisterHandler("queryreply", \&ReplyQue Line 2164  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 $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 ($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 2269  RegisterHandler("courseidput", \&PutCour Line 2222  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=~/\Q$description\E/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 2333  RegisterHandler("courseiddump", \&DumpCo Line 2291  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 2392  RegisterHandler("idput", \&PutIdHandler, Line 2342  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"; 
       
   
       $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 2437  RegisterHandler("idget", \&GetIdHandler, Line 2683  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);
       $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
   
    Debug("Command received: $command, encoded = $wasenc");      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");   Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes");
               
       #  Validate the request:   #  Validate the request:
               
       my $ok = 1;   my $ok = 1;
       my $requesterprivs = 0;   my $requesterprivs = 0;
       if(isClient()) {   if(isClient()) {
  $requesterprivs |= $CLIENT_OK;      $requesterprivs |= $CLIENT_OK;
       }   }
       if(isManager()) {   if(isManager()) {
  $requesterprivs |= $MANAGER_OK;      $requesterprivs |= $MANAGER_OK;
       }   }
       if($NeedEncode && (!$wasenc)) {   if($NeedEncode && (!$wasenc)) {
  Debug("Must encode but wasn't: $NeedEncode $wasenc");      Debug("Must encode but wasn't: $NeedEncode $wasenc");
          $ok = 0;      $ok = 0;
       }   }
       if(($ClientTypes & $requesterprivs) == 0) {   if(($ClientTypes & $requesterprivs) == 0) {
  Debug("Client not privileged to do this operation");      Debug("Client not privileged to do this operation");
  $ok = 0;      $ok = 0;
       }   }
   
       if($ok) {  
  Debug("Dispatching to handler $command $tail");  
          $KeepGoing = &$Handler($command, $tail, $client);  
       } else {  
  Debug("Refusing to dispatch because ok is false");  
  Failure($client, "refused", $userinput);  
       }  
   
   
   
   
   
 # ---------------------------------------------------------------------- tmpput   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 2678  sub ReadManagerTable { Line 2793  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 2747  sub CopyFile { Line 2862  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 2800  sub AdjustHostContents { Line 2915  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 2846  sub InstallFile { Line 2961  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 2936  sub PushFile { Line 3051  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 2952  sub PushFile { Line 3067  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 3095  sub ApplyEdit { Line 3209  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 3265  sub catchexception { Line 3379  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 3292  undef $perlvarref; Line 3406  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 3304  if ($wwwid!=$<) { Line 3418  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 3320  $server = IO::Socket::INET->new(LocalPor Line 3434  $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 3473  sub checkchildren { Line 3587  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 3551  sub Reply { Line 3665  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 3600  sub status { Line 3714  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 3634  sub reconlonc { Line 3748  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 3651  sub subreply { Line 3764  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 3660  sub subreply { Line 3773  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 3694  sub subsqlreply { Line 3807  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 3706  sub subsqlreply { Line 3819  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 3718  sub propath { Line 3834  sub propath {
   
 sub ishome {  sub ishome {
     my $author=shift;      my $author=shift;
       Debug("ishome: $author");
     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       Debug("     after big regsub: $author");
     my ($udom,$uname)=split(/\//,$author);      my ($udom,$uname)=split(/\//,$author);
       Debug("      domain: $udom  user: $uname");
     my $proname=propath($udom,$uname);      my $proname=propath($udom,$uname);
       Debug("     path = $proname");
     if (-e $proname) {      if (-e $proname) {
  return 'owner';   return 'owner';
     } else {      } else {
Line 3787  sub make_new_child { Line 3907  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 3827  sub make_new_child { Line 3947  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 3854  sub make_new_child { Line 3974  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 3862  sub make_new_child { Line 3982  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 3943  sub make_new_child { Line 4059  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 3959  sub ManagePermissions Line 4074  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 3999  sub addline { Line 4306  sub addline {
     my $expr='^'.$hostid.':'.$ip.':';      my $expr='^'.$hostid.':'.$ip.':';
     $expr =~ s/\./\\\./g;      $expr =~ s/\./\\\./g;
     my $sh;      my $sh;
       Debug("Looking for $expr");
     if ($sh=IO::File->new("$fname.subscription")) {      if ($sh=IO::File->new("$fname.subscription")) {
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
     if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;}      Debug("addline: line: $subline");
       if ($subline !~ /$expr/) {
    $contents.= $subline;
       } else {
    Debug("Found $subline");
    $found=1;
       }
  }   }
  $sh->close();   $sh->close();
     }      }
     $sh=IO::File->new(">$fname.subscription");      $sh=IO::File->new(">$fname.subscription");
     if ($contents) { print $sh $contents; }      if ($contents) { print $sh $contents; }
     if ($newline) { print $sh $newline; }      if ($newline) { 
    Debug("Appending $newline");
    print $sh $newline; 
       }
     $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 4036  sub getchat { Line 4355  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 4076  sub chatadd { Line 4397  sub chatadd {
 sub unsub {  sub unsub {
     my ($fname,$clientip)=@_;      my ($fname,$clientip)=@_;
     my $result;      my $result;
       my $unsubs = 0; # Number of successful unsubscribes:
   
   
       # An old way subscriptions were handled was to have a 
       # subscription marker file:
   
       Debug("Attempting unlink of $fname.$clientname");
     if (unlink("$fname.$clientname")) {      if (unlink("$fname.$clientname")) {
  $result="ok\n";   $unsubs++; # Successful unsub via marker file.
     } else {      } 
  $result="not_subscribed\n";  
     }      # The more modern way to do it is to have a subscription list
       # file:
   
     if (-e "$fname.subscription") {      if (-e "$fname.subscription") {
  my $found=&addline($fname,$clientname,$clientip,'');   my $found=&addline($fname,$clientname,$clientip,'');
  if ($found) { $result="ok\n"; }   if ($found) { 
       $unsubs++;
    }
       } 
   
       #  If either or both of these mechanisms succeeded in unsubscribing a 
       #  resource we can return ok:
   
       if($unsubs) {
    $result = "ok\n";
     } else {      } else {
  if ($result != "ok\n") { $result="not_subscribed\n"; }   $result = "not_subscribed\n";
     }      }
   
     return $result;      return $result;
 }  }
   
Line 4095  sub currentversion { Line 4435  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 4138  sub thisversion { Line 4478  sub thisversion {
   
 sub subscribe {  sub subscribe {
     my ($userinput,$clientip)=@_;      my ($userinput,$clientip)=@_;
       chomp($userinput);
     my $result;      my $result;
     my ($cmd,$fname)=split(/:/,$userinput);      my ($cmd,$fname)=split(/:/,$userinput);
     my $ownership=&ishome($fname);      my $ownership=&ishome($fname);
       Debug("subscribe: Owner = $ownership file: '$fname'");
     if ($ownership eq 'owner') {      if ($ownership eq 'owner') {
 # explitly asking for the current version?  # explitly asking for the current version?
         unless (-e $fname) {          unless (-e $fname) {
       Debug("subscribe - does not exist");
             my $currentversion=&currentversion($fname);              my $currentversion=&currentversion($fname);
     if (&thisversion($fname)==$currentversion) {      if (&thisversion($fname)==$currentversion) {
                 if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {                  if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) {
Line 4152  sub subscribe { Line 4495  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');
     }      }
                 }                  }
             }              }
         }          }
  if (-e $fname) {   if (-e $fname) {
       Debug("subscribe - exists");
     if (-d $fname) {      if (-d $fname) {
  $result="directory\n";   $result="directory\n";
     } else {      } else {
Line 4207  sub make_passwd_file { Line 4551  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) {   my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
  &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));  
     }   &Debug("Executing external: ".$execpath);
     my $pf = IO::File->new(">$passfilename");   &Debug("user  = ".$uname.", Password =". $npass);
     print $pf "unix:\n";   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 4237  sub make_passwd_file { Line 4593  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.178.2.2  
changed lines
  Added in v.1.178.2.23

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