Diff for /loncom/lond between versions 1.352 and 1.380.2.1

version 1.352, 2006/11/27 23:10:27 version 1.380.2.1, 2007/09/29 04:05:29
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 44  use Digest::MD5 qw(md5_hex); Line 45  use Digest::MD5 qw(md5_hex);
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  use Authen::Krb4;
 use Authen::Krb5;  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  
 use localauth;  use localauth;
 use localenroll;  use localenroll;
 use localstudentphoto;  use localstudentphoto;
 use File::Copy;  use File::Copy;
 use File::Find;  use File::Find;
 use LONCAPA::ConfigFileEdit;  
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
Line 70  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;
   
Line 86  my $tmpsnum = 0;  # Id of tmpputs. Line 84  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 143  my @adderrors    = ("ok", Line 135  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 179  sub ResetStatistics { Line 171  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 425  sub ReadManagerTable { Line 414  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 443  sub ReadManagerTable { Line 432  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 504  sub AdjustHostContents { Line 493  sub AdjustHostContents {
     my $adjusted;      my $adjusted;
     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 =~ /^ *$/))) {
     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) {
           my $ip = gethostbyname($name);   my $ip = gethostbyname($name);
           my $ipnew = inet_ntoa($ip);   my $ipnew = inet_ntoa($ip);
          $ip = $ipnew;   $ip = $ipnew;
  #  Reconstruct the host line and append to adjusted:   #  Reconstruct the host line and append to adjusted:
   
    my $newline = "$id:$domain:$role:$name:$ip";   my $newline = "$id:$domain:$role:$name:$ip";
    if($maxcon ne "") { # Not all hosts have loncnew tuning params   if($maxcon ne "") { # Not all hosts have loncnew tuning params
      $newline .= ":$maxcon:$idleto:$mincon";      $newline .= ":$maxcon:$idleto:$mincon";
    }   }
    $adjusted .= $newline."\n";   $adjusted .= $newline."\n";
   
       } else { # Not me, pass unmodified.      } else { # Not me, pass unmodified.
    $adjusted .= $line."\n";   $adjusted .= $line."\n";
       }      }
  } else {                  # Blank or comment never re-written.   } else {                  # Blank or comment never re-written.
     $adjusted .= $line."\n"; # Pass blanks and comments as is.      $adjusted .= $line."\n"; # Pass blanks and comments as is.
  }   }
  }      }
  return $adjusted;      return $adjusted;
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
Line 1033  sub ping_handler { Line 1022  sub ping_handler {
 sub pong_handler {  sub pong_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
     my $reply=&reply("ping",$clientname);      my $reply=&Apache::lonnet::reply("ping",$clientname);
     &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");       &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
     return 1;      return 1;
 }  }
Line 1143  sub load_handler { Line 1132  sub load_handler {
 sub user_load_handler {  sub user_load_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
     my $userloadpercent=&userload();      my $userloadpercent=&Apache::lonnet::userload();
     &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");      &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
           
     return 1;      return 1;
Line 1269  sub du_handler { Line 1258  sub du_handler {
  my $code=sub {    my $code=sub { 
     if ($_=~/\.\d+\./) { return;}       if ($_=~/\.\d+\./) { return;} 
     if ($_=~/\.meta$/) { return;}      if ($_=~/\.meta$/) { return;}
       if (-d $_)         { return;}
     $total_size+=(stat($_))[7];      $total_size+=(stat($_))[7];
  };   };
  chdir($ududir);   chdir($ududir);
Line 1850  sub update_resource_handler { Line 1840  sub update_resource_handler {
     my $now=time;      my $now=time;
     my $since=$now-$atime;      my $since=$now-$atime;
     if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&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 {
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
  alarm(120);   alarm(120);
  {   {
Line 1901  sub devalidate_meta_cache { Line 1891  sub devalidate_meta_cache {
     my ($url) = @_;      my ($url) = @_;
     use Cache::Memcached;      use Cache::Memcached;
     my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});      my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
     $url = &declutter($url);      $url = &Apache::lonnet::declutter($url);
     $url =~ s-\.meta$--;      $url =~ s-\.meta$--;
     my $id = &escape('meta:'.$url);      my $id = &escape('meta:'.$url);
     $memcache->delete($id);      $memcache->delete($id);
 }  }
   
 sub declutter {  
     my $thisfn=shift;  
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;  
     $thisfn=~s/^\///;  
     $thisfn=~s|^adm/wrapper/||;  
     $thisfn=~s|^adm/coursedocs/showdoc/||;  
     $thisfn=~s/^res\///;  
     $thisfn=~s/\?.+$//;  
     return $thisfn;  
 }  
 #  #
 #   Fetch a user file from a remote server to the user's home directory  #   Fetch a user file from a remote server to the user's home directory
 #   userfiles subdir.  #   userfiles subdir.
Line 2115  sub rename_user_file_handler { Line 2095  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 2207  sub subscribe_handler { Line 2218  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 3293  sub put_course_id_handler { Line 3304  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;
               my @current_items = split(/:/,$hashref->{$key},-1);
             my @current_items = split(/:/,$hashref->{$key});  
             shift(@current_items); # remove description              shift(@current_items); # remove description
             pop(@current_items);   # remove last access              pop(@current_items);   # remove last access
             my $numcurrent = scalar(@current_items);              my $numcurrent = scalar(@current_items);
               if ($numcurrent > 3) {
             my @new_items = split(/:/,$courseinfo);                  $numcurrent = 3;
               }
               my @new_items = split(/:/,$courseinfo,-1);
             my $numnew = scalar(@new_items);              my $numnew = scalar(@new_items);
             if ($numcurrent > 0) {              if ($numcurrent > 0) {
                 if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2                   if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 
Line 3599  sub get_domain_handler { Line 3611  sub get_domain_handler {
   
     return 1;      return 1;
 }  }
 &register_handler("getdom", \&get_id_handler, 0, 1, 0);  &register_handler("getdom", \&get_domain_handler, 0, 1, 0);
   
   
 #  #
Line 4451  sub get_institutional_code_format_handle Line 4463  sub get_institutional_code_format_handle
     \%cat_titles,      \%cat_titles,
     \%cat_order);      \%cat_order);
     if ($formatreply eq 'ok') {      if ($formatreply eq 'ok') {
  my $codes_str = &hash2str(%codes);   my $codes_str = &Apache::lonnet::hash2str(%codes);
  my $codetitles_str = &array2str(@codetitles);   my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
  my $cat_titles_str = &hash2str(%cat_titles);   my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
  my $cat_order_str = &hash2str(%cat_order);   my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
  &Reply($client,   &Reply($client,
        $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'         $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
        .$cat_order_str."\n",         .$cat_order_str."\n",
Line 4630  sub student_photo_handler { Line 4642  sub student_photo_handler {
 }  }
 &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);  &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
   
   sub inst_usertypes_handler {
       my ($cmd, $domain, $client) = @_;
       my $res;
       my $userinput = $cmd.":".$domain; # For logging purposes.
       my (%typeshash,@order,$result);
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
       };
       if ($result eq 'ok') {
           if (keys(%typeshash) > 0) {
               foreach my $key (keys(%typeshash)) {
                   $res.=&escape($key).'='.&escape($typeshash{$key}).'&';
               }
           }
           $res=~s/\&$//;
           $res .= ':';
           if (@order > 0) {
               foreach my $item (@order) {
                   $res .= &escape($item).'&';
               }
           }
           $res=~s/\&$//;
       }
       &Reply($client, "$res\n", $userinput);
       return 1;
   }
   &register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
   
 # mkpath makes all directories for a file, expects an absolute path with a  # mkpath makes all directories for a file, expects an absolute path with a
 # file or a trailing / if just a dir is passed  # file or a trailing / if just a dir is passed
 # returns 1 on success 0 on failure  # returns 1 on success 0 on failure
Line 4893  sub catchexception { Line 4934  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 5004  sub HUPSMAN {                      # sig Line 5045  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 5095  sub UpdateHosts { Line 5075  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 5261  sub status { Line 5240  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # ----------------------------------------------------------- Send USR1 to lonc  
   
 sub reconlonc {  
     my $peerfile=shift;  
     &logthis("Trying to reconnect for $peerfile");  
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";  
     if (my $fh=IO::File->new("$loncfile")) {  
  my $loncpid=<$fh>;  
         chomp($loncpid);  
         if (kill 0 => $loncpid) {  
     &logthis("lonc at pid $loncpid responding, sending USR1");  
             kill USR1 => $loncpid;  
         } else {  
     &logthis(  
               "<font color='red'>CRITICAL: "  
              ."lonc at pid $loncpid not responding, giving up</font>");  
         }  
     } else {  
       &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');  
     }  
 }  
   
 # -------------------------------------------------- Non-critical communication  
   
 sub subreply {  
     my ($cmd,$server)=@_;  
     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
     print $sclient "sethost:$server:$cmd\n";  
     my $answer=<$sclient>;  
     chomp($answer);  
     if (!$answer) { $answer="con_lost"; }  
     return $answer;  
 }  
   
 sub reply {  
   my ($cmd,$server)=@_;  
   my $answer;  
   if ($server ne $currenthostid) {   
     $answer=subreply($cmd,$server);  
     if ($answer eq 'con_lost') {  
  $answer=subreply("ping",$server);  
         if ($answer ne $server) {  
     &logthis("sub reply: answer != server answer is $answer, server is $server");  
            &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});  
         }  
         $answer=subreply($cmd,$server);  
     }  
   } else {  
     $answer='self_reply';  
   }   
   return $answer;  
 }  
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
   
 sub sql_reply {  sub sql_reply {
Line 5386  $SIG{USR1} = \&checkchildren; Line 5308  $SIG{USR1} = \&checkchildren;
 $SIG{USR2} = \&UpdateHosts;  $SIG{USR2} = \&UpdateHosts;
   
 #  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 5466  sub make_new_child { Line 5387  sub make_new_child {
 #        my $tmpsnum=0;            # Now global  #        my $tmpsnum=0;            # Now global
 #---------------------------------------------------- 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 'suse9.3')) {   ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 5477  sub make_new_child { Line 5398  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 5596  sub make_new_child { Line 5515  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 
     foreach my $id (keys(%hostip)) {   && $clientip ne '127.0.0.1') {
  if ($hostip{$id} ne $clientip ||   &Apache::lonnet::reconlonc($clientname);
     $hostip{$currenthostid} eq $clientip) {  
     # no need to try to do recon's to myself  
     next;  
  }  
  &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});  
     }      }
     &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);
Line 5880  sub validate_user { Line 5794  sub validate_user {
  my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;   my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);   my $krbserver  = &Authen::Krb5::parse_name($krbservice);
  my $credentials= &Authen::Krb5::cc_default();   my $credentials= &Authen::Krb5::cc_default();
  $credentials->initialize($krbclient);   $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
                                                                    .$contentpwd));
  my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,   my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,
  $krbserver,   $krbserver,
  $password,   $password,
  $credentials);   $credentials);
  $validated = ($krbreturn == 1);   $validated = ($krbreturn == 1);
    if (!$validated) {
       &logthis('krb5: '.$user.', '.$contentpwd.', '.
        &Authen::Krb5::error());
    }
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
Line 5893  sub validate_user { Line 5812  sub validate_user {
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
        $password,          $password, 
        $contentpwd);         $contentpwd,
          $domain);
       if ($validated < 0) {
    &logthis("localauth for $contentpwd $user:$domain returned a $validated");
    $validated = 0;
       }
  } else { # Unrecognized auth is also bad.   } else { # Unrecognized auth is also bad.
     $validated = 0;      $validated = 0;
  }   }
Line 5919  sub addline { Line 5843  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
     my $contents;      my $contents;
     my $found=0;      my $found=0;
     my $expr='^'.$hostid.':'.$ip.':';      my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
     $expr =~ s/\./\\\./g;  
     my $sh;      my $sh;
     if ($sh=IO::File->new("$fname.subscription")) {      if ($sh=IO::File->new("$fname.subscription")) {
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
Line 6127  sub subscribe { Line 6050  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 6281  sub sethost { Line 6204  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 ".
Line 6299  sub version { Line 6223  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
 #There is a copy of this in lonnet.pm  
 sub userload {  
     my $numusers=0;  
     {  
  opendir(LONIDS,$perlvar{'lonIDsDir'});  
  my $filename;  
  my $curtime=time;  
  while ($filename=readdir(LONIDS)) {  
     if ($filename eq '.' || $filename eq '..') {next;}  
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];  
     if ($curtime-$mtime < 1800) { $numusers++; }  
  }  
  closedir(LONIDS);  
     }  
     my $userloadpercent=0;  
     my $maxuserload=$perlvar{'lonUserLoadLim'};  
     if ($maxuserload) {  
  $userloadpercent=100*$numusers/$maxuserload;  
     }  
     $userloadpercent=sprintf("%.2f",$userloadpercent);  
     return $userloadpercent;  
 }  
   
 # Routines for serializing arrays and hashes (copies from lonnet)  
   
 sub array2str {  
   my (@array) = @_;  
   my $result=&arrayref2str(\@array);  
   $result=~s/^__ARRAY_REF__//;  
   $result=~s/__END_ARRAY_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub arrayref2str {  
   my ($arrayref) = @_;  
   my $result='__ARRAY_REF__';  
   foreach my $elem (@$arrayref) {  
     if(ref($elem) eq 'ARRAY') {  
       $result.=&arrayref2str($elem).'&';  
     } elsif(ref($elem) eq 'HASH') {  
       $result.=&hashref2str($elem).'&';  
     } elsif(ref($elem)) {  
       #print("Got a ref of ".(ref($elem))." skipping.");  
     } else {  
       $result.=&escape($elem).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_ARRAY_REF__';  
   return $result;  
 }  
                                                                                    
 sub hash2str {  
   my (%hash) = @_;  
   my $result=&hashref2str(\%hash);  
   $result=~s/^__HASH_REF__//;  
   $result=~s/__END_HASH_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub hashref2str {  
   my ($hashref)=@_;  
   my $result='__HASH_REF__';  
   foreach (sort(keys(%$hashref))) {  
     if (ref($_) eq 'ARRAY') {  
       $result.=&arrayref2str($_).'=';  
     } elsif (ref($_) eq 'HASH') {  
       $result.=&hashref2str($_).'=';  
     } elsif (ref($_)) {  
       $result.='=';  
       #print("Got a ref of ".(ref($_))." skipping.");  
     } else {  
         if ($_) {$result.=&escape($_).'=';} else { last; }  
     }  
   
     if(ref($hashref->{$_}) eq 'ARRAY') {  
       $result.=&arrayref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_}) eq 'HASH') {  
       $result.=&hashref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_})) {  
        $result.='&';  
       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");  
     } else {  
       $result.=&escape($hashref->{$_}).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_HASH_REF__';  
   return $result;  
 }  
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   

Removed from v.1.352  
changed lines
  Added in v.1.380.2.1


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