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

Diff for /loncom/lond between versions 1.226 and 1.233

version 1.226, 2004/08/10 11:30:24 version 1.233, 2004/08/18 17:43:05
Line 1756  sub fetch_user_file_handler { Line 1756  sub fetch_user_file_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my $fname           = $tail;      my $fname           = $tail;
     my ($udom,$uname,$ufile)=split(/\//,$fname);      my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
     my $udir=&propath($udom,$uname).'/userfiles';      my $udir=&propath($udom,$uname).'/userfiles';
     unless (-e $udir) {      unless (-e $udir) {
  mkdir($udir,0770);    mkdir($udir,0770); 
     }      }
       Debug("fetch user file for $fname");
     if (-e $udir) {      if (-e $udir) {
  $ufile=~s/^[\.\~]+//;   $ufile=~s/^[\.\~]+//;
  $ufile=~s/\///g;  
    # IF necessary, create the path right down to the file.
    # Note that any regular files in the way of this path are
    # wiped out to deal with some earlier folly of mine.
   
    my $path = $udir;
    if ($ufile =~m|(.+)/([^/]+)$|) {
       my @parts=split('/',$1);
       foreach my $part (@parts) {
    $path .= '/'.$part;
    if( -f $path) {
       unlink($path);
    }
    if ((-e $path)!=1) {
       mkdir($path,0770);
    }
       }
    }
   
   
  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;
    Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
  alarm(120);   alarm(120);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
Line 1781  sub fetch_user_file_handler { Line 1802  sub fetch_user_file_handler {
     &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 {
       Debug("Renaming $transname to $destname");
     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);
Line 1812  sub remove_user_file_handler { Line 1834  sub remove_user_file_handler {
     my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.      my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
   
     my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);      my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
     &logthis("$udom - $uname - $ufile");  
     if ($ufile =~m|/\.\./|) {      if ($ufile =~m|/\.\./|) {
  # any files paths with /../ in them refuse    # any files paths with /../ in them refuse 
  # to deal with   # to deal with
Line 1839  sub remove_user_file_handler { Line 1860  sub remove_user_file_handler {
 }  }
 &register_handler("removeuserfile", \&remove_user_file_handler, 0,1,0);  &register_handler("removeuserfile", \&remove_user_file_handler, 0,1,0);
   
   
   #
   #  Authenticate access to a user file by checking the user's 
   #  session token(?)
   #
   # Parameters:
   #   cmd      - The request keyword that dispatched to tus.
   #   tail     - The tail of the request (colon separated parameters).
   #   client   - Filehandle open on the client.
   # Return:
   #    1.
   
   sub token_auth_user_file_handler {
       my ($cmd, $tail, $client) = @_;
   
       my ($fname, $session) = split(/:/, $tail);
       
       chomp($session);
       my $reply='non_auth';
       if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
        $session.'.id')) {
    while (my $line=<ENVIN>) {
       if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
    }
    close(ENVIN);
    &Reply($client, $reply);
       } else {
    &Failure($client, "invalid_token\n", "$cmd:$tail");
       }
       return 1;
   
   }
   
   &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
   
   
   #
   #   Unsubscribe from a resource.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub unsubscribe_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput= "$cmd:$tail";
       
       my ($fname) = split(/:/,$tail); # Split in case there's extrs.
   
       &Debug("Unsubscribing $fname");
       if (-e $fname) {
    &Debug("Exists");
    &Reply($client, &unsub($fname,$clientip), $userinput);
       } else {
    &Failure($client, "not_found\n", $userinput);
       }
       return 1;
   }
   &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
   #   Subscribe to a resource
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub subscribe_handler {
       my ($cmd, $tail, $client)= @_;
   
       my $userinput  = "$cmd:$tail";
   
       &Reply( $client, &subscribe($userinput,$clientip), $userinput);
   
       return 1;
   }
   &register_handler("sub", \&subscribe_handler, 0, 1, 0);
   
   #
   #   Determine the version of a resource (?) Or is it return
   #   the top version of the resource?  Not yet clear from the
   #   code in currentversion.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub current_version_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput= "$cmd:$tail";
      
       my $fname   = $tail;
       &Reply( $client, &currentversion($fname)."\n", $userinput);
       return 1;
   
   }
   &register_handler("currentversion", \&current_version_handler, 0, 1, 0);
   
   #  Make an entry in a user's activity log.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub activity_log_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput= "$cmd:$tail";
   
       my ($udom,$uname,$what)=split(/:/,$tail);
       chomp($what);
       my $proname=&propath($udom,$uname);
       my $now=time;
       my $hfh;
       if ($hfh=IO::File->new(">>$proname/activity.log")) { 
    print $hfh "$now:$clientname:$what\n";
    &Reply( $client, "ok\n", $userinput); 
       } else {
    &Failure($client, "error: ".($!+0)." IO::File->new Failed "
    ."while attempting log\n", 
    $userinput);
       }
   
       return 1;
   }
   register_handler("log", \&activity_log_handler, 0, 1, 0);
   
   #
   #   Put a namespace entry in a user profile hash.
   #   My druthers would be for this to be an encrypted interaction too.
   #   anything that might be an inadvertent covert channel about either
   #   user authentication or user personal information....
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub put_user_profile_entry {
       my ($cmd, $tail, $client)  = @_;
   
       my $userinput = "$cmd:$tail";
       
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
    chomp($what);
    my $hashref = &tie_user_hash($udom, $uname, $namespace,
     &GDBM_WRCREAT(),"P",$what);
    if($hashref) {
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $hashref->{$key}=$value;
       }
       if (untie(%$hashref)) {
    &Reply( $client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting put\n", 
    $userinput);
       }
    } else {
       &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
        "while attempting put\n", $userinput);
    }
       } else {
           &Failure( $client, "refused\n", $userinput);
       }
       
       return 1;
   }
   &register_handler("put", \&put_user_profile_entry, 0, 1, 0);
   
   # 
   #   Increment a profile entry in the user history file.
   #   The history contains keyword value pairs.  In this case,
   #   The value itself is a pair of numbers.  The first, the current value
   #   the second an increment that this function applies to the current
   #   value.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub increment_user_value_handler {
       my ($cmd, $tail, $client) = @_;
       
       my $userinput   = "$cmd:$tail";
       
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
           chomp($what);
    my $hashref = &tie_user_hash($udom, $uname,
        $namespace, &GDBM_WRCREAT(),
        "P",$what);
    if ($hashref) {
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    # We could check that we have a number...
    if (! defined($value) || $value eq '') {
       $value = 1;
    }
    $hashref->{$key}+=$value;
       }
       if (untie(%$hashref)) {
    &Reply( $client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting inc\n", $userinput);
       }
    } else {
       &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting inc\n", $userinput);
    }
       } else {
    &Failure($client, "refused\n", $userinput);
       }
       
       return 1;
   }
   &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);
   
   
   #
   #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
   #   Each 'role' a user has implies a set of permissions.  Adding a new role
   #   for a person grants the permissions packaged with that role
   #   to that user when the role is selected.
   #
   # Parameters:
   #    $cmd       - The command string (rolesput).
   #    $tail      - The remainder of the request line.  For rolesput this
   #                 consists of a colon separated list that contains:
   #                 The domain and user that is granting the role (logged).
   #                 The domain and user that is getting the role.
   #                 The roles being granted as a set of & separated pairs.
   #                 each pair a key value pair.
   #    $client    - File descriptor connected to the client.
   # Returns:
   #     0         - If the daemon should exit
   #     1         - To continue processing.
   #
   #
   sub roles_put_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput  = "$cmd:$tail";
   
       my ( $exedom, $exeuser, $udom, $uname,  $what) = split(/:/,$tail);
       
   
       my $namespace='roles';
       chomp($what);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_WRCREAT(), "P",
    "$exedom:$exeuser:$what");
       #
       #  Log the attempt to set a role.  The {}'s here ensure that the file 
       #  handle is open for the minimal amount of time.  Since the flush
       #  is done on close this improves the chances the log will be an un-
       #  corrupted ordered thing.
       if ($hashref) {
    my @pairs=split(/\&/,$what);
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       &manage_permissions($key, $udom, $uname,
          &get_auth_type( $udom, $uname));
       $hashref->{$key}=$value;
    }
    if (untie($hashref)) {
       &Reply($client, "ok\n", $userinput);
    } else {
       &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting rolesput\n", $userinput);
    }
       } else {
    &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting rolesput\n", $userinput);
       }
       return 1;
   }
   &register_handler("rolesput", \&roles_put_handler, 1,1,0);  # Encoded client only.
   
   #
   #   Deletes (removes) a role for a user.   This is equivalent to removing
   #  a permissions package associated with the role from the user's profile.
   #
   # Parameters:
   #     $cmd                 - The command (rolesdel)
   #     $tail                - The remainder of the request line. This consists
   #                             of:
   #                             The domain and user requesting the change (logged)
   #                             The domain and user being changed.
   #                             The roles being revoked.  These are shipped to us
   #                             as a bunch of & separated role name keywords.
   #     $client              - The file handle open on the client.
   # Returns:
   #     1                    - Continue processing
   #     0                    - Exit.
   #
   sub roles_delete_handler {
       my ($cmd, $tail, $client)  = @_;
   
       my $userinput    = "$cmd:$tail";
      
       my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
       &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
      "what = ".$what);
       my $namespace='roles';
       chomp($what);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_WRCREAT(), "D",
    "$exedom:$exeuser:$what");
       
       if ($hashref) {
    my @rolekeys=split(/\&/,$what);
   
    foreach my $key (@rolekeys) {
       delete $hashref->{$key};
    }
    if (untie(%$hashref)) {
       &Reply($client, "ok\n", $userinput);
    } else {
       &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting rolesdel\n", $userinput);
    }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting rolesdel\n", $userinput);
       }
       
       return 1;
   }
   &register_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only
   
   # Unencrypted get from a user's profile database.  See 
   # GetProfileEntryEncrypted for a version that does end-to-end encryption.
   # This function retrieves a keyed item from a specific named database in the
   # user's directory.
   #
   # Parameters:
   #   $cmd             - Command request keyword (get).
   #   $tail            - Tail of the command.  This is a colon separated list
   #                      consisting of the domain and username that uniquely
   #                      identifies the profile,
   #                      The 'namespace' which selects the gdbm file to 
   #                      do the lookup in, 
   #                      & separated list of keys to lookup.  Note that
   #                      the values are returned as an & separated list too.
   #   $client          - File descriptor open on the client.
   # Returns:
   #   1       - Continue processing.
   #   0       - Exit.
   #
   sub get_profile_entry {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput= "$cmd:$tail";
      
       my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
           my @queries=split(/\&/,$what);
           my $qresult='';
   
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
    }
    $qresult=~s/\&$//;              # Remove trailing & from last lookup.
    if (untie(%$hashref)) {
       &Reply($client, "$qresult\n", $userinput);
    } else {
       &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting get\n", $userinput);
    }
       } else {
    if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT
       &Failure($client, "error:No such file or ".
       "GDBM reported bad block error\n", $userinput);
    } else {                        # Some other undifferentiated err.
       &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       "while attempting get\n", $userinput);
    }
       }
       return 1;
   }
   &register_handler("get", \&get_profile_entry, 0,1,0);
   
   #
   #  Process the encrypted get request.  Note that the request is sent
   #  in clear, but the reply is encrypted.  This is a small covert channel:
   #  information about the sensitive keys is given to the snooper.  Just not
   #  information about the values of the sensitive key.  Hmm if I wanted to
   #  know these I'd snoop for the egets. Get the profile item names from them
   #  and then issue a get for them since there's no enforcement of the
   #  requirement of an encrypted get for particular profile items.  If I
   #  were re-doing this, I'd force the request to be encrypted as well as the
   #  reply.  I'd also just enforce encrypted transactions for all gets since
   #  that would prevent any covert channel snooping.
   #
   #  Parameters:
   #     $cmd               - Command keyword of request (eget).
   #     $tail              - Tail of the command.  See GetProfileEntry #                          for more information about this.
   #     $client            - File open on the client.
   #  Returns:
   #     1      - Continue processing
   #     0      - server should exit.
   sub get_profile_entry_encrypted {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
      
       my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
       chomp($what);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
           my @queries=split(/\&/,$what);
           my $qresult='';
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       if ($cipher) {
    my $cmdlength=length($qresult);
    $qresult.="         ";
    my $encqresult='';
    for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
       $encqresult.= unpack("H16", 
    $cipher->encrypt(substr($qresult,
    $encidx,
    8)));
    }
    &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
       } else {
    &Failure( $client, "error:no_key\n", $userinput);
       }
    } else {
       &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting eget\n", $userinput);
    }
       } else {
    &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting eget\n", $userinput);
       }
       
       return 1;
   }
   &register_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
   #
   #   Deletes a key in a user profile database.
   #   
   #   Parameters:
   #       $cmd                  - Command keyword (del).
   #       $tail                 - Command tail.  IN this case a colon
   #                               separated list containing:
   #                               The domain and user that identifies uniquely
   #                               the identity of the user.
   #                               The profile namespace (name of the profile
   #                               database file).
   #                               & separated list of keywords to delete.
   #       $client              - File open on client socket.
   # Returns:
   #     1   - Continue processing
   #     0   - Exit server.
   #
   #
   
   sub delete_profile_entry {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "cmd:$tail";
   
       my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_WRCREAT(),
    "D",$what);
       if ($hashref) {
           my @keys=split(/\&/,$what);
    foreach my $key (@keys) {
       delete($hashref->{$key});
    }
    if (untie(%$hashref)) {
       &Reply($client, "ok\n", $userinput);
    } else {
       &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting del\n", $userinput);
    }
       } else {
    &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting del\n", $userinput);
       }
       return 1;
   }
   &register_handler("del", \&delete_profile_entry, 0, 1, 0);
   #
   #  List the set of keys that are defined in a profile database file.
   #  A successful reply from this will contain an & separated list of
   #  the keys. 
   # Parameters:
   #     $cmd              - Command request (keys).
   #     $tail             - Remainder of the request, a colon separated
   #                         list containing domain/user that identifies the
   #                         user being queried, and the database namespace
   #                         (database filename essentially).
   #     $client           - File open on the client.
   #  Returns:
   #    1    - Continue processing.
   #    0    - Exit the server.
   #
   sub get_profile_keys {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace)=split(/:/,$tail);
       my $qresult='';
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
     &GDBM_READER());
       if ($hashref) {
    foreach my $key (keys %$hashref) {
       $qresult.="$key&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       &Reply($client, "$qresult\n", $userinput);
    } else {
       &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting keys\n", $userinput);
    }
       } else {
    &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting keys\n", $userinput);
       }
      
       return 1;
   }
   &register_handler("keys", \&get_profile_keys, 0, 1, 0);
   
   #
   #   Dump the contents of a user profile database.
   #   Note that this constitutes a very large covert channel too since
   #   the dump will return sensitive information that is not encrypted.
   #   The naive security assumption is that the session negotiation ensures
   #   our client is trusted and I don't believe that's assured at present.
   #   Sure want badly to go to ssl or tls.  Of course if my peer isn't really
   #   a LonCAPA node they could have negotiated an encryption key too so >sigh<.
   # 
   #  Parameters:
   #     $cmd           - The command request keyword (currentdump).
   #     $tail          - Remainder of the request, consisting of a colon
   #                      separated list that has the domain/username and
   #                      the namespace to dump (database file).
   #     $client        - file open on the remote client.
   # Returns:
   #     1    - Continue processing.
   #     0    - Exit the server.
   #
   sub dump_profile_database {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
      
       my ($udom,$uname,$namespace) = split(/:/,$tail);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
    # Structure of %data:
    # $data{$symb}->{$parameter}=$value;
    # $data{$symb}->{'v.'.$parameter}=$version;
    # since $parameter will be unescaped, we do not
     # have to worry about silly parameter names...
   
           my $qresult='';
    my %data = ();                     # A hash of anonymous hashes..
    while (my ($key,$value) = each(%$hashref)) {
       my ($v,$symb,$param) = split(/:/,$key);
       next if ($v eq 'version' || $symb eq 'keys');
       next if (exists($data{$symb}) && 
        exists($data{$symb}->{$param}) &&
        $data{$symb}->{'v.'.$param} > $v);
       $data{$symb}->{$param}=$value;
       $data{$symb}->{'v.'.$param}=$v;
    }
    if (untie(%$hashref)) {
       while (my ($symb,$param_hash) = each(%data)) {
    while(my ($param,$value) = each (%$param_hash)){
       next if ($param =~ /^v\./);       # Ignore versions...
       #
       #   Just dump the symb=value pairs separated by &
       #
       $qresult.=$symb.':'.$param.'='.$value.'&';
    }
       }
       chop($qresult);
       &Reply($client , "$qresult\n", $userinput);
    } else {
       &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting currentdump\n", $userinput);
    }
       } else {
    &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting currentdump\n", $userinput);
       }
   
       return 1;
   }
   &register_handler("currentdump", \&dump_profile_database, 0, 1, 0);
   
   #
   #   Dump a profile database with an optional regular expression
   #   to match against the keys.  In this dump, no effort is made
   #   to separate symb from version information. Presumably the
   #   databases that are dumped by this command are of a different
   #   structure.  Need to look at this and improve the documentation of
   #   both this and the currentdump handler.
   # Parameters:
   #    $cmd                     - The command keyword.
   #    $tail                    - All of the characters after the $cmd:
   #                               These are expected to be a colon
   #                               separated list containing:
   #                               domain/user - identifying the user.
   #                               namespace   - identifying the database.
   #                               regexp      - optional regular expression
   #                                             that is matched against
   #                                             database keywords to do
   #                                             selective dumps.
   #   $client                   - Channel open on the client.
   # Returns:
   #    1    - Continue processing.
   # Side effects:
   #    response is written to $client.
   #
   sub dump_with_regexp {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
       if (defined($regexp)) {
    $regexp=&unescape($regexp);
       } else {
    $regexp='.';
       }
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
           my $qresult='';
    while (my ($key,$value) = each(%$hashref)) {
       if ($regexp eq '.') {
    $qresult.=$key.'='.$value.'&';
       } else {
    my $unescapeKey = &unescape($key);
    if (eval('$unescapeKey=~/$regexp/')) {
       $qresult.="$key=$value&";
    }
       }
    }
    if (untie(%$hashref)) {
       chop($qresult);
       &Reply($client, "$qresult\n", $userinput);
    } else {
       &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting dump\n", $userinput);
    }
       } else {
    &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting dump\n", $userinput);
       }
   
       return 1;
   }
   
   &register_handler("dump", \&dump_with_regexp, 0, 1, 0);
   
   #  Store a set of key=value pairs associated with a versioned name.
   #
   #  Parameters:
   #    $cmd                - Request command keyword.
   #    $tail               - Tail of the request.  This is a colon
   #                          separated list containing:
   #                          domain/user - User and authentication domain.
   #                          namespace   - Name of the database being modified
   #                          rid         - Resource keyword to modify.
   #                          what        - new value associated with rid.
   #
   #    $client             - Socket open on the client.
   #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub store_handler {
       my ($cmd, $tail, $client) = @_;
    
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
   
    chomp($what);
    my @pairs=split(/\&/,$what);
    my $hashref  = &tie_user_hash($udom, $uname, $namespace,
          &GDBM_WRCREAT(), "P",
          "$rid:$what");
    if ($hashref) {
       my $now = time;
       my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
       my $key;
       $hashref->{"version:$rid"}++;
       my $version=$hashref->{"version:$rid"};
       my $allkeys=''; 
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $allkeys.=$key.':';
    $hashref->{"$version:$rid:$key"}=$value;
       }
       $hashref->{"$version:$rid:timestamp"}=$now;
       $allkeys.='timestamp';
       $hashref->{"$version:keys:$rid"}=$allkeys;
       if (untie($hashref)) {
    &Reply($client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
       }
    } else {
       &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting store\n", $userinput);
    }
       } else {
    &Failure($client, "refused\n", $userinput);
       }
   
       return 1;
   }
   &register_handler("store", \&store_handler, 0, 1, 0);
   #
   #  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:
   #     $cmd               - Command keyword.
   #     $tail              - Remainder of the request which consists of:
   #                          domain/user   - User and auth. domain.
   #                          namespace     - name of resource database.
   #                          rid           - Resource id.
   #    $client             - socket open on the client.
   #
   # Returns:
   #      1  indicating the caller should not yet exit.
   # Side-effects:
   #   Writes a reply to the client.
   #   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 restore_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail"; # Only used for logging purposes.
   
       my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
       $namespace=~s/\//\_/g;
       $namespace=~s/\W//g;
       chomp($rid);
       my $proname=&propath($udom,$uname);
       my $qresult='';
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
       &GDBM_READER(),0640)) {
    my $version=$hash{"version:$rid"};
    $qresult.="version=$version&";
    my $scope;
    for ($scope=1;$scope<=$version;$scope++) {
       my $vkeys=$hash{"$scope:keys:$rid"};
       my @keys=split(/:/,$vkeys);
       my $key;
       $qresult.="$scope:keys=$vkeys&";
       foreach $key (@keys) {
    $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
       }                                  
    }
    if (untie(%hash)) {
       $qresult=~s/\&$//;
       &Reply( $client, "$qresult\n", $userinput);
    } else {
       &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting restore\n", $userinput);
    }
       } else {
    &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
    "while attempting restore\n", $userinput);
       }
     
       return 1;
   
   
   }
   &register_handler("restore", \&restore_handler, 0,1,0);
   #
   #
 #---------------------------------------------------------------  #---------------------------------------------------------------
 #  #
 #   Getting, decoding and dispatching requests:  #   Getting, decoding and dispatching requests:
