--- loncom/lonnet/perl/lonnet.pm 2017/05/25 23:55:42 1.1346
+++ loncom/lonnet/perl/lonnet.pm 2017/10/16 16:33:54 1.1357
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1346 2017/05/25 23:55:42 raeburn Exp $
+# $Id: lonnet.pm,v 1.1357 2017/10/16 16:33:54 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -650,7 +650,7 @@ sub transfer_profile_to_env {
# ---------------------------------------------------- Check for valid session
sub check_for_valid_session {
- my ($r,$name,$userhashref) = @_;
+ my ($r,$name,$userhashref,$domref) = @_;
my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
my ($linkname,$pubname);
if ($name eq '') {
@@ -678,7 +678,16 @@ sub check_for_valid_session {
} else {
$lonidsdir=$r->dir_config('lonIDsDir');
}
- return undef if (!-e "$lonidsdir/$handle.id");
+ if (!-e "$lonidsdir/$handle.id") {
+ if ((ref($domref)) && ($name eq 'lonID') &&
+ ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
+ my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
+ if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
+ $$domref = $possudom;
+ }
+ }
+ return undef;
+ }
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
return undef if (!$opened);
@@ -1598,6 +1607,100 @@ sub internet_dom_servers {
return %uniqservers;
}
+sub trusted_domains {
+ my ($cmdtype,$calldom) = @_;
+ my ($trusted,$untrusted);
+ if (&domain($calldom) eq '') {
+ return ($trusted,$untrusted);
+ }
+ unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) {
+ return ($trusted,$untrusted);
+ }
+ my $callprimary = &domain($calldom,'primary');
+ my $intcalldom = &Apache::lonnet::internet_dom($callprimary);
+ if ($intcalldom eq '') {
+ return ($trusted,$untrusted);
+ }
+
+ my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom);
+ unless (defined($cached)) {
+ my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom);
+ &Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600);
+ $trustconfig = $domconfig{'trust'};
+ }
+ if (ref($trustconfig)) {
+ my (%possexc,%possinc,@allexc,@allinc);
+ if (ref($trustconfig->{$cmdtype}) eq 'HASH') {
+ if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') {
+ map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};
+ }
+ if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
+ map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
+ }
+ }
+ if (keys(%possexc)) {
+ if (keys(%possinc)) {
+ foreach my $key (sort(keys(%possexc))) {
+ next if ($key eq $intcalldom);
+ unless ($possinc{$key}) {
+ push(@allexc,$key);
+ }
+ }
+ } else {
+ @allexc = sort(keys(%possexc));
+ }
+ }
+ if (keys(%possinc)) {
+ $possinc{$intcalldom} = 1;
+ @allinc = sort(keys(%possinc));
+ }
+ if ((@allexc > 0) || (@allinc > 0)) {
+ my %doms_by_intdom;
+ my %allintdoms = &all_host_intdom();
+ my %alldoms = &all_host_domain();
+ foreach my $key (%allintdoms) {
+ if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') {
+ unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) {
+ push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key});
+ }
+ } else {
+ $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}];
+ }
+ }
+ foreach my $exc (@allexc) {
+ if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
+ $untrusted = $doms_by_intdom{$exc};
+ }
+ }
+ foreach my $inc (@allinc) {
+ if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
+ $trusted = $doms_by_intdom{$inc};
+ }
+ }
+ }
+ }
+ return ($trusted,$untrusted);
+}
+
+sub will_trust {
+ my ($cmdtype,$domain,$possdom) = @_;
+ return 1 if ($domain eq $possdom);
+ my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom);
+ my $willtrust;
+ if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) {
+ if (grep(/^\Q$domain\E$/,@{$trustedref})) {
+ $willtrust = 1;
+ }
+ } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) {
+ unless (grep(/^\Q$domain\E$/,@{$untrustedref})) {
+ $willtrust = 1;
+ }
+ } else {
+ $willtrust = 1;
+ }
+ return $willtrust;
+}
+
# ---------------------- Find the homebase for a user from domain's lib servers
my %homecache;
@@ -1991,6 +2094,16 @@ sub inst_directory_query {
my $homeserver = &domain($udom,'primary');
my $outcome;
if ($homeserver ne '') {
+ unless ($homeserver eq $perlvar{'lonHostID'}) {
+ if ($srch->{'srchby'} eq 'email') {
+ my $lcrev = &get_server_loncaparev(undef,$homeserver);
+ my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+ if (($major eq '' && $minor eq '') || ($major < 2) ||
+ (($major == 2) && ($minor < 12))) {
+ return;
+ }
+ }
+ }
my $queryid=&reply("querysend:instdirsearch:".
&escape($srch->{'srchby'}).':'.
&escape($srch->{'srchterm'}).':'.
@@ -2032,6 +2145,14 @@ sub usersearch {
my $query = 'usersearch';
foreach my $tryserver (keys(%libserv)) {
if (&host_domain($tryserver) eq $dom) {
+ unless ($tryserver eq $perlvar{'lonHostID'}) {
+ if ($srch->{'srchby'} eq 'email') {
+ my $lcrev = &get_server_loncaparev(undef,$tryserver);
+ my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
+ next if (($major eq '' && $minor eq '') || ($major < 2) ||
+ (($major == 2) && ($minor < 12)));
+ }
+ }
my $host=&hostname($tryserver);
my $queryid=
&reply("querysend:".&escape($query).':'.
@@ -2350,6 +2471,9 @@ sub get_domain_defaults {
} elsif ($domconfig{'coursedefaults'}{'canclone'}) {
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
}
+ if ($domconfig{'coursedefaults'}{'texengine'}) {
+ $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
+ }
}
if (ref($domconfig{'usersessions'}) eq 'HASH') {
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
@@ -3077,6 +3201,71 @@ sub externalssi {
}
}
+
+# If the local copy of a replicated resource is outdated, trigger a
+# connection from the homeserver to flush the delayed queue. If no update
+# happens, remove local copies of outdated resource (and corresponding
+# metadata file).
+
+sub remove_stale_resfile {
+ my ($url) = @_;
+ my $removed;
+ if ($url=~m{^/res/($match_domain)/($match_username)/}) {
+ my $audom = $1;
+ my $auname = $2;
+ unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
+ my $homeserver = &homeserver($auname,$audom);
+ unless (($homeserver eq 'no_host') ||
+ (grep { $_ eq $homeserver } ¤t_machine_ids())) {
+ my $fname = &filelocation('',$url);
+ if (-e $fname) {
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
+ my $hostname = &hostname($homeserver);
+ if ($hostname) {
+ my $uri = &declutter($url);
+ my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
+ my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
+ if ($response->is_success()) {
+ my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
+ my $locmodtime = (stat($fname))[9];
+ if ($locmodtime < $remmodtime) {
+ my $stale;
+ my $answer = &reply('pong',$homeserver);
+ if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
+ sleep(0.2);
+ $locmodtime = (stat($fname))[9];
+ if ($locmodtime < $remmodtime) {
+ my $posstransfer = $fname.'.in.transfer';
+ if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
+ $removed = 1;
+ } else {
+ $stale = 1;
+ }
+ } else {
+ $removed = 1;
+ }
+ } else {
+ $stale = 1;
+ }
+ if ($stale) {
+ unlink($fname);
+ if ($uri!~/\.meta$/) {
+ unlink($fname.'.meta');
+ }
+ &reply("unsub:$fname",$homeserver);
+ $removed = 1;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return $removed;
+}
+
# -------------------------------- Allow a /uploaded/ URI to be vouched for
sub allowuploaded {
@@ -3600,12 +3789,12 @@ sub userfileupload {
'_'.$env{'user.domain'}.'/pending';
} elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
my ($docuname,$docudom);
- if ($destudom) {
+ if ($destudom =~ /^$match_domain$/) {
$docudom = $destudom;
} else {
$docudom = $env{'user.domain'};
}
- if ($destuname) {
+ if ($destuname =~ /^$match_username$/) {
$docuname = $destuname;
} else {
$docuname = $env{'user.name'};
@@ -13269,8 +13458,23 @@ sub fetch_dns_checksums {
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
+ if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
+ my $curr = $hostname{$id};
+ my $skip;
+ if (ref($name_to_host{$curr}) eq 'ARRAY') {
+ if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
+ $skip = 1;
+ } else {
+ @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
+ }
+ }
+ unless ($skip) {
+ push(@{$name_to_host{$name}},$id);
+ }
+ } else {
+ push(@{$name_to_host{$name}},$id);
+ }
$hostname{$id}=$name;
- push(@{$name_to_host{$name}}, $id);
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
if (defined($protocol)) {