Diff for /loncom/lond between versions 1.367 and 1.385

version 1.367, 2007/03/28 22:46:44 version 1.385, 2007/10/08 17:40:56
Line 33  use strict; Line 33  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 Apache::lonnet;  
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
Line 53  use File::Find; Line 52  use File::Find;
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   use Apache::lonnet;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
Line 69  my $clientip;   # IP address of client. Line 69  my $clientip;   # IP address of client.
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
   
 my $server;  my $server;
 my $thisserver; # DNS of us.  
   
 my $keymode;  my $keymode;
   
 my $cipher; # Cipher key negotiated with client  my $cipher; # Cipher key negotiated with client
 my $tmpsnum = 0; # Id of tmpputs.  my $tmpsnum = 0; # Id of tmpputs.
   my $max_children = 1;           # warn when exceeding this
   my $max_children_enforcing = 0;
   
 #   # 
 #   Connection type is:  #   Connection type is:
Line 85  my $tmpsnum = 0;  # Id of tmpputs. Line 86  my $tmpsnum = 0;  # Id of tmpputs.
   
 my $ConnectionType;  my $ConnectionType;
   
 my %hostid; # ID's for hosts in cluster by ip.  
 my %hostdom; # LonCAPA domain for hosts in cluster.  
 my %hostname; # DNSname -> ID's mapping.  
 my %hostip; # IPs for hosts in cluster.  
 my %hostdns; # ID's of hosts looked up by DNS name.  
   
 my %managers; # Ip -> manager names  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.
