--- loncom/lonnet/perl/lonnet.pm 2020/01/21 19:04:45 1.1172.2.118.2.4 +++ loncom/lonnet/perl/lonnet.pm 2020/10/01 10:24:06 1.1172.2.127 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.118.2.4 2020/01/21 19:04:45 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.127 2020/10/01 10:24:06 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -1162,6 +1162,28 @@ sub choose_server { return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); } +sub get_course_sessions { + my ($cnum,$cdom,$lastactivity) = @_; + my %servers = &internet_dom_servers($cdom); + my %returnhash; + foreach my $server (sort(keys(%servers))) { + my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server); + my @pairs=split(/\&/,$rep); + unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) { + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + if (exists($returnhash{$key})) { + next if ($value < $returnhash{$key}); + } + $returnhash{$key}=$value; + } + } + } + return %returnhash; +} + # --------------------------------------------- Try to change a user's password sub changepass { @@ -1851,12 +1873,7 @@ sub get_dom { } } if ($udom && $uhome && ($uhome ne 'no_host')) { - my $rep; - if ($namespace =~ /^enc/) { - $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); - } else { - $rep=&reply("getdom:$udom:$namespace:$items",$uhome); - } + my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); my %returnhash; if ($rep eq '' || $rep =~ /^error: 2 /) { return %returnhash; @@ -1900,11 +1917,7 @@ sub put_dom { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; - if ($namespace =~ /^enc/) { - return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); - } else { - return &reply("putdom:$udom:$namespace:$items",$uhome); - } + return &reply("putdom:$udom:$namespace:$items",$uhome); } else { &logthis("put_dom failed - no homeserver and/or domain"); } @@ -2521,22 +2534,6 @@ sub get_passwdconf { return %passwdconf; } -sub course_portal_url { - my ($cnum,$cdom) = @_; - my $chome = &homeserver($cnum,$cdom); - my $hostname = &hostname($chome); - my $protocol = $protocol{$chome}; - $protocol = 'http' if ($protocol ne 'https'); - my %domdefaults = &get_domain_defaults($cdom); - my $firsturl; - if ($domdefaults{'portal_def'}) { - $firsturl = $domdefaults{'portal_def'}; - } else { - $firsturl = $protocol.'://'.$hostname; - } - return $firsturl; -} - # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -3072,6 +3069,27 @@ 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 { + $answer = reply("unsub:$fname",$home); + } + return $answer; +} + # ------------------------------------------------ Get server side include body sub ssi_body { my ($filelink,%form)=@_; @@ -3230,12 +3248,18 @@ sub remove_stale_resfile { $stale = 1; } if ($stale) { - unlink($fname); - if ($uri!~/\.meta$/) { - unlink($fname.'.meta'); + if (unlink($fname)) { + if ($uri!~/\.meta$/) { + if (-e $fname.'.meta') { + unlink($fname.'.meta'); + } + } + my $unsubresult = &unsubscribe($fname); + unless ($unsubresult eq 'ok') { + &logthis("no unsub of $fname from $homeserver, reason: $unsubresult"); + } + $removed = 1; } - &reply("unsub:$fname",$homeserver); - $removed = 1; } } } @@ -3385,14 +3409,18 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; + } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) { + my ($map,$id,$res) = &decode_symb($symb); + if ($map =~ /\.page$/) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + $cfile = $map; + } else { + $forceedit = 1; + $cfile = '/adm/wrapper'.$resurl; + } } - $cfile = $resurl; } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3417,14 +3445,6 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { $incourse = 1; $forceview = 1; @@ -3434,13 +3454,8 @@ sub can_edit_resource { $cfile = &clutter($res); } else { $cfile = $env{'form.suppurl'}; - my $escfile = &unescape($cfile); - if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { - $cfile = '/adm/wrapper'.$escfile; - } else { - $escfile =~ s{^http://}{}; - $cfile = &escape("/adm/wrapper/ext/$escfile"); - } + $cfile =~ s{^http://}{}; + $cfile = '/adm/wrapper/ext/'.$cfile; } } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { if ($env{'form.forceedit'}) { @@ -5413,10 +5428,9 @@ my %cachedtimes=(); my $cachedtime=''; sub load_all_first_access { - my ($uname,$udom,$ignorecache)=@_; + my ($uname,$udom)=@_; if (($cachedkey eq $uname.':'.$udom) && - (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && - (!$ignorecache)) { + (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) { return; } $cachedtime=time; @@ -5425,7 +5439,7 @@ sub load_all_first_access { } sub get_first_access { - my ($type,$argsymb,$argmap,$ignorecache)=@_; + my ($type,$argsymb,$argmap)=@_; my ($symb,$courseid,$udom,$uname)=&whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); @@ -5437,7 +5451,7 @@ sub get_first_access { } else { $res=$symb; } - &load_all_first_access($uname,$udom,$ignorecache); + &load_all_first_access($uname,$udom); return $cachedtimes{"$courseid\0$res"}; } @@ -6854,7 +6868,7 @@ sub currentdump { # my %returnhash=(); # - if ($rep eq 'unknown_cmd') { + if ($rep eq "unknown_cmd") { # an old lond will not know currentdump # Do a dump and make it look like a currentdump my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); @@ -7770,7 +7784,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; @@ -7787,7 +7801,7 @@ sub allowed { if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources - if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) && ($priv eq 'bre')) { return 'F'; @@ -7995,7 +8009,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 { @@ -8015,7 +8029,7 @@ sub allowed { if ($noblockcheck) { $thisallowed='F'; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); + my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8088,7 +8102,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 { @@ -8101,7 +8115,7 @@ sub allowed { $checkreferer=0; } } - + if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { @@ -8130,7 +8144,7 @@ sub allowed { if ($noblockcheck) { $thisallowed.=$value; } else { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); + my @blockers = &has_comm_blocking($priv,'',$refuri,'',1); if (@blockers > 0) { $thisallowed = 'B'; } else { @@ -8216,7 +8230,7 @@ sub allowed { } } } - + # # Rest of the restrictions depend on selected course # @@ -8374,6 +8388,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. @@ -8383,13 +8401,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 { @@ -8484,8 +8511,7 @@ sub get_commblock_resources { } } } - if ($interval[0] =~ /^(\d+)/) { - my $timelimit = $1; + if ($interval[0] =~ /^\d+$/) { my $first_access; if ($type eq 'resource') { $first_access=&get_first_access($interval[1],$item); @@ -8495,7 +8521,7 @@ sub get_commblock_resources { $first_access=&get_first_access($interval[1]); } if ($first_access) { - my $timesup = $first_access+$timelimit; + my $timesup = $first_access+$interval[0]; if ($timesup > $now) { my $activeblock; foreach my $res (@to_test) { @@ -8527,7 +8553,7 @@ sub get_commblock_resources { } sub has_comm_blocking { - my ($priv,$symb,$uri,$blocks) = @_; + my ($priv,$symb,$uri,$nosymbcache,$noenccheck,$blocked,$blocks) = @_; my @blockers; return unless ($env{'request.course.id'}); return unless ($priv eq 'bre'); @@ -8537,7 +8563,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,1,\%possibles,$nosymbcache,$noenccheck); } if ($symb) { @symbs = ($symb); @@ -8551,9 +8577,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') { @@ -8564,18 +8592,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; } } @@ -11237,7 +11267,7 @@ sub get_userresdata { # Parameters: # $name - Course/user name. # $domain - Name of the domain the user/course is registered on. -# $type - Type of thing $name is (must be 'course' or 'user') +# $type - Type of thing $name is (must be 'course' or 'user' # @which - Array of names of resources desired. # Returns: # The value of the first reasource in @which that is found in the @@ -11256,44 +11286,13 @@ sub resdata { } if (!ref($result)) { return $result; } foreach my $item (@which) { - if (ref($item) eq 'ARRAY') { - if (defined($result->{$item->[0]})) { - return [$result->{$item->[0]},$item->[1]]; - } - } + if (defined($result->{$item->[0]})) { + return [$result->{$item->[0]},$item->[1]]; + } } return undef; } -sub get_domain_ltitools { - my ($cdom) = @_; - my %ltitools; - my ($result,$cached)=&is_cached_new('ltitools',$cdom); - if (defined($cached)) { - if (ref($result) eq 'HASH') { - %ltitools = %{$result}; - } - } else { - my %domconfig = &get_dom('configuration',['ltitools'],$cdom); - if (ref($domconfig{'ltitools'}) eq 'HASH') { - %ltitools = %{$domconfig{'ltitools'}}; - my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom); - if (ref($encdomconfig{'ltitools'}) eq 'HASH') { - foreach my $id (keys(%ltitools)) { - if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') { - foreach my $item ('key','secret') { - $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item}; - } - } - } - } - } - my $cachetime = 24*60*60; - &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); - } - return %ltitools; -} - sub get_numsuppfiles { my ($cnum,$cdom,$ignorecache)=@_; my $hashid=$cnum.':'.$cdom; @@ -11749,7 +11748,7 @@ sub metadata { # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && - ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || + ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -12336,18 +12335,16 @@ sub symbverify { if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $noclutter; if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { $thisurl =~ s/\?.+$//; if ($map =~ m{^uploaded/.+\.page$}) { $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; $thisurl =~ s{^\Qhttp://https://\E}{https://}; - $noclutter = 1; } } my $ids; - if ($noclutter) { - $ids=$bighash{'ids_'.$thisurl}; + if ($map =~ m{^uploaded/.+\.page$}) { + $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)}; } else { $ids=$bighash{'ids_'.&clutter($thisurl)}; } @@ -12447,19 +12444,26 @@ sub deversion { # ------------------------------------------------------ Return symb list entry sub symbread { - my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; + my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles, + $nocache,$noenccheck)=@_; 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'}; } @@ -12467,7 +12471,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); @@ -12482,10 +12490,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,$noenccheck); + if (@blockers) { + $syval=''; + } + } } # ---------------------------------------------------------- There was an entry if ($syval) { @@ -12518,13 +12534,19 @@ 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},'',$noenccheck); + if (@blockers) { + $syval = ''; + untie(%bighash); + return '' if ($nocache); + return $env{$cache_str}=''; + } } } } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { @@ -12543,12 +12565,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 (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'})); if ($checkforblock) { - my @blockers = &has_comm_blocking('bre',$poss_syval,$file); - unless (@blockers > 0) { + my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck); + if (@blockers > 0) { + $syval = ''; + } else { $syval = $poss_syval; $realpossible++; } @@ -12556,6 +12579,11 @@ sub symbread { $syval = $poss_syval; $realpossible++; } + if ($syval) { + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + } } } } @@ -12568,10 +12596,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}=''; } @@ -13406,8 +13439,6 @@ sub clutter { # &logthis("Got a blank emb style"); } } - } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { - $thisfn='/adm/wrapper'.$thisfn; } return $thisfn; }