[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1172.2.118.2.7 and 1.1172.2.119

version 1.1172.2.118.2.7, 2020/09/08 02:08:27 version 1.1172.2.119, 2020/01/20 17:48:49
Line 263  sub get_server_loncaparev { Line 263  sub get_server_loncaparev {
                 if ($caller eq 'loncron') {                  if ($caller eq 'loncron') {
                     my $ua=new LWP::UserAgent;                      my $ua=new LWP::UserAgent;
                     $ua->timeout(4);                      $ua->timeout(4);
                     my $hostname = &hostname($lonhost);  
                     my $protocol = $protocol{$lonhost};                      my $protocol = $protocol{$lonhost};
                     $protocol = 'http' if ($protocol ne 'https');                      $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 $request=new HTTP::Request('GET',$url);
                     my $response=$ua->request($request);                      my $response=$ua->request($request);
                     unless ($response->is_error()) {                      unless ($response->is_error()) {
Line 954  sub spareserver { Line 953  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
           my $protocol = 'http';
           if ($protocol{$spare_server} eq 'https') {
               $protocol = $protocol{$spare_server};
           }
         if (defined($spare_server)) {          if (defined($spare_server)) {
             my $hostname = &hostname($spare_server);              my $hostname = &hostname($spare_server);
             if (defined($hostname)) {              if (defined($hostname)) {
                 my $protocol = 'http';  
                 if ($protocol{$spare_server} eq 'https') {  
                     $protocol = $protocol{$spare_server};  
                 }  
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 1162  sub choose_server { Line 1161  sub choose_server {
     return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);      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  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 1873  sub get_dom { Line 1850  sub get_dom {
         }          }
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep;          my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
         if ($namespace =~ /^enc/) {  
             $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);  
         } else {  
             $rep=&reply("getdom:$udom:$namespace:$items",$uhome);  
         }  
         my %returnhash;          my %returnhash;
         if ($rep eq '' || $rep =~ /^error: 2 /) {          if ($rep eq '' || $rep =~ /^error: 2 /) {
             return %returnhash;              return %returnhash;
Line 1922  sub put_dom { Line 1894  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         if ($namespace =~ /^enc/) {          return &reply("putdom:$udom:$namespace:$items",$uhome);
             return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);  
         } else {  
             return &reply("putdom:$udom:$namespace:$items",$uhome);  
         }  
     } else {      } else {
         &logthis("put_dom failed - no homeserver and/or domain");          &logthis("put_dom failed - no homeserver and/or domain");
     }      }
Line 2543  sub get_passwdconf { Line 2511  sub get_passwdconf {
     return %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  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 3094  sub repcopy { Line 3046  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 } &current_machine_ids()) {  
         $answer = 'home';  
     } else {  
         $answer = reply("unsub:$fname",$home);  
     }  
     return $answer;  
 }  
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 3241  sub remove_stale_resfile { Line 3172  sub remove_stale_resfile {
                     (grep { $_ eq $homeserver } &current_machine_ids())) {                      (grep { $_ eq $homeserver } &current_machine_ids())) {
                 my $fname = &filelocation('',$url);                  my $fname = &filelocation('',$url);
                 if (-e $fname) {                  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);                      my $hostname = &hostname($homeserver);
                     if ($hostname) {                      if ($hostname) {
                         my $protocol = $protocol{$homeserver};  
                         $protocol = 'http' if ($protocol ne 'https');  
                         my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);                          my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url);
                         my $ua=new LWP::UserAgent;  
                         $ua->timeout(5);  
                         my $request=new HTTP::Request('HEAD',$uri);                          my $request=new HTTP::Request('HEAD',$uri);
                         my $response=$ua->request($request);                          my $response=$ua->request($request);
                         if ($response->is_success()) {                          if ($response->is_success()) {
Line 3273  sub remove_stale_resfile { Line 3204  sub remove_stale_resfile {
                                     $stale = 1;                                      $stale = 1;
                                 }                                  }
                                 if ($stale) {                                  if ($stale) {
                                     if (unlink($fname)) {                                      unlink($fname);
                                         if ($uri!~/\.meta$/) {                                      if ($uri!~/\.meta$/) {
                                             if (-e $fname.'.meta') {                                          unlink($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;
                                 }                                  }
                             }                              }
                         }                          }
Line 3434  sub can_edit_resource { Line 3359  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $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$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3478  sub can_edit_resource { Line 3383  sub can_edit_resource {
                     $forceedit = 1;                      $forceedit = 1;
                 }                  }
                 $cfile = $resurl;                  $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'})) {              } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
                 $incourse = 1;                  $incourse = 1;
                 $forceview = 1;                  $forceview = 1;
Line 3495  sub can_edit_resource { Line 3392  sub can_edit_resource {
                     $cfile = &clutter($res);                      $cfile = &clutter($res);
                 } else {                  } else {
                     $cfile = $env{'form.suppurl'};                      $cfile = $env{'form.suppurl'};
                     my $escfile = &unescape($cfile);                      $cfile =~ s{^http://}{};
                     if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {                      $cfile = '/adm/wrapper/ext/'.$cfile;
                         $cfile = '/adm/wrapper'.$escfile;  
                     } else {  
                         $escfile =~ s{^http://}{};  
                         $cfile = &escape("/adm/wrapper/ext/$escfile");  
                     }  
                 }                  }
             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {              } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                 if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
Line 5474  my %cachedtimes=(); Line 5366  my %cachedtimes=();
 my $cachedtime='';  my $cachedtime='';
   
 sub load_all_first_access {  sub load_all_first_access {
     my ($uname,$udom,$ignorecache)=@_;      my ($uname,$udom)=@_;
     if (($cachedkey eq $uname.':'.$udom) &&      if (($cachedkey eq $uname.':'.$udom) &&
         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&          (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
         (!$ignorecache)) {  
         return;          return;
     }      }
     $cachedtime=time;      $cachedtime=time;
Line 5486  sub load_all_first_access { Line 5377  sub load_all_first_access {
 }  }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb,$argmap,$ignorecache)=@_;      my ($type,$argsymb,$argmap)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
Line 5498  sub get_first_access { Line 5389  sub get_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     &load_all_first_access($uname,$udom,$ignorecache);      &load_all_first_access($uname,$udom);
     return $cachedtimes{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
Line 6915  sub currentdump { Line 6806  sub currentdump {
    #     #
    my %returnhash=();     my %returnhash=();
    #     #
    if ($rep eq 'unknown_cmd') {     if ($rep eq "unknown_cmd") { 
        # an old lond will not know currentdump         # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump         # Do a dump and make it look like a currentdump
        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 7848  sub allowed { Line 7739  sub allowed {
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # 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/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 8545  sub get_commblock_resources { Line 8436  sub get_commblock_resources {
                             }                              }
                         }                          }
                     }                      }
                     if ($interval[0] =~ /^(\d+)/) {                      if ($interval[0] =~ /^\d+$/) {
                         my $timelimit = $1;   
                         my $first_access;                          my $first_access;
                         if ($type eq 'resource') {                          if ($type eq 'resource') {
                             $first_access=&get_first_access($interval[1],$item);                              $first_access=&get_first_access($interval[1],$item);
Line 8556  sub get_commblock_resources { Line 8446  sub get_commblock_resources {
                             $first_access=&get_first_access($interval[1]);                              $first_access=&get_first_access($interval[1]);
                         }                          }
                         if ($first_access) {                          if ($first_access) {
                             my $timesup = $first_access+$timelimit;                              my $timesup = $first_access+$interval[0];
                             if ($timesup > $now) {                              if ($timesup > $now) {
                                 my $activeblock;                                  my $activeblock;
                                 foreach my $res (@to_test) {                                  foreach my $res (@to_test) {
Line 10282  sub writecoursepref { Line 10172  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      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);      $url=&declutter($url);
     my $cid='';      my $cid='';
     if ($context eq 'requestcourses') {      if ($context eq 'requestcourses') {
         my $can_create = 0;          my $can_create = 0;
         my ($ownername,$ownerdom) = split(':',$course_owner);          my ($ownername,$ownerdom) = split(':',$course_owner);
         if ($udom eq $ownerdom) {          if ($udom eq $ownerdom) {
             my $reload;              if (&usertools_access($ownername,$ownerdom,$category,undef,
             if (($callercontext eq 'auto') &&  
                ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {  
                 $reload = 'reload';  
             }  
             if (&usertools_access($ownername,$ownerdom,$category,$reload,  
                                   $context)) {                                    $context)) {
                 $can_create = 1;                  $can_create = 1;
             }              }
Line 11303  sub get_userresdata { Line 11188  sub get_userresdata {
 #  Parameters:  #  Parameters:
 #     $name      - Course/user name.  #     $name      - Course/user name.
 #     $domain    - Name of the domain the user/course is registered on.  #     $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.  #     @which     - Array of names of resources desired.
 #  Returns:  #  Returns:
 #     The value of the first reasource in @which that is found in the  #     The value of the first reasource in @which that is found in the
Line 11322  sub resdata { Line 11207  sub resdata {
     }      }
     if (!ref($result)) { return $result; }          if (!ref($result)) { return $result; }    
     foreach my $item (@which) {      foreach my $item (@which) {
         if (ref($item) eq 'ARRAY') {   if (defined($result->{$item->[0]})) {
     if (defined($result->{$item->[0]})) {      return [$result->{$item->[0]},$item->[1]];
         return [$result->{$item->[0]},$item->[1]];   }
     }  
         }  
     }      }
     return undef;      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 {  sub get_numsuppfiles {
     my ($cnum,$cdom,$ignorecache)=@_;      my ($cnum,$cdom,$ignorecache)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
Line 11815  sub metadata { Line 11669  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($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$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 12402  sub symbverify { Line 12256  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
           my $noclutter;
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
             if ($map =~ m{^uploaded/.+\.page$}) {              if ($map =~ m{^uploaded/.+\.page$}) {
                 $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};                  $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                 $thisurl =~ s{^\Qhttp://https://\E}{https://};                  $thisurl =~ s{^\Qhttp://https://\E}{https://};
                   $noclutter = 1;
             }              }
         }          }
         my $ids;          my $ids;
         if ($map =~ m{^uploaded/.+\.page$}) {          if ($noclutter) {
             $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};              $ids=$bighash{'ids_'.$thisurl};
         } else {          } else {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $ids=$bighash{'ids_'.&clutter($thisurl)};
         }          }
Line 13157  sub repcopy_userfile { Line 13013  sub repcopy_userfile {
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $hostname = &hostname($homeserver);  
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $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);      my $response=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 13184  sub tokenwrapper { Line 13039  sub tokenwrapper {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         my $homeserver = &homeserver($uname,$udom);          my $homeserver = &homeserver($uname,$udom);
         my $hostname = &hostname($homeserver);  
         my $protocol = $protocol{$homeserver};          my $protocol = $protocol{$homeserver};
         $protocol = 'http' if ($protocol ne 'https');          $protocol = 'http' if ($protocol ne 'https');
         return $protocol.'://'.$hostname.'/'.$uri.          return $protocol.'://'.&hostname($homeserver).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 13203  sub getuploaded { Line 13057  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
     my $hostname = &hostname($homeserver);  
     my $protocol = $protocol{$homeserver};      my $protocol = $protocol{$homeserver};
     $protocol = 'http' if ($protocol ne 'https');      $protocol = 'http' if ($protocol ne 'https');
     $uri = $protocol.'://'.$hostname.'/raw/'.$uri;      $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
Line 13381  sub shared_institution { Line 13234  sub shared_institution {
     return $same_intdom;      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  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 13470  sub clutter { Line 13284  sub clutter {
 # &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
     } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {  
         $thisfn='/adm/wrapper'.$thisfn;  
     }      }
     return $thisfn;      return $thisfn;
 }  }
Removed from v.1.1172.2.118.2.7  
changed lines
  Added in v.1.1172.2.119

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>