Line 142  my @adderrors    = ("ok", Line 137  my @adderrors    = ("ok",
     "lcuseradd Unable to make www member of users's group",      "lcuseradd Unable to make www member of users's group",
     "lcuseradd Unable to su to root",      "lcuseradd Unable to su to root",
     "lcuseradd Unable to set password",      "lcuseradd Unable to set password",
     "lcuseradd Usrname has invalid characters",      "lcuseradd Username has invalid characters",
     "lcuseradd Password has an invalid character",      "lcuseradd Password has an invalid character",
     "lcuseradd User already exists",      "lcuseradd User already exists",
     "lcuseradd Could not add user.",      "lcuseradd Could not add user.",
Line 178  sub ResetStatistics { Line 173  sub ResetStatistics {
 #   $Socket      - Socket open on client.  #   $Socket      - Socket open on client.
 #   $initcmd     - The full text of the init command.  #   $initcmd     - The full text of the init command.
 #  #
 # Implicit inputs:  
 #    $thisserver - Our DNS name.  
 #  
 # Returns:  # Returns:
 #     IDEA session key on success.  #     IDEA session key on success.
 #     undef on failure.  #     undef on failure.
 #  #
 sub LocalConnection {  sub LocalConnection {
     my ($Socket, $initcmd) = @_;      my ($Socket, $initcmd) = @_;
     Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");      Debug("Attempting local connection: $initcmd client: $clientip");
     if($clientip ne "127.0.0.1") {      if($clientip ne "127.0.0.1") {
  &logthis('<font color="red"> LocalConnection rejecting non local: '   &logthis('<font color="red"> LocalConnection rejecting non local: '
  ."$clientip ne $thisserver </font>");   ."$clientip ne 127.0.0.1 </font>");
  close $Socket;   close $Socket;
  return undef;   return undef;
     }  else {      }  else {
Line 424  sub ReadManagerTable { Line 416  sub ReadManagerTable {
       if ($host =~ "^#") {                  # Comment line.        if ($host =~ "^#") {                  # Comment line.
          next;           next;
       }        }
       if (!defined $hostip{$host}) { # This is a non cluster member        if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
     #  The entry is of the form:      #  The entry is of the form:
     #    cluname:hostname      #    cluname:hostname
     #  cluname - A 'cluster hostname' is needed in order to negotiate      #  cluname - A 'cluster hostname' is needed in order to negotiate
Line 442  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{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber           $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if clumemeber
       }        }
    }     }
 }  }
Line 2105  sub rename_user_file_handler { Line 2097  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);
   
 #  #
   #  Checks if the specified user has an active session on the server
   #  return ok if so, not_found if not
   #
   # Parameters:
   #   cmd      - The request keyword that dispatched to tus.
   #   tail     - The tail of the request (colon separated parameters).
   #   client   - Filehandle open on the client.
   # Return:
   #    1.
   sub user_has_session_handler {
       my ($cmd, $tail, $client) = @_;
   
       my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
       
       &logthis("Looking for $udom $uname");
       opendir(DIR,$perlvar{'lonIDsDir'});
       my $filename;
       while ($filename=readdir(DIR)) {
    last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
       }
       if ($filename) {
    &Reply($client, "ok\n", "$cmd:$tail");
       } else {
    &Failure($client, "not_found\n", "$cmd:$tail");
       }
       return 1;
   
   }
   &register_handler("userhassession", \&user_has_session_handler, 0,1,0);
   
   #
 #  Authenticate access to a user file by checking that the token the user's   #  Authenticate access to a user file by checking that the token the user's 
 #  passed also exists in their session file  #  passed also exists in their session file
 #  #
Line 2197  sub subscribe_handler { Line 2220  sub subscribe_handler {
 &register_handler("sub", \&subscribe_handler, 0, 1, 0);  &register_handler("sub", \&subscribe_handler, 0, 1, 0);
   
 #  #
 #   Determine the version of a resource (?) Or is it return  #   Determine the latest version of a resource (it looks for the highest
 #   the top version of the resource?  Not yet clear from the  #   past version and then returns that +1)
 #   code in currentversion.  
 #  #
 # 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).
   #                 (Should consist of an absolute path to a file)
 #    $client   - File descriptor connected to client.  #    $client   - File descriptor connected to client.
 # Returns  # Returns
 #     0        - Requested to exit, caller should shut down.  #     0        - Requested to exit, caller should shut down.
Line 3283  sub put_course_id_handler { Line 3306  sub put_course_id_handler {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
             my ($key,$courseinfo) = split(/=/,$pair,2);              my ($key,$courseinfo) = split(/=/,$pair,2);
             $courseinfo =~ s/=/:/g;              $courseinfo =~ s/=/:/g;
               if (defined($hashref->{$key})) {
                   my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
                   if (ref($value) eq 'HASH') {
                       my @items = ('description','inst_code','owner','type');
                       my @new_items = split(/:/,$courseinfo,-1);
                       my %storehash; 
                       for (my $i=0; $i<@new_items; $i++) {
                           $storehash{$items[$i]} = $new_items[$i];
                       }
                       $hashref->{$key} = 
                           &Apache::lonnet::freeze_escape(\%storehash);
                       my $unesc_key = &unescape($key);
                       $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
                       next;
                   }
               }
             my @current_items = split(/:/,$hashref->{$key},-1);              my @current_items = split(/:/,$hashref->{$key},-1);
             shift(@current_items); # remove description              shift(@current_items); # remove description
             pop(@current_items);   # remove last access              pop(@current_items);   # remove last access
Line 3299  sub put_course_id_handler { Line 3338  sub put_course_id_handler {
                     }                      }
                 }                  }
             }              }
     $hashref->{$key}=$courseinfo.':'.$now;              $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (&untie_domain_hash($hashref)) {   if (&untie_domain_hash($hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
Line 3313  sub put_course_id_handler { Line 3352  sub put_course_id_handler {
  ." tie(GDBM) Failed ".   ." tie(GDBM) Failed ".
  "while attempting courseidput\n", $userinput);   "while attempting courseidput\n", $userinput);
     }      }
       
   
     return 1;      return 1;
 }  }
 &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);  &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);
   
   sub put_course_id_hash_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($udom,$mode,$what) = split(/:/, $tail,3);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               my $unesc_key = &unescape($key);
               if ($mode ne 'timeonly') {
                   if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
                       my $curritems = &Apache::lonnet::thaw_unescape($key); 
                       if (ref($curritems) ne 'HASH') {
                           my @current_items = split(/:/,$hashref->{$key},-1);
                           my $lasttime = pop(@current_items);
                           $hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
                       } else {
                           $hashref->{&escape('lasttime:'.$unesc_key)} = '';
                       }
                   } 
                   $hashref->{$key} = $value;
               }
               if ($mode ne 'notime') {
                   $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
               }
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting courseidputhash\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting courseidputhash\n", $userinput);
       }
       return 1;
   }
   &register_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);
   
 #  Retrieves the value of a course id resource keyword pattern  #  Retrieves the value of a course id resource keyword pattern
 #  defined since a starting date.  Both the starting date and the  #  defined since a starting date.  Both the starting date and the
 #  keyword pattern are optional.  If the starting date is not supplied it  #  keyword pattern are optional.  If the starting date is not supplied it
