--- loncom/lonnet/perl/lonnet.pm 2011/01/07 06:24:41 1.1056.4.17
+++ loncom/lonnet/perl/lonnet.pm 2014/05/05 11:37:07 1.1056.4.39
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1056.4.17 2011/01/07 06:24:41 raeburn Exp $
+# $Id: lonnet.pm,v 1.1056.4.39 2014/05/05 11:37:07 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -76,7 +76,8 @@ use HTTP::Date;
use Image::Magick;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
- $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease);
+ $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
+ %managerstab);
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
@@ -196,6 +197,29 @@ sub get_server_timezone {
}
}
+sub get_server_distarch {
+ my ($lonhost,$ignore_cache) = @_;
+ if (defined($lonhost)) {
+ if (!defined(&hostname($lonhost))) {
+ return;
+ }
+ my $cachetime = 12*3600;
+ if (!$ignore_cache) {
+ my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost);
+ if (defined($cached)) {
+ return $distarch;
+ }
+ }
+ my $rep = &reply('serverdistarch',$lonhost);
+ unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||
+ $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
+ $rep eq '') {
+ return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
+ }
+ }
+ return;
+}
+
sub get_server_loncaparev {
my ($dom,$lonhost,$ignore_cache,$caller) = @_;
if (defined($lonhost)) {
@@ -752,22 +776,22 @@ sub overloaderror {
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
- my ($loadpercent,$userloadpercent,$want_server_name) = @_;
+ my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
my $spare_server;
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
: $userloadpercent;
my ($uint_dom,$remotesessions);
- if ($env{'user.domain'}) {
- my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary');
+ if (($udom ne '') && (&domain($udom) ne '')) {
+ my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
- my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'});
+ my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
$remotesessions = $udomdefaults{'remotesessions'};
}
foreach my $try_server (@{ $spareid{'primary'} }) {
if ($uint_dom) {
- next unless (&spare_can_host($env{'user.domain'},$uint_dom,
- $remotesessions,$try_server));
+ next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+ $try_server));
}
($spare_server, $lowest_load) =
&compare_server_load($try_server, $spare_server, $lowest_load);
@@ -778,8 +802,8 @@ sub spareserver {
if (!$found_server) {
foreach my $try_server (@{ $spareid{'default'} }) {
if ($uint_dom) {
- next unless (&spare_can_host($env{'user.domain'},$uint_dom,
- $remotesessions,$try_server));
+ next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+ $try_server));
}
($spare_server, $lowest_load) =
&compare_server_load($try_server, $spare_server, $lowest_load);
@@ -802,13 +826,23 @@ sub spareserver {
}
sub compare_server_load {
- my ($try_server, $spare_server, $lowest_load) = @_;
+ my ($try_server, $spare_server, $lowest_load, $required) = @_;
+
+ if ($required) {
+ my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
+ my $remoterev = &get_server_loncaparev(undef,$try_server);
+ my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+ if (($major eq '' && $minor eq '') ||
+ (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
+ return ($spare_server,$lowest_load);
+ }
+ }
my $loadans = &reply('load', $try_server);
my $userloadans = &reply('userload',$try_server);
if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
- return; #didn't get a number from the server
+ return ($spare_server, $lowest_load); #didn't get a number from the server
}
my $load;
@@ -854,22 +888,57 @@ sub has_user_session {
# --------- determine least loaded server in a user's domain which allows login
sub choose_server {
- my ($udom) = @_;
+ my ($udom,$checkloginvia,$required,$notloadbal) = @_;
my %domconfhash = &Apache::loncommon::get_domainconf($udom);
my %servers = &get_servers($udom);
my $lowest_load = 30000;
- my ($login_host,$hostname);
+ my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
+ if ($notloadbal) {
+ ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
+ unless (defined($cached)) {
+ my $cachetime = 60*60*24;
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+ if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+ $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
+ $cachetime);
+ }
+ }
+ }
foreach my $lonhost (keys(%servers)) {
- my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
- if ($loginvia eq '') {
+ if ($notloadbal) {
+ if (ref($balancers) eq 'HASH') {
+ next if (exists($balancers->{$lonhost}));
+ }
+ }
+ my $loginvia;
+ if ($checkloginvia) {
+ $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
+ if ($loginvia) {
+ my ($server,$path) = split(/:/,$loginvia);
+ ($login_host, $lowest_load) =
+ &compare_server_load($lonhost, $login_host, $lowest_load, $required);
+ if ($login_host eq $server) {
+ $portal_path = $path;
+ $isredirect = 1;
+ }
+ } else {
+ ($login_host, $lowest_load) =
+ &compare_server_load($lonhost, $login_host, $lowest_load, $required);
+ if ($login_host eq $lonhost) {
+ $portal_path = '';
+ $isredirect = '';
+ }
+ }
+ } else {
($login_host, $lowest_load) =
- &compare_server_load($lonhost, $login_host, $lowest_load);
+ &compare_server_load($lonhost, $login_host, $lowest_load, $required);
}
}
if ($login_host ne '') {
- $hostname = $servers{$login_host};
+ $hostname = &hostname($login_host);
}
- return ($login_host,$hostname);
+ return ($login_host,$hostname,$portal_path,$isredirect);
}
# --------------------------------------------- Try to change a user's password
@@ -1010,15 +1079,19 @@ sub can_host_session {
}
if ($canhost) {
if (ref($hostedsessions) eq 'HASH') {
+ my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+ my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') {
- if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) {
+ if (($uint_dom ne '') &&
+ (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) {
$canhost = 0;
} else {
$canhost = 1;
}
}
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') {
- if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) {
+ if (($uint_dom ne '') &&
+ (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) {
$canhost = 1;
} else {
$canhost = 0;
@@ -1532,6 +1605,7 @@ sub get_domain_defaults {
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
+ $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
@@ -3671,7 +3745,7 @@ sub hashref2str {
$result.='=';
#print("Got a ref of ".(ref($key))." skipping.");
} else {
- if ($key) {$result.=&escape($key).'=';} else { last; }
+ if (defined($key)) {$result.=&escape($key).'=';} else { last; }
}
if(ref($hashref->{$key}) eq 'ARRAY') {
@@ -4016,9 +4090,12 @@ sub restore {
if ($stuname) { $home=&homeserver($stuname,$domain); }
if (!$symb) {
- unless ($symb=escape(&symbread())) { return ''; }
+ return if ($namespace eq 'courserequests');
+ unless ($symb=escape(&symbread())) { return ''; }
} else {
- $symb=&escape(&symbclean($symb));
+ unless ($namespace eq 'courserequests') {
+ $symb=&escape(&symbclean($symb));
+ }
}
if (!$namespace) {
unless ($namespace=$env{'request.course.id'}) {
@@ -5754,7 +5831,7 @@ sub allowed {
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
=~/\Q$rolecode\E/) {
- if ($priv ne 'pch') {
+ if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
$env{'request.course.id'});
@@ -5764,7 +5841,7 @@ sub allowed {
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
=~/\Q$unamedom\E/) {
- if ($priv ne 'pch') {
+ if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
$env{'request.course.id'});
@@ -5778,7 +5855,7 @@ sub allowed {
if ($thisallowed=~/R/) {
my $rolecode=(split(/\./,$env{'request.role'}))[0];
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
- if ($priv ne 'pch') {
+ if (($priv ne 'pch') && ($priv ne 'plc')) {
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
}
@@ -6131,9 +6208,9 @@ sub auto_get_sections {
}
sub auto_new_course {
- my ($cnum,$cdom,$inst_course_id,$owner) = @_;
+ my ($cnum,$cdom,$inst_course_id,$owner,$coowners) = @_;
my $homeserver = &homeserver($cnum,$cdom);
- my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.$owner.':'.$cdom,$homeserver));
+ my $response=&unescape(&reply('autonewcourse:'.$inst_course_id.':'.&escape($owner).':'.$cdom.':'.&escape($coowners),$homeserver));
return $response;
}
@@ -6705,6 +6782,13 @@ sub assignrole {
return 'refused';
}
}
+ } elsif ($role eq 'au') {
+ if ($url ne '/'.$udom.'/') {
+ &logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}.
+ ' to assign author role for '.$uname.':'.$udom.
+ ' in domain: '.$url.' refused (wrong domain).');
+ return 'refused';
+ }
}
$mrole=$role;
}
@@ -7350,8 +7434,11 @@ sub store_userdata {
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
}
$namevalue=~s/\&$//;
- $result = &reply("store:$env{'user.domain'}:$env{'user.name'}:".
- "$namespace:$datakey:$namevalue",$uhome);
+ unless ($namespace eq 'courserequests') {
+ $datakey = &escape($datakey);
+ }
+ $result = &reply("store:$udom:$uname:$namespace:$datakey:".
+ $namevalue,$uhome);
}
} else {
$result = 'error: data to store was not a hash reference';
@@ -8578,7 +8665,7 @@ sub metadata {
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
- ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^\*uploaded\/.+\.sequence$/) ) {
+ ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})
@@ -8620,7 +8707,8 @@ sub metadata {
&Apache::lonnet::ssi_body($which,
('grade_target' => 'meta'));
$cachetime = 1; # only want this cached in the child not long term
- } elsif ($uri !~ m -^(editupload)/-) {
+ } elsif (($uri !~ m -^(editupload)/-) &&
+ ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) {
my $file=&filelocation('',&clutter($filename));
#push(@{$metaentry{$uri.'.file'}},$file);
$metastring=&getfile($file);
@@ -8968,7 +9056,8 @@ sub symbverify {
}
my $ids=$bighash{'ids_'.&clutter($thisurl)};
unless ($ids) {
- $ids=$bighash{'ids_/'.$thisurl};
+ my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
+ $ids=$bighash{$idkey};
}
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
@@ -8981,7 +9070,8 @@ sub symbverify {
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {
if (($env{'request.role.adv'}) ||
- $bighash{'encrypted_'.$id} eq $env{'request.enc'}) {
+ ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
+ ($thisurl eq '/adm/navmaps')) {
$okay=1;
}
}
@@ -9976,6 +10066,7 @@ sub get_dns {
while (%alldns) {
my ($dns) = keys(%alldns);
my $ua=new LWP::UserAgent;
+ $ua->timeout(30);
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
my $response=$ua->request($request);
delete($alldns{$dns});
@@ -10060,13 +10151,19 @@ sub get_dns {
my $loaded;
my %name_to_host;
my %internetdom;
+ my %LC_dns_serv;
sub parse_hosts_tab {
my ($file) = @_;
foreach my $configline (@$file) {
next if ($configline =~ /^(\#|\s*$ )/x);
- next if ($configline =~ /^\^/);
- chomp($configline);
+ chomp($configline);
+ if ($configline =~ /^\^/) {
+ if ($configline =~ /^\^([\w.\-]+)/) {
+ $LC_dns_serv{$1} = 1;
+ }
+ next;
+ }
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
@@ -10202,6 +10299,14 @@ sub get_dns {
my ($lonid) = @_;
return $internetdom{$lonid};
}
+
+ sub is_LC_dns {
+ &load_hosts_tab() if (!$loaded);
+
+ my ($hostname) = @_;
+ return exists($LC_dns_serv{$hostname});
+ }
+
}
{
@@ -10477,6 +10582,22 @@ BEGIN {
}
}
+# ---------------------------------------------------------- Read managers table
+{
+ if (-e "$perlvar{'lonTabDir'}/managers.tab") {
+ if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {
+ while (my $configline=<$config>) {
+ chomp($configline);
+ next if ($configline =~ /^\#/);
+ if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) {
+ $managerstab{$configline} = 1;
+ }
+ }
+ close($config);
+ }
+ }
+}
+
# ------------- set up temporary directory
{
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
@@ -11370,11 +11491,11 @@ splitting on '&', supports elements that
=head2 Logging Routines
-=over 4
-
These routines allow one to make log messages in the lonnet.log and
lonnet.perm logfiles.
+=over 4
+
=item *
logtouch() : make sure the logfile, lonnet.log, exists