[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1056.4.2 and 1.1056.4.3

version 1.1056.4.2, 2010/05/26 17:14:43 version 1.1056.4.3, 2010/08/17 00:19:24
Line 76  use HTTP::Date; Line 76  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol);              $_64bit %env %protocol %loncaparevs %serverhomeIDs);
   
 my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,  my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
     %userrolehash, $processmarker, $dumpcount, %coursedombuf,      %userrolehash, $processmarker, $dumpcount, %coursedombuf,
Line 196  sub get_server_timezone { Line 196  sub get_server_timezone {
 }  }
   
 sub get_server_loncaparev {  sub get_server_loncaparev {
     my ($dom,$lonhost) = @_;      my ($dom,$lonhost,$ignore_cache,$caller) = @_;
     if (defined($lonhost)) {      if (defined($lonhost)) {
         if (!defined(&hostname($lonhost))) {          if (!defined(&hostname($lonhost))) {
             undef($lonhost);              undef($lonhost);
Line 211  sub get_server_loncaparev { Line 211  sub get_server_loncaparev {
         }          }
     }      }
     if (defined($lonhost)) {      if (defined($lonhost)) {
         my $cachetime = 24*3600;          my $cachetime = 12*3600;
         my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);          if (!$ignore_cache) {
               my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
               if (defined($cached)) {
                   return $loncaparev;
               }
           }
           my ($answer,$loncaparev);
           my @ids=&current_machine_ids();
           if (grep(/^\Q$lonhost\E$/,@ids)) {
               $answer = $perlvar{'lonVersion'};
               if ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) {
                   $loncaparev = $1;
               }
           } else {
               $answer = &reply('serverloncaparev',$lonhost);
               if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
                   if ($caller eq 'loncron') {
                       my $ua=new LWP::UserAgent;
                       $ua->timeout(20);
                       my $protocol = $protocol{$lonhost};
                       $protocol = 'http' if ($protocol ne 'https');
                       my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
                       my $request=new HTTP::Request('GET',$url);
                       my $response=$ua->request($request);
                       unless ($response->is_error()) {
                           my $content = $response->content;
                           if ($content =~ /<p>VERSION\:\s*([\d.\-]+)<\/p>/) {
                               $loncaparev = $1;
                           }
                       }
                   } else {
                       $loncaparev = $loncaparevs{$lonhost};
                   }
               } elsif ($answer =~ /^[\'\"]?([\d.\-]+)[\'\"]?$/) {
                   $loncaparev = $1;
               }
           }
           return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
       }
   }
   
   sub get_server_homeID {
       my ($hostname,$ignore_cache,$caller) = @_;
       unless ($ignore_cache) {
           my ($serverhomeID,$cached)=&is_cached_new('serverhomeID',$hostname);
         if (defined($cached)) {          if (defined($cached)) {
             return $loncaparev;              return $serverhomeID;
         } else {          }
             my $loncaparev = &reply('serverloncaparev',$lonhost);      }
             return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);      my $cachetime = 12*3600;
       my $serverhomeID;
       if ($caller eq 'loncron') {
           my @machine_ids = &machine_ids($hostname);
           foreach my $id (@machine_ids) {
               my $response = &reply('serverhomeID',$id);
               unless (($response eq 'unknown_cmd') || ($response eq 'con_lost')) {
                   $serverhomeID = $response;
                   last;
               }
         }          }
           if ($serverhomeID eq '') {
               $serverhomeID = $machine_ids[-1];
           }
       } else {
           $serverhomeID = $serverhomeIDs{$hostname};
     }      }
       return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
Line 734  sub compare_server_load { Line 793  sub compare_server_load {
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
   
     if ($loadans !~ /\d/ && $userloadans !~ /\d/) {      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
  next; #didn't get a number from the server          return; #didn't get a number from the server
     }      }
   
     my $load;      my $load;
Line 777  sub has_user_session { Line 836  sub has_user_session {
     return 0;      return 0;
 }  }
   
   # --------- determine least loaded server in a user's domain which allows login
   
   sub choose_server {
       my ($udom) = @_;
       my %domconfhash = &Apache::loncommon::get_domainconf($udom);
       my %servers = &get_servers($udom);
       my $lowest_load = 30000;
       my ($login_host,$hostname);
       foreach my $lonhost (keys(%servers)) {
           my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
           if ($loginvia eq '') {
               ($login_host, $lowest_load) =
               &compare_server_load($lonhost, $login_host, $lowest_load);
           }
       }
       if ($login_host ne '') {
           $hostname = $servers{$login_host};
       }
       return ($login_host,$hostname);
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 835  sub queryauthenticate { Line 915  sub queryauthenticate {
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom,$checkdefauth)=@_;      my ($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)=@_;
     $upass=&escape($upass);      $upass=&escape($upass);
     $uname= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom,1);      my $uhome=&homeserver($uname,$udom,1);
Line 858  sub authenticate { Line 938  sub authenticate {
     return 'no_host';      return 'no_host';
         }          }
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth:$clientcancheckhost",$uhome);
     if ($answer eq 'authorized') {      if ($answer eq 'authorized') {
         if ($newhome) {          if ($newhome) {
             &logthis("User $uname at $udom authorized by $uhome, but needs account");              &logthis("User $uname at $udom authorized by $uhome, but needs account");
Line 876  sub authenticate { Line 956  sub authenticate {
     return 'no_host';      return 'no_host';
 }  }
   
   sub can_host_session {
       my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
       my $canhost = 1;
       my $host_idn = &Apache::lonnet::internet_dom($lonhost);
       if (ref($remotesessions) eq 'HASH') {
           if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') {
               if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) {
                   $canhost = 0;
               } else {
                   $canhost = 1;
               }
           }
           if (ref($remotesessions->{'includedomain'}) eq 'ARRAY') {
               if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'includedomain'}})) {
                   $canhost = 1;
               } else {
                   $canhost = 0;
               }
           }
           if ($canhost) {
               if ($remotesessions->{'version'} ne '') {
                   my ($reqmajor,$reqminor) = ($remotesessions->{'version'} =~ /^(\d+)\.(\d+)$/);
                   if ($reqmajor ne '' && $reqminor ne '') {
                       if ($remoterev =~ /^\'?(\d+)\.(\d+)/) {
                           my $major = $1;
                           my $minor = $2;
                           if (($major < $reqmajor ) ||
                               (($major == $reqmajor) && ($minor < $reqminor))) {
                               $canhost = 0;
                           }
                       } else {
                           $canhost = 0;
                       }
                   }
               }
           }
       }
       if ($canhost) {
           if (ref($hostedsessions) eq 'HASH') {
               if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
                   if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
                       $canhost = 0;
                   } else {
                       $canhost = 1;
                   }
               }
               if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
                   if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
                       $canhost = 1;
                   } else {
                       $canhost = 0;
                   }
               }
           }
       }
       return $canhost;
   }
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
 my %homecache;  my %homecache;
