--- loncom/lonnet/perl/lonnet.pm 2020/09/08 02:08:27 1.1172.2.118.2.7 +++ loncom/lonnet/perl/lonnet.pm 2020/01/20 17:48:49 1.1172.2.119 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.118.2.7 2020/09/08 02:08:27 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.119 2020/01/20 17:48:49 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -263,10 +263,9 @@ sub get_server_loncaparev { if ($caller eq 'loncron') { my $ua=new LWP::UserAgent; $ua->timeout(4); - my $hostname = &hostname($lonhost); my $protocol = $protocol{$lonhost}; $protocol = 'http' if ($protocol ne 'https'); - my $url = $protocol.'://'.$hostname.'/adm/about.html'; + my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; my $request=new HTTP::Request('GET',$url); my $response=$ua->request($request); unless ($response->is_error()) { @@ -954,13 +953,13 @@ sub spareserver { } if (!$want_server_name) { + my $protocol = 'http'; + if ($protocol{$spare_server} eq 'https') { + $protocol = $protocol{$spare_server}; + } if (defined($spare_server)) { my $hostname = &hostname($spare_server); if (defined($hostname)) { - my $protocol = 'http'; - if ($protocol{$spare_server} eq 'https') { - $protocol = $protocol{$spare_server}; - } $spare_server = $protocol.'://'.$hostname; } } @@ -1162,28 +1161,6 @@ 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 { @@ -1873,12 +1850,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; @@ -1922,11 +1894,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"); } @@ -2543,22 +2511,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 { @@ -3094,27 +3046,6 @@ 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)=@_; @@ -3241,13 +3172,13 @@ sub remove_stale_resfile { (grep { $_ eq $homeserver } ¤t_machine_ids())) { my $fname = &filelocation('',$url); if (-e $fname) { + my $ua=new LWP::UserAgent; + $ua->timeout(5); + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); my $hostname = &hostname($homeserver); if ($hostname) { - my $protocol = $protocol{$homeserver}; - $protocol = 'http' if ($protocol ne 'https'); my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url); - my $ua=new LWP::UserAgent; - $ua->timeout(5); my $request=new HTTP::Request('HEAD',$uri); my $response=$ua->request($request); if ($response->is_success()) { @@ -3273,18 +3204,12 @@ sub remove_stale_resfile { $stale = 1; } if ($stale) { - 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; + unlink($fname); + if ($uri!~/\.meta$/) { + unlink($fname.'.meta'); } + &reply("unsub:$fname",$homeserver); + $removed = 1; } } } @@ -3434,26 +3359,6 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } 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; - } - } - } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3478,14 +3383,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; @@ -3495,13 +3392,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'}) { @@ -5474,10 +5366,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; @@ -5486,7 +5377,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); @@ -5498,7 +5389,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"}; } @@ -6915,7 +6806,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,'.'); @@ -7848,7 +7739,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'; @@ -8545,8 +8436,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); @@ -8556,7 +8446,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) { @@ -10282,19 +10172,14 @@ sub writecoursepref { sub createcourse { my ($udom,$description,$url,$course_server,$nonstandard,$inst_code, - $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_; + $course_owner,$crstype,$cnum,$context,$category)=@_; $url=&declutter($url); my $cid=''; if ($context eq 'requestcourses') { my $can_create = 0; my ($ownername,$ownerdom) = split(':',$course_owner); if ($udom eq $ownerdom) { - 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, + if (&usertools_access($ownername,$ownerdom,$category,undef, $context)) { $can_create = 1; } @@ -11303,7 +11188,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 @@ -11322,44 +11207,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; @@ -11815,7 +11669,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; } @@ -12402,16 +12256,18 @@ 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 ($map =~ m{^uploaded/.+\.page$}) { - $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)}; + if ($noclutter) { + $ids=$bighash{'ids_'.$thisurl}; } else { $ids=$bighash{'ids_'.&clutter($thisurl)}; } @@ -13157,10 +13013,9 @@ sub repcopy_userfile { my $request; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); - my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri); + $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); my $response=$ua->request($request,$transferfile); # did it work? if ($response->is_error()) { @@ -13184,10 +13039,9 @@ sub tokenwrapper { $file=~s|(\?\.*)*$||; &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); my $homeserver = &homeserver($uname,$udom); - my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - return $protocol.'://'.$hostname.'/'.$uri. + return $protocol.'://'.&hostname($homeserver).'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -13203,10 +13057,9 @@ sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); - my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $uri = $protocol.'://'.$hostname.'/raw/'.$uri; + $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; my $ua=new LWP::UserAgent; my $request=new HTTP::Request($reqtype,$uri); my $response=$ua->request($request); @@ -13381,45 +13234,6 @@ sub shared_institution { return $same_intdom; } -sub uses_sts { - my ($ignore_cache) = @_; - my $lonhost = $perlvar{'lonHostID'}; - my $hostname = &hostname($lonhost); - my $sts_on; - if ($protocol{$lonhost} eq 'https') { - my $cachetime = 12*3600; - if (!$ignore_cache) { - ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost); - if (defined($cached)) { - return $sts_on; - } - } - my $ua=new LWP::UserAgent; - my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html'; - my $request=new HTTP::Request('HEAD',$url); - my $response=$ua->request($request); - if ($response->is_success) { - my $has_sts = $response->header('Strict-Transport-Security'); - if ($has_sts eq '') { - $sts_on = 0; - } else { - if ($has_sts =~ /\Qmax-age=\E(\d+)/) { - my $maxage = $1; - if ($maxage) { - $sts_on = 1; - } else { - $sts_on = 0; - } - } else { - $sts_on = 0; - } - } - return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime); - } - } - return; -} - # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -13470,8 +13284,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; }