Line 1954  sub process_request { Line 2813  sub process_request {
   
   
   
 # ------------------------------------------ authenticate access to a user file  
   
     if ($userinput =~ /^tokenauthuserfile/) { # Client only  
  if(isClient) {  
     my ($cmd,$fname,$session)=split(/:/,$userinput);  
     chomp($session);  
     my $reply='non_auth';  
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.  
      $session.'.id')) {  
  while (my $line=<ENVIN>) {  
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }  
     }  
  close(ENVIN);  
  print $client $reply."\n";  
     } else {  
  print $client "invalid_token\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ----------------------------------------------------------------- unsubscribe  
     } elsif ($userinput =~ /^unsub/) {  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     if (-e $fname) {  
  print $client &unsub($fname,$clientip);  
     } else {  
  print $client "not_found\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------- subscribe  
     } elsif ($userinput =~ /^sub/) {  
  if(isClient) {  
     print $client &subscribe($userinput,$clientip);  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------- current version  
     } elsif ($userinput =~ /^currentversion/) {  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     print $client &currentversion($fname)."\n";  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------- log  
     } elsif ($userinput =~ /^log/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/activity.log")) {   
     print $hfh "$now:$clientname:$what\n";  
     print $client "ok\n";   
  } else {  
     print $client "error: ".($!+0)  
  ." IO::File->new Failed "  
  ."while attempting log\n";  
  }  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------- put  
     } elsif ($userinput =~ /^put/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$what)  
  =split(/:/,$userinput,5);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     if ($namespace ne 'roles') {  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',  
  "$proname/$namespace.db",  
  &GDBM_WRCREAT(),0640)) {  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }  
     }  
       
     foreach my $pair (@pairs) {  
  my ($key,$value)=split(/=/,$pair);  
  $hash{$key}=$value;  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) failed ".  
     "while attempting put\n";  
     }  
  } else {  
     print $client "error: ".($!)  
  ." tie(GDBM) Failed ".  
  "while attempting put\n";  
  }  
     } else {  
  print $client "refused\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------- inc  
     } elsif ($userinput =~ /^inc:/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$what)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     if ($namespace ne 'roles') {  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',  
  "$proname/$namespace.db",  
  &GDBM_WRCREAT(),0640)) {  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }  
     }  
     foreach my $pair (@pairs) {  
  my ($key,$value)=split(/=/,$pair);  
  # We could check that we have a number...  
  if (! defined($value) || $value eq '') {  
     $value = 1;  
  }  
  $hash{$key}+=$value;  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) failed ".  
     "while attempting inc\n";  
     }  
  } else {  
     print $client "error: ".($!)  
  ." tie(GDBM) Failed ".  
  "while attempting inc\n";  
  }  
     } else {  
  print $client "refused\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # -------------------------------------------------------------------- rolesput  
     } elsif ($userinput =~ /^rolesput/) {  
  if(isClient) {  
     &Debug("rolesput");  
     if ($wasenc==1) {  
  my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  
     =split(/:/,$userinput);  
  &Debug("cmd = ".$cmd." exedom= ".$exedom.  
        "user = ".$exeuser." udom=".$udom.  
        "what = ".$what);  
  my $namespace='roles';  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
     print $hfh "P:$now:$exedom:$exeuser:$what\n";  
  }  
     }  
       
     foreach my $pair (@pairs) {  
  my ($key,$value)=split(/=/,$pair);  
  &ManagePermissions($key, $udom, $uname,  
    &get_auth_type( $udom,   
  $uname));  
  $hash{$key}=$value;  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting rolesput\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting rolesput\n";  
     }  
     } else {  
  print $client "refused\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # -------------------------------------------------------------------- rolesdel  
     } elsif ($userinput =~ /^rolesdel/) {  
  if(isClient) {  
     &Debug("rolesdel");  
     if ($wasenc==1) {  
  my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  
     =split(/:/,$userinput);  
  &Debug("cmd = ".$cmd." exedom= ".$exedom.  
        "user = ".$exeuser." udom=".$udom.  
        "what = ".$what);  
  my $namespace='roles';  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  my @rolekeys=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
     print $hfh "D:$now:$exedom:$exeuser:$what\n";  
  }  
     }  
     foreach my $key (@rolekeys) {  
  delete $hash{$key};  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting rolesdel\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting rolesdel\n";  
  }  
     } else {  
  print $client "refused\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------- get  
     } elsif ($userinput =~ /^get/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$what)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     chomp($what);  
     my @queries=split(/\&/,$what);  
     my $proname=propath($udom,$uname);  
     my $qresult='';  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
  for (my $i=0;$i<=$#queries;$i++) {  
     $qresult.="$hash{$queries[$i]}&";  
  }  
  if (untie(%hash)) {  
     $qresult=~s/\&$//;  
     print $client "$qresult\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting get\n";  
  }  
     } else {  
  if ($!+0 == 2) {  
     print $client "error:No such file or ".  
  "GDBM reported bad block error\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting get\n";  
  }  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------ eget  
     } elsif ($userinput =~ /^eget/) {  
  if (isClient) {  
     my ($cmd,$udom,$uname,$namespace,$what)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     chomp($what);  
     my @queries=split(/\&/,$what);  
     my $proname=propath($udom,$uname);  
     my $qresult='';  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
  for (my $i=0;$i<=$#queries;$i++) {  
     $qresult.="$hash{$queries[$i]}&";  
  }  
  if (untie(%hash)) {  
     $qresult=~s/\&$//;  
     if ($cipher) {  
  my $cmdlength=length($qresult);  
  $qresult.="         ";  
  my $encqresult='';  
  for   
     (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  
  $encqresult.=  
     unpack("H16",  
    $cipher->encrypt(substr($qresult,$encidx,8)));  
     }  
  print $client "enc:$cmdlength:$encqresult\n";  
     } else {  
  print $client "error:no_key\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting eget\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting eget\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------- del  
     } elsif ($userinput =~ /^del/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$what)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     my @keys=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
  unless ($namespace=~/^nohist\_/) {  
     my $hfh;  
     if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }  
  }  
  foreach my $key (@keys) {  
     delete($hash{$key});  
  }  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting del\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting del\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------ keys  
     } elsif ($userinput =~ /^keys/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     my $proname=propath($udom,$uname);  
     my $qresult='';  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
  foreach my $key (keys %hash) {  
     $qresult.="$key&";  
  }  
  if (untie(%hash)) {  
     $qresult=~s/\&$//;  
     print $client "$qresult\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting keys\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting keys\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ----------------------------------------------------------------- dumpcurrent  
     } elsif ($userinput =~ /^currentdump/) {  
  if (isClient) {  
     my ($cmd,$udom,$uname,$namespace)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     my $qresult='';  
     my $proname=propath($udom,$uname);  
     my %hash;  
     if (tie(%hash,'GDBM_File',  
     "$proname/$namespace.db",  
     &GDBM_READER(),0640)) {  
     # Structure of %data:  
  # $data{$symb}->{$parameter}=$value;  
  # $data{$symb}->{'v.'.$parameter}=$version;  
  # since $parameter will be unescaped, we do not  
  # have to worry about silly parameter names...  
  my %data = ();  
  while (my ($key,$value) = each(%hash)) {  
     my ($v,$symb,$param) = split(/:/,$key);  
     next if ($v eq 'version' || $symb eq 'keys');  
     next if (exists($data{$symb}) &&   
      exists($data{$symb}->{$param}) &&  
      $data{$symb}->{'v.'.$param} > $v);  
     $data{$symb}->{$param}=$value;  
     $data{$symb}->{'v.'.$param}=$v;  
  }  
  if (untie(%hash)) {  
     while (my ($symb,$param_hash) = each(%data)) {  
  while(my ($param,$value) = each (%$param_hash)){  
     next if ($param =~ /^v\./);  
     $qresult.=$symb.':'.$param.'='.$value.'&';  
  }  
     }  
     chop($qresult);  
     print $client "$qresult\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting currentdump\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting currentdump\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
  }  
 # ------------------------------------------------------------------------ dump  
     } elsif ($userinput =~ /^dump/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$regexp)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     if (defined($regexp)) {  
  $regexp=&unescape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my $qresult='';  
     my $proname=propath($udom,$uname);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
  while (my ($key,$value) = each(%hash)) {  
     if ($regexp eq '.') {  
  $qresult.=$key.'='.$value.'&';  
     } else {  
  my $unescapeKey = &unescape($key);  
  if (eval('$unescapeKey=~/$regexp/')) {  
     $qresult.="$key=$value&";  
  }  
     }  
  }  
  if (untie(%hash)) {  
     chop($qresult);  
     print $client "$qresult\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting dump\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting dump\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ----------------------------------------------------------------------- store  
     } elsif ($userinput =~ /^store/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$rid,$what)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     if ($namespace ne 'roles') {  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {  
     print $hfh "P:$now:$rid:$what\n";  
  }  
     }  
     my @previouskeys=split(/&/,$hash{"keys:$rid"});  
     my $key;  
     $hash{"version:$rid"}++;  
     my $version=$hash{"version:$rid"};  
     my $allkeys='';   
     foreach my $pair (@pairs) {  
  my ($key,$value)=split(/=/,$pair);  
  $allkeys.=$key.':';  
  $hash{"$version:$rid:$key"}=$value;  
     }  
     $hash{"$version:$rid:timestamp"}=$now;  
     $allkeys.='timestamp';  
     $hash{"$version:keys:$rid"}=$allkeys;  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting store\n";  
  }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting store\n";  
  }  
     } else {  
  print $client "refused\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # --------------------------------------------------------------------- restore  
     } elsif ($userinput =~ /^restore/) {  
  if(isClient) {  
     my ($cmd,$udom,$uname,$namespace,$rid)  
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  
     $namespace=~s/\W//g;  
     chomp($rid);  
     my $proname=propath($udom,$uname);  
     my $qresult='';  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
  my $version=$hash{"version:$rid"};  
  $qresult.="version=$version&";  
  my $scope;  
  for ($scope=1;$scope<=$version;$scope++) {  
     my $vkeys=$hash{"$scope:keys:$rid"};  
     my @keys=split(/:/,$vkeys);  
     my $key;  
     $qresult.="$scope:keys=$vkeys&";  
     foreach $key (@keys) {  
  $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";  
     }                                    
  }  
  if (untie(%hash)) {  
     $qresult=~s/\&$//;  
     print $client "$qresult\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting restore\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting restore\n";  
     }  
  } else  {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # -------------------------------------------------------------------- chatsend  # -------------------------------------------------------------------- chatsend
     } elsif ($userinput =~ /^chatsend/) {     if ($userinput =~ /^chatsend/) {
  if(isClient) {   if(isClient) {
     my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);      my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);
     &chatadd($cdom,$cnum,$newpost);      &chatadd($cdom,$cnum,$newpost);
Line 2917  sub process_request { Line 3180  sub process_request {
  return 0;   return 0;
   
 # ---------------------------------- set current host/domain  # ---------------------------------- set current host/domain
     } elsif ($userinput =~ /^sethost:/) {      } elsif ($userinput =~ /^sethost/) {
  if (isClient) {   if (isClient) {
     print $client &sethost($userinput)."\n";      print $client &sethost($userinput)."\n";
  } else {   } else {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #---------------------------------- request file (?) version.  #---------------------------------- request file (?) version.
     } elsif ($userinput =~/^version:/) {      } elsif ($userinput =~/^version/) {
  if (isClient) {   if (isClient) {
     print $client &version($userinput)."\n";      print $client &version($userinput)."\n";
  } else {   } else {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #------------------------------- is auto-enrollment enabled?  #------------------------------- is auto-enrollment enabled?
     } elsif ($userinput =~/^autorun:/) {      } elsif ($userinput =~/^autorun/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$cdom) = split(/:/,$userinput);      my ($cmd,$cdom) = split(/:/,$userinput);
     my $outcome = &localenroll::run($cdom);      my $outcome = &localenroll::run($cdom);
Line 2940  sub process_request { Line 3203  sub process_request {
     print $client "0\n";      print $client "0\n";
  }   }
 #------------------------------- get official sections (for auto-enrollment).  #------------------------------- get official sections (for auto-enrollment).
     } elsif ($userinput =~/^autogetsections:/) {      } elsif ($userinput =~/^autogetsections/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);      my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
     my @secs = &localenroll::get_sections($coursecode,$cdom);      my @secs = &localenroll::get_sections($coursecode,$cdom);
Line 2950  sub process_request { Line 3213  sub process_request {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #----------------------- validate owner of new course section (for auto-enrollment).  #----------------------- validate owner of new course section (for auto-enrollment).
     } elsif ($userinput =~/^autonewcourse:/) {      } elsif ($userinput =~/^autonewcourse/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);      my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);      my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
Line 2959  sub process_request { Line 3222  sub process_request {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #-------------- validate course section in schedule of classes (for auto-enrollment).  #-------------- validate course section in schedule of classes (for auto-enrollment).
     } elsif ($userinput =~/^autovalidatecourse:/) {      } elsif ($userinput =~/^autovalidatecourse/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);      my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);      my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
Line 2968  sub process_request { Line 3231  sub process_request {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #--------------------------- create password for new user (for auto-enrollment).  #--------------------------- create password for new user (for auto-enrollment).
     } elsif ($userinput =~/^autocreatepassword:/) {      } elsif ($userinput =~/^autocreatepassword/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$authparam,$cdom)=split(/:/,$userinput);      my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
     my ($create_passwd,$authchk);      my ($create_passwd,$authchk);
Line 2978  sub process_request { Line 3241  sub process_request {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #---------------------------  read and remove temporary files (for auto-enrollment).  #---------------------------  read and remove temporary files (for auto-enrollment).
     } elsif ($userinput =~/^autoretrieve:/) {      } elsif ($userinput =~/^autoretrieve/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$filename) = split(/:/,$userinput);      my ($cmd,$filename) = split(/:/,$userinput);
     my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;      my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
Line 3004  sub process_request { Line 3267  sub process_request {
     print $client "refused\n";      print $client "refused\n";
  }   }
 #---------------------  read and retrieve institutional code format (for support form).  #---------------------  read and retrieve institutional code format (for support form).
     } elsif ($userinput =~/^autoinstcodeformat:/) {      } elsif ($userinput =~/^autoinstcodeformat/) {
  if (isClient) {   if (isClient) {
     my $reply;      my $reply;
     my($cmd,$cdom,$course) = split(/:/,$userinput);      my($cmd,$cdom,$course) = split(/:/,$userinput);
Line 3922  sub make_new_child { Line 4185  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 manage_permissions
 {  {
   
     my ($request, $domain, $user, $authtype) = @_;      my ($request, $domain, $user, $authtype) = @_;
Line 4763  Place in B<logs/lond.log> Line 5026  Place in B<logs/lond.log>
   
 stores hash in namespace  stores hash in namespace
   
 =item rolesput  =item rolesputy
   
 put a role into a user's environment  put a role into a user's environment
   
Removed from v.1.226  
changed lines
  Added in v.1.233

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

Internal Server Error

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

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

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