Line 3345  sub put_course_id_handler { Line 3426  sub put_course_id_handler {
 #                            owner matches the supplied username and/or domain  #                            owner matches the supplied username and/or domain
 #                            will be returned. Pre-2.2.0 legacy entries from   #                            will be returned. Pre-2.2.0 legacy entries from 
 #                            nohist_courseiddump will only contain usernames.  #                            nohist_courseiddump will only contain usernames.
   #                 type     - optional parameter for selection 
   #                 regexp_ok - if true, allow the supplied institutional code
   #                            filter to behave as a regular expression.  
   #                 rtn_as_hash - whether to return the information available for
   #                            each matched item as a frozen hash of all 
   #                            key, value pairs in the item's hash, or as a 
   #                            colon-separated list of (in order) description,
   #                            institutional code, and course owner.
   #    
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3352  sub put_course_id_handler { Line 3442  sub put_course_id_handler {
 #   a reply is written to $client.  #   a reply is written to $client.
 sub dump_course_id_handler {  sub dump_course_id_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
         $typefilter,$regexp_ok) =split(/:/,$tail);          $typefilter,$regexp_ok,$rtn_as_hash) =split(/:/,$tail);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
Line 3396  sub dump_course_id_handler { Line 3485  sub dump_course_id_handler {
     if (defined($regexp_ok)) {      if (defined($regexp_ok)) {
         $regexp_ok=&unescape($regexp_ok);          $regexp_ok=&unescape($regexp_ok);
     }      }
       my $unpack = 1;
     unless (defined($since)) { $since=0; }      if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && 
           $typefilter eq '.') {
           $unpack = 0;
       }
       if (!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,$owner,$type);              my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,%unesc_val);
             my @courseitems = split(/:/,$value);              $unesc_key = &unescape($key);
             $lasttime = pop(@courseitems);              if ($unesc_key =~ /^lasttime:/) {
     ($descr,$inst_code,$owner,$type)=@courseitems;                  next;
     if ($lasttime<$since) { next; }              } else {
                   $lasttime_key = &escape('lasttime:'.$unesc_key);
               }
               if ($hashref->{$lasttime_key} ne '') {
                   $lasttime = $hashref->{$lasttime_key};
                   next if ($lasttime<$since);
               }
               my $items = &Apache::lonnet::thaw_unescape($value);
               if (ref($items) eq 'HASH') {
                   $is_hash =  1;
                   if ($unpack || !$rtn_as_hash) {
                       $unesc_val{'descr'} = $items->{'description'};
                       $unesc_val{'inst_code'} = $items->{'inst_code'};
                       $unesc_val{'owner'} = $items->{'owner'};
                       $unesc_val{'type'} = $items->{'type'};
                   }
               } else {
                   $is_hash =  0;
                   my @courseitems = split(/:/,&unescape($value));
                   $lasttime = pop(@courseitems);
                   next if ($lasttime<$since);
           ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
               }
             my $match = 1;              my $match = 1;
     unless ($description eq '.') {      if ($description ne '.') {
  my $unescapeDescr = &unescape($descr);                  if (!$is_hash) {
  unless (eval('$unescapeDescr=~/\Q$description\E/i')) {                      $unesc_val{'descr'} = &unescape($val{'descr'});
                   }
                   if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
                     $match = 0;                      $match = 0;
  }                  }
             }              }
             unless ($instcodefilter eq '.' || !defined($instcodefilter)) {              if ($instcodefilter ne '.') {
                 my $unescapeInstcode = &unescape($inst_code);                  if (!$is_hash) {
                       $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                   }
                 if ($regexp_ok) {                  if ($regexp_ok) {
                     unless (eval('$unescapeInstcode=~/$instcodefilter/')) {                      if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                         $match = 0;                          $match = 0;
                     }                      }
                 } else {                  } else {
                     unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {                      if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                         $match = 0;                          $match = 0;
                     }                      }
                 }                  }
     }      }
             unless ($ownerfilter eq '.' || !defined($ownerfilter)) {              if ($ownerfilter ne '.') {
                 my $unescapeOwner = &unescape($owner);                  if (!$is_hash) {
                       $unesc_val{'owner'} = &unescape($val{'owner'});
                   }
                 if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {                  if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner !~                           if (eval{$unesc_val{'owner'} !~ 
                              /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {                               /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                             $match = 0;                              $match = 0;
                         }                           } 
                     } else {                      } else {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                             $match = 0;                              $match = 0;
                         }                          }
                     }                      }
                 } elsif ($ownerunamefilter ne '') {                  } elsif ($ownerunamefilter ne '') {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                              $match = 0;                               $match = 0;
                         }                          }
                     } else {                      } else {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                             $match = 0;                              $match = 0;
                         }                          }
                     }                      }
                 } elsif ($ownerdomfilter ne '') {                  } elsif ($ownerdomfilter ne '') {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {                          if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                              $match = 0;                               $match = 0;
                         }                          }
                     } else {                      } else {
Line 3461  sub dump_course_id_handler { Line 3582  sub dump_course_id_handler {
                     }                      }
                 }                  }
             }              }
             unless ($coursefilter eq '.' || !defined($coursefilter)) {              if ($coursefilter ne '.') {
                 my $unescapeCourse = &unescape($key);                  if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
                 unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {  
                     $match = 0;                      $match = 0;
                 }                  }
             }              }
             unless ($typefilter eq '.' || !defined($typefilter)) {              if ($typefilter ne '.') {
                 my $unescapeType = &unescape($type);                  if (!$is_hash) {
                 if ($type eq '') {                      $unesc_val{'type'} = &unescape($val{'type'});
                   }
                   if ($unesc_val{'type'} eq '') {
                     if ($typefilter ne 'Course') {                      if ($typefilter ne 'Course') {
                         $match = 0;                          $match = 0;
                     }                      }
                 } else {                   } else {
                     unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {                      if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                         $match = 0;                          $match = 0;
                     }                      }
                 }                  }
             }              }
             if ($match == 1) {              if ($match == 1) {
                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';                  if ($rtn_as_hash) {
                       if ($is_hash) {
                           $qresult.=$key.'='.$value.'&';
                       } else {
                           my %rtnhash = ( 'description' => &escape($val{'descr'}),
                                           'inst_code' => &escape($val{'inst_code'}),
                                           'owner'     => &escape($val{'owner'}),
                                           'type'      => &escape($val{'type'}),
                                         );
                           my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                           $qresult.=$key.'='.$items.'&';
                       }
                   } else {
                       if ($is_hash) {
                           $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
                                       &escape($unesc_val{'inst_code'}).':'.
                                       &escape($unesc_val{'owner'}).'&';
                       } else {
                           $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
                                       ':'.$val{'owner'}.'&';
                       }
                   }
             }              }
  }   }
  if (&untie_domain_hash($hashref)) {   if (&untie_domain_hash($hashref)) {
Line 3494  sub dump_course_id_handler { Line 3637  sub dump_course_id_handler {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  "while attempting courseiddump\n", $userinput);   "while attempting courseiddump\n", $userinput);
     }      }
   
   
     return 1;      return 1;
 }  }
 &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);  &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