Line 1352  sub get_domain_defaults { Line 1490  sub get_domain_defaults {
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults'],$domain);                                    'coursedefaults','usersessions'],$domain);
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 1392  sub get_domain_defaults { Line 1530  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
         }          }
     }      }
       if (ref($domconfig{'usersessions'}) eq 'HASH') {
           if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
               $domdefaults{'remotesessions'} = $domconfig{'usersessions'}{'remote'};
           }
           if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
               $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
           }
       }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                   $cachetime);                                    $cachetime);
     return %domdefaults;      return %domdefaults;
Line 3059  sub courseiddump { Line 3205  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 3081  sub courseiddump { Line 3227  sub courseiddump {
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                          &escape($cc_clone).':'.$cloneonly.':'.                           &escape($cc_clone).':'.$cloneonly.':'.
                          &escape($createdbefore).':'.&escape($createdafter).':'.                           &escape($createdbefore).':'.&escape($createdafter).':'.
                          &escape($creationcontext),$tryserver);                           &escape($creationcontext).':'.$domcloner,
                            $tryserver);
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 3905  sub rolesinit { Line 4052  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
     my $now=time;      my $now=time;
     my %userroles = ('user.login.time' => $now);      my %userroles = ('user.login.time' => $now);
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $extra = &freeze_escape({'clientcheckrole' => 1});
       my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       if (($rolesdump eq 'con_lost') || ($rolesdump eq '') || 
         ($rolesdump =~ /^error:/)) {           ($rolesdump =~ /^error:/)) {
         return \%userroles;          return \%userroles;
     }      }
     my %allroles=();      my %allroles=();
Line 9861  sub get_dns { Line 10009  sub get_dns {
  my @uniq = grep(!$seen{$_}++, values(%hostdom));   my @uniq = grep(!$seen{$_}++, values(%hostdom));
  return @uniq;   return @uniq;
     }      }
   
       sub internet_dom {
           &load_hosts_tab() if (!$loaded);
   
           my ($lonid) = @_;
           return $internetdom{$lonid};
       }
   
 }  }
   
 {   { 
Line 9978  sub get_dns { Line 10134  sub get_dns {
         return undef;          return undef;
     }      }
   
       sub get_internet_names {
           my ($lonid) = @_;
           return if ($lonid eq '');
           my ($idnref,$cached)=
               &Apache::lonnet::is_cached_new('internetnames',$lonid);
           if ($cached) {
               return $idnref;
           }
           my $ip = &get_host_ip($lonid);
           my @hosts = &get_hosts_from_ip($ip);
           my %iphost = &get_iphost();
           my (@idns,%seen);
           foreach my $id (@hosts) {
               my $dom = &host_domain($id);
               my $prim_id = &domain($dom,'primary');
               my $prim_ip = &get_host_ip($prim_id);
               next if ($seen{$prim_ip});
               if (ref($iphost{$prim_ip}) eq 'ARRAY') {
                   foreach my $id (@{$iphost{$prim_ip}}) {
                       my $intdom = &internet_dom($id);
                       unless (grep(/^\Q$intdom\E$/,@idns)) {
                           push(@idns,$intdom);
                       }
                   }
               }
               $seen{$prim_ip} = 1;
           }
           return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);
       }
   
   }
   
   sub all_loncaparevs {
       return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);
 }  }
   
 BEGIN {  BEGIN {
Line 10055  BEGIN { Line 10245  BEGIN {
     close($config);      close($config);
 }  }
   
   # ---------------------------------------------------------- Read loncaparev table
   {
       if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
               while (my $configline=<$config>) {
                   chomp($configline);
                   my ($hostid,$loncaparev)=split(/:/,$configline);
                   $loncaparevs{$hostid}=$loncaparev;
               }
               close($config);
           }
       }
   }
   
   # ---------------------------------------------------------- Read serverhostID table
   {
       if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
           if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
               while (my $configline=<$config>) {
                   chomp($configline);
                   my ($name,$id)=split(/:/,$configline);
                   $serverhomeIDs{$name}=$id;
               }
               close($config);
           }
       }
   }
   
 # ------------- set up temporary directory  # ------------- set up temporary directory
 {  {
     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';      $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
Line 10285  authentication scheme Line 10503  authentication scheme
   
 =item *  =item *
 X<authenticate()>  X<authenticate()>
 B<authenticate($uname,$upass,$udom)>: try to  B<authenticate($uname,$upass,$udom,$checkdefauth,$clientcancheckhost)>: try to
 authenticate user from domain's lib servers (first use the current  authenticate user from domain's lib servers (first use the current
 one). C<$upass> should be the users password.  one). C<$upass> should be the users password.
   $checkdefauth is optional (value is 1 if a check should be made to
      authenticate user using default authentication method, and allow
      account creation if username does not have account in the domain).
   $clientcancheckhost is optional (value is 1 if checking whether the
      server can host will occur on the client side in lonauth.pm).
   
 =item *  =item *
 X<homeserver()>  X<homeserver()>
Removed from v.1.1056.4.2  
changed lines
  Added in v.1.1056.4.3

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