Diff for /loncom/lond between versions 1.432 and 1.489.2.14

version 1.432, 2009/10/29 03:23:52 version 1.489.2.14, 2014/04/30 23:16:03
Line 15 Line 15
 #  #
 # LON-CAPA is distributed in the hope that it will be useful,  # LON-CAPA is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of  # but WITHOUT ANY WARRANTY; without even the implied warranty of
   
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.  # GNU General Public License for more details.
 #  #
Line 33  use strict; Line 34  use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use LONCAPA;  use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   use LONCAPA::Lond;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
Line 42  use Crypt::IDEA; Line 44  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
 use Digest::MD5 qw(md5_hex);  use Digest::MD5 qw(md5_hex);
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  
 use Authen::Krb5;  use Authen::Krb5;
 use localauth;  use localauth;
 use localenroll;  use localenroll;
Line 53  use LONCAPA::lonlocal; Line 54  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::lonnet;  use Apache::lonnet;
   use Mail::Send;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
Line 67  my $currentdomainid; Line 69  my $currentdomainid;
 my $client;  my $client;
 my $clientip; # IP address of client.  my $clientip; # IP address of client.
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
 my $clientversion;              # LonCAPA version running on client  my $clientversion;              # LonCAPA version running on client.
   my $clienthomedom;              # LonCAPA domain of homeID for client. 
                                   # primary library server. 
   
 my $server;  my $server;
   
Line 89  my %managers;   # Ip -> manager names Line 93  my %managers;   # Ip -> manager names
   
 my %perlvar; # Will have the apache conf defined perl vars.  my %perlvar; # Will have the apache conf defined perl vars.
   
   my $dist;
   
 #  #
 #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.  #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.
 #    Each element of the hash contains a reference to an array that contains:  #    Each element of the hash contains a reference to an array that contains:
Line 124  my @passwderrors = ("ok", Line 130  my @passwderrors = ("ok",
    "pwchange_failure - lcpasswd Error filename is invalid");     "pwchange_failure - lcpasswd Error filename is invalid");
   
   
 #  The array below are lcuseradd error strings.:  
   
 my $lastadderror = 13;  
 my @adderrors    = ("ok",  
     "User ID mismatch, lcuseradd must run as user www",  
     "lcuseradd Incorrect number of command line parameters must be 3",  
     "lcuseradd Incorrect number of stdinput lines, must be 3",  
     "lcuseradd Too many other simultaneous pwd changes in progress",  
     "lcuseradd User does not exist",  
     "lcuseradd Unable to make www member of users's group",  
     "lcuseradd Unable to su to root",  
     "lcuseradd Unable to set password",  
     "lcuseradd Username has invalid characters",  
     "lcuseradd Password has an invalid character",  
     "lcuseradd User already exists",  
     "lcuseradd Could not add user.",  
     "lcuseradd Password mismatch");  
   
   
 # This array are the errors from lcinstallfile:  # This array are the errors from lcinstallfile:
   
 my @installerrors = ("ok",  my @installerrors = ("ok",
      "Initial user id of client not that of www",       "Initial user id of client not that of www",
      "Usage error, not enough command line arguments",       "Usage error, not enough command line arguments",
      "Source file name does not exist",       "Source filename does not exist",
      "Destination file name does not exist",       "Destination filename does not exist",
      "Some file operation failed",       "Some file operation failed",
      "Invalid table filename."       "Invalid table filename."
      );       );
Line 418  sub ReadManagerTable { Line 405  sub ReadManagerTable {
   
    my $tablename = $perlvar{'lonTabDir'}."/managers.tab";     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
    if (!open (MANAGERS, $tablename)) {     if (!open (MANAGERS, $tablename)) {
       logthis('<font color="red">No manager table.  Nobody can manage!!</font>');         my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
       return;         if (&Apache::lonnet::is_LC_dns($hostname)) {
              &logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
          }
          return;
    }     }
    while(my $host = <MANAGERS>) {     while(my $host = <MANAGERS>) {
       chomp($host);        chomp($host);
Line 444  sub ReadManagerTable { Line 434  sub ReadManagerTable {
          }           }
       } else {        } else {
          logthis('<font color="green"> existing host'." $host</font>\n");           logthis('<font color="green"> existing host'." $host</font>\n");
          $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if clumemeber           $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if cluster memeber
       }        }
    }     }
 }  }