Line 4314  sub validate_course_section_handler { Line 4455  sub validate_course_section_handler {
 sub validate_class_access_handler {  sub validate_class_access_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my ($inst_class,$courseowner,$cdom) = split(/:/, $tail);      my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
     $courseowner = &unescape($courseowner);      my @owners = split(/,/,&unescape($ownerlist));
     my $outcome;      my $outcome;
     eval {      eval {
  local($SIG{__DIE__})='DEFAULT';   local($SIG{__DIE__})='DEFAULT';
  $outcome=&localenroll::check_section($inst_class,$courseowner,$cdom);   $outcome=&localenroll::check_section($inst_class,\@owners,$cdom);
     };      };
     &Reply($client,"$outcome\n", $userinput);      &Reply($client,"$outcome\n", $userinput);
   
Line 4493  sub get_institutional_defaults_handler { Line 4634  sub get_institutional_defaults_handler {
 &register_handler("autoinstcodedefaults",  &register_handler("autoinstcodedefaults",
                   \&get_institutional_defaults_handler,0,1,0);                    \&get_institutional_defaults_handler,0,1,0);
   
   sub get_institutional_user_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,$result."\n",$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instuserrules",\&get_institutional_user_rules,0,1,0);
   
   
   sub institutional_username_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$uname,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $uname = &unescape($uname);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,$result."\n",$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instrulecheck",\&institutional_username_check,0,1,0);
   
   
 # Get domain specific conditions for import of student photographs to a course  # Get domain specific conditions for import of student photographs to a course
 #  #
Line 4625  sub inst_usertypes_handler { Line 4830  sub inst_usertypes_handler {
     my ($cmd, $domain, $client) = @_;      my ($cmd, $domain, $client) = @_;
     my $res;      my $res;
     my $userinput = $cmd.":".$domain; # For logging purposes.      my $userinput = $cmd.":".$domain; # For logging purposes.
     my (%typeshash,@order);        my (%typeshash,@order,$result);
     if (&localenroll::inst_usertypes($domain,\%typeshash,\@order) eq 'ok') {      eval {
    local($SIG{__DIE__})='DEFAULT';
    $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
       };
       if ($result eq 'ok') {
         if (keys(%typeshash) > 0) {          if (keys(%typeshash) > 0) {
             foreach my $key (keys(%typeshash)) {              foreach my $key (keys(%typeshash)) {
                 $res.=&escape($key).'='.&escape($typeshash{$key}).'&';                  $res.=&escape($key).'='.&escape($typeshash{$key}).'&';
Line 4909  sub catchexception { Line 5118  sub catchexception {
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &status("Catching exception");      &status("Catching exception");
     &logthis("<font color='red'>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "       ."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
     if ($client) { print $client "error: $error\n"; }      if ($client) { print $client "error: $error\n"; }
Line 4972  $server = IO::Socket::INET->new(LocalPor Line 5181  $server = IO::Socket::INET->new(LocalPor
   
 my %children               = ();       # keys are current child process IDs  my %children               = ();       # keys are current child process IDs
   
   sub flip_max_children_enforcing {
       $max_children_enforcing = !$max_children_enforcing;
       &logthis("Flipped child maximum enforcement to (".
        $max_children_enforcing.")");
   }
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
     &status("Handling child death");      &status("Handling child death");
Line 5020  sub HUPSMAN {                      # sig Line 5235  sub HUPSMAN {                      # sig
 }  }
   
 #  #
 #    Kill off hashes that describe the host table prior to re-reading it.  
 #    Hashes affected are:  
 #       %hostid, %hostdom %hostip %hostdns.  
 #  
 sub KillHostHashes {  
     foreach my $key (keys %hostid) {  
  delete $hostid{$key};  
     }  
     foreach my $key (keys %hostdom) {  
  delete $hostdom{$key};  
     }  
     foreach my $key (keys %hostip) {  
  delete $hostip{$key};  
     }  
     foreach my $key (keys %hostdns) {  
  delete $hostdns{$key};  
     }  
 }  
 #  
 #   Read in the host table from file and distribute it into the various hashes:  
 #  
 #    - %hostid  -  Indexed by IP, the loncapa hostname.  
 #    - %hostdom -  Indexed by  loncapa hostname, the domain.  
 #    - %hostip  -  Indexed by hostid, the Ip address of the host.  
 sub ReadHostTable {  
   
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  
     my $myloncapaname = $perlvar{'lonHostID'};  
     Debug("My loncapa name is : $myloncapaname");  
     my %name_to_ip;  
     while (my $configline=<CONFIG>) {  
  if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {  
     my ($id,$domain,$role,$name)=split(/:/,$configline);  
     $name=~s/\s//g;  
     my $ip;  
     if (!exists($name_to_ip{$name})) {  
  $ip = gethostbyname($name);  
  if (!$ip || length($ip) ne 4) {  
     &logthis("Skipping host $id name $name no IP found\n");  
     next;  
  }  
  $ip=inet_ntoa($ip);  
  $name_to_ip{$name} = $ip;  
     } else {  
  $ip = $name_to_ip{$name};  
     }  
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.  
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.   
     $hostname{$id}=$name;     # LonCAPA name -> DNS name  
     $hostip{$id}=$ip;         # IP address of host.  
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.  
   
     if ($id eq $perlvar{'lonHostID'}) {   
  Debug("Found me in the host table: $name");  
  $thisserver=$name;   
     }  
  }  
     }  
     close(CONFIG);  
 }  
 #  
 #  Reload the Apache daemon's state.  #  Reload the Apache daemon's state.
 #  This is done by invoking /home/httpd/perl/apachereload  #  This is done by invoking /home/httpd/perl/apachereload
 #  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.
Line 5111  sub UpdateHosts { Line 5265  sub UpdateHosts {
     #  either dropped or changed hosts.  Note that the re-read of the table      #  either dropped or changed hosts.  Note that the re-read of the table
     #  will take care of new and changed hosts as connections come into being.      #  will take care of new and changed hosts as connections come into being.
   
       &Apache::lonnet::reset_hosts_info();
   
     KillHostHashes;      foreach my $child (keys(%children)) {
     ReadHostTable;  
   
     foreach my $child (keys %children) {  
  my $childip = $children{$child};   my $childip = $children{$child};
  if(!$hostid{$childip}) {   if ($childip ne '127.0.0.1'
       && !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
     logthis('<font color="blue"> UpdateHosts killing child '      logthis('<font color="blue"> UpdateHosts killing child '
     ." $child for ip $childip </font>");      ." $child for ip $childip </font>");
     kill('INT', $child);      kill('INT', $child);
Line 5343  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN; Line 5496  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 $SIG{HUP}  = \&HUPSMAN;  $SIG{HUP}  = \&HUPSMAN;
 $SIG{USR1} = \&checkchildren;  $SIG{USR1} = \&checkchildren;
 $SIG{USR2} = \&UpdateHosts;  $SIG{USR2} = \&UpdateHosts;
   $SIG{SEGV} = \&flip_max_children_enforcing;
   
 #  Read the host hashes:  #  Read the host hashes:
   &Apache::lonnet::load_hosts_tab();
 ReadHostTable;  
   
 my $dist=`$perlvar{'lonDaemons'}/distprobe`;  my $dist=`$perlvar{'lonDaemons'}/distprobe`;
   
Line 5359  while (1) { Line 5512  while (1) {
     &status('Starting accept');      &status('Starting accept');
     $client = $server->accept() or next;      $client = $server->accept() or next;
     &status('Accepted '.$client.' off to spawn');      &status('Accepted '.$client.' off to spawn');
     make_new_child($client);      my $child_count = scalar(keys(%children));
       if ($child_count > $max_children) {
    &logthis("Warning too many children (".$child_count.")");
       }
   #    if ($child_count > $max_children && $max_children_enforcing) {
   # &logthis(" Not creating new child ");
   # $client->close();
   #    } else {
    &make_new_child($client);
   #    }
       &logthis("Concurrent children at ($child_count)");
     &status('Finished spawning');      &status('Finished spawning');
 }  }
   
Line 5436  sub make_new_child { Line 5599  sub make_new_child {
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
  # see if we know client and 'check' for spoof IP by ineffective challenge   # see if we know client and 'check' for spoof IP by ineffective challenge
   
  ReadManagerTable; # May also be a manager!!  
   
  my $outsideip=$clientip;   my $outsideip=$clientip;
  if ($clientip eq '127.0.0.1') {   if ($clientip eq '127.0.0.1') {
     $outsideip=$hostip{$perlvar{'lonHostID'}};      $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
  }   }
   
  my $clientrec=($hostid{$outsideip}     ne undef);   my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
  my $ismanager=($managers{$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{$outsideip};      $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
     if($ismanager) {      if($ismanager) {
  $ConnectionType = "both";   $ConnectionType = "both";
     }      }
Line 5555  sub make_new_child { Line 5716  sub make_new_child {
     
  if ($clientok) {   if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
           if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip 
     if ($hostip{$currenthostid} ne $clientip   
  && $clientip ne '127.0.0.1') {   && $clientip ne '127.0.0.1') {
  &Apache::lonnet::reconlonc();   &Apache::lonnet::reconlonc($clientname);
     }      }
     &logthis("<font color='green'>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     my $keep_going = 1;      my $keep_going = 1;
     my $user_input;      my $user_input;
       my $max_size = (split("\n",`ps -o vsz $$`))[-1];
     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");
  $keep_going = &process_request($user_input);   $keep_going = &process_request($user_input);
    if (!$max_children_enforcing) {
       my $new_size = (split("\n",`ps -o vsz $$`))[-1];
       if ($new_size > $max_size) {
    &logthis("size increase of ".($new_size-$max_size)." ($new_size) while processing (".length($user_input).")\n".substr($user_input,0,80));
    $max_size = $new_size;
       }
    }
  alarm(0);   alarm(0);
  &status('Listening to '.$clientname." ($keymode)");      &status('Listening to '.$clientname." ($keymode)");   
     }      }
Line 5842  sub validate_user { Line 6010  sub validate_user {
  $password,   $password,
  $credentials);   $credentials);
  $validated = ($krbreturn == 1);   $validated = ($krbreturn == 1);
    if (!$validated) {
       &logthis('krb5: '.$user.', '.$contentpwd.', '.
        &Authen::Krb5::error());
    }
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
Line 6087  sub subscribe { Line 6259  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://$thisserver/".$fname;   $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
  $result="$fname\n";   $result="$fname\n";
     }      }
  } else {   } else {
Line 6241  sub sethost { Line 6413  sub sethost {
     }      }
   
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}) 
    eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=$hostdom{$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");

Removed from v.1.367  
changed lines
  Added in v.1.385


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