[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.115 and 1.1172.2.124

version 1.1172.2.115, 2019/08/27 16:50:07 version 1.1172.2.124, 2020/05/27 17:11:31
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($lonhost).'/adm/about.html';                      my $url = $protocol.'://'.$hostname.'/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 953  sub spareserver { Line 954  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 1161  sub choose_server { Line 1162  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 1985  sub inst_directory_query { Line 2008  sub inst_directory_query {
     my $homeserver = &domain($udom,'primary');      my $homeserver = &domain($udom,'primary');
     my $outcome;      my $outcome;
     if ($homeserver ne '') {      if ($homeserver ne '') {
           unless ($homeserver eq $perlvar{'lonHostID'}) {
               if ($srch->{'srchby'} eq 'email') {
                   my $lcrev = &get_server_loncaparev($udom,$homeserver);
                   my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
                   if (($major eq '' && $minor eq '') || ($major < 2) ||
                       (($major == 2) && ($minor < 11)) ||
                       (($major == 2) && ($minor == 11) && ($subver < 3))) {
                       return;
                   }
               }
           }
  my $queryid=&reply("querysend:instdirsearch:".   my $queryid=&reply("querysend:instdirsearch:".
    &escape($srch->{'srchby'}).':'.     &escape($srch->{'srchby'}).':'.
    &escape($srch->{'srchterm'}).':'.     &escape($srch->{'srchterm'}).':'.
Line 2026  sub usersearch { Line 2060  sub usersearch {
     my $query = 'usersearch';      my $query = 'usersearch';
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
               unless ($tryserver eq $perlvar{'lonHostID'}) {
                   if ($srch->{'srchby'} eq 'email') {
                       my $lcrev = &get_server_loncaparev($dom,$tryserver);
                       my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.(\d+)[\w.\-]+\'?$/);
                       next if (($major eq '' && $minor eq '') || ($major < 2) ||
                                (($major == 2) && ($minor < 11)) ||
                                (($major == 2) && ($minor == 11) && ($subver < 3)));
                   }
               }
             my $host=&hostname($tryserver);              my $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.                  &reply("querysend:".&escape($query).':'.
Line 3026  sub repcopy { Line 3069  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 {
           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  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 3152  sub remove_stale_resfile { Line 3221  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 3184  sub remove_stale_resfile { Line 3253  sub remove_stale_resfile {
                                     $stale = 1;                                      $stale = 1;
                                 }                                  }
                                 if ($stale) {                                  if ($stale) {
                                     unlink($fname);                                      if (unlink($fname)) {
                                     if ($uri!~/\.meta$/) {                                          if ($uri!~/\.meta$/) {
                                         unlink($fname.'.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;  
                                 }                                  }
                             }                              }
                         }                          }
Line 3339  sub can_edit_resource { Line 3414  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/viewclasslist$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3356  sub can_edit_resource { Line 3443  sub can_edit_resource {
                     $cfile = $template;                      $cfile = $template;
                 }                  }
             } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {              } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                     $incourse = 1;                  $incourse = 1;
                     if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
                         $forceview = 1;                      $forceview = 1;
                     } else {                  } else {
                         $forceedit = 1;                      $forceedit = 1;
                     }                  }
                     $cfile = $resurl;                  $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 12236  sub symbverify { Line 12323  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 ($noclutter) {          if ($map =~ m{^uploaded/.+\.page$}) {
             $ids=$bighash{'ids_'.$thisurl};              $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
         } else {          } else {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $ids=$bighash{'ids_'.&clutter($thisurl)};
         }          }
Line 12993  sub repcopy_userfile { Line 13078  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($homeserver).'/raw/'.$uri);      $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/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 13019  sub tokenwrapper { Line 13105  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($homeserver).'/'.$uri.          return $protocol.'://'.$hostname.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 13037  sub getuploaded { Line 13124  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($homeserver).'/raw/'.$uri;      $uri = $protocol.'://'.$hostname.'/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 13214  sub shared_institution { Line 13302  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 {
Removed from v.1.1172.2.115  
changed lines
  Added in v.1.1172.2.124

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