Line 506  sub AdjustHostContents { Line 496  sub AdjustHostContents {
     my $me        = $perlvar{'lonHostID'};      my $me        = $perlvar{'lonHostID'};
   
     foreach my $line (split(/\n/,$contents)) {      foreach my $line (split(/\n/,$contents)) {
  if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {   if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) ||
                ($line =~ /^\s*\^/))) {
     chomp($line);      chomp($line);
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);      my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
     if ($id eq $me) {      if ($id eq $me) {
Line 594  sub InstallFile { Line 585  sub InstallFile {
 #  #
 #   ConfigFileFromSelector: converts a configuration file selector  #   ConfigFileFromSelector: converts a configuration file selector
 #                 into a configuration file pathname.  #                 into a configuration file pathname.
 #                 It's probably no longer necessary to preserve  #                 Supports the following file selectors: 
 #                 special handling of hosts or domain as those  #                 hosts, domain, dns_hosts, dns_domain  
 #                 files have been superceded by dns_hosts, dns_domain.  
 #                 The default action is just to prepend the directory  
 #                 and append .tab  
 #  #
 #  #
 #  Parameters:  #  Parameters:
Line 611  sub ConfigFileFromSelector { Line 599  sub ConfigFileFromSelector {
     my $tablefile;      my $tablefile;
   
     my $tabledir = $perlvar{'lonTabDir'}.'/';      my $tabledir = $perlvar{'lonTabDir'}.'/';
     if ($selector eq "hosts") {      if (($selector eq "hosts") || ($selector eq "domain") || 
  $tablefile = $tabledir."hosts.tab";          ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {
     } elsif ($selector eq "domain") {  
  $tablefile = $tabledir."domain.tab";  
     } else {  
  $tablefile =  $tabledir.$selector.'.tab';   $tablefile =  $tabledir.$selector.'.tab';
     }      }
     return $tablefile;      return $tablefile;
   
 }  }
 #  #
 #   PushFile:  Called to do an administrative push of a file.  #   PushFile:  Called to do an administrative push of a file.
Line 645  sub PushFile { Line 629  sub PushFile {
     #  supported:      #  supported:
     #   hosts.tab  ($filename eq host).      #   hosts.tab  ($filename eq host).
     #   domain.tab ($filename eq domain).      #   domain.tab ($filename eq domain).
       #   dns_hosts.tab ($filename eq dns_host).
       #   dns_domain.tab ($filename eq dns_domain). 
     # Construct the destination filename or reject the request.      # Construct the destination filename or reject the request.
     #      #
     # lonManage is supposed to ensure this, however this session could be      # lonManage is supposed to ensure this, however this session could be
Line 676  sub PushFile { Line 662  sub PushFile {
  return "error:$!";   return "error:$!";
     } else {      } else {
  &logthis('<font color="green"> Installed new '.$tablefile   &logthis('<font color="green"> Installed new '.$tablefile
  ."</font>");   ." - transaction by: $clientname ($clientip)</font>");
           my $adminmail = $perlvar{'lonAdmEMail'};
           my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
           if ($admindom ne '') {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
               if (ref($domconfig{'contacts'}) eq 'HASH') {
                   if ($domconfig{'contacts'}{'adminemail'} ne '') {
                       $adminmail = $domconfig{'contacts'}{'adminemail'};
                   }
               }
           }
           if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
               my $msg = new Mail::Send;
               $msg->to($adminmail);
               $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
               $msg->add('Content-type','text/plain; charset=UTF-8');
               if (my $fh = $msg->open()) {
                   print $fh 'Update to '.$tablefile.' from Cluster Manager '.
                             "$clientname ($clientip)\n";
                   $fh->close;
               }
           }
     }      }
   
   
     #  Indicate success:      #  Indicate success:
     
     return "ok";      return "ok";
Line 976  sub read_profile { Line 982  sub read_profile {
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my @queries=split(/\&/,$what);          my @queries=split(/\&/,$what);
           if ($namespace eq 'roles') {
               @queries = map { &unescape($_); } @queries; 
           }
         my $qresult='';          my $qresult='';
   
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
Line 1069  sub pong_handler { Line 1078  sub pong_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit.  #      0       - Program should exit.
Line 1108  sub establish_key_handler { Line 1117  sub establish_key_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit.  #      0       - Program should exit.
Line 1117  sub establish_key_handler { Line 1126  sub establish_key_handler {
 sub load_handler {  sub load_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
   
   
    # Get the load average from /proc/loadavg and calculate it as a percentage of     # Get the load average from /proc/loadavg and calculate it as a percentage of
    # the allowed load limit as set by the perl global variable lonLoadLim     # the allowed load limit as set by the perl global variable lonLoadLim
   
Line 1145  sub load_handler { Line 1156  sub load_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit  #      0       - Program should exit
Line 1614  sub ls3_handler { Line 1625  sub ls3_handler {
 }  }
 &register_handler("ls3", \&ls3_handler, 0, 1, 0);  &register_handler("ls3", \&ls3_handler, 0, 1, 0);
   
   sub read_lonnet_global {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $requested = &Apache::lonnet::thaw_unescape($tail);
       my $result;
       my %packagevars = (
                           spareid => \%Apache::lonnet::spareid,
                           perlvar => \%Apache::lonnet::perlvar,
                         );
       my %limit_to = (
                       perlvar => {
                                    lonOtherAuthen => 1,
                                    lonBalancer    => 1,
                                    lonVersion     => 1,
                                    lonSysEMail    => 1,
                                    lonHostID      => 1,
                                    lonRole        => 1,
                                    lonDefDomain   => 1,
                                    lonLoadLim     => 1,
                                    lonUserLoadLim => 1,
                                  }
                     );
       if (ref($requested) eq 'HASH') {
           foreach my $what (keys(%{$requested})) {
               my $response;
               my $items = {};
               if (exists($packagevars{$what})) {
                   if (ref($limit_to{$what}) eq 'HASH') {
                       foreach my $varname (keys(%{$packagevars{$what}})) {
                           if ($limit_to{$what}{$varname}) {
                               $items->{$varname} = $packagevars{$what}{$varname};
                           }
                       }
                   } else {
                       $items = $packagevars{$what};
                   }
                   if ($what eq 'perlvar') {
                       if (!exists($packagevars{$what}{'lonBalancer'})) {
                           if ($dist =~ /^(centos|rhes|fedora|scientific)/) {
                               my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
                               if (ref($othervarref) eq 'HASH') {
                                   $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
                               }
                           }
                       }
                   }
                   $response = &Apache::lonnet::freeze_escape($items);
               }
               $result .= &escape($what).'='.$response.'&';
           }
       }
       $result =~ s/\&$//;
       &Reply($client,\$result,$userinput);
       return 1;
   }
   &register_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);
   
   sub server_devalidatecache_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $items = &unescape($tail);
       my @cached = split(/\&/,$items);
       foreach my $key (@cached) {
           if ($key =~ /:/) {
               my ($name,$id) = map { &unescape($_); } split(/:/,$key);
               &Apache::lonnet::devalidate_cache_new($name,$id);
           }
       }
       my $result = 'ok';
       &Reply($client,\$result,$userinput);
       return 1;
   }
   &register_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);
   
 sub server_timezone_handler {  sub server_timezone_handler {
     my ($cmd,$tail,$client) = @_;      my ($cmd,$tail,$client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
Line 1654  sub server_loncaparev_handler { Line 1739  sub server_loncaparev_handler {
 }  }
 &register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);  &register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);
   
   sub server_homeID_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       &Reply($client,\$perlvar{'lonHostID'},$userinput);
       return 1;
   }
   &register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);
   
   sub server_distarch_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $reply = &distro_and_arch();
       &Reply($client,\$reply,$userinput);
       return 1;
   }
   &register_handler("serverdistarch", \&server_distarch_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 1763  sub authenticate_handler { Line 1865  sub authenticate_handler {
     #  upass   - User's password.      #  upass   - User's password.
     #  checkdefauth - Pass to validate_user() to try authentication      #  checkdefauth - Pass to validate_user() to try authentication
     #                 with default auth type(s) if no user account.      #                 with default auth type(s) if no user account.
       #  clientcancheckhost - Passed by clients with functionality in lonauth.pm
       #                       to check if session can be hosted.
           
     my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);      my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
     &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");      &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");
     chomp($upass);      chomp($upass);
     $upass=&unescape($upass);      $upass=&unescape($upass);
   
     my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);      my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
     if($pwdcorrect) {      if($pwdcorrect) {
  &Reply( $client, "authorized\n", $userinput);          my $canhost = 1;
           unless ($clientcancheckhost) {
               my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
               my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
               my @intdoms;
               my $internet_names = &Apache::lonnet::get_internet_names($clientname);
               if (ref($internet_names) eq 'ARRAY') {
                   @intdoms = @{$internet_names};
               }
               unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
                   my ($remote,$hosted);
                   my $remotesession = &get_usersession_config($udom,'remotesession');
                   if (ref($remotesession) eq 'HASH') {
                       $remote = $remotesession->{'remote'}
                   }
                   my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
                   if (ref($hostedsession) eq 'HASH') {
                       $hosted = $hostedsession->{'hosted'};
                   }
                   my $loncaparev = $clientversion;
                   if ($loncaparev eq '') {
                       $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
                   }
                   $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
                                                                $loncaparev,
                                                                $remote,$hosted);
               }
           }
           if ($canhost) {               
               &Reply( $client, "authorized\n", $userinput);
           } else {
               &Reply( $client, "not_allowed_to_host\n", $userinput);
           }
  #   #
  #  Bad credentials: Failed to authorize   #  Bad credentials: Failed to authorize
  #   #
Line 1925  sub add_user_handler { Line 2061  sub add_user_handler {
     ."makeuser";      ."makeuser";
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename);
  &Reply($client,\$result, $userinput);     #BUGBUG - could be fail   &Reply($client,\$result, $userinput);     #BUGBUG - could be fail
     } else {      } else {
  &Failure($client, \$fperror, $userinput);   &Failure($client, \$fperror, $userinput);
Line 1986  sub change_authentication_handler { Line 2122  sub change_authentication_handler {
  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!!
     # If just changing the unix passwd. need to arrange to run      # If just changing the unix passwd. need to arrange to run
     # passwd since otherwise make_passwd_file will run      # passwd since otherwise make_passwd_file will fail as 
     # lcuseradd which fails if an account already exists      # creation of unix authenticated users is no longer supported
     # (to prevent an unscrupulous LONCAPA admin from stealing              # except from the command line, when running make_domain_coordinator.pl
     # an existing account by overwriting it as a LonCAPA account).  
   
     if(($oldauth =~/^unix/) && ($umode eq "unix")) {      if(($oldauth =~/^unix/) && ($umode eq "unix")) {
  my $result = &change_unix_password($uname, $npass);   my $result = &change_unix_password($uname, $npass);
Line 2000  sub change_authentication_handler { Line 2135  sub change_authentication_handler {
     &Failure($client, \$result);      &Failure($client, \$result);
  }   }
     } else {      } else {
  my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);   my $result=&make_passwd_file($uname,$udom,$umode,$npass,$passfilename);
  #   #
  #  If the current auth mode is internal, and the old auth mode was   #  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,   #  unix, or krb*,  and the user is an author for this domain,
  #  re-run manage_permissions for that role in order to be able   #  re-run manage_permissions for that role in order to be able
  #  to take ownership of the construction space back to www:www   #  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);
     }      }
                 
Line 2062  sub is_home_handler { Line 2190  sub is_home_handler {
 &register_handler("home", \&is_home_handler, 0,1,0);  &register_handler("home", \&is_home_handler, 0,1,0);
   
 #  #
 #   Process an update request for a resource?? I think what's going on here is  #   Process an update request for a resource.
 #   that a resource has been modified that we hold a subscription to.  #   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  #   If the resource is not local, then we must update, or at least invalidate our
 #   cached copy of the resource.   #   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:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
 #    $tail     - Tail of the command (remaining parameters).  #    $tail     - Tail of the command (remaining parameters).
Line 2095  sub update_resource_handler { Line 2217  sub update_resource_handler {
     my $ownership=ishome($fname);      my $ownership=ishome($fname);
     if ($ownership eq 'not_owner') {      if ($ownership eq 'not_owner') {
  if (-e $fname) {   if (-e $fname) {
               # Delete preview file, if exists
               unlink("$fname.tmp");
               # Get usage stats
     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
     my $now=time;      my $now=time;
     my $since=$now-$atime;      my $since=$now-$atime;
               # If the file has not been used within lonExpire seconds,
               # unsubscribe from it and delete local copy
     if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");   my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
  &devalidate_meta_cache($fname);   &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
  unlink("$fname.meta");   unlink("$fname.meta");
     } else {      } else {
               # Yes, this is in active use. Get a fresh copy. Since it might be in
               # very active use and huge (like a movie), copy it to "in.transfer" filename first.
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
  alarm(120);  # FIXME: cannot replicate files that take more than two minutes to transfer?
   # alarm(120);
   # FIXME: this should use the LWP mechanism, not internal alarms.
                   alarm(1200);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',"$remoteurl");      my $request=new HTTP::Request('GET',"$remoteurl");
Line 2116  sub update_resource_handler { Line 2248  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
  if ($response->is_error()) {   if ($response->is_error()) {
   # FIXME: we should probably clean up here instead of just whine
     unlink($transname);      unlink($transname);
     my $message=$response->status_line;      my $message=$response->status_line;
     &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
  } else {   } else {
     if ($remoteurl!~/\.meta$/) {      if ($remoteurl!~/\.meta$/) {
   # FIXME: isn't there an internal LWP mechanism for this?
  alarm(120);   alarm(120);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
Line 2132  sub update_resource_handler { Line 2266  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
     }      }
                       # we successfully transfered, copy file over to real name
     rename($transname,$fname);      rename($transname,$fname);
     &devalidate_meta_cache($fname);      &devalidate_meta_cache($fname);
  }   }
Line 2193  sub fetch_user_file_handler { Line 2328  sub fetch_user_file_handler {
   
  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 $clientprotocol=$Apache::lonnet::protocol{$clientname};
           $clientprotocol = 'http' if ($clientprotocol ne 'https');
    my $clienthost = &Apache::lonnet::hostname($clientname);
    my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
  my $response;   my $response;
  Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");   Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
  alarm(120);   alarm(120);
Line 2215  sub fetch_user_file_handler { Line 2353  sub fetch_user_file_handler {
  unlink($transname);   unlink($transname);
  &Failure($client, "failed\n", $userinput);   &Failure($client, "failed\n", $userinput);
     } else {      } else {
                   if ($fname =~ /^default.+\.(page|sequence)$/) {
                       my ($major,$minor) = split(/\./,$clientversion);
                       if (($major < 2) || ($major == 2 && $minor < 11)) {
                           my $now = time;
                           &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
                           my $key = &escape('internal.contentchange');
                           my $what = "$key=$now";
                           my $hashref = &tie_user_hash($udom,$uname,'environment',
                                                        &GDBM_WRCREAT(),"P",$what);
                           if ($hashref) {
                               $hashref->{$key}=$now;
                               if (!&untie_user_hash($hashref)) {
                                   &logthis("error: ".($!+0)." untie (GDBM) failed ".
                                            "when updating internal.contentchange");
                               }
                           }
                       }
                   }
  &Reply($client, "ok\n", $userinput);   &Reply($client, "ok\n", $userinput);
     }      }
  }      }   
Line 2369  sub user_has_session_handler { Line 2525  sub user_has_session_handler {
   
     my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));      my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
           
     &logthis("Looking for $udom $uname");  
     opendir(DIR,$perlvar{'lonIDsDir'});      opendir(DIR,$perlvar{'lonIDsDir'});
     my $filename;      my $filename;
     while ($filename=readdir(DIR)) {      while ($filename=readdir(DIR)) {
Line 3088  sub dump_profile_database { Line 3243  sub dump_profile_database {
 #                                             that is matched against  #                                             that is matched against
 #                                             database keywords to do  #                                             database keywords to do
 #                                             selective dumps.  #                                             selective dumps.
   #                               range       - optional range of entries
   #                                             e.g., 10-20 would return the
   #                                             10th to 19th items, etc.  
 #   $client                   - Channel open on the client.  #   $client                   - Channel open on the client.
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
Line 3097  sub dump_profile_database { Line 3255  sub dump_profile_database {
 sub dump_with_regexp {  sub dump_with_regexp {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
       my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
   
     my $userinput = "$cmd:$tail";      if ($res =~ /^error:/) {
           &Failure($client, \$res, "$cmd:$tail");
     my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);  
     if (defined($regexp)) {  
  $regexp=&unescape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my ($start,$end);  
     if (defined($range)) {  
  if ($range =~/^(\d+)\-(\d+)$/) {  
     ($start,$end) = ($1,$2);  
  } elsif ($range =~/^(\d+)$/) {  
     ($start,$end) = (0,$1);  
  } else {  
     undef($range);  
  }  
     }  
     my $hashref = &tie_user_hash($udom, $uname, $namespace,  
  &GDBM_READER());  
     if ($hashref) {  
         my $qresult='';  
  my $count=0;  
  while (my ($key,$value) = each(%$hashref)) {  
             if ($namespace eq 'roles') {  
                 if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_cc$/) {  
                     if ($clientversion =~ /^(\d+\.\d+)$/) {  
                         next if ($1 <= 2.9);  
                     }  
                 }  
             }  
     if ($regexp eq '.') {  
  $count++;  
  if (defined($range) && $count >= $end)   { last; }  
  if (defined($range) && $count <  $start) { next; }  
  $qresult.=$key.'='.$value.'&';  
     } else {  
  my $unescapeKey = &unescape($key);  
  if (eval('$unescapeKey=~/$regexp/')) {  
     $count++;  
     if (defined($range) && $count >= $end)   { last; }  
     if (defined($range) && $count <  $start) { next; }  
     $qresult.="$key=$value&";  
  }  
     }  
  }  
  if (&untie_user_hash($hashref)) {  
     chop($qresult);  
     &Reply($client, \$qresult, $userinput);  
  } else {  
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".  
      "while attempting dump\n", $userinput);  
  }  
     } else {      } else {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".          &Reply($client, \$res, "$cmd:$tail");
  "while attempting dump\n", $userinput);  
     }      }
   
     return 1;      return 1;
Line 3722  sub put_course_id_hash_handler { Line 3829  sub put_course_id_hash_handler {
 #                 createdafter - include courses for which creation date followed this date.  #                 createdafter - include courses for which creation date followed this date.
 #                 creationcontext - include courses created in specified context   #                 creationcontext - include courses created in specified context 
 #  #
   #                 domcloner - flag to indicate if user can create CCs in course's domain.
   #                             If so, ability to clone course is automatic.
   #                 hasuniquecode - filter by courses for which a six character unique code has
   #                                 been set.
   #
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3734  sub dump_course_id_handler { Line 3846  sub dump_course_id_handler {
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
         $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,          $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
         $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,          $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
         $creationcontext) =split(/:/,$tail);          $creationcontext,$domcloner,$hasuniquecode) =split(/:/,$tail);
     my $now = time;      my $now = time;
     my ($cloneruname,$clonerudom,%cc_clone);      my ($cloneruname,$clonerudom,%cc_clone);
     if (defined($description)) {      if (defined($description)) {
Line 3807  sub dump_course_id_handler { Line 3919  sub dump_course_id_handler {
     } else {      } else {
         $creationcontext = '.';          $creationcontext = '.';
     }      }
           unless ($hasuniquecode) {
           $hasuniquecode = '.';
       }
     my $unpack = 1;      my $unpack = 1;
     if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&       if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && 
         $typefilter eq '.') {          $typefilter eq '.') {
         $unpack = 0;          $unpack = 0;
     }      }
Line 3838  sub dump_course_id_handler { Line 3952  sub dump_course_id_handler {
                     next if ($since > 1);                      next if ($since > 1);
                 }                  }
                 $is_hash =  1;                  $is_hash =  1;
                 if (defined($clonerudom)) {                  if ($domcloner) {
                       $canclone = 1;
                   } elsif (defined($clonerudom)) {
                     if ($items->{'cloners'}) {                      if ($items->{'cloners'}) {
                         my @cloneable = split(',',$items->{'cloners'});                          my @cloneable = split(',',$items->{'cloners'});
                         if (@cloneable) {                          if (@cloneable) {
Line 3866  sub dump_course_id_handler { Line 3982  sub dump_course_id_handler {
                             $items->{'cloners'} = $cloneruname.':'.$clonerudom;                              $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                             $valchange = 1;                              $valchange = 1;
                         }                          }
                           unless ($canclone) {
                               if ($items->{'owner'} =~ /:/) {
                                   if ($items->{'owner'} eq $cloner) {
                                       $canclone = 1;
                                   }
                               } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
                                   $canclone = 1;
                               }
                               if ($canclone) {
                                   $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                                   $valchange = 1;
                               }
                           }
                     }                      }
                 }                  }
                 if ($unpack || !$rtn_as_hash) {                  if ($unpack || !$rtn_as_hash) {
Line 3881  sub dump_course_id_handler { Line 4010  sub dump_course_id_handler {
                 $selfenroll_end = $items->{'selfenroll_end_date'};                  $selfenroll_end = $items->{'selfenroll_end_date'};
                 $created = $items->{'created'};                  $created = $items->{'created'};
                 $context = $items->{'context'};                  $context = $items->{'context'};
                   if ($hasuniquecode ne '.') {
                       next unless ($items->{'uniquecode'});
                   }
                 if ($selfenrollonly) {                  if ($selfenrollonly) {
                     next if (!$selfenroll_types);                      next if (!$selfenroll_types);
                     if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {                      if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
Line 4066  sub dump_course_id_handler { Line 4198  sub dump_course_id_handler {
 }  }
 &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);  &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
   
   sub course_lastaccess_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($cdom,$cnum) = split(':',$tail); 
       my (%lastaccess,$qresult);
       my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
           while (my ($key,$value) = each(%$hashref)) {
               my ($unesc_key,$lasttime);
               $unesc_key = &unescape($key);
               if ($cnum) {
                   next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
               }
               if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
                   $lastaccess{$1} = $value;
               } else {
                   my $items = &Apache::lonnet::thaw_unescape($value);
                   if (ref($items) eq 'HASH') {
                       unless ($lastaccess{$unesc_key}) {
                           $lastaccess{$unesc_key} = '';
                       }
                   } else {
                       my @courseitems = split(':',$value);
                       $lastaccess{$unesc_key} = pop(@courseitems);
                   }
               }
           }
           foreach my $cid (sort(keys(%lastaccess))) {
               $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&'; 
           }
           if (&untie_domain_hash($hashref)) {
               if ($qresult) {
                   chop($qresult);
               }
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting lastacourseaccess\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting lastcourseaccess\n", $userinput);
       }
       return 1;
   }
   &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
   
 #  #
 # Puts an unencrypted entry in a namespace db file at the domain level   # Puts an unencrypted entry in a namespace db file at the domain level 
 #  #
Line 4131  sub put_domain_handler { Line 4310  sub put_domain_handler {
 sub get_domain_handler {  sub get_domain_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
   
     my $userinput = "$client:$tail";      my $userinput = "$client:$tail";
   
     my ($udom,$namespace,$what)=split(/:/,$tail,3);      my ($udom,$namespace,$what)=split(/:/,$tail,3);
Line 4255  sub get_id_handler { Line 4435  sub get_id_handler {
 }  }
 &register_handler("idget", \&get_id_handler, 0, 1, 0);  &register_handler("idget", \&get_id_handler, 0, 1, 0);
   
   #   Deletes one or more ids in a domain's id database.
   #
   #   Parameters:
   #       $cmd                  - Command keyword (iddel).
   #       $tail                 - Command tail.  In this case a colon
   #                               separated list containing:
   #                               The domain for which we are deleting the id(s).
   #                               &-separated list of id(s) to delete.
   #       $client               - File open on client socket.
   # Returns:
   #     1   - Continue processing
   #     0   - Exit server.
   #
   #
   
   sub del_id_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
                                      "D", $what);
       if ($hashref) {
           my @keys=split(/\&/,$what);
           foreach my $key (@keys) {
               delete($hashref->{$key});
           }
           if (&untie_user_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting iddel\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                    "while attempting iddel\n", $userinput);
       }
       return 1;
   }
   &register_handler("iddel", \&del_id_handler, 0, 1, 0);
   
 #  #
 # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database   # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database 
 #  #
Line 4275  sub get_id_handler { Line 4498  sub get_id_handler {
 sub put_dcmail_handler {  sub put_dcmail_handler {
     my ($cmd,$tail,$client) = @_;      my ($cmd,$tail,$client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
                                                                                   
   
     my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
Line 4539  sub tmp_put_handler { Line 4763  sub tmp_put_handler {
     }      }
     my ($id,$store);      my ($id,$store);
     $tmpsnum++;      $tmpsnum++;
     if ($context eq 'resetpw') {      if (($context eq 'resetpw') || ($context eq 'createaccount')) {
         $id = &md5_hex(&md5_hex(time.{}.rand().$$));          $id = &md5_hex(&md5_hex(time.{}.rand().$$));
     } else {      } else {
         $id = $$.'_'.$clientip.'_'.$tmpsnum;          $id = $$.'_'.$clientip.'_'.$tmpsnum;
Line 4802  sub validate_instcode_handler { Line 5026  sub validate_instcode_handler {
     my ($dom,$instcode,$owner) = split(/:/, $tail);      my ($dom,$instcode,$owner) = split(/:/, $tail);
     $instcode = &unescape($instcode);      $instcode = &unescape($instcode);
     $owner = &unescape($owner);      $owner = &unescape($owner);
     my ($outcome,$description) =       my ($outcome,$description,$credits) = 
         &localenroll::validate_instcode($dom,$instcode,$owner);          &localenroll::validate_instcode($dom,$instcode,$owner);
     my $result = &escape($outcome).'&'.&escape($description);      my $result = &escape($outcome).'&'.&escape($description).'&'.
                    &escape($credits);
     &Reply($client, \$result, $userinput);      &Reply($client, \$result, $userinput);
   
     return 1;      return 1;
Line 4857  sub get_sections_handler { Line 5082  sub get_sections_handler {
 sub validate_course_owner_handler {  sub validate_course_owner_handler {
     my ($cmd, $tail, $client)  = @_;      my ($cmd, $tail, $client)  = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);      my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);
       
     $owner = &unescape($owner);      $owner = &unescape($owner);
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);      $coowners = &unescape($coowners);
       my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
     &Reply($client, \$outcome, $userinput);      &Reply($client, \$outcome, $userinput);
   
   
Line 5019  sub crsreq_checks_handler { Line 5245  sub crsreq_checks_handler {
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my $dom = $tail;      my $dom = $tail;
     my $result;      my $result;
     my @reqtypes = ('official','unofficial','community');      my @reqtypes = ('official','unofficial','community','textbook');
     eval {      eval {
         local($SIG{__DIE__})='DEFAULT';          local($SIG{__DIE__})='DEFAULT';
         my %validations;          my %validations;
Line 5046  sub crsreq_checks_handler { Line 5272  sub crsreq_checks_handler {
 sub validate_crsreq_handler {  sub validate_crsreq_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail);      my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$customdata) = split(/:/, $tail);
     $instcode = &unescape($instcode);      $instcode = &unescape($instcode);
     $owner = &unescape($owner);      $owner = &unescape($owner);
     $crstype = &unescape($crstype);      $crstype = &unescape($crstype);
     $inststatuslist = &unescape($inststatuslist);      $inststatuslist = &unescape($inststatuslist);
     $instcode = &unescape($instcode);      $instcode = &unescape($instcode);
     $instseclist = &unescape($instseclist);      $instseclist = &unescape($instseclist);
       my $custominfo = &Apache::lonnet::thaw_unescape($customdata);
     my $outcome;      my $outcome;
     eval {      eval {
         local($SIG{__DIE__})='DEFAULT';          local($SIG{__DIE__})='DEFAULT';
         $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,          $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,
                                                  $inststatuslist,$instcode,                                                   $inststatuslist,$instcode,
                                                  $instseclist);                                                   $instseclist,$custominfo);
     };      };
     if (!$@) {      if (!$@) {
         &Reply($client, \$outcome, $userinput);          &Reply($client, \$outcome, $userinput);
Line 5069  sub validate_crsreq_handler { Line 5296  sub validate_crsreq_handler {
 }  }
 &register_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);  &register_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);
   
   sub crsreq_update_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,$code,
           $accessstart,$accessend,$infohashref) =
           split(/:/, $tail);
       $crstype = &unescape($crstype);
       $action = &unescape($action);
       $ownername = &unescape($ownername);
       $ownerdomain = &unescape($ownerdomain);
       $fullname = &unescape($fullname);
       $title = &unescape($title);
       $code = &unescape($code);
       $accessstart = &unescape($accessstart);
       $accessend = &unescape($accessend);
       my $incoming = &Apache::lonnet::thaw_unescape($infohashref);
       my ($result,$outcome);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           my %rtnhash;
           $outcome = &localenroll::crsreq_updates($cdom,$cnum,$crstype,$action,
                                                   $ownername,$ownerdomain,$fullname,
                                                   $title,$code,$accessstart,$accessend,
                                                   $incoming,\%rtnhash);
           if ($outcome eq 'ok') {
               my @posskeys = qw(createdweb createdmsg queuedweb queuedmsg formitems reviewweb);
               foreach my $key (keys(%rtnhash)) {
                   if (grep(/^\Q$key\E/,@posskeys)) {
                       $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rtnhash{$key}).'&';
                   }
               }
               $result =~ s/\&$//;
           }
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               &Reply($client, \$result, $userinput);
           } else {
               &Reply($client, "format_error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autocrsrequpdate", \&crsreq_update_handler, 0, 1, 0);
   
 #  #
 #   Read and retrieve institutional code format (for support form).  #   Read and retrieve institutional code format (for support form).
 # Formal Parameters:  # Formal Parameters:
Line 5776  sub lcpasswdstrerror { Line 6050  sub lcpasswdstrerror {
     }      }
 }  }
   
 #  
 # Convert an error return code from lcuseradd to a string value:  
 #  
 sub lcuseraddstrerror {  
     my $ErrorCode = shift;  
     if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) {  
  return "lcuseradd - Unrecognized error code: ".$ErrorCode;  
     } else {  
  return $adderrors[$ErrorCode];  
     }  
 }  
   
 # grabs exception and records it to log before exiting  # grabs exception and records it to log before exiting
 sub catchexception {  sub catchexception {
     my ($error)=@_;      my ($error)=@_;
Line 5848  if (-e $pidfile) { Line 6110  if (-e $pidfile) {
 $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},  $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
                                 Type      => SOCK_STREAM,                                  Type      => SOCK_STREAM,
                                 Proto     => 'tcp',                                  Proto     => 'tcp',
                                 Reuse     => 1,                                  ReuseAddr     => 1,
                                 Listen    => 10 )                                  Listen    => 10 )
   or die "making socket: $@\n";    or die "making socket: $@\n";
   
Line 5911  sub HUPSMAN {                      # sig Line 6173  sub HUPSMAN {                      # sig
 #  a setuid perl script that can be root for us to do this job.  #  a setuid perl script that can be root for us to do this job.
 #  #
 sub ReloadApache {  sub ReloadApache {
     my $execdir = $perlvar{'lonDaemons'};  # --------------------------- Handle case of another apachereload process (locking)
     my $script  = $execdir."/apachereload";      if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
     system($script);          my $execdir = $perlvar{'lonDaemons'};
           my $script  = $execdir."/apachereload";
           system($script);
           unlink('/tmp/lock_apachereload'); #  Remove the lock file.
       }
 }  }
   
 #  #
Line 6086  sub logstatus { Line 6352  sub logstatus {
 sub initnewstatus {  sub initnewstatus {
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");      my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
     my $now=time;      my $now=time();
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "LOND status $local - parent $$\n\n";      print $fh "LOND status $local - parent $$\n\n";
     opendir(DIR,"$docdir/lon-status/londchld");      opendir(DIR,"$docdir/lon-status/londchld");
Line 6175  $SIG{USR2} = \&UpdateHosts; Line 6441  $SIG{USR2} = \&UpdateHosts;
   
 #  Read the host hashes:  #  Read the host hashes:
 &Apache::lonnet::load_hosts_tab();  &Apache::lonnet::load_hosts_tab();
   my %iphost = &Apache::lonnet::get_iphost(1);
   
   $dist=`$perlvar{'lonDaemons'}/distprobe`;
   
 my $dist=`$perlvar{'lonDaemons'}/distprobe`;  my $arch = `uname -i`;
   chomp($arch);
   if ($arch eq 'unknown') {
       $arch = `uname -m`;
       chomp($arch);
   }
   
 # --------------------------------------------------------------  # --------------------------------------------------------------
 #   Accept connections.  When a connection comes in, it is validated  #   Accept connections.  When a connection comes in, it is validated
Line 6235  sub make_new_child { Line 6509  sub make_new_child {
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $clientip;          $children{$pid} = $clientip;
         &status('Started child '.$pid);          &status('Started child '.$pid);
    close($client);
         return;          return;
     } else {      } else {
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
Line 6243  sub make_new_child { Line 6518  sub make_new_child {
                                 #don't get intercepted                                  #don't get intercepted
         $SIG{USR1}= \&logstatus;          $SIG{USR1}= \&logstatus;
         $SIG{ALRM}= \&timeout;          $SIG{ALRM}= \&timeout;
    #
    # Block sigpipe as it gets thrownon socket disconnect and we want to 
    # deal with that as a read faiure instead.
    #
    my $blockset = POSIX::SigSet->new(SIGPIPE);
    sigprocmask(SIG_BLOCK, $blockset);
   
         $lastlog='Forked ';          $lastlog='Forked ';
         $status='Forked';          $status='Forked';
   
Line 6254  sub make_new_child { Line 6536  sub make_new_child {
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
  unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||     unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||  
  ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {   ($dist eq 'fedora6') || ($dist eq 'suse9.3') ||
                   ($dist eq 'suse12.2') || ($dist eq 'suse12.3') ||
                   ($dist eq 'suse13.1')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 6300  sub make_new_child { Line 6584  sub make_new_child {
  #  If the remote is attempting a local init... give that a try:   #  If the remote is attempting a local init... give that a try:
  #   #
  (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);   (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
                   # For LON-CAPA 2.9, the  client session will have sent its LON-CAPA
                   # version when initiating the connection. For LON-CAPA 2.8 and older,
                   # the version is retrieved from the global %loncaparevs in lonnet.pm.
                   # $clientversion contains path to keyfile if $inittype eq 'local'
                   # it's overridden below in this case
                   $clientversion ||= $Apache::lonnet::loncaparevs{$clientname};
   
  # If the connection type is ssl, but I didn't get my   # If the connection type is ssl, but I didn't get my
  # certificate files yet, then I'll drop  back to    # certificate files yet, then I'll drop  back to 
Line 6327  sub make_new_child { Line 6617  sub make_new_child {
  my $cipherkey = pack("H32", $key);   my $cipherkey = pack("H32", $key);
  $cipher       = new IDEA($cipherkey);   $cipher       = new IDEA($cipherkey);
  print $client "ok:local\n";   print $client "ok:local\n";
  &logthis('<font color="green"'   &logthis('<font color="green">'
  . "Successful local authentication </font>");   . "Successful local authentication </font>");
  $keymode = "local"   $keymode = "local"
     } else {      } else {
Line 6391  sub make_new_child { Line 6681  sub make_new_child {
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     my $keep_going = 1;      my $keep_going = 1;
     my $user_input;      my $user_input;
               my $clienthost = &Apache::lonnet::hostname($clientname);
               my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
               $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
     while(($user_input = get_request) && $keep_going) {      while(($user_input = get_request) && $keep_going) {
  alarm(120);   alarm(120);
  Debug("Main: Got $user_input\n");   Debug("Main: Got $user_input\n");
Line 6440  sub is_author { Line 6733  sub is_author {
   
     #  Author role should show up as a key /domain/_au      #  Author role should show up as a key /domain/_au
   
     my $key    = "/$domain/_au";  
     my $value;      my $value;
     if (defined($hashref)) {      if ($hashref) {
  $value = $hashref->{$key};  
     }  
   
     if(defined($value)) {   my $key    = "/$domain/_au";
  &Debug("$user @ $domain is an author");   if (defined($hashref)) {
       $value = $hashref->{$key};
       if(!untie_user_hash($hashref)) {
    return 'error: ' .  ($!+0)." untie (GDBM) Failed";
       }
    }
   
    if(defined($value)) {
       &Debug("$user @ $domain is an author");
    }
       } else {
    return 'error: '.($!+0)." tie (GDBM) Failed";
     }      }
   
     return defined($value);      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, creates construction space 
 # up a correct public_html   
 # Parameters:  # Parameters:
 #    request   - The request sent to the rolesput subchunk.  #    request   - The request sent to the rolesput subchunk.
 #                We're looking for  /domain/_au  #                We're looking for  /domain/_au
Line 6465  sub is_author { Line 6765  sub is_author {
 #  #
 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 =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};          my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
  my $userhome= "/home/$user" ;          unless (-e $path) {        
  &logthis("system $execdir/lchtmldir $userhome $user $authtype");             mkdir($path);
  &Debug("Setting homedir permissions for $userhome");          }
  system("$execdir/lchtmldir $userhome $user $authtype");          unless (-e $path.'/'.$user) {
              mkdir($path.'/'.$user);
           }
     }      }
 }  }
   
Line 6549  sub rewrite_password_file { Line 6848  sub rewrite_password_file {
   
 #     Returns the authorization type or nouser if there is no such user.  #     Returns the authorization type or nouser if there is no such user.
 #  #
 sub get_auth_type   sub get_auth_type {
 {  
   
     my ($domain, $user)  = @_;      my ($domain, $user)  = @_;
   
     Debug("get_auth_type( $domain, $user ) \n");      Debug("get_auth_type( $domain, $user ) \n");
Line 6646  sub validate_user { Line 6943  sub validate_user {
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
  }   } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
  elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.              my $checkwithkrb5 = 0;
     if(! ($password =~ /$null/) ) {              if ($dist =~/^fedora(\d+)$/) {
  my $k4error = &Authen::Krb4::get_pw_in_tkt($user,                  if ($1 > 11) {
    "",                      $checkwithkrb5 = 1;
    $contentpwd,,                  }
    'krbtgt',              } elsif ($dist =~ /^suse([\d.]+)$/) {
    $contentpwd,                  if ($1 > 11.1) {
    1,                      $checkwithkrb5 = 1; 
    $password);                  }
  if(!$k4error) {              }
     $validated = 1;              if ($checkwithkrb5) {
  } else {                  $validated = &krb5_authen($password,$null,$user,$contentpwd);
     $validated = 0;              } else {
     &logthis('krb4: '.$user.', '.$contentpwd.', '.                  $validated = &krb4_authen($password,$null,$user,$contentpwd);
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));              }
  }  
     } else {  
  $validated = 0; # Password has a match with null.  
     }  
  } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.   } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
     if(!($password =~ /$null/)) { # Null password not allowed.              $validated = &krb5_authen($password,$null,$user,$contentpwd);
  my $krbclient = &Authen::Krb5::parse_name($user.'@'  
   .$contentpwd);  
  my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;  
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);  
  my $credentials= &Authen::Krb5::cc_default();  
  $credentials->initialize(&Authen::Krb5::parse_name($user.'@'  
                                                                  .$contentpwd));  
                 my $krbreturn;  
                 if (exists(&Authen::Krb5::get_init_creds_password)) {  
                     $krbreturn =   
                         &Authen::Krb5::get_init_creds_password($krbclient,$password,  
                                                                $krbservice);  
                     $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');  
                 } else {  
     $krbreturn  =   
                         &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,  
  $password,$credentials);  
     $validated = ($krbreturn == 1);  
                 }  
  if (!$validated) {  
     &logthis('krb5: '.$user.', '.$contentpwd.', '.  
      &Authen::Krb5::error());  
  }  
     } else {  
  $validated = 0;  
     }  
  } elsif ($howpwd eq "localauth") {    } elsif ($howpwd eq "localauth") { 
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
Line 6724  sub validate_user { Line 6991  sub validate_user {
     return $validated;      return $validated;
 }  }
   
   sub krb4_authen {
       my ($password,$null,$user,$contentpwd) = @_;
       my $validated = 0;
       if (!($password =~ /$null/) ) {  # Null password not allowed.
           eval {
               require Authen::Krb4;
           };
           if (!$@) {
               my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
                                                          "",
                                                          $contentpwd,,
                                                          'krbtgt',
                                                          $contentpwd,
                                                          1,
                                                          $password);
               if(!$k4error) {
                   $validated = 1;
               } else {
                   $validated = 0;
                   &logthis('krb4: '.$user.', '.$contentpwd.', '.
                             &Authen::Krb4::get_err_txt($Authen::Krb4::error));
               }
           } else {
               $validated = krb5_authen($password,$null,$user,$contentpwd);
           }
       }
       return $validated;
   }
   
   sub krb5_authen {
       my ($password,$null,$user,$contentpwd) = @_;
       my $validated = 0;
       if(!($password =~ /$null/)) { # Null password not allowed.
           my $krbclient = &Authen::Krb5::parse_name($user.'@'
                                                     .$contentpwd);
           my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
           my $krbserver  = &Authen::Krb5::parse_name($krbservice);
           my $credentials= &Authen::Krb5::cc_default();
           $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
                                                               .$contentpwd));
           my $krbreturn;
           if (exists(&Authen::Krb5::get_init_creds_password)) {
               $krbreturn =
                   &Authen::Krb5::get_init_creds_password($krbclient,$password,
                                                             $krbservice);
               $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
           } else {
               $krbreturn  =
                   &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
                                                            $password,$credentials);
               $validated = ($krbreturn == 1);
           }
           if (!$validated) {
               &logthis('krb5: '.$user.', '.$contentpwd.', '.
                        &Authen::Krb5::error());
           }
       }
       return $validated;
   }
   
 sub addline {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
Line 6936  sub subscribe { Line 7262  sub subscribe {
                 # the metadata                  # the metadata
  unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }   unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
  $fname=~s/\/home\/httpd\/html\/res/raw/;   $fname=~s/\/home\/httpd\/html\/res/raw/;
  $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;                  my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
                   $protocol = 'http' if ($protocol ne 'https');
    $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
  $result="$fname\n";   $result="$fname\n";
     }      }
  } else {   } else {
Line 6978  sub change_unix_password { Line 7306  sub change_unix_password {
   
   
 sub make_passwd_file {  sub make_passwd_file {
     my ($uname, $umode,$npass,$passfilename)=@_;      my ($uname,$udom,$umode,$npass,$passfilename)=@_;
     my $result="ok";      my $result="ok";
     if ($umode eq 'krb4' or $umode eq 'krb5') {      if ($umode eq 'krb4' or $umode eq 'krb5') {
  {   {
Line 7012  sub make_passwd_file { Line 7340  sub make_passwd_file {
     }      }
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   &logthis(">>>Attempt to create unix account blocked -- unix auth not available for new users.");
     #   $result="no_new_unix_accounts";
     #  Don't allow the creation of privileged accounts!!! that would  
     #  be real bad!!!  
     #  
     my $uid = getpwnam($uname);  
     if((defined $uid) && ($uid == 0)) {  
  &logthis(">>>Attempted to create privilged account blocked");  
  return "no_priv_account_error\n";  
     }  
   
     my $execpath       ="$perlvar{'lonDaemons'}/"."lcuseradd";  
   
     my $lc_error_file  = $execdir."/tmp/lcuseradd".$$.".status";  
     {  
  &Debug("Executing external: ".$execpath);  
  &Debug("user  = ".$uname.", Password =". $npass);  
  my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");  
  print $se "$uname\n";  
  print $se "$npass\n";  
  print $se "$npass\n";  
  print $se "$lc_error_file\n"; # Status -> unique file.  
     }  
     if (-r $lc_error_file) {  
  &Debug("Opening error file: $lc_error_file");  
  my $error = IO::File->new("< $lc_error_file");  
  my $useraddok = <$error>;  
  $error->close;  
  unlink($lc_error_file);  
   
  chomp $useraddok;  
   
  if($useraddok > 0) {  
     my $error_text = &lcuseraddstrerror($useraddok);  
     &logthis("Failed lcuseradd: $error_text");  
     $result = "lcuseradd_failed:$error_text";  
  }  else {  
     my $pf = IO::File->new(">$passfilename");  
     if($pf) {  
  print $pf "unix:\n";  
     } else {  
  $result = "pass_file_failed_error";  
     }  
  }  
     }  else {  
  &Debug("Could not locate lcuseradd error: $lc_error_file");  
  $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");
Line 7094  sub sethost { Line 7375  sub sethost {
  eq &Apache::lonnet::get_host_ip($hostid)) {   eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=&Apache::lonnet::host_domain($hostid);   $currentdomainid=&Apache::lonnet::host_domain($hostid);
  &logthis("Setting hostid to $hostid, and domain to $currentdomainid");  # &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
  &logthis("Requested host id $hostid not an alias of ".   &logthis("Requested host id $hostid not an alias of ".
  $perlvar{'lonHostID'}." refusing connection");   $perlvar{'lonHostID'}." refusing connection");
Line 7109  sub version { Line 7390  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
   sub get_usersession_config {
       my ($dom,$name) = @_;
       my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
       if (defined($cached)) {
           return $usersessionconf;
       } else {
           my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
           if (ref($domconfig{'usersessions'}) eq 'HASH') {
               &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
               return $domconfig{'usersessions'};
           }
       }
       return;
   }
   
   
   sub distro_and_arch {
       return $dist.':'.$arch;
   }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
Line 7317  Place in B<logs/lond.log> Line 7617  Place in B<logs/lond.log>
   
 stores hash in namespace  stores hash in namespace
   
 =item rolesputy  =item rolesput
   
 put a role into a user's environment  put a role into a user's environment
   
Line 7844  string. Line 8144  string.
   
 =back  =back
   
   =back
   
   
 =cut  =cut

Removed from v.1.432  
changed lines
  Added in v.1.489.2.14


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