--- loncom/lonnet/perl/lonnet.pm 2020/05/13 01:58:16 1.1421 +++ loncom/lonnet/perl/lonnet.pm 2020/09/28 00:10:29 1.1424 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1421 2020/05/13 01:58:16 raeburn Exp $ +# $Id: lonnet.pm,v 1.1424 2020/09/28 00:10:29 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -3383,6 +3383,32 @@ sub repcopy { } } +# ------------------------------------------------- Unsubscribe from a resource + +sub unsubscribe { + my ($fname) = @_; + my $answer; + if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; } + $fname=~s/[\n\r]//g; + my $author=$fname; + $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; + my ($udom,$uname)=split(/\//,$author); + my $home=homeserver($uname,$udom); + if ($home eq 'no_host') { + $answer = 'no_host'; + } elsif (grep { $_ eq $home } ¤t_machine_ids()) { + $answer = 'home'; + } else { + my $defdom = $perlvar{'lonDefDomain'}; + if (&will_trust('content',$defdom,$udom)) { + $answer = reply("unsub:$fname",$home); + } else { + $answer = 'untrusted'; + } + } + return $answer; +} + # ------------------------------------------------ Get server side include body sub ssi_body { my ($filelink,%form)=@_; @@ -3534,7 +3560,10 @@ sub remove_stale_resfile { unlink($fname.'.meta'); } } - &reply("unsub:$fname",$homeserver); + my $unsubresult = &unsubscribe($fname); + unless ($unsubresult eq 'ok') { + &logthis("no unsub of $fname from $homeserver, reason: $unsubresult"); + } $removed = 1; } } @@ -8007,7 +8036,7 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; + my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; @@ -8238,7 +8267,7 @@ sub allowed { } elsif ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$uri); + my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8261,7 +8290,7 @@ sub allowed { } elsif ($noblockcheck) { $thisallowed='F'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); + my @blockers = &has_comm_blocking($priv,$symb,$refuri,$ignorecache); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8334,7 +8363,7 @@ sub allowed { if ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$uri); + my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8347,7 +8376,7 @@ sub allowed { $checkreferer=0; } } - + if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { @@ -8379,7 +8408,7 @@ sub allowed { } elsif ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); + my @blockers = &has_comm_blocking($priv,'',$refuri,$ignorecache); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8465,7 +8494,7 @@ sub allowed { } } } - + # # Rest of the restrictions depend on selected course # @@ -8634,6 +8663,10 @@ sub constructaccess { # # User for whom data are being temporarily cached. my $cacheduser=''; +# Course for which data are being temporarily cached. +my $cachedcid=''; +# List of blocks passed to &get_commblock_resources(); +my $cachedblocks=''; # Cached blockers for this user (a hash of blocking items). my %cachedblockers=(); # When the data were last cached. @@ -8643,13 +8676,22 @@ sub load_all_blockers { my ($uname,$udom,$blocks)=@_; if (($uname ne '') && ($udom ne '')) { if (($cacheduser eq $uname.':'.$udom) && - (abs($cachedlast-time)<5)) { + ($cachedcid eq $env{'request.course.id'}) && + (abs($cachedlast-time)<5) && + (((ref($blocks) eq 'HASH') && + ($cachedblocks eq join(',',sort(keys(%{$blocks}))))) || + (!ref($blocks) && $cachedblocks eq ''))) { return; } } $cachedlast=time; $cacheduser=$uname.':'.$udom; + $cachedcid=$env{'request.course.id'}; %cachedblockers = &get_commblock_resources($blocks); + if ((ref($blocks) eq 'HASH') && (keys(%{$blocks}) > 0)) { + $cachedblocks = join(',',sort(keys(%{$blocks}))); + } + return; } sub get_comm_blocks { @@ -8787,7 +8829,7 @@ sub get_commblock_resources { } sub has_comm_blocking { - my ($priv,$symb,$uri,$blocks) = @_; + my ($priv,$symb,$uri,$nosymbcache,$blocked,$blocks) = @_; my @blockers; return unless ($env{'request.course.id'}); return unless ($priv eq 'bre'); @@ -8797,7 +8839,7 @@ sub has_comm_blocking { return unless (keys(%cachedblockers) > 0); my (%possibles,@symbs); if (!$symb) { - $symb = &symbread($uri,1,1,1,\%possibles); + $symb = &symbread($uri,1,1,'',\%possibles,$nosymbcache); } if ($symb) { @symbs = ($symb); @@ -8811,9 +8853,11 @@ sub has_comm_blocking { foreach my $block (keys(%cachedblockers)) { if ($block =~ /^firstaccess____(.+)$/) { my $item = $1; - if (($item eq $map) || ($item eq $symb)) { - $noblock = 1; - last; + unless ($blocked) { + if (($item eq $map) || ($item eq $symb)) { + $noblock = 1; + last; + } } } if (ref($cachedblockers{$block}) eq 'HASH') { @@ -8824,18 +8868,20 @@ sub has_comm_blocking { } } } - } - if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { - if ($cachedblockers{$block}{'maps'}{$map}) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); + if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { + if ($cachedblockers{$block}{'maps'}{$map}) { + unless (grep(/^\Q$block\E$/,@blockers)) { + push(@blockers,$block); + } } } } } } - return if ($noblock); - return @blockers; + unless ($noblock) { + return @blockers; + } + return; } } @@ -10578,14 +10624,19 @@ sub writecoursepref { sub createcourse { my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, - $course_owner,$crstype,$cnum,$context,$category)=@_; + $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_; $url=&declutter($url); my $cid=''; if ($context eq 'requestcourses') { my $can_create = 0; my ($ownername,$ownerdom) = split(':',$course_owner); if ($udom eq $ownerdom) { - if (&usertools_access($ownername,$ownerdom,$category,undef, + my $reload; + if (($callercontext eq 'auto') && + ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) { + $reload = 'reload'; + } + if (&usertools_access($ownername,$ownerdom,$category,$reload, $context)) { $can_create = 1; } @@ -13258,19 +13309,26 @@ sub deversion { # ------------------------------------------------------ Return symb list entry sub symbread { - my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; + my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles, + $nocache)=@_; my $cache_str='request.symbread.cached.'.$thisfn; - if (defined($env{$cache_str})) { - if ($ignorecachednull) { - return $env{$cache_str} unless ($env{$cache_str} eq ''); - } else { - return $env{$cache_str}; + if (defined($env{$cache_str}) && !$nocache) { + unless (ref($possibles) eq 'HASH') { + if ($ignorecachednull) { + return $env{$cache_str} unless ($env{$cache_str} eq ''); + } else { + return $env{$cache_str}; + } } } # no filename provided? try from environment unless ($thisfn) { if ($env{'request.symb'}) { - return $env{$cache_str}=&symbclean($env{'request.symb'}); + if ($nocache) { + return &symbclean($env{'request.symb'}); + } else { + return $env{$cache_str}=&symbclean($env{'request.symb'}); + } } $thisfn=$env{'request.filename'}; } @@ -13278,7 +13336,11 @@ sub symbread { # is that filename actually a symb? Verify, clean, and return if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) { if (&symbverify($thisfn,$1)) { - return $env{$cache_str}=&symbclean($thisfn); + if ($nocache) { + return &symbclean($thisfn); + } else { + return $env{$cache_str}=&symbclean($thisfn); + } } } $thisfn=declutter($thisfn); @@ -13293,10 +13355,18 @@ sub symbread { if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) { $targetfn=$1; } - if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', - &GDBM_READER(),0640)) { - $syval=$hash{$targetfn}; - untie(%hash); + unless ($nocache) { + if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db', + &GDBM_READER(),0640)) { + $syval=$hash{$targetfn}; + untie(%hash); + } + if ($syval) { + my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$nocache); + if (@blockers) { + $syval=''; + } + } } # ---------------------------------------------------------- There was an entry if ($syval) { @@ -13329,13 +13399,17 @@ sub symbread { $syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; + unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { + $possibles->{$syval} = 1; + } } if ($checkforblock) { - my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); - if (@blockers) { - $syval = ''; - return; + unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) { + my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); + if (@blockers) { + $syval = ''; + return; + } } } } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { @@ -13354,12 +13428,13 @@ sub symbread { if ($bighash{'map_type_'.$mapid} ne 'page') { my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); - if (ref($possibles) eq 'HASH') { - $possibles->{$syval} = 1; - } + next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'}); + next unless ($bighash{'encrypted_'.$id} eq $env{'request.enc'}); if ($checkforblock) { my @blockers = &has_comm_blocking('bre',$poss_syval,$file); - unless (@blockers > 0) { + if (@blockers > 0) { + $syval = ''; + } else { $syval = $poss_syval; $realpossible++; } @@ -13367,6 +13442,11 @@ sub symbread { $syval = $poss_syval; $realpossible++; } + if ($syval) { + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + } } } } @@ -13379,10 +13459,15 @@ sub symbread { } } if ($syval) { - return $env{$cache_str}=$syval; + if ($nocache) { + return $syval; + } else { + return $env{$cache_str}=$syval; + } } } &appenv({'request.ambiguous' => $thisfn}); + return '' if ($nocache); return $env{$cache_str}=''; }