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

Diff for /loncom/lond between versions 1.224 and 1.239

version 1.224, 2004/08/06 10:27:53 version 1.239, 2004/08/24 10:59:50
Line 52  use LONCAPA::lonlocal; Line 52  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   
 my $DEBUG = 1;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
Line 162  sub ResetStatistics { Line 162  sub ResetStatistics {
     $Failures     = 0;      $Failures     = 0;
 }  }
   
   
   
 #------------------------------------------------------------------------  #------------------------------------------------------------------------
 #  #
 #   LocalConnection  #   LocalConnection
Line 372  sub isClient { Line 370  sub isClient {
 #                     - This allows dynamic changes to the manager table  #                     - This allows dynamic changes to the manager table
 #                       without the need to signal to the lond.  #                       without the need to signal to the lond.
 #  #
   
 sub ReadManagerTable {  sub ReadManagerTable {
   
     #   Clean out the old table first..      #   Clean out the old table first..
Line 1287  sub push_file_handler { Line 1284  sub push_file_handler {
   
   
   
   
   #
   #   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 ls_handler {
       my ($cmd, $ulsdir, $client) = @_;
   
       my $userinput = "$cmd:$ulsdir";
   
       my $obs;
       my $rights;
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
    if(-d $ulsdir) {
       if (opendir(LSDIR,$ulsdir)) {
    while ($ulsfn=readdir(LSDIR)) {
       undef $obs, $rights; 
       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
       #We do some obsolete checking here
       if(-e $ulsdir.'/'.$ulsfn.".meta") { 
    open(FILE, $ulsdir.'/'.$ulsfn.".meta");
    my @obsolete=<FILE>;
    foreach my $obsolete (@obsolete) {
       if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } 
       if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
    }
       }
       $ulsout.=$ulsfn.'&'.join('&',@ulsstats);
       if($obs eq '1') { $ulsout.="&1"; }
       else { $ulsout.="&0"; }
       if($rights eq '1') { $ulsout.="&1:"; }
       else { $ulsout.="&0:"; }
    }
    closedir(LSDIR);
       }
    } else {
       my @ulsstats=stat($ulsdir);
       $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
    }
       } else {
    $ulsout='no_such_dir';
       }
       if ($ulsout eq '') { $ulsout='empty'; }
       print $client "$ulsout\n";
       
       return 1;
   
   }
   &register_handler("ls", \&ls_handler, 0, 1, 0);
   
   
 #   Process a reinit request.  Reinit requests that either  #   Process a reinit request.  Reinit requests that either
 #   lonc or lond be reinitialized so that an updated   #   lonc or lond be reinitialized so that an updated 
 #   host.tab or domain.tab can be processed.  #   host.tab or domain.tab can be processed.
Line 1509  sub change_password_handler { Line 1571  sub change_password_handler {
 register_handler("passwd", \&change_password_handler, 1, 1, 0);  register_handler("passwd", \&change_password_handler, 1, 1, 0);
   
   
 #---------------------------------------------------------------  
 #  #
 #   Getting, decoding and dispatching requests:  #   Create a new user.  User in this case means a lon-capa user.
   #   The user must either already exist in some authentication realm
   #   like kerberos or the /etc/passwd.  If not, a user completely local to
   #   this loncapa system is created.
 #  #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   sub add_user_handler {
   
 #      my ($cmd, $tail, $client) = @_;
 #   Get a Request:  
 #   Gets a Request message from the client.  The transaction  
 #   is defined as a 'line' of text.  We remove the new line  
 #   from the text line.    
 #     
 sub get_request {  
     my $input = <$client>;  
     chomp($input);  
   
     Debug("get_request: Request = $input\n");  
   
     &status('Processing '.$clientname.':'.$input);      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
       my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
   
     return $input;      &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
 }  
 #---------------------------------------------------------------  
 #      if($udom eq $currentdomainid) { # Reject new users for other domains...
 #  Process a request.  This sub should shrink as each action  
 #  gets farmed out into a separat sub that is registered    my $oldumask=umask(0077);
 #  with the dispatch hash.     chomp($npass);
 #   $npass=&unescape($npass);
 # Parameters:   my $passfilename  = &password_path($udom, $uname);
 #    user_input   - The request received from the client (lonc).   &Debug("Password file created will be:".$passfilename);
 # Returns:   if (-e $passfilename) {
 #    true to keep processing, false if caller should exit.      &Failure( $client, "already_exists\n", $userinput);
 #   } else {
 sub process_request {      my @fpparts=split(/\//,$passfilename);
     my ($userinput) = @_;      # Easier for now to break style than to      my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
                                 # fix all the userinput -> user_input.      my $fperror='';
     my $wasenc    = 0; # True if request was encrypted.      for (my $i=3;$i<= ($#fpparts-1);$i++) {
 # ------------------------------------------------------------ See if encrypted   $fpnow.='/'.$fpparts[$i]; 
     if ($userinput =~ /^enc/) {   unless (-e $fpnow) {
  $userinput = decipher($userinput);      &logthis("mkdir $fpnow");
  $wasenc=1;      unless (mkdir($fpnow,0777)) {
  if(!$userinput) { # Cipher not defined.   $fperror="error: ".($!+0)." mkdir failed while attempting "
     &Failure($client, "error: Encrypted data without negotated key");      ."makeuser";
     return 0;      }
    }
       }
       unless ($fperror) {
    my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
    &Reply($client, $result, $userinput);     #BUGBUG - could be fail
       } else {
    &Failure($client, "$fperror\n", $userinput);
       }
  }   }
     }   umask($oldumask);
     Debug("process_request: $userinput\n");      }  else {
    &Failure($client, "not_right_domain\n",
    $userinput); # Even if we are multihomed.
           
     #    
     #   The 'correct way' to add a command to lond is now to  
     #   write a sub to execute it and Add it to the command dispatch  
     #   hash via a call to register_handler..  The comments to that  
     #   sub should give you enough to go on to show how to do this  
     #   along with the examples that are building up as this code  
     #   is getting refactored.   Until all branches of the  
     #   if/elseif monster below have been factored out into  
     #   separate procesor subs, if the dispatch hash is missing  
     #   the command keyword, we will fall through to the remainder  
     #   of the if/else chain below in order to keep this thing in   
     #   working order throughout the transmogrification.  
   
     my ($command, $tail) = split(/:/, $userinput, 2);  
     chomp($command);  
     chomp($tail);  
     $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.  
     $command =~ s/(\r)//; # And this too for parameterless commands.  
     if(!$tail) {  
  $tail =""; # defined but blank.  
     }      }
       return 1;
   
     &Debug("Command received: $command, encoded = $wasenc");  }
   &register_handler("makeuser", \&add_user_handler, 1, 1, 0);
   
     if(defined $Dispatcher{$command}) {  #
   #   Change the authentication method of a user.  Note that this may
   #   also implicitly change the user's password if, for example, the user is
   #   joining an existing authentication realm.  Known authentication realms at
   #   this time are:
   #    internal   - Purely internal password file (only loncapa knows this user)
   #    local      - Institutionally written authentication module.
   #    unix       - Unix user (/etc/passwd with or without /etc/shadow).
   #    kerb4      - kerberos version 4
   #    kerb5      - kerberos version 5
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub change_authentication_handler {
   
  my $dispatch_info = $Dispatcher{$command};      my ($cmd, $tail, $client) = @_;
  my $handler       = $$dispatch_info[0];     
  my $need_encode   = $$dispatch_info[1];      my $userinput  = "$cmd:$tail";              # Reconstruct user input.
  my $client_types  = $$dispatch_info[2];  
  Debug("Matched dispatch hash: mustencode: $need_encode "  
       ."ClientType $client_types");  
         
  #  Validate the request:  
         
  my $ok = 1;  
  my $requesterprivs = 0;  
  if(&isClient()) {  
     $requesterprivs |= $CLIENT_OK;  
  }  
  if(&isManager()) {  
     $requesterprivs |= $MANAGER_OK;  
  }  
  if($need_encode && (!$wasenc)) {  
     Debug("Must encode but wasn't: $need_encode $wasenc");  
     $ok = 0;  
  }  
  if(($client_types & $requesterprivs) == 0) {  
     Debug("Client not privileged to do this operation");  
     $ok = 0;  
  }  
   
  if($ok) {      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
     Debug("Dispatching to handler $command $tail");      &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
     my $keep_going = &$handler($command, $tail, $client);      if ($udom ne $currentdomainid) {
     return $keep_going;   &Failure( $client, "not_right_domain\n", $client);
  } else {      } else {
     Debug("Refusing to dispatch because client did not match requirements");  
     Failure($client, "refused\n", $userinput);   chomp($npass);
     return 1;  
    $npass=&unescape($npass);
    my $passfilename = &password_path($udom, $uname);
    if ($passfilename) { # Not allowed to create a new user!!
       my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
       &Reply($client, $result, $userinput);
    } else {       
       &Failure($client, "non_authorized", $userinput); # Fail the user now.
  }   }
       }
       return 1;
   }
   &register_handler("changeuserauth", \&change_authentication_handler, 1,1, 0);
   
     }      #
   #   Determines if this is the home server for a user.  The home server
   #   for a user will have his/her lon-capa passwd file.  Therefore all we need
   #   to do is determine if this file exists.
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub is_home_handler {
       my ($cmd, $tail, $client) = @_;
      
       my $userinput  = "$cmd:$tail";
      
       my ($udom,$uname)=split(/:/,$tail);
       chomp($uname);
       my $passfile = &password_filename($udom, $uname);
       if($passfile) {
    &Reply( $client, "found\n", $userinput);
       } else {
    &Failure($client, "not_found\n", $userinput);
       }
       return 1;
   }
   &register_handler("home", \&is_home_handler, 0,1,0);
   
 #------------------- Commands not yet in spearate handlers. --------------  #
   #   Process an update request for a resource?? I think what's going on here is
   #   that a resource has been modified that we hold a subscription to.
   #   If the resource is not local, then we must update, or at least invalidate our
   #   cached copy of the resource. 
   #   FUTURE WORK:
   #      I need to look at this logic carefully.  My druthers would be to follow
   #      typical caching logic, and simple invalidate the cache, drop any subscription
   #      an let the next fetch start the ball rolling again... however that may
   #      actually be more difficult than it looks given the complex web of
   #      proxy servers.
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub update_resource_handler {
   
       my ($cmd, $tail, $client) = @_;
      
       my $userinput = "$cmd:$tail";
      
       my $fname= $tail; # This allows interactive testing
   
   
 # -------------------------------------------------------------------- makeuser      my $ownership=ishome($fname);
     if ($userinput =~ /^makeuser/) { # encoded and client.      if ($ownership eq 'not_owner') {
  &Debug("Make user received");   if (-e $fname) {
  my $oldumask=umask(0077);      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  if (($wasenc==1) && isClient) {   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
     my       my $now=time;
  ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);      my $since=$now-$atime;
     &Debug("cmd =".$cmd." $udom =".$udom.      if ($since>$perlvar{'lonExpire'}) {
    " uname=".$uname);   my $reply=&reply("unsub:$fname","$clientname");
     chomp($npass);   unlink("$fname");
     $npass=&unescape($npass);  
     my $proname=propath($udom,$uname);  
     my $passfilename="$proname/passwd";  
     &Debug("Password file created will be:".  
    $passfilename);  
     if (-e $passfilename) {  
  print $client "already_exists\n";  
     } elsif ($udom ne $currentdomainid) {  
  print $client "not_right_domain\n";  
     } else {  
  my @fpparts=split(/\//,$proname);  
  my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];  
  my $fperror='';  
  for (my $i=3;$i<=$#fpparts;$i++) {  
     $fpnow.='/'.$fpparts[$i];   
     unless (-e $fpnow) {  
  unless (mkdir($fpnow,0777)) {  
     $fperror="error: ".($!+0)  
  ." mkdir failed while attempting "  
  ."makeuser";  
  }  
     }  
  }  
  unless ($fperror) {  
     my $result=&make_passwd_file($uname, $umode,$npass,  
  $passfilename);  
     print $client $result;  
  } else {  
     print $client "$fperror\n";  
  }  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
  umask($oldumask);  
 # -------------------------------------------------------------- changeuserauth  
     } elsif ($userinput =~ /^changeuserauth/) { # encoded & client  
  &Debug("Changing authorization");  
  if (($wasenc==1) && isClient) {  
     my   
  ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);  
     chomp($npass);  
     &Debug("cmd = ".$cmd." domain= ".$udom.  
    "uname =".$uname." umode= ".$umode);  
     $npass=&unescape($npass);  
     my $proname=&propath($udom,$uname);  
     my $passfilename="$proname/passwd";  
     if ($udom ne $currentdomainid) {  
  print $client "not_right_domain\n";  
     } else {  
  my $result=&make_passwd_file($uname, $umode,$npass,  
      $passfilename);  
  Reply($client, $result, $userinput);  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------ home  
     } elsif ($userinput =~ /^home/) { # client clear or encoded  
  if(isClient) {  
     my ($cmd,$udom,$uname)=split(/:/,$userinput);  
     chomp($uname);  
     my $proname=propath($udom,$uname);  
     if (-e $proname) {  
  print $client "found\n";  
     } else {  
  print $client "not_found\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ---------------------------------------------------------------------- update  
     } elsif ($userinput =~ /^update/) { # client clear or encoded.  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     my $ownership=ishome($fname);  
     if ($ownership eq 'not_owner') {  
  if (-e $fname) {  
     my ($dev,$ino,$mode,$nlink,  
  $uid,$gid,$rdev,$size,  
  $atime,$mtime,$ctime,  
  $blksize,$blocks)=stat($fname);  
     my $now=time;  
     my $since=$now-$atime;  
     if ($since>$perlvar{'lonExpire'}) {  
  my $reply=  
     &reply("unsub:$fname","$clientname");  
     unlink("$fname");  
     } else {  
  my $transname="$fname.in.transfer";  
  my $remoteurl=  
     &reply("sub:$fname","$clientname");  
  my $response;  
  {  
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request('GET',"$remoteurl");  
     $response=$ua->request($request,$transname);  
  }  
  if ($response->is_error()) {  
     unlink($transname);  
     my $message=$response->status_line;  
     &logthis(  
      "LWP GET: $message for $fname ($remoteurl)");  
  } else {  
     if ($remoteurl!~/\.meta$/) {  
  my $ua=new LWP::UserAgent;  
  my $mrequest=  
     new HTTP::Request('GET',$remoteurl.'.meta');  
  my $mresponse=  
     $ua->request($mrequest,$fname.'.meta');  
  if ($mresponse->is_error()) {  
     unlink($fname.'.meta');  
  }  
     }  
     rename($transname,$fname);  
  }  
     }  
     print $client "ok\n";  
  } else {  
     print $client "not_found\n";  
  }  
     } else {      } else {
  print $client "rejected\n";   my $transname="$fname.in.transfer";
     }   my $remoteurl=&reply("sub:$fname","$clientname");
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # -------------------------------------- fetch a user file from a remote server  
     } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);  
     my $udir=propath($udom,$uname).'/userfiles';  
     unless (-e $udir) { mkdir($udir,0770); }  
     if (-e $udir) {  
  $ufile=~s/^[\.\~]+//;  
  my $path = $udir;  
  if ($ufile =~m|(.+)/([^/]+)$|) {  
     my @parts=split('/',$1);  
     foreach my $part (@parts) {  
  $path .= '/'.$part;  
  if ((-e $path)!=1) {  
     mkdir($path,0770);  
  }  
     }  
  }  
  my $destname=$udir.'/'.$ufile;  
  my $transname=$udir.'/'.$ufile.'.in.transit';  
  my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;  
  my $response;   my $response;
    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);
  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)");
     print $client "failed\n";  
  } else {   } else {
     if (!rename($transname,$destname)) {      if ($remoteurl!~/\.meta$/) {
  &logthis("Unable to move $transname to $destname");   alarm(120);
  unlink($transname);   {
  print $client "failed\n";      my $ua=new LWP::UserAgent;
     } else {      my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
  print $client "ok\n";      my $mresponse=$ua->request($mrequest,$fname.'.meta');
     }      if ($mresponse->is_error()) {
  }   unlink($fname.'.meta');
     } else {      }
  print $client "not_home\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
  }  
 # --------------------------------------------------------- remove a user file   
     } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);  
     &logthis("$udom - $uname - $ufile");  
     if ($ufile =~m|/\.\./|) {  
  # any files paths with /../ in them refuse   
  # to deal with  
  print $client "refused\n";  
     } else {  
  my $udir=propath($udom,$uname);  
  if (-e $udir) {  
     my $file=$udir.'/userfiles/'.$ufile;  
     if (-e $file) {  
  unlink($file);  
  if (-e $file) {  
     print $client "failed\n";  
  } else {  
     print $client "ok\n";  
  }   }
     } else {   alarm(0);
  print $client "not_found\n";  
     }      }
  } else {      rename($transname,$fname);
     print $client "not_home\n";  
  }   }
     }      }
       &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_found\n", $userinput);
  }   }
 # ------------------------------------------ authenticate access to a user file      } else {
     } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only   &Failure($client, "rejected\n", $userinput);
  if(isClient) {      }
     my ($cmd,$fname,$session)=split(/:/,$userinput);      return 1;
     chomp($session);  }
     my $reply='non_auth';  &register_handler("update", \&update_resource_handler, 0 ,1, 0);
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.  
      $session.'.id')) {  #
  while (my $line=<ENVIN>) {  #   Fetch a user file from a remote server to the user's home directory
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }  #   userfiles subdir.
     }  # Parameters:
  close(ENVIN);  #    $cmd      - The command that got us here.
  print $client $reply."\n";  #    $tail     - Tail of the command (remaining parameters).
     } else {  #    $client   - File descriptor connected to client.
  print $client "invalid_token\n";  # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #
   sub fetch_user_file_handler {
   
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
       my $fname           = $tail;
       my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
       my $udir=&propath($udom,$uname).'/userfiles';
       unless (-e $udir) {
    mkdir($udir,0770); 
       }
       Debug("fetch user file for $fname");
       if (-e $udir) {
    $ufile=~s/^[\.\~]+//;
   
    # 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);
    }
     }      }
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }   }
 # ----------------------------------------------------------------- unsubscribe  
     } elsif ($userinput =~ /^unsub/) {  
  if(isClient) {   my $destname=$udir.'/'.$ufile;
     my ($cmd,$fname)=split(/:/,$userinput);   my $transname=$udir.'/'.$ufile.'.in.transit';
     if (-e $fname) {   my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
  print $client &unsub($fname,$clientip);   my $response;
    Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
    alarm(120);
    {
       my $ua=new LWP::UserAgent;
       my $request=new HTTP::Request('GET',"$remoteurl");
       $response=$ua->request($request,$transname);
    }
    alarm(0);
    if ($response->is_error()) {
       unlink($transname);
       my $message=$response->status_line;
       &logthis("LWP GET: $message for $fname ($remoteurl)");
       &Failure($client, "failed\n", $userinput);
    } else {
       Debug("Renaming $transname to $destname");
       if (!rename($transname,$destname)) {
    &logthis("Unable to move $transname to $destname");
    unlink($transname);
    &Failure($client, "failed\n", $userinput);
     } else {      } else {
  print $client "not_found\n";   &Reply($client, "ok\n", $userinput);
     }      }
  } else {   }   
     Reply($client, "refused\n", $userinput);      } else {
        &Failure($client, "not_home\n", $userinput);
  }      }
 # ------------------------------------------------------------------- subscribe      return 1;
     } elsif ($userinput =~ /^sub/) {  }
  if(isClient) {  &register_handler("fetchuserfile", \&fetch_user_file_handler, 0, 1, 0);
     print $client &subscribe($userinput,$clientip);  
  } else {  #
     Reply($client, "refused\n", $userinput);  #   Remove a file from a user's home directory userfiles subdirectory.
       # Parameters:
  }  #    cmd   - the Lond request keyword that got us here.
 # ------------------------------------------------------------- current version  #    tail  - the part of the command past the keyword.
     } elsif ($userinput =~ /^currentversion/) {  #    client- File descriptor connected with the client.
  if(isClient) {  #
     my ($cmd,$fname)=split(/:/,$userinput);  # Returns:
     print $client &currentversion($fname)."\n";  #    1    - Continue processing.
  } else {  
     Reply($client, "refused\n", $userinput);  sub remove_user_file_handler {
           my ($cmd, $tail, $client) = @_;
  }  
 # ------------------------------------------------------------------------- log      my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
     } elsif ($userinput =~ /^log/) {  
  if(isClient) {      my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
     my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);      if ($ufile =~m|/\.\./|) {
     chomp($what);   # any files paths with /../ in them refuse 
     my $proname=propath($udom,$uname);   # to deal with
     my $now=time;   &Failure($client, "refused\n", "$cmd:$tail");
     {      } else {
  my $hfh;   my $udir = &propath($udom,$uname);
  if ($hfh=IO::File->new(">>$proname/activity.log")) {    if (-e $udir) {
     print $hfh "$now:$clientname:$what\n";      my $file=$udir.'/userfiles/'.$ufile;
     print $client "ok\n";       if (-e $file) {
    unlink($file);
    if (-e $file) {
       &Failure($client, "failed\n", "$cmd:$tail");
  } else {   } else {
     print $client "error: ".($!+0)      &Reply($client, "ok\n", "$cmd:$tail");
  ." IO::File->new Failed "  
  ."while attempting log\n";  
  }   }
       } else {
    &Failure($client, "not_found\n", "$cmd:$tail");
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_home\n", "$cmd:$tail");
       
  }   }
 # ------------------------------------------------------------------------- put      }
     } elsif ($userinput =~ /^put/) {      return 1;
  if(isClient) {  }
     my ($cmd,$udom,$uname,$namespace,$what)  &register_handler("removeuserfile", \&remove_user_file_handler, 0,1,0);
  =split(/:/,$userinput,5);  
     $namespace=~s/\//\_/g;  #
     $namespace=~s/\W//g;  #   make a directory in a user's home directory userfiles subdirectory.
     if ($namespace ne 'roles') {  # Parameters:
  chomp($what);  #    cmd   - the Lond request keyword that got us here.
  my $proname=propath($udom,$uname);  #    tail  - the part of the command past the keyword.
  my $now=time;  #    client- File descriptor connected with the client.
  my @pairs=split(/\&/,$what);  #
  my %hash;  # Returns:
  if (tie(%hash,'GDBM_File',  #    1    - Continue processing.
  "$proname/$namespace.db",  
  &GDBM_WRCREAT(),0640)) {  sub mkdir_user_file_handler {
     unless ($namespace=~/^nohist\_/) {      my ($cmd, $tail, $client) = @_;
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }      my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
     }      $dir=&unescape($dir);
           my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|);
     foreach my $pair (@pairs) {      if ($ufile =~m|/\.\./|) {
  my ($key,$value)=split(/=/,$pair);   # any files paths with /../ in them refuse 
  $hash{$key}=$value;   # to deal with
     }   &Failure($client, "refused\n", "$cmd:$tail");
     if (untie(%hash)) {      } else {
  print $client "ok\n";   my $udir = &propath($udom,$uname);
     } else {   if (-e $udir) {
  print $client "error: ".($!+0)      my $newdir=$udir.'/userfiles/'.$ufile;
     ." untie(GDBM) failed ".      if (!-e $newdir) {
     "while attempting put\n";   mkdir($newdir);
     }   if (!-e $newdir) {
       &Failure($client, "failed\n", "$cmd:$tail");
  } else {   } else {
     print $client "error: ".($!)      &Reply($client, "ok\n", "$cmd:$tail");
  ." tie(GDBM) Failed ".  
  "while attempting put\n";  
  }   }
     } else {      } else {
  print $client "refused\n";   &Failure($client, "not_found\n", "$cmd:$tail");
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_home\n", "$cmd:$tail");
       
  }   }
 # ------------------------------------------------------------------- inc      }
     } elsif ($userinput =~ /^inc:/) {      return 1;
  if(isClient) {  }
     my ($cmd,$udom,$uname,$namespace,$what)  &register_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0);
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  #
     $namespace=~s/\W//g;  #   rename a file in a user's home directory userfiles subdirectory.
     if ($namespace ne 'roles') {  # Parameters:
  chomp($what);  #    cmd   - the Lond request keyword that got us here.
  my $proname=propath($udom,$uname);  #    tail  - the part of the command past the keyword.
  my $now=time;  #    client- File descriptor connected with the client.
  my @pairs=split(/\&/,$what);  #
  my %hash;  # Returns:
  if (tie(%hash,'GDBM_File',  #    1    - Continue processing.
  "$proname/$namespace.db",  
  &GDBM_WRCREAT(),0640)) {  sub rename_user_file_handler {
     unless ($namespace=~/^nohist\_/) {      my ($cmd, $tail, $client) = @_;
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }      my ($udom,$uname,$old,$new) = split(/:/, $tail);
     }      $old=&unescape($old);
     foreach my $pair (@pairs) {      $new=&unescape($new);
  my ($key,$value)=split(/=/,$pair);      if ($new =~m|/\.\./| || $old =~m|/\.\./|) {
  # We could check that we have a number...   # any files paths with /../ in them refuse to deal with
  if (! defined($value) || $value eq '') {   &Failure($client, "refused\n", "$cmd:$tail");
     $value = 1;      } else {
  }   my $udir = &propath($udom,$uname);
  $hash{$key}+=$value;   if (-e $udir) {
     }      my $oldfile=$udir.'/userfiles/'.$old;
     if (untie(%hash)) {      my $newfile=$udir.'/userfiles/'.$new;
  print $client "ok\n";      if (-e $newfile) {
     } else {   &Failure($client, "exists\n", "$cmd:$tail");
  print $client "error: ".($!+0)      } elsif (! -e $oldfile) {
     ." untie(GDBM) failed ".   &Failure($client, "not_found\n", "$cmd:$tail");
     "while attempting inc\n";      } else {
     }   if (!rename($oldfile,$newfile)) {
       &Failure($client, "failed\n", "$cmd:$tail");
  } else {   } else {
     print $client "error: ".($!)      &Reply($client, "ok\n", "$cmd:$tail");
  ." tie(GDBM) Failed ".  
  "while attempting inc\n";  
  }   }
     } else {  
  print $client "refused\n";  
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_home\n", "$cmd:$tail");
       
  }   }
 # -------------------------------------------------------------------- rolesput      }
     } elsif ($userinput =~ /^rolesput/) {      return 1;
  if(isClient) {  }
     &Debug("rolesput");  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
     if ($wasenc==1) {  
  my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  
     =split(/:/,$userinput);  #
  &Debug("cmd = ".$cmd." exedom= ".$exedom.  #  Authenticate access to a user file by checking the user's 
        "user = ".$exeuser." udom=".$udom.  #  session token(?)
        "what = ".$what);  #
  my $namespace='roles';  # Parameters:
  chomp($what);  #   cmd      - The request keyword that dispatched to tus.
  my $proname=propath($udom,$uname);  #   tail     - The tail of the request (colon separated parameters).
  my $now=time;  #   client   - Filehandle open on the client.
  my @pairs=split(/\&/,$what);  # Return:
  my %hash;  #    1.
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     {  sub token_auth_user_file_handler {
  my $hfh;      my ($cmd, $tail, $client) = @_;
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
     print $hfh "P:$now:$exedom:$exeuser:$what\n";      my ($fname, $session) = split(/:/, $tail);
  }      
     }      chomp($session);
           my $reply='non_auth';
     foreach my $pair (@pairs) {      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
  my ($key,$value)=split(/=/,$pair);       $session.'.id')) {
  &ManagePermissions($key, $udom, $uname,   while (my $line=<ENVIN>) {
    &get_auth_type( $udom,       if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
  $uname));   }
  $hash{$key}=$value;   close(ENVIN);
     }   &Reply($client, $reply);
     if (untie(%hash)) {      } else {
  print $client "ok\n";   &Failure($client, "invalid_token\n", "$cmd:$tail");
     } else {      }
  print $client "error: ".($!+0)      return 1;
     ." untie(GDBM) Failed ".  
     "while attempting rolesput\n";  }
     }  
  } else {  &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting rolesput\n";  #
     }  #   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 {      } else {
  print $client "refused\n";   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting put\n", 
    $userinput);
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
            "while attempting put\n", $userinput);
  }   }
 # -------------------------------------------------------------------- rolesdel      } else {
     } elsif ($userinput =~ /^rolesdel/) {          &Failure( $client, "refused\n", $userinput);
  if(isClient) {      }
     &Debug("rolesdel");      
     if ($wasenc==1) {      return 1;
  my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  }
     =split(/:/,$userinput);  &register_handler("put", \&put_user_profile_entry, 0, 1, 0);
  &Debug("cmd = ".$cmd." exedom= ".$exedom.  
        "user = ".$exeuser." udom=".$udom.  # 
        "what = ".$what);  #   Increment a profile entry in the user history file.
  my $namespace='roles';  #   The history contains keyword value pairs.  In this case,
  chomp($what);  #   The value itself is a pair of numbers.  The first, the current value
  my $proname=propath($udom,$uname);  #   the second an increment that this function applies to the current
  my $now=time;  #   value.
  my @rolekeys=split(/\&/,$what);  #
  my %hash;  # Parameters:
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  #    $cmd      - The command that got us here.
     {  #    $tail     - Tail of the command (remaining parameters).
  my $hfh;  #    $client   - File descriptor connected to client.
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   # Returns
     print $hfh "D:$now:$exedom:$exeuser:$what\n";  #     0        - Requested to exit, caller should shut down.
  }  #     1        - Continue processing.
     }  #
     foreach my $key (@rolekeys) {  sub increment_user_value_handler {
  delete $hash{$key};      my ($cmd, $tail, $client) = @_;
     }      
     if (untie(%hash)) {      my $userinput   = "$cmd:$tail";
  print $client "ok\n";      
     } else {      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
  print $client "error: ".($!+0)      if ($namespace ne 'roles') {
     ." untie(GDBM) Failed ".          chomp($what);
     "while attempting rolesdel\n";   my $hashref = &tie_user_hash($udom, $uname,
     }       $namespace, &GDBM_WRCREAT(),
  } else {       "P",$what);
     print $client "error: ".($!+0)   if ($hashref) {
  ." tie(GDBM) Failed ".      my @pairs=split(/\&/,$what);
  "while attempting rolesdel\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;
  }   }
    $hashref->{$key}+=$value;
       }
       if (untie(%$hashref)) {
    &Reply( $client, "ok\n", $userinput);
     } else {      } else {
  print $client "refused\n";   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting inc\n", $userinput);
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
            "while attempting inc\n", $userinput);
  }   }
 # ------------------------------------------------------------------------- get      } else {
     } elsif ($userinput =~ /^get/) {   &Failure($client, "refused\n", $userinput);
  if(isClient) {      }
     my ($cmd,$udom,$uname,$namespace,$what)      
  =split(/:/,$userinput);      return 1;
     $namespace=~s/\//\_/g;  }
     $namespace=~s/\W//g;  &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);
     chomp($what);  
     my @queries=split(/\&/,$what);  
     my $proname=propath($udom,$uname);  #
     my $qresult='';  #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
     my %hash;  #   Each 'role' a user has implies a set of permissions.  Adding a new role
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  #   for a person grants the permissions packaged with that role
  for (my $i=0;$i<=$#queries;$i++) {  #   to that user when the role is selected.
     $qresult.="$hash{$queries[$i]}&";  #
  }  # Parameters:
  if (untie(%hash)) {  #    $cmd       - The command string (rolesput).
     $qresult=~s/\&$//;  #    $tail      - The remainder of the request line.  For rolesput this
     print $client "$qresult\n";  #                 consists of a colon separated list that contains:
  } else {  #                 The domain and user that is granting the role (logged).
     print $client "error: ".($!+0)  #                 The domain and user that is getting the role.
  ." untie(GDBM) Failed ".  #                 The roles being granted as a set of & separated pairs.
  "while attempting get\n";  #                 each pair a key value pair.
  }  #    $client    - File descriptor connected to the client.
     } else {  # Returns:
  if ($!+0 == 2) {  #     0         - If the daemon should exit
     print $client "error:No such file or ".  #     1         - To continue processing.
  "GDBM reported bad block error\n";  #
  } else {  #
     print $client "error: ".($!+0)  sub roles_put_handler {
  ." tie(GDBM) Failed ".      my ($cmd, $tail, $client) = @_;
  "while attempting get\n";  
  }      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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting rolesput\n", $userinput);
  }   }
 # ------------------------------------------------------------------------ eget      } else {
     } elsif ($userinput =~ /^eget/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if (isClient) {   "while attempting rolesput\n", $userinput);
     my ($cmd,$udom,$uname,$namespace,$what)      }
  =split(/:/,$userinput);      return 1;
     $namespace=~s/\//\_/g;  }
     $namespace=~s/\W//g;  &register_handler("rolesput", \&roles_put_handler, 1,1,0);  # Encoded client only.
     chomp($what);  
     my @queries=split(/\&/,$what);  #
     my $proname=propath($udom,$uname);  #   Deletes (removes) a role for a user.   This is equivalent to removing
     my $qresult='';  #  a permissions package associated with the role from the user's profile.
     my %hash;  #
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  # Parameters:
  for (my $i=0;$i<=$#queries;$i++) {  #     $cmd                 - The command (rolesdel)
     $qresult.="$hash{$queries[$i]}&";  #     $tail                - The remainder of the request line. This consists
  }  #                             of:
  if (untie(%hash)) {  #                             The domain and user requesting the change (logged)
     $qresult=~s/\&$//;  #                             The domain and user being changed.
     if ($cipher) {  #                             The roles being revoked.  These are shipped to us
  my $cmdlength=length($qresult);  #                             as a bunch of & separated role name keywords.
  $qresult.="         ";  #     $client              - The file handle open on the client.
  my $encqresult='';  # Returns:
  for   #     1                    - Continue processing
     (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  #     0                    - Exit.
  $encqresult.=  #
     unpack("H16",  sub roles_delete_handler {
    $cipher->encrypt(substr($qresult,$encidx,8)));      my ($cmd, $tail, $client)  = @_;
     }  
  print $client "enc:$cmdlength:$encqresult\n";      my $userinput    = "$cmd:$tail";
     } else {     
  print $client "error:no_key\n";      my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
     }      &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
  } else {     "what = ".$what);
     print $client "error: ".($!+0)      my $namespace='roles';
  ." untie(GDBM) Failed ".      chomp($what);
  "while attempting eget\n";      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  }   &GDBM_WRCREAT(), "D",
     } else {   "$exedom:$exeuser:$what");
  print $client "error: ".($!+0)      
     ." tie(GDBM) Failed ".      if ($hashref) {
     "while attempting eget\n";   my @rolekeys=split(/\&/,$what);
     }  
    foreach my $key (@rolekeys) {
       delete $hashref->{$key};
    }
    if (untie(%$hashref)) {
       &Reply($client, "ok\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting rolesdel\n", $userinput);
  }   }
 # ------------------------------------------------------------------------- del      } else {
     } elsif ($userinput =~ /^del/) {          &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting rolesdel\n", $userinput);
     my ($cmd,$udom,$uname,$namespace,$what)      }
  =split(/:/,$userinput);      
     $namespace=~s/\//\_/g;      return 1;
     $namespace=~s/\W//g;  }
     chomp($what);  &register_handler("rolesdel", \&roles_delete_handler, 1,1, 0); # Encoded client only
     my $proname=propath($udom,$uname);  
     my $now=time;  # Unencrypted get from a user's profile database.  See 
     my @keys=split(/\&/,$what);  # GetProfileEntryEncrypted for a version that does end-to-end encryption.
     my %hash;  # This function retrieves a keyed item from a specific named database in the
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  # user's directory.
  unless ($namespace=~/^nohist\_/) {  #
     my $hfh;  # Parameters:
     if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }  #   $cmd             - Command request keyword (get).
  }  #   $tail            - Tail of the command.  This is a colon separated list
  foreach my $key (@keys) {  #                      consisting of the domain and username that uniquely
     delete($hash{$key});  #                      identifies the profile,
  }  #                      The 'namespace' which selects the gdbm file to 
  if (untie(%hash)) {  #                      do the lookup in, 
     print $client "ok\n";  #                      & separated list of keys to lookup.  Note that
  } else {  #                      the values are returned as an & separated list too.
     print $client "error: ".($!+0)  #   $client          - File descriptor open on the client.
  ." untie(GDBM) Failed ".  # Returns:
  "while attempting del\n";  #   1       - Continue processing.
  }  #   0       - Exit.
     } else {  #
  print $client "error: ".($!+0)  sub get_profile_entry {
     ." tie(GDBM) Failed ".      my ($cmd, $tail, $client) = @_;
     "while attempting del\n";  
     }      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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting get\n", $userinput);
  }   }
 # ------------------------------------------------------------------------ keys      } else {
     } elsif ($userinput =~ /^keys/) {   if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT
  if(isClient) {      &Failure($client, "error:No such file or ".
     my ($cmd,$udom,$uname,$namespace)      "GDBM reported bad block error\n", $userinput);
  =split(/:/,$userinput);   } else {                        # Some other undifferentiated err.
     $namespace=~s/\//\_/g;      &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
     $namespace=~s/\W//g;      "while attempting get\n", $userinput);
     my $proname=propath($udom,$uname);   }
     my $qresult='';      }
     my %hash;      return 1;
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  }
  foreach my $key (keys %hash) {  &register_handler("get", \&get_profile_entry, 0,1,0);
     $qresult.="$key&";  
  }  #
  if (untie(%hash)) {  #  Process the encrypted get request.  Note that the request is sent
     $qresult=~s/\&$//;  #  in clear, but the reply is encrypted.  This is a small covert channel:
     print $client "$qresult\n";  #  information about the sensitive keys is given to the snooper.  Just not
  } else {  #  information about the values of the sensitive key.  Hmm if I wanted to
     print $client "error: ".($!+0)  #  know these I'd snoop for the egets. Get the profile item names from them
  ." untie(GDBM) Failed ".  #  and then issue a get for them since there's no enforcement of the
  "while attempting keys\n";  #  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 {      } else {
  print $client "error: ".($!+0)   &Failure( $client, "error:no_key\n", $userinput);
     ." tie(GDBM) Failed ".  
     "while attempting keys\n";  
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting eget\n", $userinput);
  }   }
 # ----------------------------------------------------------------- dumpcurrent      } else {
     } elsif ($userinput =~ /^currentdump/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if (isClient) {   "while attempting eget\n", $userinput);
     my ($cmd,$udom,$uname,$namespace)      }
  =split(/:/,$userinput);      
     $namespace=~s/\//\_/g;      return 1;
     $namespace=~s/\W//g;  }
     my $qresult='';  &register_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);
     my $proname=propath($udom,$uname);  #
     my %hash;  #   Deletes a key in a user profile database.
     if (tie(%hash,'GDBM_File',  #   
     "$proname/$namespace.db",  #   Parameters:
     &GDBM_READER(),0640)) {  #       $cmd                  - Command keyword (del).
     # Structure of %data:  #       $tail                 - Command tail.  IN this case a colon
  # $data{$symb}->{$parameter}=$value;  #                               separated list containing:
  # $data{$symb}->{'v.'.$parameter}=$version;  #                               The domain and user that identifies uniquely
  # since $parameter will be unescaped, we do not  #                               the identity of the user.
  # have to worry about silly parameter names...  #                               The profile namespace (name of the profile
  my %data = ();  #                               database file).
  while (my ($key,$value) = each(%hash)) {  #                               & separated list of keywords to delete.
     my ($v,$symb,$param) = split(/:/,$key);  #       $client              - File open on client socket.
     next if ($v eq 'version' || $symb eq 'keys');  # Returns:
     next if (exists($data{$symb}) &&   #     1   - Continue processing
      exists($data{$symb}->{$param}) &&  #     0   - Exit server.
      $data{$symb}->{'v.'.$param} > $v);  #
     $data{$symb}->{$param}=$value;  #
     $data{$symb}->{'v.'.$param}=$v;  
  }  sub delete_profile_entry {
  if (untie(%hash)) {      my ($cmd, $tail, $client) = @_;
     while (my ($symb,$param_hash) = each(%data)) {  
  while(my ($param,$value) = each (%$param_hash)){      my $userinput = "cmd:$tail";
     next if ($param =~ /^v\./);  
     $qresult.=$symb.':'.$param.'='.$value.'&';      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
  }      chomp($what);
     }      my $hashref = &tie_user_hash($udom, $uname, $namespace,
     chop($qresult);   &GDBM_WRCREAT(),
     print $client "$qresult\n";   "D",$what);
  } else {      if ($hashref) {
     print $client "error: ".($!+0)          my @keys=split(/\&/,$what);
  ." untie(GDBM) Failed ".   foreach my $key (@keys) {
  "while attempting currentdump\n";      delete($hashref->{$key});
  }   }
     } else {   if (untie(%$hashref)) {
  print $client "error: ".($!+0)      &Reply($client, "ok\n", $userinput);
     ." tie(GDBM) Failed ".  
     "while attempting currentdump\n";  
     }  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting del\n", $userinput);
  }   }
 # ------------------------------------------------------------------------ dump      } else {
     } elsif ($userinput =~ /^dump/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting del\n", $userinput);
     my ($cmd,$udom,$uname,$namespace,$regexp)      }
  =split(/:/,$userinput);      return 1;
     $namespace=~s/\//\_/g;  }
     $namespace=~s/\W//g;  &register_handler("del", \&delete_profile_entry, 0, 1, 0);
     if (defined($regexp)) {  #
  $regexp=&unescape($regexp);  #  List the set of keys that are defined in a profile database file.
     } else {  #  A successful reply from this will contain an & separated list of
  $regexp='.';  #  the keys. 
     }  # Parameters:
     my $qresult='';  #     $cmd              - Command request (keys).
     my $proname=propath($udom,$uname);  #     $tail             - Remainder of the request, a colon separated
     my %hash;  #                         list containing domain/user that identifies the
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  #                         user being queried, and the database namespace
  while (my ($key,$value) = each(%hash)) {  #                         (database filename essentially).
     if ($regexp eq '.') {  #     $client           - File open on the client.
  $qresult.=$key.'='.$value.'&';  #  Returns:
     } else {  #    1    - Continue processing.
  my $unescapeKey = &unescape($key);  #    0    - Exit the server.
  if (eval('$unescapeKey=~/$regexp/')) {  #
     $qresult.="$key=$value&";  sub get_profile_keys {
  }      my ($cmd, $tail, $client) = @_;
     }  
  }      my $userinput = "$cmd:$tail";
  if (untie(%hash)) {  
     chop($qresult);      my ($udom,$uname,$namespace)=split(/:/,$tail);
     print $client "$qresult\n";      my $qresult='';
  } else {      my $hashref = &tie_user_hash($udom, $uname, $namespace,
     print $client "error: ".($!+0)    &GDBM_READER());
  ." untie(GDBM) Failed ".      if ($hashref) {
  "while attempting dump\n";   foreach my $key (keys %$hashref) {
  }      $qresult.="$key&";
     } else {   }
  print $client "error: ".($!+0)   if (untie(%$hashref)) {
     ." tie(GDBM) Failed ".      $qresult=~s/\&$//;
     "while attempting dump\n";      &Reply($client, "$qresult\n", $userinput);
     }  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting keys\n", $userinput);
  }   }
 # ----------------------------------------------------------------------- store      } else {
     } elsif ($userinput =~ /^store/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting keys\n", $userinput);
     my ($cmd,$udom,$uname,$namespace,$rid,$what)      }
  =split(/:/,$userinput);     
     $namespace=~s/\//\_/g;      return 1;
     $namespace=~s/\W//g;  }
     if ($namespace ne 'roles') {  &register_handler("keys", \&get_profile_keys, 0, 1, 0);
  chomp($what);  
  my $proname=propath($udom,$uname);  #
  my $now=time;  #   Dump the contents of a user profile database.
  my @pairs=split(/\&/,$what);  #   Note that this constitutes a very large covert channel too since
  my %hash;  #   the dump will return sensitive information that is not encrypted.
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  #   The naive security assumption is that the session negotiation ensures
     unless ($namespace=~/^nohist\_/) {  #   our client is trusted and I don't believe that's assured at present.
  my $hfh;  #   Sure want badly to go to ssl or tls.  Of course if my peer isn't really
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {  #   a LonCAPA node they could have negotiated an encryption key too so >sigh<.
     print $hfh "P:$now:$rid:$what\n";  # 
  }  #  Parameters:
     }  #     $cmd           - The command request keyword (currentdump).
     my @previouskeys=split(/&/,$hash{"keys:$rid"});  #     $tail          - Remainder of the request, consisting of a colon
     my $key;  #                      separated list that has the domain/username and
     $hash{"version:$rid"}++;  #                      the namespace to dump (database file).
     my $version=$hash{"version:$rid"};  #     $client        - file open on the remote client.
     my $allkeys='';   # Returns:
     foreach my $pair (@pairs) {  #     1    - Continue processing.
  my ($key,$value)=split(/=/,$pair);  #     0    - Exit the server.
  $allkeys.=$key.':';  #
  $hash{"$version:$rid:$key"}=$value;  sub dump_profile_database {
     }      my ($cmd, $tail, $client) = @_;
     $hash{"$version:$rid:timestamp"}=$now;  
     $allkeys.='timestamp';      my $userinput = "$cmd:$tail";
     $hash{"$version:keys:$rid"}=$allkeys;     
     if (untie(%hash)) {      my ($udom,$uname,$namespace) = split(/:/,$tail);
  print $client "ok\n";      my $hashref = &tie_user_hash($udom, $uname, $namespace,
     } else {   &GDBM_READER());
  print $client "error: ".($!+0)      if ($hashref) {
     ." untie(GDBM) Failed ".   # Structure of %data:
     "while attempting store\n";   # $data{$symb}->{$parameter}=$value;
  }   # $data{$symb}->{'v.'.$parameter}=$version;
  } else {   # since $parameter will be unescaped, we do not
     print $client "error: ".($!+0)    # have to worry about silly parameter names...
  ." tie(GDBM) Failed ".  
  "while attempting store\n";          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.'&';
  }   }
     } else {  
  print $client "refused\n";  
     }      }
       chop($qresult);
       &Reply($client , "$qresult\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting currentdump\n", $userinput);
  }   }
 # --------------------------------------------------------------------- restore      } else {
     } elsif ($userinput =~ /^restore/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting currentdump\n", $userinput);
     my ($cmd,$udom,$uname,$namespace,$rid)      }
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;      return 1;
     $namespace=~s/\W//g;  }
     chomp($rid);  &register_handler("currentdump", \&dump_profile_database, 0, 1, 0);
     my $proname=propath($udom,$uname);  
     my $qresult='';  #
     my %hash;  #   Dump a profile database with an optional regular expression
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  #   to match against the keys.  In this dump, no effort is made
  my $version=$hash{"version:$rid"};  #   to separate symb from version information. Presumably the
  $qresult.="version=$version&";  #   databases that are dumped by this command are of a different
  my $scope;  #   structure.  Need to look at this and improve the documentation of
  for ($scope=1;$scope<=$version;$scope++) {  #   both this and the currentdump handler.
     my $vkeys=$hash{"$scope:keys:$rid"};  # Parameters:
     my @keys=split(/:/,$vkeys);  #    $cmd                     - The command keyword.
     my $key;  #    $tail                    - All of the characters after the $cmd:
     $qresult.="$scope:keys=$vkeys&";  #                               These are expected to be a colon
     foreach $key (@keys) {  #                               separated list containing:
  $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";  #                               domain/user - identifying the user.
     }                                    #                               namespace   - identifying the database.
  }  #                               regexp      - optional regular expression
  if (untie(%hash)) {  #                                             that is matched against
     $qresult=~s/\&$//;  #                                             database keywords to do
     print $client "$qresult\n";  #                                             selective dumps.
  } else {  #   $client                   - Channel open on the client.
     print $client "error: ".($!+0)  # Returns:
  ." untie(GDBM) Failed ".  #    1    - Continue processing.
  "while attempting restore\n";  # 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 {      } else {
  print $client "error: ".($!+0)   my $unescapeKey = &unescape($key);
     ." tie(GDBM) Failed ".   if (eval('$unescapeKey=~/$regexp/')) {
     "while attempting restore\n";      $qresult.="$key=$value&";
    }
     }      }
  } else  {  
     Reply($client, "refused\n", $userinput);  
       
  }   }
 # -------------------------------------------------------------------- chatsend   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^chatsend/) {      chop($qresult);
  if(isClient) {      &Reply($client, "$qresult\n", $userinput);
     my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);  
     &chatadd($cdom,$cnum,$newpost);  
     print $client "ok\n";  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting dump\n", $userinput);
  }   }
 # -------------------------------------------------------------------- chatretr      } else {
     } elsif ($userinput =~ /^chatretr/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting dump\n", $userinput);
     my       }
  ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);  
     my $reply='';      return 1;
     foreach (&getchat($cdom,$cnum,$udom,$uname)) {  }
  $reply.=&escape($_).':';  
   &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);
     }      }
     $reply=~s/\:$//;  
     print $client $reply."\n";  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
            "while attempting store\n", $userinput);
  }   }
 # ------------------------------------------------------------------- querysend      } else {
     } elsif ($userinput =~ /^querysend/) {   &Failure($client, "refused\n", $userinput);
  if (isClient) {      }
     my ($cmd,$query,  
  $arg1,$arg2,$arg3)=split(/\:/,$userinput);      return 1;
     $query=~s/\n*$//g;  }
     print $client "".  &register_handler("store", \&store_handler, 0, 1, 0);
  sqlreply("$clientname\&$query".  #
  "\&$arg1"."\&$arg2"."\&$arg3")."\n";  #  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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting restore\n", $userinput);
  }   }
 # ------------------------------------------------------------------ queryreply      } else {
     } elsif ($userinput =~ /^queryreply/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting restore\n", $userinput);
     my ($cmd,$id,$reply)=split(/:/,$userinput);       }
     my $store;    
     my $execdir=$perlvar{'lonDaemons'};      return 1;
     if ($store=IO::File->new(">$execdir/tmp/$id")) {  
  $reply=~s/\&/\n/g;  
  print $store $reply;  }
  close $store;  &register_handler("restore", \&restore_handler, 0,1,0);
  my $store2=IO::File->new(">$execdir/tmp/$id.end");  
  print $store2 "done\n";  #
  close $store2;  #   Add a chat message to to a discussion board.
  print $client "ok\n";  #
     } else {  # Parameters:
  print $client "error: ".($!+0)  #    $cmd                - Request keyword.
     ." IO::File->new Failed ".  #    $tail               - Tail of the command. A colon separated list
     "while attempting queryreply\n";  #                          containing:
     }  #                          cdom    - Domain on which the chat board lives
  } else {  #                          cnum    - Identifier of the discussion group.
     Reply($client, "refused\n", $userinput);  #                          post    - Body of the posting.
       #   $client              - Socket open on the client.
   # Returns:
   #   1    - Indicating caller should keep on processing.
   #
   # Side-effects:
   #   writes a reply to the client.
   #
   #
   sub send_chat_handler {
       my ($cmd, $tail, $client) = @_;
   
       
       my $userinput = "$cmd:$tail";
   
       my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
       &chat_add($cdom,$cnum,$newpost);
       &Reply($client, "ok\n", $userinput);
   
       return 1;
   }
   &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
   #
   #   Retrieve the set of chat messagss from a discussion board.
   #
   #  Parameters:
   #    $cmd             - Command keyword that initiated the request.
   #    $tail            - Remainder of the request after the command
   #                       keyword.  In this case a colon separated list of
   #                       chat domain    - Which discussion board.
   #                       chat id        - Discussion thread(?)
   #                       domain/user    - Authentication domain and username
   #                                        of the requesting person.
   #   $client           - Socket open on the client program.
   # Returns:
   #    1     - continue processing
   # Side effects:
   #    Response is written to the client.
   #
   sub retrieve_chat_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);
       my $reply='';
       foreach (&get_chat($cdom,$cnum,$udom,$uname)) {
    $reply.=&escape($_).':';
       }
       $reply=~s/\:$//;
       &Reply($client, $reply."\n", $userinput);
   
   
       return 1;
   }
   &register_handler("chatretr", \&retrieve_chat_handler, 0, 1, 0);
   
   #
   #  Initiate a query of an sql database.  SQL query repsonses get put in
   #  a file for later retrieval.  This prevents sql query results from
   #  bottlenecking the system.  Note that with loncnew, perhaps this is
   #  less of an issue since multiple outstanding requests can be concurrently
   #  serviced.
   #
   #  Parameters:
   #     $cmd       - COmmand keyword that initiated the request.
   #     $tail      - Remainder of the command after the keyword.
   #                  For this function, this consists of a query and
   #                  3 arguments that are self-documentingly labelled
   #                  in the original arg1, arg2, arg3.
   #     $client    - Socket open on the client.
   # Return:
   #    1   - Indicating processing should continue.
   # Side-effects:
   #    a reply is written to $client.
   #
   sub send_query_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
       $query=~s/\n*$//g;
       &Reply($client, "". &sql_reply("$clientname\&$query".
    "\&$arg1"."\&$arg2"."\&$arg3")."\n",
     $userinput);
       
       return 1;
   }
   &register_handler("querysend", \&send_query_handler, 0, 1, 0);
   
   #
   #   Add a reply to an sql query.  SQL queries are done asyncrhonously.
   #   The query is submitted via a "querysend" transaction.
   #   There it is passed on to the lonsql daemon, queued and issued to
   #   mysql.
   #     This transaction is invoked when the sql transaction is complete
   #   it stores the query results in flie and indicates query completion.
   #   presumably local software then fetches this response... I'm guessing
   #   the sequence is: lonc does a querysend, we ask lonsql to do it.
   #   lonsql on completion of the query interacts with the lond of our
   #   client to do a query reply storing two files:
   #    - id     - The results of the query.
   #    - id.end - Indicating the transaction completed. 
   #    NOTE: id is a unique id assigned to the query and querysend time.
   # Parameters:
   #    $cmd        - Command keyword that initiated this request.
   #    $tail       - Remainder of the tail.  In this case that's a colon
   #                  separated list containing the query Id and the 
   #                  results of the query.
   #    $client     - Socket open on the client.
   # Return:
   #    1           - Indicating that we should continue processing.
   # Side effects:
   #    ok written to the client.
   #
   sub reply_query_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($cmd,$id,$reply)=split(/:/,$userinput); 
       my $store;
       my $execdir=$perlvar{'lonDaemons'};
       if ($store=IO::File->new(">$execdir/tmp/$id")) {
    $reply=~s/\&/\n/g;
    print $store $reply;
    close $store;
    my $store2=IO::File->new(">$execdir/tmp/$id.end");
    print $store2 "done\n";
    close $store2;
    &Reply($client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)
    ." IO::File->new Failed ".
    "while attempting queryreply\n", $userinput);
       }
    
   
       return 1;
   }
   &register_handler("queryreply", \&reply_query_handler, 0, 1, 0);
   
   #
   #  Process the courseidput request.  Not quite sure what this means
   #  at the system level sense.  It appears a gdbm file in the 
   #  /home/httpd/lonUsers/$domain/nohist_courseids is tied and
   #  a set of entries made in that database.
   #
   # Parameters:
   #   $cmd      - The command keyword that initiated this request.
   #   $tail     - Tail of the command.  In this case consists of a colon
   #               separated list contaning the domain to apply this to and
   #               an ampersand separated list of keyword=value pairs.
   #   $client   - Socket open on the client.
   # Returns:
   #   1    - indicating that processing should continue
   #
   # Side effects:
   #   reply is written to the client.
   #
   sub put_course_id_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($udom, $what) = split(/:/, $tail);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
   
       my $hashref = &tie_domain_hash($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);
  }   }
 # ----------------------------------------------------------------- courseidput      } else {
     } elsif ($userinput =~ /^courseidput/) {   &Failure( $client, "error: ".($!+0)
  if(isClient) {   ." tie(GDBM) Failed ".
     my ($cmd,$udom,$what)=split(/:/,$userinput);   "while attempting courseidput\n", $userinput);
     chomp($what);      }
  $udom=~s/\W//g;  
     my $proname=      return 1;
  "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";  }
     my $now=time;  &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);
     my @pairs=split(/\&/,$what);  
     my %hash;  #  Retrieves the value of a course id resource keyword pattern
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  #  defined since a starting date.  Both the starting date and the
  foreach my $pair (@pairs) {  #  keyword pattern are optional.  If the starting date is not supplied it
     my ($key,$descr,$inst_code)=split(/=/,$pair);  #  is treated as the beginning of time.  If the pattern is not found,
     $hash{$key}=$descr.':'.$inst_code.':'.$now;  #  it is treatred as "." matching everything.
  }  #
  if (untie(%hash)) {  #  Parameters:
     print $client "ok\n";  #     $cmd     - Command keyword that resulted in us being dispatched.
  } else {  #     $tail    - The remainder of the command that, in this case, consists
     print $client "error: ".($!+0)  #                of a colon separated list of:
  ." untie(GDBM) Failed ".  #                 domain   - The domain in which the course database is 
  "while attempting courseidput\n";  #                            defined.
  }  #                 since    - Optional parameter describing the minimum
   #                            time of definition(?) of the resources that
   #                            will match the dump.
   #                 description - regular expression that is used to filter
   #                            the dump.  Only keywords matching this regexp
   #                            will be used.
   #     $client  - The socket open on the client.
   # Returns:
   #    1     - Continue processing.
   # Side Effects:
   #   a reply is written to $client.
   sub dump_course_id_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$since,$description) =split(/:/,$tail);
       if (defined($description)) {
    $description=&unescape($description);
       } else {
    $description='.';
       }
       unless (defined($since)) { $since=0; }
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
    while (my ($key,$value) = each(%$hashref)) {
       my ($descr,$lasttime,$inst_code);
       if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {
    ($descr,$inst_code,$lasttime)=($1,$2,$3);
     } else {      } else {
  print $client "error: ".($!+0)   ($descr,$lasttime) = split(/\:/,$value);
     ." tie(GDBM) Failed ".  
     "while attempting courseidput\n";  
     }      }
  } else {      if ($lasttime<$since) { next; }
     Reply($client, "refused\n", $userinput);      if ($description eq '.') {
        $qresult.=$key.'='.$descr.':'.$inst_code.'&';
  }  
 # ---------------------------------------------------------------- courseiddump  
     } elsif ($userinput =~ /^courseiddump/) {  
  if(isClient) {  
     my ($cmd,$udom,$since,$description)  
  =split(/:/,$userinput);  
     if (defined($description)) {  
  $description=&unescape($description);  
     } else {      } else {
  $description='.';   my $unescapeVal = &unescape($descr);
     }   if (eval('$unescapeVal=~/\Q$description\E/i')) {
     unless (defined($since)) { $since=0; }      $qresult.=$key.'='.$descr.':'.$inst_code.'&';
     my $qresult='';  
     my $proname=  
  "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {  
  while (my ($key,$value) = each(%hash)) {  
     my ($descr,$lasttime,$inst_code);  
     if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {  
  ($descr,$inst_code,$lasttime)=($1,$2,$3);  
     } else {  
  ($descr,$lasttime) = split(/\:/,$value);  
     }  
     if ($lasttime<$since) { next; }  
     if ($description eq '.') {  
  $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
     } else {  
  my $unescapeVal = &unescape($descr);  
  if (eval('$unescapeVal=~/\Q$description\E/i')) {  
     $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
  }  
     }  
  }   }
  if (untie(%hash)) {  
     chop($qresult);  
     print $client "$qresult\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting courseiddump\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting courseiddump\n";  
     }      }
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }   }
 # ----------------------------------------------------------------------- idput   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^idput/) {      chop($qresult);
  if(isClient) {      &Reply($client, "$qresult\n", $userinput);
     my ($cmd,$udom,$what)=split(/:/,$userinput);  
     chomp($what);  
     $udom=~s/\W//g;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
     my $now=time;  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  
  {  
     my $hfh;  
     if ($hfh=IO::File->new(">>$proname.hist")) {  
  print $hfh "P:$now:$what\n";  
     }  
  }  
  foreach my $pair (@pairs) {  
     my ($key,$value)=split(/=/,$pair);  
     $hash{$key}=$value;  
  }  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting idput\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting idput\n";  
     }  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting courseiddump\n", $userinput);
  }   }
 # ----------------------------------------------------------------------- idget      } else {
     } elsif ($userinput =~ /^idget/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting courseiddump\n", $userinput);
     my ($cmd,$udom,$what)=split(/:/,$userinput);      }
     chomp($what);  
     $udom=~s/\W//g;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";      return 1;
     my @queries=split(/\&/,$what);  }
     my $qresult='';  &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {  #
  for (my $i=0;$i<=$#queries;$i++) {  #  Puts an id to a domains id database. 
     $qresult.="$hash{$queries[$i]}&";  #
  }  #  Parameters:
  if (untie(%hash)) {  #   $cmd     - The command that triggered us.
     $qresult=~s/\&$//;  #   $tail    - Remainder of the request other than the command. This is a 
     print $client "$qresult\n";  #              colon separated list containing:
  } else {  #              $domain  - The domain for which we are writing the id.
     print $client "error: ".($!+0)  #              $pairs  - The id info to write... this is and & separated list
  ." untie(GDBM) Failed ".  #                        of keyword=value.
  "while attempting idget\n";  #   $client  - Socket open on the client.
  }  #  Returns:
     } else {  #    1   - Continue processing.
  print $client "error: ".($!+0)  #  Side effects:
     ." tie(GDBM) Failed ".  #     reply is written to $client.
     "while attempting idget\n";  #
     }  sub put_id_handler {
  } else {      my ($cmd,$tail,$client) = @_;
     Reply($client, "refused\n", $userinput);  
       
       my $userinput = "$cmd:$tail";
   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
      "P", $what);
       if ($hashref) {
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       $hashref->{$key}=$value;
  }   }
 # ---------------------------------------------------------------------- tmpput   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^tmpput/) {      &Reply($client, "ok\n", $userinput);
  if(isClient) {  
     my ($cmd,$what)=split(/:/,$userinput);  
     my $store;  
     $tmpsnum++;  
     my $id=$$.'_'.$clientip.'_'.$tmpsnum;  
     $id=~s/\W/\_/g;  
     $what=~s/\n//g;  
     my $execdir=$perlvar{'lonDaemons'};  
     if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {  
  print $store $what;  
  close $store;  
  print $client "$id\n";  
     }  
     else {  
  print $client "error: ".($!+0)  
     ."IO::File->new Failed ".  
     "while attempting tmpput\n";  
     }  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting idput\n", $userinput);
  }   }
       } else {
 # ---------------------------------------------------------------------- tmpget   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
     } elsif ($userinput =~ /^tmpget/) {    "while attempting idput\n", $userinput);
  if(isClient) {      }
     my ($cmd,$id)=split(/:/,$userinput);  
     chomp($id);      return 1;
     $id=~s/\W/\_/g;  }
     my $store;  
     my $execdir=$perlvar{'lonDaemons'};  &register_handler("idput", \&put_id_handler, 0, 1, 0);
     if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {  #
  my $reply=<$store>;  #  Retrieves a set of id values from the id database.
     print $client "$reply\n";  #  Returns an & separated list of results, one for each requested id to the
  close $store;  #  client.
     }  #
     else {  # Parameters:
  print $client "error: ".($!+0)  #   $cmd       - Command keyword that caused us to be dispatched.
     ."IO::File->new Failed ".  #   $tail      - Tail of the command.  Consists of a colon separated:
     "while attempting tmpget\n";  #               domain - the domain whose id table we dump
     }  #               ids      Consists of an & separated list of
   #                        id keywords whose values will be fetched.
   #                        nonexisting keywords will have an empty value.
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects:
   #   An & separated list of results is written to $client.
   #
   sub get_id_handler {
       my ($cmd, $tail, $client) = @_;
   
       
       my $userinput = "$client:$tail";
       
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @queries=split(/\&/,$what);
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER());
       if ($hashref) {
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
             "while attempting idget\n",$userinput);
  }   }
 # ---------------------------------------------------------------------- tmpdel      } else {
     } elsif ($userinput =~ /^tmpdel/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting idget\n",$userinput);
     my ($cmd,$id)=split(/:/,$userinput);      }
     chomp($id);      
     $id=~s/\W/\_/g;      return 1;
     my $execdir=$perlvar{'lonDaemons'};  }
     if (unlink("$execdir/tmp/$id.tmp")) {  
  print $client "ok\n";  register_handler("idget", \&get_id_handler, 0, 1, 0);
     } else {  
  print $client "error: ".($!+0)  #
     ."Unlink tmp Failed ".  #  Process the tmpput command I'm not sure what this does.. Seems to
     "while attempting tmpdel\n";  #  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.
  } else {  # The file will contain some value that is passed in.  Is this e.g.
     Reply($client, "refused\n", $userinput);  # 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 tmp_put_handler {
       my ($cmd, $what, $client) = @_;
   
       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;
     
   }
   &register_handler("tmpput", \&tmp_put_handler, 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 tmp_get_handler {
       my ($cmd, $id, $client) = @_;
   
       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;
   }
   &register_handler("tmpget", \&tmp_get_handler, 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 tmp_del_handler {
       my ($cmd, $id, $client) = @_;
       
       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;
   
   }
   &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
   #
   #
   #
   #
   #---------------------------------------------------------------
   #
   #   Getting, decoding and dispatching requests:
   #
   
   #
   #   Get a Request:
   #   Gets a Request message from the client.  The transaction
   #   is defined as a 'line' of text.  We remove the new line
   #   from the text line.  
   #
   sub get_request {
       my $input = <$client>;
       chomp($input);
   
       &Debug("get_request: Request = $input\n");
   
       &status('Processing '.$clientname.':'.$input);
   
       return $input;
   }
   #---------------------------------------------------------------
   #
   #  Process a request.  This sub should shrink as each action
   #  gets farmed out into a separat sub that is registered 
   #  with the dispatch hash.  
   #
   # Parameters:
   #    user_input   - The request received from the client (lonc).
   # Returns:
   #    true to keep processing, false if caller should exit.
   #
   sub process_request {
       my ($userinput) = @_;      # Easier for now to break style than to
                                   # fix all the userinput -> user_input.
       my $wasenc    = 0; # True if request was encrypted.
   # ------------------------------------------------------------ See if encrypted
       if ($userinput =~ /^enc/) {
    $userinput = decipher($userinput);
    $wasenc=1;
    if(!$userinput) { # Cipher not defined.
       &Failure($client, "error: Encrypted data without negotated key");
       return 0;
  }   }
 # ----------------------------------------- portfolio directory list (portls)      }
     } elsif ($userinput =~ /^portls/) {      Debug("process_request: $userinput\n");
  if(isClient) {      
     my ($cmd,$uname,$udom)=split(/:/,$userinput);      #  
     my $udir=propath($udom,$uname).'/userfiles/portfolio';      #   The 'correct way' to add a command to lond is now to
     my $dirLine='';      #   write a sub to execute it and Add it to the command dispatch
     my $dirContents='';      #   hash via a call to register_handler..  The comments to that
     if (opendir(LSDIR,$udir.'/')){      #   sub should give you enough to go on to show how to do this
  while ($dirLine = readdir(LSDIR)){      #   along with the examples that are building up as this code
     $dirContents = $dirContents.$dirLine.'<br />';      #   is getting refactored.   Until all branches of the
  }      #   if/elseif monster below have been factored out into
     } else {      #   separate procesor subs, if the dispatch hash is missing
  $dirContents = "No directory found\n";      #   the command keyword, we will fall through to the remainder
     }      #   of the if/else chain below in order to keep this thing in 
     print $client $dirContents."\n";      #   working order throughout the transmogrification.
  } else {  
     Reply($client, "refused\n", $userinput);      my ($command, $tail) = split(/:/, $userinput, 2);
       chomp($command);
       chomp($tail);
       $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
       $command =~ s/(\r)//; # And this too for parameterless commands.
       if(!$tail) {
    $tail =""; # defined but blank.
       }
   
       &Debug("Command received: $command, encoded = $wasenc");
   
       if(defined $Dispatcher{$command}) {
   
    my $dispatch_info = $Dispatcher{$command};
    my $handler       = $$dispatch_info[0];
    my $need_encode   = $$dispatch_info[1];
    my $client_types  = $$dispatch_info[2];
    Debug("Matched dispatch hash: mustencode: $need_encode "
         ."ClientType $client_types");
         
    #  Validate the request:
         
    my $ok = 1;
    my $requesterprivs = 0;
    if(&isClient()) {
       $requesterprivs |= $CLIENT_OK;
  }   }
 # -------------------------------------------------------------------------- ls   if(&isManager()) {
     } elsif ($userinput =~ /^ls/) {      $requesterprivs |= $MANAGER_OK;
  if(isClient) {   }
     my $obs;   if($need_encode && (!$wasenc)) {
     my $rights;      Debug("Must encode but wasn't: $need_encode $wasenc");
     my ($cmd,$ulsdir)=split(/:/,$userinput);      $ok = 0;
     my $ulsout='';   }
     my $ulsfn;   if(($client_types & $requesterprivs) == 0) {
     if (-e $ulsdir) {      Debug("Client not privileged to do this operation");
  if(-d $ulsdir) {      $ok = 0;
     if (opendir(LSDIR,$ulsdir)) {   }
  while ($ulsfn=readdir(LSDIR)) {  
     undef $obs, $rights;    if($ok) {
     my @ulsstats=stat($ulsdir.'/'.$ulsfn);      Debug("Dispatching to handler $command $tail");
     #We do some obsolete checking here      my $keep_going = &$handler($command, $tail, $client);
     if(-e $ulsdir.'/'.$ulsfn.".meta") {       return $keep_going;
  open(FILE, $ulsdir.'/'.$ulsfn.".meta");  
  my @obsolete=<FILE>;  
  foreach my $obsolete (@obsolete) {  
     if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }   
     if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }  
  }  
     }  
     $ulsout.=$ulsfn.'&'.join('&',@ulsstats);  
     if($obs eq '1') { $ulsout.="&1"; }  
     else { $ulsout.="&0"; }  
     if($rights eq '1') { $ulsout.="&1:"; }  
     else { $ulsout.="&0:"; }  
  }  
  closedir(LSDIR);  
     }  
  } else {  
     my @ulsstats=stat($ulsdir);  
     $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';  
  }  
     } else {  
  $ulsout='no_such_dir';  
     }  
     if ($ulsout eq '') { $ulsout='empty'; }  
     print $client "$ulsout\n";  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      Debug("Refusing to dispatch because client did not match requirements");
           Failure($client, "refused\n", $userinput);
       return 1;
  }   }
   
       }    
   
   #------------------- Commands not yet in spearate handlers. --------------
   
   
   
 # ----------------------------------------------------------------- setannounce  # ----------------------------------------------------------------- setannounce
     } elsif ($userinput =~ /^setannounce/) {      if ($userinput =~ /^setannounce/) {
  if (isClient) {   if (isClient) {
     my ($cmd,$announcement)=split(/:/,$userinput);      my ($cmd,$announcement)=split(/:/,$userinput);
     chomp($announcement);      chomp($announcement);
Line 2806  sub process_request { Line 3481  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 2829  sub process_request { Line 3504  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 2839  sub process_request { Line 3514  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 2848  sub process_request { Line 3523  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 2857  sub process_request { Line 3532  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 2867  sub process_request { Line 3542  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 2893  sub process_request { Line 3568  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 3005  sub register_handler { Line 3680  sub register_handler {
         
     $Dispatcher{$request_name} = \@entry;      $Dispatcher{$request_name} = \@entry;
         
      
 }  }
   
   
Line 3052  sub catchexception { Line 3726  sub catchexception {
     $server->close();      $server->close();
     die($error);      die($error);
 }  }
   
 sub timeout {  sub timeout {
     &status("Handling Timeout");      &status("Handling Timeout");
     &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");      &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
Line 3060  sub timeout { Line 3733  sub timeout {
 }  }
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
   
   
 $SIG{'QUIT'}=\&catchexception;  $SIG{'QUIT'}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
Line 3476  sub reply { Line 4150  sub reply {
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
   
 sub sqlreply {  sub sql_reply {
     my ($cmd)=@_;      my ($cmd)=@_;
     my $answer=subsqlreply($cmd);      my $answer=&sub_sql_reply($cmd);
     if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }      if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); }
     return $answer;      return $answer;
 }  }
   
 sub subsqlreply {  sub sub_sql_reply {
     my ($cmd)=@_;      my ($cmd)=@_;
     my $unixsock="mysqlsock";      my $unixsock="mysqlsock";
     my $peerfile="$perlvar{'lonSockDir'}/$unixsock";      my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
Line 3812  sub make_new_child { Line 4486  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 4069  sub addline { Line 4743  sub addline {
     return $found;      return $found;
 }  }
   
 sub getchat {  sub get_chat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
Line 4094  sub getchat { Line 4768  sub getchat {
     return (@participants,@entries);      return (@participants,@entries);
 }  }
   
 sub chatadd {  sub chat_add {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
Line 4653  Place in B<logs/lond.log> Line 5327  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.224  
changed lines
  Added in v.1.239

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