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

Diff for /loncom/lond between versions 1.245 and 1.285

version 1.245, 2004/08/29 04:12:18 version 1.285, 2005/06/21 11:01:35
Line 46  use Authen::Krb5; Line 46  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
 use localenroll;  use localenroll;
   use localstudentphoto;
 use File::Copy;  use File::Copy;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
Line 64  my $currentdomainid; Line 65  my $currentdomainid;
   
 my $client;  my $client;
 my $clientip; # IP address of client.  my $clientip; # IP address of client.
 my $clientdns; # DNS name of client.  
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
   
 my $server;  my $server;
Line 177  sub ResetStatistics { Line 177  sub ResetStatistics {
 #   $initcmd     - The full text of the init command.  #   $initcmd     - The full text of the init command.
 #  #
 # Implicit inputs:  # Implicit inputs:
 #    $clientdns  - The DNS name of the remote client.  
 #    $thisserver - Our DNS name.  #    $thisserver - Our DNS name.
 #  #
 # Returns:  # Returns:
Line 186  sub ResetStatistics { Line 185  sub ResetStatistics {
 #  #
 sub LocalConnection {  sub LocalConnection {
     my ($Socket, $initcmd) = @_;      my ($Socket, $initcmd) = @_;
     Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");      Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");
     if($clientdns ne $thisserver) {      if($clientip ne "127.0.0.1") {
  &logthis('<font color="red"> LocalConnection rejecting non local: '   &logthis('<font color="red"> LocalConnection rejecting non local: '
  ."$clientdns ne $thisserver </font>");   ."$clientip ne $thisserver </font>");
  close $Socket;   close $Socket;
  return undef;   return undef;
     }  else {      }  else {
Line 331  sub InsecureConnection { Line 330  sub InsecureConnection {
           
   
 }  }
   
 #  #
   #   Safely execute a command (as long as it's not a shel command and doesn
   #   not require/rely on shell escapes.   The function operates by doing a
   #   a pipe based fork and capturing stdout and stderr  from the pipe.
   #
   # Formal Parameters:
   #     $line                    - A line of text to be executed as a command.
   # Returns:
   #     The output from that command.  If the output is multiline the caller
   #     must know how to split up the output.
   #
   #
   sub execute_command {
       my ($line)    = @_;
       my @words     = split(/\s/, $line); # Bust the command up into words.
       my $output    = "";
   
       my $pid = open(CHILD, "-|");
       
       if($pid) { # Parent process
    Debug("In parent process for execute_command");
    my @data = <CHILD>; # Read the child's outupt...
    close CHILD;
    foreach my $output_line (@data) {
       Debug("Adding $output_line");
       $output .= $output_line; # Presumably has a \n on it.
    }
   
       } else { # Child process
    close (STDERR);
    open  (STDERR, ">&STDOUT");# Combine stderr, and stdout...
    exec(@words); # won't return.
       }
       return $output;
   }
   
   
 #   GetCertificate: Given a transaction that requires a certificate,  #   GetCertificate: Given a transaction that requires a certificate,
 #   this function will extract the certificate from the transaction  #   this function will extract the certificate from the transaction
 #   request.  Note that at this point, the only concept of a certificate  #   request.  Note that at this point, the only concept of a certificate
Line 438  sub CopyFile { Line 472  sub CopyFile {
   
     my ($oldfile, $newfile) = @_;      my ($oldfile, $newfile) = @_;
   
     #  The file must exist:      if (! copy($oldfile,$newfile)) {
           return 0;
     if(-e $oldfile) {  
   
  # Read the old file.  
   
  my $oldfh = IO::File->new("< $oldfile");  
  if(!$oldfh) {  
     return 0;  
  }  
  my @contents = <$oldfh>;  # Suck in the entire file.  
   
  # write the backup file:  
   
  my $newfh = IO::File->new("> $newfile");  
  if(!(defined $newfh)){  
     return 0;  
  }  
  my $lines = scalar @contents;  
  for (my $i =0; $i < $lines; $i++) {  
     print $newfh ($contents[$i]);  
  }  
   
  $oldfh->close;  
  $newfh->close;  
   
  chmod(0660, $newfile);  
   
  return 1;  
       
     } else {  
  return 0;  
     }      }
       chmod(0660, $newfile);
       return 1;
 }  }
 #  #
 #  Host files are passed out with externally visible host IPs.  #  Host files are passed out with externally visible host IPs.
Line 1013  sub tie_user_hash { Line 1019  sub tie_user_hash {
    $how, 0640)) {     $how, 0640)) {
  # If this is a namespace for which a history is kept,   # If this is a namespace for which a history is kept,
  # make the history log entry:       # make the history log entry:    
  if (($namespace =~/^nohist\_/) && (defined($loghead))) {   if (($namespace !~/^nohist\_/) && (defined($loghead))) {
     my $args = scalar @_;      my $args = scalar @_;
     Debug(" Opening history: $namespace $args");      Debug(" Opening history: $namespace $args");
     my $hfh = IO::File->new(">>$proname/$namespace.hist");       my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
Line 1030  sub tie_user_hash { Line 1036  sub tie_user_hash {
           
 }  }
   
   #   read_profile
   #
   #   Returns a set of specific entries from a user's profile file.
   #   this is a utility function that is used by both get_profile_entry and
   #   get_profile_entry_encrypted.
   #
   # Parameters:
   #    udom       - Domain in which the user exists.
   #    uname      - User's account name (loncapa account)
   #    namespace  - The profile namespace to open.
   #    what       - A set of & separated queries.
   # Returns:
   #    If all ok: - The string that needs to be shipped back to the user.
   #    If failure - A string that starts with error: followed by the failure
   #                 reason.. note that this probabyl gets shipped back to the
   #                 user as well.
   #
   sub read_profile {
       my ($udom, $uname, $namespace, $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) {
       return $qresult;
    } else {
       return "error: ".($!+0)." untie (GDBM) Failed";
    }
       } else {
    if ($!+0 == 2) {
       return "error:No such file or GDBM reported bad block error";
    } else {
       return "error: ".($!+0)." tie (GDBM) Failed";
    }
       }
   
   }
 #--------------------- Request Handlers --------------------------------------------  #--------------------- Request Handlers --------------------------------------------
 #  #
 #   By convention each request handler registers itself prior to the sub   #   By convention each request handler registers itself prior to the sub 
Line 1051  sub tie_user_hash { Line 1101  sub tie_user_hash {
 #      0       - Program should exit.  #      0       - Program should exit.
 #  Side effects:  #  Side effects:
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
   
 sub ping_handler {  sub ping_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     Debug("$cmd $tail $client .. $currenthostid:");      Debug("$cmd $tail $client .. $currenthostid:");
Line 1079  sub ping_handler { Line 1128  sub ping_handler {
 #      0       - Program should exit.  #      0       - Program should exit.
 #  Side effects:  #  Side effects:
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
   
 sub pong_handler {  sub pong_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
Line 1134  sub establish_key_handler { Line 1182  sub establish_key_handler {
 }  }
 &register_handler("ekey", \&establish_key_handler, 0, 1,1);  &register_handler("ekey", \&establish_key_handler, 0, 1,1);
   
   
 #     Handler for the load command.  Returns the current system load average  #     Handler for the load command.  Returns the current system load average
 #     to the requestor.  #     to the requestor.
 #  #
Line 1169  sub load_handler { Line 1216  sub load_handler {
         
     return 1;      return 1;
 }  }
 register_handler("load", \&load_handler, 0, 1, 0);  &register_handler("load", \&load_handler, 0, 1, 0);
   
 #  #
 #   Process the userload request.  This sub returns to the client the current  #   Process the userload request.  This sub returns to the client the current
Line 1199  sub user_load_handler { Line 1246  sub user_load_handler {
           
     return 1;      return 1;
 }  }
 register_handler("userload", \&user_load_handler, 0, 1, 0);  &register_handler("userload", \&user_load_handler, 0, 1, 0);
   
 #   Process a request for the authorization type of a user:  #   Process a request for the authorization type of a user:
 #   (userauth).  #   (userauth).
Line 1235  sub user_authorization_type { Line 1282  sub user_authorization_type {
  my ($type,$otherinfo) = split(/:/,$result);   my ($type,$otherinfo) = split(/:/,$result);
  if($type =~ /^krb/) {   if($type =~ /^krb/) {
     $type = $result;      $type = $result;
  }   } else {
  &Reply( $replyfd, "$type:\n", $userinput);              $type .= ':';
           }
    &Reply( $replyfd, "$type\n", $userinput);
     }      }
       
     return 1;      return 1;
Line 1256  sub user_authorization_type { Line 1305  sub user_authorization_type {
 #      0       - Program should exit  #      0       - Program should exit
 # Implicit Output:  # Implicit Output:
 #    a reply is written to the client.  #    a reply is written to the client.
   
 sub push_file_handler {  sub push_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 1299  sub push_file_handler { Line 1347  sub push_file_handler {
 # Side Effects:  # Side Effects:
 #   The reply is written to  $client.  #   The reply is written to  $client.
 #  #
   
 sub du_handler {  sub du_handler {
     my ($cmd, $ududir, $client) = @_;      my ($cmd, $ududir, $client) = @_;
       my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
       my $userinput = "$cmd:$ududir";
   
     if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {      if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
  &Failure($client,"refused\n","$cmd:$ududir");   &Failure($client,"refused\n","$cmd:$ududir");
  return 1;   return 1;
     }      }
     my $duout = `du -ks $ududir 2>/dev/null`;      #  Since $ududir could have some nasties in it,
     $duout=~s/[^\d]//g; #preserve only the numbers      #  we will require that ududir is a valid
     &Reply($client,"$duout\n","$cmd:$ududir");      #  directory.  Just in case someone tries to
       #  slip us a  line like .;(cd /home/httpd rm -rf*)
       #  etc.
       #
       if (-d $ududir) {
    #  And as Shakespeare would say to make
    #  assurance double sure, 
    # use execute_command to ensure that the command is not executed in
    # a shell that can screw us up.
   
    my $duout = execute_command("du -ks $ududir");
    $duout=~s/[^\d]//g; #preserve only the numbers
    &Reply($client,"$duout\n","$cmd:$ududir");
       } else {
   
    &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 
   
       }
     return 1;      return 1;
 }  }
 &register_handler("du", \&du_handler, 0, 1, 0);  &register_handler("du", \&du_handler, 0, 1, 0);
   
   #
   # The ls_handler routine should be considered obosolete and is retained
   # for communication with legacy servers.  Please see the ls2_handler.
 #  #
 #   ls  - list the contents of a directory.  For each file in the  #   ls  - list the contents of a directory.  For each file in the
 #    selected directory the filename followed by the full output of  #    selected directory the filename followed by the full output of
Line 1331  sub du_handler { Line 1400  sub du_handler {
 #   The reply is written to  $client.  #   The reply is written to  $client.
 #  #
 sub ls_handler {  sub ls_handler {
       # obsoleted by ls2_handler
     my ($cmd, $ulsdir, $client) = @_;      my ($cmd, $ulsdir, $client) = @_;
   
     my $userinput = "$cmd:$ulsdir";      my $userinput = "$cmd:$ulsdir";
Line 1370  sub ls_handler { Line 1440  sub ls_handler {
  $ulsout='no_such_dir';   $ulsout='no_such_dir';
     }      }
     if ($ulsout eq '') { $ulsout='empty'; }      if ($ulsout eq '') { $ulsout='empty'; }
     print $client "$ulsout\n";      &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
           
     return 1;      return 1;
   
 }  }
 &register_handler("ls", \&ls_handler, 0, 1, 0);  &register_handler("ls", \&ls_handler, 0, 1, 0);
   
   #
   # Please also see the ls_handler, which this routine obosolets.
   # ls2_handler differs from ls_handler in that it escapes its return 
   # values before concatenating them together with ':'s.
   #
   #   ls2  - 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 ls2_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;
                               }
                           }
                       }
                       my $tmp = $ulsfn.'&'.join('&',@ulsstats);
                       if ($obs    eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       $ulsout.= &escape($tmp).':';
                   }
                   closedir(LSDIR);
               }
           } else {
               my @ulsstats=stat($ulsdir);
               $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
           }
       } else {
           $ulsout='no_such_dir';
      }
      if ($ulsout eq '') { $ulsout='empty'; }
      &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
      return 1;
   }
   &register_handler("ls2", \&ls2_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 
Line 1409  sub reinit_process_handler { Line 1542  sub reinit_process_handler {
     }      }
     return 1;      return 1;
 }  }
   
 &register_handler("reinit", \&reinit_process_handler, 1, 0, 1);  &register_handler("reinit", \&reinit_process_handler, 1, 0, 1);
   
 #  Process the editing script for a table edit operation.  #  Process the editing script for a table edit operation.
Line 1451  sub edit_table_handler { Line 1583  sub edit_table_handler {
     }      }
     return 1;      return 1;
 }  }
 register_handler("edit", \&edit_table_handler, 1, 0, 1);  &register_handler("edit", \&edit_table_handler, 1, 0, 1);
   
   
 #  #
 #   Authenticate a user against the LonCAPA authentication  #   Authenticate a user against the LonCAPA authentication
Line 1507  sub authenticate_handler { Line 1638  sub authenticate_handler {
   
     return 1;      return 1;
 }  }
   &register_handler("auth", \&authenticate_handler, 1, 1, 0);
 register_handler("auth", \&authenticate_handler, 1, 1, 0);  
   
 #  #
 #   Change a user's password.  Note that this function is complicated by  #   Change a user's password.  Note that this function is complicated by
Line 1599  sub change_password_handler { Line 1729  sub change_password_handler {
   
     return 1;      return 1;
 }  }
 register_handler("passwd", \&change_password_handler, 1, 1, 0);  &register_handler("passwd", \&change_password_handler, 1, 1, 0);
   
   
 #  #
 #   Create a new user.  User in this case means a lon-capa user.  #   Create a new user.  User in this case means a lon-capa user.
Line 1639  sub add_user_handler { Line 1768  sub add_user_handler {
  if (-e $passfilename) {   if (-e $passfilename) {
     &Failure( $client, "already_exists\n", $userinput);      &Failure( $client, "already_exists\n", $userinput);
  } else {   } else {
     my @fpparts=split(/\//,$passfilename);  
     my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];  
     my $fperror='';      my $fperror='';
     for (my $i=3;$i<= ($#fpparts-1);$i++) {      if (!&mkpath($passfilename)) {
  $fpnow.='/'.$fpparts[$i];    $fperror="error: ".($!+0)." mkdir failed while attempting "
  unless (-e $fpnow) {      ."makeuser";
     &logthis("mkdir $fpnow");  
     unless (mkdir($fpnow,0777)) {  
  $fperror="error: ".($!+0)." mkdir failed while attempting "  
     ."makeuser";  
     }  
  }  
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
Line 1707  sub change_authentication_handler { Line 1828  sub change_authentication_handler {
  chomp($npass);   chomp($npass);
   
  $npass=&unescape($npass);   $npass=&unescape($npass);
    my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
  my $passfilename = &password_path($udom, $uname);   my $passfilename = &password_path($udom, $uname);
  if ($passfilename) { # Not allowed to create a new user!!   if ($passfilename) { # Not allowed to create a new user!!
     my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);      my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
       #
       #  If the current auth mode is internal, and the old auth mode was
       #  unix, or krb*,  and the user is an author for this domain,
       #  re-run manage_permissions for that role in order to be able
       #  to take ownership of the construction space back to www:www
       #
   
       if( (($oldauth =~ /^unix/) && ($umode eq "internal")) ||
    (($oldauth =~ /^internal/) && ($umode eq "unix")) ) { 
    if(&is_author($udom, $uname)) {
       &Debug(" Need to manage author permissions...");
       &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
    }
       }
          
   
     &Reply($client, $result, $userinput);      &Reply($client, $result, $userinput);
  } else {          } else {       
     &Failure($client, "non_authorized", $userinput); # Fail the user now.      &Failure($client, "non_authorized\n", $userinput); # Fail the user now.
  }   }
     }      }
     return 1;      return 1;
Line 1865  sub fetch_user_file_handler { Line 2003  sub fetch_user_file_handler {
  # Note that any regular files in the way of this path are   # Note that any regular files in the way of this path are
  # wiped out to deal with some earlier folly of mine.   # wiped out to deal with some earlier folly of mine.
   
  my $path = $udir;   if (!&mkpath($udir.'/'.$ufile)) {
  if ($ufile =~m|(.+)/([^/]+)$|) {      &Failure($client, "unable_to_create\n", $userinput);    
     my @parts=split('/',$1);  
     foreach my $part (@parts) {  
  $path .= '/'.$part;  
  if( -f $path) {  
     unlink($path);  
  }  
  if ((-e $path)!=1) {  
     mkdir($path,0770);  
  }  
     }  
  }   }
   
   
  my $destname=$udir.'/'.$ufile;   my $destname=$udir.'/'.$ufile;
  my $transname=$udir.'/'.$ufile.'.in.transit';   my $transname=$udir.'/'.$ufile.'.in.transit';
  my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;   my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 1923  sub fetch_user_file_handler { Line 2050  sub fetch_user_file_handler {
 #  #
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
   
 sub remove_user_file_handler {  sub remove_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 1939  sub remove_user_file_handler { Line 2065  sub remove_user_file_handler {
  if (-e $udir) {   if (-e $udir) {
     my $file=$udir.'/userfiles/'.$ufile;      my $file=$udir.'/userfiles/'.$ufile;
     if (-e $file) {      if (-e $file) {
    #
    #   If the file is a regular file unlink is fine...
    #   However it's possible the client wants a dir.
    #   removed, in which case rmdir is more approprate:
    #
         if (-f $file){          if (-f $file){
     unlink($file);      unlink($file);
  } elsif(-d $file) {   } elsif(-d $file) {
     rmdir($file);      rmdir($file);
  }   }
  if (-e $file) {   if (-e $file) {
       #  File is still there after we deleted it ?!?
   
     &Failure($client, "failed\n", "$cmd:$tail");      &Failure($client, "failed\n", "$cmd:$tail");
  } else {   } else {
     &Reply($client, "ok\n", "$cmd:$tail");      &Reply($client, "ok\n", "$cmd:$tail");
Line 1969  sub remove_user_file_handler { Line 2102  sub remove_user_file_handler {
 #  #
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
   
 sub mkdir_user_file_handler {  sub mkdir_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 1983  sub mkdir_user_file_handler { Line 2115  sub mkdir_user_file_handler {
     } else {      } else {
  my $udir = &propath($udom,$uname);   my $udir = &propath($udom,$uname);
  if (-e $udir) {   if (-e $udir) {
     my $newdir=$udir.'/userfiles/'.$ufile;      my $newdir=$udir.'/userfiles/'.$ufile.'/';
     if (!-e $newdir) {      if (!&mkpath($newdir)) {
  mkdir($newdir);   &Failure($client, "failed\n", "$cmd:$tail");
  if (!-e $newdir) {  
     &Failure($client, "failed\n", "$cmd:$tail");  
  } else {  
     &Reply($client, "ok\n", "$cmd:$tail");  
  }  
     } else {  
  &Failure($client, "not_found\n", "$cmd:$tail");  
     }      }
       &Reply($client, "ok\n", "$cmd:$tail");
  } else {   } else {
     &Failure($client, "not_home\n", "$cmd:$tail");      &Failure($client, "not_home\n", "$cmd:$tail");
  }   }
Line 2011  sub mkdir_user_file_handler { Line 2137  sub mkdir_user_file_handler {
 #  #
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
   
 sub rename_user_file_handler {  sub rename_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 2045  sub rename_user_file_handler { Line 2170  sub rename_user_file_handler {
 }  }
 &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
   
   
 #  #
 #  Authenticate access to a user file by checking the user's   #  Authenticate access to a user file by checking that the token the user's 
 #  session token(?)  #  passed also exists in their session file
 #  #
 # Parameters:  # Parameters:
 #   cmd      - The request keyword that dispatched to tus.  #   cmd      - The request keyword that dispatched to tus.
Line 2056  sub rename_user_file_handler { Line 2180  sub rename_user_file_handler {
 #   client   - Filehandle open on the client.  #   client   - Filehandle open on the client.
 # Return:  # Return:
 #    1.  #    1.
   
 sub token_auth_user_file_handler {  sub token_auth_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my ($fname, $session) = split(/:/, $tail);      my ($fname, $session) = split(/:/, $tail);
           
     chomp($session);      chomp($session);
     my $reply='non_auth';      my $reply="non_auth\n";
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
      $session.'.id')) {       $session.'.id')) {
  while (my $line=<ENVIN>) {   while (my $line=<ENVIN>) {
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }      if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
  }   }
  close(ENVIN);   close(ENVIN);
  &Reply($client, $reply);   &Reply($client, $reply, "$cmd:$tail");
     } else {      } else {
  &Failure($client, "invalid_token\n", "$cmd:$tail");   &Failure($client, "invalid_token\n", "$cmd:$tail");
     }      }
     return 1;      return 1;
   
 }  }
   
 &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);  &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
   
   
 #  #
 #   Unsubscribe from a resource.  #   Unsubscribe from a resource.
 #  #
Line 2109  sub unsubscribe_handler { Line 2230  sub unsubscribe_handler {
     return 1;      return 1;
 }  }
 &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);  &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
   
 #   Subscribe to a resource  #   Subscribe to a resource
 #  #
 # Parameters:  # Parameters:
Line 2187  sub activity_log_handler { Line 2309  sub activity_log_handler {
   
     return 1;      return 1;
 }  }
 register_handler("log", \&activity_log_handler, 0, 1, 0);  &register_handler("log", \&activity_log_handler, 0, 1, 0);
   
 #  #
 #   Put a namespace entry in a user profile hash.  #   Put a namespace entry in a user profile hash.
Line 2238  sub put_user_profile_entry { Line 2360  sub put_user_profile_entry {
 }  }
 &register_handler("put", \&put_user_profile_entry, 0, 1, 0);  &register_handler("put", \&put_user_profile_entry, 0, 1, 0);
   
   #   Put a piece of new data in hash, returns error if entry already 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.
   #
   sub newput_user_profile_entry {
       my ($cmd, $tail, $client)  = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
       if ($namespace eq 'roles') {
           &Failure( $client, "refused\n", $userinput);
    return 1;
       }
   
       chomp($what);
   
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_WRCREAT(),"N",$what);
       if(!$hashref) {
    &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
     "while attempting put\n", $userinput);
    return 1;
       }
   
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    if (exists($hashref->{$key})) {
       &Failure($client, "key_exists: ".$key."\n",$userinput);
       return 1;
    }
       }
   
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $hashref->{$key}=$value;
       }
   
       if (untie(%$hashref)) {
    &Reply( $client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting put\n", 
    $userinput);
       }
       return 1;
   }
   &register_handler("newput", \&newput_user_profile_entry, 0, 1, 0);
   
 #   # 
 #   Increment a profile entry in the user history file.  #   Increment a profile entry in the user history file.
 #   The history contains keyword value pairs.  In this case,  #   The history contains keyword value pairs.  In this case,
Line 2268  sub increment_user_value_handler { Line 2445  sub increment_user_value_handler {
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
     foreach my $pair (@pairs) {      foreach my $pair (@pairs) {
  my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
                   $value = &unescape($value);
  # We could check that we have a number...   # We could check that we have a number...
  if (! defined($value) || $value eq '') {   if (! defined($value) || $value eq '') {
     $value = 1;      $value = 1;
  }   }
  $hashref->{$key}+=$value;   $hashref->{$key}+=$value;
                   if ($namespace eq 'nohist_resourcetracker') {
                       if ($hashref->{$key} < 0) {
                           $hashref->{$key} = 0;
                       }
                   }
     }      }
     if (untie(%$hashref)) {      if (untie(%$hashref)) {
  &Reply( $client, "ok\n", $userinput);   &Reply( $client, "ok\n", $userinput);
Line 2292  sub increment_user_value_handler { Line 2475  sub increment_user_value_handler {
 }  }
 &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);  &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);
   
   
 #  #
 #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.  #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
 #   Each 'role' a user has implies a set of permissions.  Adding a new role  #   Each 'role' a user has implies a set of permissions.  Adding a new role
Line 2332  sub roles_put_handler { Line 2514  sub roles_put_handler {
     #  is done on close this improves the chances the log will be an un-      #  is done on close this improves the chances the log will be an un-
     #  corrupted ordered thing.      #  corrupted ordered thing.
     if ($hashref) {      if ($hashref) {
    my $pass_entry = &get_auth_type($udom, $uname);
    my ($auth_type,$pwd)  = split(/:/, $pass_entry);
    $auth_type = $auth_type.":";
  my @pairs=split(/\&/,$what);   my @pairs=split(/\&/,$what);
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     &manage_permissions($key, $udom, $uname,      &manage_permissions($key, $udom, $uname,
        &get_auth_type( $udom, $uname));         $auth_type);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie($hashref)) {   if (untie($hashref)) {
Line 2431  sub get_profile_entry { Line 2616  sub get_profile_entry {
         
     my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = &tie_user_hash($udom, $uname, $namespace,  
  &GDBM_READER());      my $replystring = read_profile($udom, $uname, $namespace, $what);
     if ($hashref) {      my ($first) = split(/:/,$replystring);
         my @queries=split(/\&/,$what);      if($first ne "error") {
         my $qresult='';   &Reply($client, "$replystring\n", $userinput);
   
  for (my $i=0;$i<=$#queries;$i++) {  
     $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.  
  }  
  $qresult=~s/\&$//;              # Remove trailing & from last lookup.  
  if (untie(%$hashref)) {  
     &Reply($client, "$qresult\n", $userinput);  
  } else {  
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".  
     "while attempting get\n", $userinput);  
  }  
     } else {      } else {
  if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT   &Failure($client, $replystring." while attempting get\n", $userinput);
     &Failure($client, "error:No such file or ".  
     "GDBM reported bad block error\n", $userinput);  
  } else {                        # Some other undifferentiated err.  
     &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
     "while attempting get\n", $userinput);  
  }  
     }      }
     return 1;      return 1;
   
   
 }  }
 &register_handler("get", \&get_profile_entry, 0,1,0);  &register_handler("get", \&get_profile_entry, 0,1,0);
   
Line 2486  sub get_profile_entry_encrypted { Line 2656  sub get_profile_entry_encrypted {
         
     my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);      my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
     chomp($what);      chomp($what);
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $qresult = read_profile($udom, $uname, $namespace, $what);
  &GDBM_READER());      my ($first) = split(/:/, $qresult);
     if ($hashref) {      if($first ne "error") {
         my @queries=split(/\&/,$what);  
         my $qresult='';   if ($cipher) {
  for (my $i=0;$i<=$#queries;$i++) {      my $cmdlength=length($qresult);
     $qresult.="$hashref->{$queries[$i]}&";      $qresult.="         ";
  }      my $encqresult='';
  if (untie(%$hashref)) {      for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
     $qresult=~s/\&$//;   $encqresult.= unpack("H16", 
     if ($cipher) {       $cipher->encrypt(substr($qresult,
  my $cmdlength=length($qresult);       $encidx,
  $qresult.="         ";       8)));
  my $encqresult='';  
  for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  
     $encqresult.= unpack("H16",   
  $cipher->encrypt(substr($qresult,  
  $encidx,  
  8)));  
  }  
  &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);  
     } else {  
  &Failure( $client, "error:no_key\n", $userinput);  
     }      }
       &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".   &Failure( $client, "error:no_key\n", $userinput);
     "while attempting eget\n", $userinput);      }
  }  
     } else {      } else {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   &Failure($client, "$qresult while attempting eget\n", $userinput);
  "while attempting eget\n", $userinput);  
     }      }
           
     return 1;      return 1;
 }  }
 &register_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);  &register_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);
   
 #  #
 #   Deletes a key in a user profile database.  #   Deletes a key in a user profile database.
 #     #   
Line 2540  sub get_profile_entry_encrypted { Line 2701  sub get_profile_entry_encrypted {
 #     0   - Exit server.  #     0   - Exit server.
 #  #
 #  #
   
 sub delete_profile_entry {  sub delete_profile_entry {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 2569  sub delete_profile_entry { Line 2729  sub delete_profile_entry {
     return 1;      return 1;
 }  }
 &register_handler("del", \&delete_profile_entry, 0, 1, 0);  &register_handler("del", \&delete_profile_entry, 0, 1, 0);
   
 #  #
 #  List the set of keys that are defined in a profile database file.  #  List the set of keys that are defined in a profile database file.
 #  A successful reply from this will contain an & separated list of  #  A successful reply from this will contain an & separated list of
Line 2747  sub dump_with_regexp { Line 2908  sub dump_with_regexp {
   
     return 1;      return 1;
 }  }
   
 &register_handler("dump", \&dump_with_regexp, 0, 1, 0);  &register_handler("dump", \&dump_with_regexp, 0, 1, 0);
   
 #  Store a set of key=value pairs associated with a versioned name.  #  Store a set of key=value pairs associated with a versioned name.
Line 2779  sub store_handler { Line 2939  sub store_handler {
  chomp($what);   chomp($what);
  my @pairs=split(/\&/,$what);   my @pairs=split(/\&/,$what);
  my $hashref  = &tie_user_hash($udom, $uname, $namespace,   my $hashref  = &tie_user_hash($udom, $uname, $namespace,
        &GDBM_WRCREAT(), "P",         &GDBM_WRCREAT(), "S",
        "$rid:$what");         "$rid:$what");
  if ($hashref) {   if ($hashref) {
     my $now = time;      my $now = time;
Line 2813  sub store_handler { Line 2973  sub store_handler {
     return 1;      return 1;
 }  }
 &register_handler("store", \&store_handler, 0, 1, 0);  &register_handler("store", \&store_handler, 0, 1, 0);
   
 #  #
 #  Dump out all versions of a resource that has key=value pairs associated  #  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  # with it for each version.  These resources are built up via the store
Line 2913  sub send_chat_handler { Line 3074  sub send_chat_handler {
     return 1;      return 1;
 }  }
 &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);  &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
   
 #  #
 #   Retrieve the set of chat messagss from a discussion board.  #   Retrieve the set of chat messagss from a discussion board.
 #  #
Line 3048  sub reply_query_handler { Line 3210  sub reply_query_handler {
 #   $tail     - Tail of the command.  In this case consists of a colon  #   $tail     - Tail of the command.  In this case consists of a colon
 #               separated list contaning the domain to apply this to and  #               separated list contaning the domain to apply this to and
 #               an ampersand separated list of keyword=value pairs.  #               an ampersand separated list of keyword=value pairs.
   #               Each value is a colon separated list that includes:  
   #               description, institutional code and course owner.
   #               For backward compatibility with versions included
   #               in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
   #               code and/or course owner are preserved from the existing 
   #               record when writing a new record in response to 1.1 or 
   #               1.2 implementations of lonnet::flushcourselogs().   
   #                      
 #   $client   - Socket open on the client.  #   $client   - Socket open on the client.
 # Returns:  # Returns:
 #   1    - indicating that processing should continue  #   1    - indicating that processing should continue
Line 3061  sub put_course_id_handler { Line 3231  sub put_course_id_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom, $what) = split(/:/, $tail);      my ($udom, $what) = split(/:/, $tail,2);
     chomp($what);      chomp($what);
     my $now=time;      my $now=time;
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
Line 3069  sub put_course_id_handler { Line 3239  sub put_course_id_handler {
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);              my ($key,$courseinfo) = split(/=/,$pair,2);
     $hashref->{$key}=$value.':'.$now;              $courseinfo =~ s/=/:/g;
   
               my @current_items = split(/:/,$hashref->{$key});
               shift(@current_items); # remove description
               pop(@current_items);   # remove last access
               my $numcurrent = scalar(@current_items);
   
               my @new_items = split(/:/,$courseinfo);
               my $numnew = scalar(@new_items);
               if ($numcurrent > 0) {
                   if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier
                       $courseinfo .= ':'.join(':',@current_items);
                   } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X
                       $courseinfo .= ':'.$current_items[$numcurrent-1];
                   }
               }
       $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (untie(%$hashref)) {   if (untie(%$hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)      &Failure($client, "error: ".($!+0)
      ." untie(GDBM) Failed ".       ." untie(GDBM) Failed ".
      "while attempting courseidput\n", $userinput);       "while attempting courseidput\n", $userinput);
  }   }
     } else {      } else {
  &Failure( $client, "error: ".($!+0)   &Failure($client, "error: ".($!+0)
  ." tie(GDBM) Failed ".   ." tie(GDBM) Failed ".
  "while attempting courseidput\n", $userinput);   "while attempting courseidput\n", $userinput);
     }      }
       
   
     return 1;      return 1;
 }  }
Line 3107  sub put_course_id_handler { Line 3294  sub put_course_id_handler {
 #                 description - regular expression that is used to filter  #                 description - regular expression that is used to filter
 #                            the dump.  Only keywords matching this regexp  #                            the dump.  Only keywords matching this regexp
 #                            will be used.  #                            will be used.
   #                 institutional code - optional supplied code to filter 
   #                            the dump. Only courses with an institutional code 
   #                            that match the supplied code will be returned.
   #                 owner    - optional supplied username of owner to filter
   #                            the dump.  Only courses for which the course 
   #                            owner matches the supplied username will be
   #                            returned. Implicit assumption that owner
   #                            is a user in the domain in which the
   #                            course database is defined.
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3117  sub dump_course_id_handler { Line 3313  sub dump_course_id_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description) =split(/:/,$tail);      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
  $description='.';   $description='.';
     }      }
       if (defined($instcodefilter)) {
           $instcodefilter=&unescape($instcodefilter);
       } else {
           $instcodefilter='.';
       }
       if (defined($ownerfilter)) {
           $ownerfilter=&unescape($ownerfilter);
       } else {
           $ownerfilter='.';
       }
       if (defined($coursefilter)) {
           $coursefilter=&unescape($coursefilter);
       } else {
           $coursefilter='.';
       }
   
     unless (defined($since)) { $since=0; }      unless (defined($since)) { $since=0; }
     my $qresult='';      my $qresult='';
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($descr,$lasttime,$inst_code);      my ($descr,$lasttime,$inst_code,$owner);
     if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {              my @courseitems = split(/:/,$value);
  ($descr,$inst_code,$lasttime)=($1,$2,$3);              $lasttime = pop(@courseitems);
     } else {      ($descr,$inst_code,$owner)=@courseitems;
  ($descr,$lasttime) = split(/\:/,$value);  
     }  
     if ($lasttime<$since) { next; }      if ($lasttime<$since) { next; }
     if ($description eq '.') {              my $match = 1;
  $qresult.=$key.'='.$descr.':'.$inst_code.'&';      unless ($description eq '.') {
     } else {   my $unescapeDescr = &unescape($descr);
  my $unescapeVal = &unescape($descr);   unless (eval('$unescapeDescr=~/\Q$description\E/i')) {
  if (eval('$unescapeVal=~/\Q$description\E/i')) {                      $match = 0;
     $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
  }   }
               }
               unless ($instcodefilter eq '.' || !defined($instcodefilter)) {
                   my $unescapeInstcode = &unescape($inst_code);
                   unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
                       $match = 0;
                   }
     }      }
               unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
                   my $unescapeOwner = &unescape($owner);
                   unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
                       $match = 0;
                   }
               }
               unless ($coursefilter eq '.' || !defined($coursefilter)) {
                   my $unescapeCourse = &unescape($key);
                   unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
               }
  }   }
  if (untie(%$hashref)) {   if (untie(%$hashref)) {
     chop($qresult);      chop($qresult);
Line 3206  sub put_id_handler { Line 3436  sub put_id_handler {
   
     return 1;      return 1;
 }  }
   
 &register_handler("idput", \&put_id_handler, 0, 1, 0);  &register_handler("idput", \&put_id_handler, 0, 1, 0);
   
 #  #
 #  Retrieves a set of id values from the id database.  #  Retrieves a set of id values from the id database.
 #  Returns an & separated list of results, one for each requested id to the  #  Returns an & separated list of results, one for each requested id to the
Line 3256  sub get_id_handler { Line 3486  sub get_id_handler {
           
     return 1;      return 1;
 }  }
   &register_handler("idget", \&get_id_handler, 0, 1, 0);
 register_handler("idget", \&get_id_handler, 0, 1, 0);  
   
 #  #
 #  Process the tmpput command I'm not sure what this does.. Seems to  #  Process the tmpput command I'm not sure what this does.. Seems to
Line 3300  sub tmp_put_handler { Line 3529  sub tmp_put_handler {
       
 }  }
 &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);  &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);
   
 #   Processes the tmpget command.  This command returns the contents  #   Processes the tmpget command.  This command returns the contents
 #  of a temporary resource file(?) created via tmpput.  #  of a temporary resource file(?) created via tmpput.
 #  #
Line 3312  sub tmp_put_handler { Line 3542  sub tmp_put_handler {
 #    1         - Inidcating processing can continue.  #    1         - Inidcating processing can continue.
 # Side effects:  # Side effects:
 #   A reply is sent to the client.  #   A reply is sent to the client.
   
 #  #
 sub tmp_get_handler {  sub tmp_get_handler {
     my ($cmd, $id, $client) = @_;      my ($cmd, $id, $client) = @_;
Line 3335  sub tmp_get_handler { Line 3564  sub tmp_get_handler {
     return 1;      return 1;
 }  }
 &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);  &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);
   
 #  #
 #  Process the tmpdel command.  This command deletes a temp resource  #  Process the tmpdel command.  This command deletes a temp resource
 #  created by the tmpput command.  #  created by the tmpput command.
Line 3368  sub tmp_del_handler { Line 3598  sub tmp_del_handler {
   
 }  }
 &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);  &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
   
   #
   #   Processes the setannounce command.  This command
   #   creates a file named announce.txt in the top directory of
   #   the documentn root and sets its contents.  The announce.txt file is
   #   printed in its entirety at the LonCAPA login page.  Note:
   #   once the announcement.txt fileis created it cannot be deleted.
   #   However, setting the contents of the file to empty removes the
   #   announcement from the login page of loncapa so who cares.
   #
   # Parameters:
   #    $cmd          - The command that got us dispatched.
   #    $announcement - The text of the announcement.
   #    $client       - Socket open on the client process.
   # Retunrns:
   #   1             - Indicating request processing should continue
   # Side Effects:
   #   The file {DocRoot}/announcement.txt is created.
   #   A reply is sent to $client.
   #
   sub set_announce_handler {
       my ($cmd, $announcement, $client) = @_;
     
       my $userinput    = "$cmd:$announcement";
   
       chomp($announcement);
       $announcement=&unescape($announcement);
       if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
    '/announcement.txt')) {
    print $store $announcement;
    close $store;
    &Reply($client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)."\n", $userinput);
       }
   
       return 1;
   }
   &register_handler("setannounce", \&set_announce_handler, 0, 1, 0);
   
   #
   #  Return the version of the daemon.  This can be used to determine
   #  the compatibility of cross version installations or, alternatively to
   #  simply know who's out of date and who isn't.  Note that the version
   #  is returned concatenated with the tail.
   # Parameters:
   #   $cmd        - the request that dispatched to us.
   #   $tail       - Tail of the request (client's version?).
   #   $client     - Socket open on the client.
   #Returns:
   #   1 - continue processing requests.
   # Side Effects:
   #   Replies with version to $client.
   sub get_version_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput  = $cmd.$tail;
       
       &Reply($client, &version($userinput)."\n", $userinput);
   
   
       return 1;
   }
   &register_handler("version", \&get_version_handler, 0, 1, 0);
   
   #  Set the current host and domain.  This is used to support
   #  multihomed systems.  Each IP of the system, or even separate daemons
   #  on the same IP can be treated as handling a separate lonCAPA virtual
   #  machine.  This command selects the virtual lonCAPA.  The client always
   #  knows the right one since it is lonc and it is selecting the domain/system
   #  from the hosts.tab file.
   # Parameters:
   #    $cmd      - Command that dispatched us.
   #    $tail     - Tail of the command (domain/host requested).
   #    $socket   - Socket open on the client.
   #
   # Returns:
   #     1   - Indicates the program should continue to process requests.
   # Side-effects:
   #     The default domain/system context is modified for this daemon.
   #     a reply is sent to the client.
   #
   sub set_virtual_host_handler {
       my ($cmd, $tail, $socket) = @_;
     
       my $userinput  ="$cmd:$tail";
   
       &Reply($client, &sethost($userinput)."\n", $userinput);
   
   
       return 1;
   }
   &register_handler("sethost", \&set_virtual_host_handler, 0, 1, 0);
   
   #  Process a request to exit:
   #   - "bye" is sent to the client.
   #   - The client socket is shutdown and closed.
   #   - We indicate to the caller that we should exit.
   # Formal Parameters:
   #   $cmd                - The command that got us here.
   #   $tail               - Tail of the command (empty).
   #   $client             - Socket open on the tail.
   # Returns:
   #   0      - Indicating the program should exit!!
   #
   sub exit_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       &logthis("Client $clientip ($clientname) hanging up: $userinput");
       &Reply($client, "bye\n", $userinput);
       $client->shutdown(2);        # shutdown the socket forcibly.
       $client->close();
   
       return 0;
   }
   &register_handler("exit", \&exit_handler, 0,1,1);
   &register_handler("init", \&exit_handler, 0,1,1);
   &register_handler("quit", \&exit_handler, 0,1,1);
   
   #  Determine if auto-enrollment is enabled.
   #  Note that the original had what I believe to be a defect.
   #  The original returned 0 if the requestor was not a registerd client.
   #  It should return "refused".
   # Formal Parameters:
   #   $cmd       - The command that invoked us.
   #   $tail      - The tail of the command (Extra command parameters.
   #   $client    - The socket open on the client that issued the request.
   # Returns:
   #    1         - Indicating processing should continue.
   #
   sub enrollment_enabled_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = $cmd.":".$tail; # For logging purposes.
   
       
       my $cdom = split(/:/, $tail);   # Domain we're asking about.
       my $outcome  = &localenroll::run($cdom);
       &Reply($client, "$outcome\n", $userinput);
   
       return 1;
   }
   &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
   
   #   Get the official sections for which auto-enrollment is possible.
   #   Since the admin people won't know about 'unofficial sections' 
   #   we cannot auto-enroll on them.
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched here.
   #    $tail    - The remainder of the request.  In our case this
   #               will be split into:
   #               $coursecode   - The course name from the admin point of view.
   #               $cdom         - The course's domain(?).
   #    $client  - Socket open on the client.
   # Returns:
   #    1    - Indiciting processing should continue.
 #  #
   sub get_sections_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
   
       my ($coursecode, $cdom) = split(/:/, $tail);
       my @secs = &localenroll::get_sections($coursecode,$cdom);
       my $seclist = &escape(join(':',@secs));
   
       &Reply($client, "$seclist\n", $userinput);
       
   
       return 1;
   }
   &register_handler("autogetsections", \&get_sections_handler, 0, 1, 0);
   
   #   Validate the owner of a new course section.  
   #
   # Formal Parameters:
   #   $cmd      - Command that got us dispatched.
   #   $tail     - the remainder of the command.  For us this consists of a
   #               colon separated string containing:
   #                  $inst    - Course Id from the institutions point of view.
   #                  $owner   - Proposed owner of the course.
   #                  $cdom    - Domain of the course (from the institutions
   #                             point of view?)..
   #   $client   - Socket open on the client.
   #
   # Returns:
   #   1        - Processing should continue.
   #
   sub validate_course_owner_handler {
       my ($cmd, $tail, $client)  = @_;
       my $userinput = "$cmd:$tail";
       my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
   
       my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
       &Reply($client, "$outcome\n", $userinput);
   
   
   
       return 1;
   }
   &register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);
   
   #
   #   Validate a course section in the official schedule of classes
   #   from the institutions point of view (part of autoenrollment).
   #
   # Formal Parameters:
   #   $cmd          - The command request that got us dispatched.
   #   $tail         - The tail of the command.  In this case,
   #                   this is a colon separated set of words that will be split
   #                   into:
   #                        $inst_course_id - The course/section id from the
   #                                          institutions point of view.
   #                        $cdom           - The domain from the institutions
   #                                          point of view.
   #   $client       - Socket open on the client.
   # Returns:
   #    1           - Indicating processing should continue.
   #
   sub validate_course_section_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($inst_course_id, $cdom) = split(/:/, $tail);
   
       my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
       &Reply($client, "$outcome\n", $userinput);
   
   
       return 1;
   }
   &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
   
 #  #
   #   Create a password for a new auto-enrollment user.
   #   I think/guess, this password allows access to the institutions 
   #   AIS class list server/services.  Stuart can correct this comment
   #   when he finds out how wrong I am.
 #  #
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of words that will be split into:
   #               $authparam - An authentication parameter (username??).
   #               $cdom      - The domain of the course from the institution's
   #                            point of view.
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
 #  #
   sub create_auto_enroll_password_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
   
       my ($authparam, $cdom) = split(/:/, $userinput);
   
       my ($create_passwd,$authchk);
       ($authparam,
        $create_passwd,
        $authchk) = &localenroll::create_password($authparam,$cdom);
   
       &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n",
      $userinput);
   
   
       return 1;
   }
   &register_handler("autocreatepassword", \&create_auto_enroll_password_handler, 
     0, 1, 0);
   
   #   Retrieve and remove temporary files created by/during autoenrollment.
   #
   # Formal Parameters:
   #    $cmd      - The command that got us dispatched.
   #    $tail     - The tail of the command.  In our case this is a colon 
   #                separated list that will be split into:
   #                $filename - The name of the file to remove.
   #                            The filename is given as a path relative to
   #                            the LonCAPA temp file directory.
   #    $client   - Socket open on the client.
   #
   # Returns:
   #   1     - Continue processing.
   sub retrieve_auto_file_handler {
       my ($cmd, $tail, $client)    = @_;
       my $userinput                = "cmd:$tail";
   
       my ($filename)   = split(/:/, $tail);
   
       my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
       if ( (-e $source) && ($filename ne '') ) {
    my $reply = '';
    if (open(my $fh,$source)) {
       while (<$fh>) {
    chomp($_);
    $_ =~ s/^\s+//g;
    $_ =~ s/\s+$//g;
    $reply .= $_;
       }
       close($fh);
       &Reply($client, &escape($reply)."\n", $userinput);
   
   #   Does this have to be uncommented??!?  (RF).
   #
   #                                unlink($source);
    } else {
       &Failure($client, "error\n", $userinput);
    }
       } else {
    &Failure($client, "error\n", $userinput);
       }
       
   
       return 1;
   }
   &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
   
   #
   #   Read and retrieve institutional code format (for support form).
   # Formal Parameters:
   #    $cmd        - Command that dispatched us.
   #    $tail       - Tail of the command.  In this case it conatins 
   #                  the course domain and the coursename.
   #    $client     - Socket open on the client.
   # Returns:
   #    1     - Continue processing.
   #
   sub get_institutional_code_format_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
   
       my $reply;
       my($cdom,$course) = split(/:/,$tail);
       my @pairs = split/\&/,$course;
       my %instcodes = ();
       my %codes = ();
       my @codetitles = ();
       my %cat_titles = ();
       my %cat_order = ();
       foreach (@pairs) {
    my ($key,$value) = split/=/,$_;
    $instcodes{&unescape($key)} = &unescape($value);
       }
       my $formatreply = &localenroll::instcode_format($cdom,
       \%instcodes,
       \%codes,
       \@codetitles,
       \%cat_titles,
       \%cat_order);
       if ($formatreply eq 'ok') {
    my $codes_str = &hash2str(%codes);
    my $codetitles_str = &array2str(@codetitles);
    my $cat_titles_str = &hash2str(%cat_titles);
    my $cat_order_str = &hash2str(%cat_order);
    &Reply($client,
          $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
          .$cat_order_str."\n",
          $userinput);
       } else {
    # this else branch added by RF since if not ok, lonc will
    # hang waiting on reply until timeout.
    #
    &Reply($client, "format_error\n", $userinput);
       }
       
       return 1;
   }
   &register_handler("autoinstcodeformat",
     \&get_institutional_code_format_handler,0,1,0);
   
   #
   # Gets a student's photo to exist (in the correct image type) in the user's 
   # directory.
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - A colon separated set of words that will be split into:
   #               $domain - student's domain
   #               $uname  - student username
   #               $type   - image type desired
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   sub student_photo_handler {
       my ($cmd, $tail, $client) = @_;
       my ($domain,$uname,$type) = split(/:/, $tail);
   
       my $path=&propath($domain,$uname).
    '/userfiles/internal/studentphoto.'.$type;
       if (-e $path) {
    &Reply($client,"ok\n","$cmd:$tail");
    return 1;
       }
       &mkpath($path);
       my $file=&localstudentphoto::fetch($domain,$uname);
       if (!$file) {
    &Failure($client,"unavailable\n","$cmd:$tail");
    return 1;
       }
       if (!-e $path) { &convert_photo($file,$path); }
       if (-e $path) {
    &Reply($client,"ok\n","$cmd:$tail");
    return 1;
       }
       &Failure($client,"unable_to_convert\n","$cmd:$tail");
       return 1;
   }
   &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
   
   # mkpath makes all directories for a file, expects an absolute path with a
   # file or a trailing / if just a dir is passed
   # returns 1 on success 0 on failure
   sub mkpath {
       my ($file)=@_;
       my @parts=split(/\//,$file,-1);
       my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
       for (my $i=3;$i<= ($#parts-1);$i++) {
    $now.='/'.$parts[$i]; 
    if (!-e $now) {
       if  (!mkdir($now,0770)) { return 0; }
    }
       }
       return 1;
   }
   
 #---------------------------------------------------------------  #---------------------------------------------------------------
 #  #
 #   Getting, decoding and dispatching requests:  #   Getting, decoding and dispatching requests:
 #  #
   
 #  #
 #   Get a Request:  #   Get a Request:
 #   Gets a Request message from the client.  The transaction  #   Gets a Request message from the client.  The transaction
Line 3413  sub process_request { Line 4061  sub process_request {
  $userinput = decipher($userinput);   $userinput = decipher($userinput);
  $wasenc=1;   $wasenc=1;
  if(!$userinput) { # Cipher not defined.   if(!$userinput) { # Cipher not defined.
     &Failure($client, "error: Encrypted data without negotated key");      &Failure($client, "error: Encrypted data without negotated key\n");
     return 0;      return 0;
  }   }
     }      }
Line 3483  sub process_request { Line 4131  sub process_request {
   
     }          }    
   
 #------------------- Commands not yet in spearate handlers. --------------      print $client "unknown_cmd\n";
   
   
   
 # ----------------------------------------------------------------- setannounce  
     if ($userinput =~ /^setannounce/) {  
  if (isClient) {  
     my ($cmd,$announcement)=split(/:/,$userinput);  
     chomp($announcement);  
     $announcement=&unescape($announcement);  
     if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.  
  '/announcement.txt')) {  
  print $store $announcement;  
  close $store;  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)."\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------ Hanging up  
     } elsif (($userinput =~ /^exit/) ||  
      ($userinput =~ /^init/)) { # no restrictions.  
  &logthis(  
  "Client $clientip ($clientname) hanging up: $userinput");  
  print $client "bye\n";  
  $client->shutdown(2);        # shutdown the socket forcibly.  
  $client->close();  
  return 0;  
   
 # ---------------------------------- set current host/domain  
     } elsif ($userinput =~ /^sethost/) {  
  if (isClient) {  
     print $client &sethost($userinput)."\n";  
  } else {  
     print $client "refused\n";  
  }  
 #---------------------------------- request file (?) version.  
     } elsif ($userinput =~/^version/) {  
  if (isClient) {  
     print $client &version($userinput)."\n";  
  } else {  
     print $client "refused\n";  
  }  
 #------------------------------- is auto-enrollment enabled?  
     } elsif ($userinput =~/^autorun/) {  
  if (isClient) {  
     my ($cmd,$cdom) = split(/:/,$userinput);  
     my $outcome = &localenroll::run($cdom);  
     print $client "$outcome\n";  
  } else {  
     print $client "0\n";  
  }  
 #------------------------------- get official sections (for auto-enrollment).  
     } elsif ($userinput =~/^autogetsections/) {  
  if (isClient) {  
     my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);  
     my @secs = &localenroll::get_sections($coursecode,$cdom);  
     my $seclist = &escape(join(':',@secs));  
     print $client "$seclist\n";  
  } else {  
     print $client "refused\n";  
  }  
 #----------------------- validate owner of new course section (for auto-enrollment).  
     } elsif ($userinput =~/^autonewcourse/) {  
  if (isClient) {  
     my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);  
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);  
     print $client "$outcome\n";  
  } else {  
     print $client "refused\n";  
  }  
 #-------------- validate course section in schedule of classes (for auto-enrollment).  
     } elsif ($userinput =~/^autovalidatecourse/) {  
  if (isClient) {  
     my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);  
     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);  
     print $client "$outcome\n";  
  } else {  
     print $client "refused\n";  
  }  
 #--------------------------- create password for new user (for auto-enrollment).  
     } elsif ($userinput =~/^autocreatepassword/) {  
  if (isClient) {  
     my ($cmd,$authparam,$cdom)=split(/:/,$userinput);  
     my ($create_passwd,$authchk);  
     ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);  
     print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";  
  } else {  
     print $client "refused\n";  
  }  
 #---------------------------  read and remove temporary files (for auto-enrollment).  
     } elsif ($userinput =~/^autoretrieve/) {  
  if (isClient) {  
     my ($cmd,$filename) = split(/:/,$userinput);  
     my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;  
     if ( (-e $source) && ($filename ne '') ) {  
  my $reply = '';  
  if (open(my $fh,$source)) {  
     while (<$fh>) {  
  chomp($_);  
  $_ =~ s/^\s+//g;  
  $_ =~ s/\s+$//g;  
  $reply .= $_;  
     }  
     close($fh);  
     print $client &escape($reply)."\n";  
 #                                unlink($source);  
  } else {  
     print $client "error\n";  
  }  
     } else {  
  print $client "error\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
 #---------------------  read and retrieve institutional code format (for support form).  
     } elsif ($userinput =~/^autoinstcodeformat/) {  
  if (isClient) {  
     my $reply;  
     my($cmd,$cdom,$course) = split(/:/,$userinput);  
     my @pairs = split/\&/,$course;  
     my %instcodes = ();  
     my %codes = ();  
     my @codetitles = ();  
     my %cat_titles = ();  
     my %cat_order = ();  
     foreach (@pairs) {  
  my ($key,$value) = split/=/,$_;  
  $instcodes{&unescape($key)} = &unescape($value);  
     }  
     my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);  
     if ($formatreply eq 'ok') {  
  my $codes_str = &hash2str(%codes);  
  my $codetitles_str = &array2str(@codetitles);  
  my $cat_titles_str = &hash2str(%cat_titles);  
  my $cat_order_str = &hash2str(%cat_order);  
  print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
 # ------------------------------------------------------------- unknown command  
   
     } else {  
  # unknown command  
  print $client "unknown_cmd\n";  
     }  
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
     Debug("process_request - returning 1");      Debug("process_request - returning 1");
     return 1;      return 1;
Line 3895  sub ReadHostTable { Line 4393  sub ReadHostTable {
     my $myloncapaname = $perlvar{'lonHostID'};      my $myloncapaname = $perlvar{'lonHostID'};
     Debug("My loncapa name is : $myloncapaname");      Debug("My loncapa name is : $myloncapaname");
     while (my $configline=<CONFIG>) {      while (my $configline=<CONFIG>) {
  if (!($configline =~ /^\s*\#/)) {   if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name)=split(/:/,$configline);
     chomp($ip); $ip=~s/\D+$//;      $name=~s/\s//g;
       my $ip = gethostbyname($name);
       if (length($ip) ne 4) {
    &logthis("Skipping host $id name $name no IP $ip found\n");
    next;
       }
       $ip=inet_ntoa($ip);
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.      $hostid{$ip}=$id;         # LonCAPA name of host by IP.
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.       $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
     $hostip{$id}=$ip;      # IP address of host.      $hostip{$id}=$ip;         # IP address of host.
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.      $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
   
     if ($id eq $perlvar{'lonHostID'}) {       if ($id eq $perlvar{'lonHostID'}) { 
Line 4037  sub Reply { Line 4541  sub Reply {
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
     $Transactions++;      $Transactions++;
   
   
 }  }
   
   
Line 4081  sub logstatus { Line 4583  sub logstatus {
  flock(LOG,LOCK_EX);   flock(LOG,LOCK_EX);
  print LOG $$."\t".$clientname."\t".$currenthostid."\t"   print LOG $$."\t".$clientname."\t".$currenthostid."\t"
     .$status."\t".$lastlog."\t $keymode\n";      .$status."\t".$lastlog."\t $keymode\n";
  flock(DB,LOCK_UN);   flock(LOG,LOCK_UN);
  close(LOG);   close(LOG);
     }      }
     &status("Finished logging");      &status("Finished logging");
Line 4312  sub make_new_child { Line 4814  sub make_new_child {
     if (defined($iaddr)) {      if (defined($iaddr)) {
  $clientip  = inet_ntoa($iaddr);   $clientip  = inet_ntoa($iaddr);
  Debug("Connected with $clientip");   Debug("Connected with $clientip");
  $clientdns = gethostbyaddr($iaddr, AF_INET);  
  Debug("Connected with $clientdns by name");  
     } else {      } else {
  &logthis("Unable to determine clientip");   &logthis("Unable to determine clientip");
  $clientip='Unavailable';   $clientip='Unavailable';
Line 4353  sub make_new_child { Line 4853  sub make_new_child {
   
  ReadManagerTable; # May also be a manager!!   ReadManagerTable; # May also be a manager!!
   
  my $clientrec=($hostid{$clientip}     ne undef);   my $outsideip=$clientip;
  my $ismanager=($managers{$clientip}    ne undef);   if ($clientip eq '127.0.0.1') {
       $outsideip=$hostip{$perlvar{'lonHostID'}};
    }
   
    my $clientrec=($hostid{$outsideip}     ne undef);
    my $ismanager=($managers{$outsideip}    ne undef);
  $clientname  = "[unknonwn]";   $clientname  = "[unknonwn]";
  if($clientrec) { # Establish client type.   if($clientrec) { # Establish client type.
     $ConnectionType = "client";      $ConnectionType = "client";
     $clientname = $hostid{$clientip};      $clientname = $hostid{$outsideip};
     if($ismanager) {      if($ismanager) {
  $ConnectionType = "both";   $ConnectionType = "both";
     }      }
  } else {   } else {
     $ConnectionType = "manager";      $ConnectionType = "manager";
     $clientname = $managers{$clientip};      $clientname = $managers{$outsideip};
  }   }
  my $clientok;   my $clientok;
   
Line 4508  sub make_new_child { Line 5013  sub make_new_child {
     exit;      exit;
           
 }  }
   #
   #   Determine if a user is an author for the indicated domain.
   #
   # Parameters:
   #    domain          - domain to check in .
   #    user            - Name of user to check.
   #
   # Return:
   #     1             - User is an author for domain.
   #     0             - User is not an author for domain.
   sub is_author {
       my ($domain, $user) = @_;
   
       &Debug("is_author: $user @ $domain");
   
       my $hashref = &tie_user_hash($domain, $user, "roles",
    &GDBM_READER());
   
       #  Author role should show up as a key /domain/_au
   
       my $key   = "/$domain/_au";
       my $value = $hashref->{$key};
   
       if(defined($value)) {
    &Debug("$user @ $domain is an author");
       }
   
       return defined($value);
   }
 #  #
 #   Checks to see if the input roleput request was to set  #   Checks to see if the input roleput request was to set
 # an author role.  If so, invokes the lchtmldir script to set  # an author role.  If so, invokes the lchtmldir script to set
Line 4524  sub make_new_child { Line 5056  sub make_new_child {
 sub manage_permissions  sub manage_permissions
 {  {
   
   
     my ($request, $domain, $user, $authtype) = @_;      my ($request, $domain, $user, $authtype) = @_;
   
       &Debug("manage_permissions: $request $domain $user $authtype");
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
  &logthis("system $execdir/lchtmldir $userhome $user $authtype");   &logthis("system $execdir/lchtmldir $userhome $user $authtype");
    &Debug("Setting homedir permissions for $userhome");
  system("$execdir/lchtmldir $userhome $user $authtype");   system("$execdir/lchtmldir $userhome $user $authtype");
     }      }
 }  }
Line 4546  sub manage_permissions Line 5082  sub manage_permissions
 #  #
 sub password_path {  sub password_path {
     my ($domain, $user) = @_;      my ($domain, $user) = @_;
       return &propath($domain, $user).'/passwd';
   
     my $path   = &propath($domain, $user);  
     $path  .= "/passwd";  
   
     return $path;  
 }  }
   
 #   Password Filename  #   Password Filename
Line 4626  sub get_auth_type Line 5157  sub get_auth_type
  Debug("Password info = $realpassword\n");   Debug("Password info = $realpassword\n");
  my ($authtype, $contentpwd) = split(/:/, $realpassword);   my ($authtype, $contentpwd) = split(/:/, $realpassword);
  Debug("Authtype = $authtype, content = $contentpwd\n");   Debug("Authtype = $authtype, content = $contentpwd\n");
  my $availinfo = '';   return "$authtype:$contentpwd";     
  if($authtype eq 'krb4' or $authtype eq 'krb5') {  
     $availinfo = $contentpwd;  
  }  
   
  return "$authtype:$availinfo";  
     } else {      } else {
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
Line 4664  sub validate_user { Line 5190  sub validate_user {
     # At the end of this function. I'll ensure that it's not still that      # At the end of this function. I'll ensure that it's not still that
     # value so we don't just wind up returning some accidental value      # value so we don't just wind up returning some accidental value
     # as a result of executing an unforseen code path that      # as a result of executing an unforseen code path that
     # did not set $validated.      # did not set $validated.  At the end of valid execution paths,
       # validated shoule be 1 for success or 0 for failuer.
   
     my $validated = -3.14159;      my $validated = -3.14159;
   
Line 4728  sub validate_user { Line 5255  sub validate_user {
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);   my $krbserver  = &Authen::Krb5::parse_name($krbservice);
  my $credentials= &Authen::Krb5::cc_default();   my $credentials= &Authen::Krb5::cc_default();
  $credentials->initialize($krbclient);   $credentials->initialize($krbclient);
  my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,   my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,
  $krbserver,   $krbserver,
  $password,   $password,
  $credentials);   $credentials);
Line 4752  sub validate_user { Line 5279  sub validate_user {
     #      #
   
     unless ($validated != -3.14159) {      unless ($validated != -3.14159) {
  die "ValidateUser - failed to set the value of validated";   #  I >really really< want to know if this happens.
    #  since it indicates that user authentication is badly
    #  broken in some code path.
           #
    die "ValidateUser - failed to set the value of validated $domain, $user $password";
     }      }
     return $validated;      return $validated;
 }  }
Line 4975  sub make_passwd_file { Line 5506  sub make_passwd_file {
     if ($umode eq 'krb4' or $umode eq 'krb5') {      if ($umode eq 'krb4' or $umode eq 'krb5') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     print $pf "$umode:$npass\n";      if ($pf) {
    print $pf "$umode:$npass\n";
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } elsif ($umode eq 'internal') {      } elsif ($umode eq 'internal') {
  my $salt=time;   my $salt=time;
Line 4984  sub make_passwd_file { Line 5519  sub make_passwd_file {
  {   {
     &Debug("Creating internal auth");      &Debug("Creating internal auth");
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     print $pf "internal:$ncpass\n";       if($pf) {
    print $pf "internal:$ncpass\n"; 
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } elsif ($umode eq 'localauth') {      } elsif ($umode eq 'localauth') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     print $pf "localauth:$npass\n";      if($pf) {
    print $pf "localauth:$npass\n";
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   {
Line 5015  sub make_passwd_file { Line 5558  sub make_passwd_file {
  print $se "$npass\n";   print $se "$npass\n";
  print $se "$lc_error_file\n"; # Status -> unique file.   print $se "$lc_error_file\n"; # Status -> unique file.
     }      }
     my $error = IO::File->new("< $lc_error_file");      if (-r $lc_error_file) {
     my $useraddok = <$error>;   &Debug("Opening error file: $lc_error_file");
     $error->close;   my $error = IO::File->new("< $lc_error_file");
     unlink($lc_error_file);   my $useraddok = <$error>;
    $error->close;
     chomp $useraddok;   unlink($lc_error_file);
   
     if($useraddok > 0) {   chomp $useraddok;
  my $error_text = &lcuseraddstrerror($useraddok);  
  &logthis("Failed lcuseradd: $error_text");   if($useraddok > 0) {
  $result = "lcuseradd_failed:$error_text\n";      my $error_text = &lcuseraddstrerror($useraddok);
       &logthis("Failed lcuseradd: $error_text");
       $result = "lcuseradd_failed:$error_text\n";
    }  else {
       my $pf = IO::File->new(">$passfilename");
       if($pf) {
    print $pf "unix:\n";
       } else {
    $result = "pass_file_failed_error";
       }
    }
     }  else {      }  else {
  my $pf = IO::File->new(">$passfilename");   &Debug("Could not locate lcuseradd error: $lc_error_file");
  print $pf "unix:\n";   $result="bug_lcuseradd_no_output_file";
     }      }
  }   }
     } elsif ($umode eq 'none') {      } elsif ($umode eq 'none') {
  {   {
     my $pf = IO::File->new("> $passfilename");      my $pf = IO::File->new("> $passfilename");
     print $pf "none:\n";      if($pf) {
    print $pf "none:\n";
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } else {      } else {
  $result="auth_mode_error\n";   $result="auth_mode_error\n";
Line 5042  sub make_passwd_file { Line 5599  sub make_passwd_file {
     return $result;      return $result;
 }  }
   
   sub convert_photo {
       my ($start,$dest)=@_;
       system("convert $start $dest");
   }
   
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
Removed from v.1.245  
changed lines
  Added in v.1.285

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

Internal Server Error

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

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

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