[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.1449 and 1.1487

version 1.1449, 2021/04/29 17:45:23 version 1.1487, 2022/06/08 20:49:09
Line 97  use Digest::MD5; Line 97  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use File::MMagic;  use File::MMagic;
 use Net::CIDR;  use Net::CIDR;
   use Sys::Hostname::FQDN();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
Line 467  sub reply { Line 468  sub reply {
             my $subcmd = $1;              my $subcmd = $1;
             if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||              if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
                 ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||                  ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                 ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) {                  ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades') ||
                   ($subcmd eq 'put')) {
                 (undef,undef,my @rest) = split(/:/,$cmd);                  (undef,undef,my @rest) = split(/:/,$cmd);
                 if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {                  if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
                     splice(@rest,2,1,'Hidden');                      splice(@rest,2,1,'Hidden');
                 } elsif ($subcmd eq 'passwd') {                  } elsif ($subcmd eq 'passwd') {
                     splice(@rest,2,2,('Hidden','Hidden'));                      splice(@rest,2,2,('Hidden','Hidden'));
                 } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||                  } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                          ($subcmd eq 'autoexportgrades')) {                           ($subcmd eq 'autoexportgrades') || ($subcmd eq 'put')) {
                     splice(@rest,3,1,'Hidden');                      splice(@rest,3,1,'Hidden');
                 }                  }
                 $logged = join(':',('encrypt:'.$subcmd,@rest));                  $logged = join(':',('encrypt:'.$subcmd,@rest));
Line 976  sub userload { Line 978  sub userload {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;      my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
Line 1021  sub spareserver { Line 1023  sub spareserver {
                 if ($protocol{$spare_server} eq 'https') {                  if ($protocol{$spare_server} eq 'https') {
                     $protocol = $protocol{$spare_server};                      $protocol = $protocol{$spare_server};
                 }                  }
                   my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
                   $hostname = $alias if ($alias ne '');
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 1319  sub changepass { Line 1323  sub changepass {
 sub queryauthenticate {  sub queryauthenticate {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (!$uhome) {      if ((!$uhome) || ($uhome eq 'no_host')) {
  &logthis("User $uname at $udom is unknown when looking for authentication mechanism");   &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  return 'no_host';   return 'no_host';
     }      }
Line 1368  sub authenticate { Line 1372  sub authenticate {
     }      }
     if ($answer eq 'non_authorized') {      if ($answer eq 'non_authorized') {
  &logthis("User $uname at $udom rejected by $uhome");   &logthis("User $uname at $udom rejected by $uhome");
  return 'no_host';    return 'no_host';
     }      }
     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");      &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     return 'no_host';      return 'no_host';
Line 2143  sub dump_dom { Line 2147  sub dump_dom {
 # ------------------------------------------ get items from domain db files     # ------------------------------------------ get items from domain db files   
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome)=@_;      my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
     return if ($udom eq 'public');      return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
Line 2169  sub get_dom { Line 2173  sub get_dom {
         my $rep;          my $rep;
         if (grep { $_ eq $uhome } &current_machine_ids()) {          if (grep { $_ eq $uhome } &current_machine_ids()) {
             # domain information is hosted on this machine              # domain information is hosted on this machine
             my $cmd = 'getdom';              $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
             if ($namespace =~ /^enc/) {  
                 $cmd = 'egetdom';  
             }  
             $rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items");  
         } else {          } else {
             if ($namespace =~ /^enc/) {              if ($encrypt) {
                 $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);                  $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
             } else {              } else {
                 $rep=&reply("getdom:$udom:$namespace:$items",$uhome);                  $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
Line 2203  sub get_dom { Line 2203  sub get_dom {
 # -------------------------------------------- put items in domain db files   # -------------------------------------------- put items in domain db files 
   
 sub put_dom {  sub put_dom {
     my ($namespace,$storehash,$udom,$uhome)=@_;      my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
Line 2224  sub put_dom { Line 2224  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         if ($namespace =~ /^enc/) {          if ($encrypt) {
             return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);              return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
         } else {          } else {
             return &reply("putdom:$udom:$namespace:$items",$uhome);              return &reply("putdom:$udom:$namespace:$items",$uhome);
Line 2262  sub del_dom { Line 2262  sub del_dom {
     }      }
 }  }
   
   sub store_dom {
       my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;
       $$storehash{'ip'}=&get_requestor_ip();
       $$storehash{'host'}=$perlvar{'lonHostID'};
       my $namevalue='';
       foreach my $key (keys(%{$storehash})) {
           $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
       }
       $namevalue=~s/\&$//;
       if (grep { $_ eq $home } current_machine_ids()) {
           return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");
       } else {
           if ($namespace eq 'private') {
               return 'refused';
           } elsif ($encrypt) {
               return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);
           } else {
               return reply("storedom:$dom:$namespace:$id:$namevalue",$home);
           }
       }
   }
   
   sub restore_dom {
       my ($id,$namespace,$dom,$home,$encrypt) = @_;
       my $answer;
       if (grep { $_ eq $home } current_machine_ids()) {
           $answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");
       } elsif ($namespace ne 'private') {
           if ($encrypt) {
               $answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);
           } else {
               $answer=&reply("restoredom:$dom:$namespace:$id",$home);
           }
       }
       my %returnhash=();
       unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') || 
               ($answer eq 'unknown_cmd') || ($answer eq 'rejected')) {
           foreach my $line (split(/\&/,$answer)) {
               my ($name,$value)=split(/\=/,$line);
               $returnhash{&unescape($name)}=&thaw_unescape($value);
           }
           my $version;
           for ($version=1;$version<=$returnhash{'version'};$version++) {
               foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {
                   $returnhash{$item}=$returnhash{$version.':'.$item};
               }
           }
       }
       return %returnhash;
   }
   
 # ----------------------------------construct domainconfig user for a domain   # ----------------------------------construct domainconfig user for a domain 
 sub get_domainconfiguser {  sub get_domainconfiguser {
     my ($udom) = @_;      my ($udom) = @_;
Line 2304  sub retrieve_inst_usertypes { Line 2355  sub retrieve_inst_usertypes {
   
 sub is_domainimage {  sub is_domainimage {
     my ($url) = @_;      my ($url) = @_;
     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) {      if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo|login)/+[^/]-) {
         if (&domain($1) ne '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 2542  sub inst_rulecheck { Line 2593  sub inst_rulecheck {
                     $response=&unescape(&reply('instselfcreatecheck:'.                      $response=&unescape(&reply('instselfcreatecheck:'.
                                                &escape($udom).':'.&escape($uname).                                                 &escape($udom).':'.&escape($uname).
                                               ':'.$rulestr,$homeserver));                                                ':'.$rulestr,$homeserver));
                   } elsif ($item eq 'unamemap') {
                       $response=&unescape(&reply('instunamemapcheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                 }                  }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
Line 2571  sub inst_userrules { Line 2626  sub inst_userrules {
             } elsif ($check eq 'email') {              } elsif ($check eq 'email') {
                 $response=&reply('instemailrules:'.&escape($udom),                  $response=&reply('instemailrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } elsif ($check eq 'unamemap') {
                   $response=&reply('unamemaprules:'.&escape($udom),
                                    $homeserver); 
             } else {              } else {
                 $response=&reply('instuserrules:'.&escape($udom),                  $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
Line 2617  sub get_domain_defaults { Line 2675  sub get_domain_defaults {
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories','ssl','autoenroll',                                    'coursecategories','ssl','autoenroll',
                                   'trust','helpsettings','wafproxy'],$domain);                                    'trust','helpsettings','wafproxy','ltisec'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook','placement');      my @coursetypes = ('official','unofficial','community','textbook','placement');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2629  sub get_domain_defaults { Line 2687  sub get_domain_defaults {
         $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};          $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
         $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};          $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
         $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};          $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
           $domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
     } else {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2666  sub get_domain_defaults { Line 2725  sub get_domain_defaults {
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};          $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};          $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
           $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
         $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};          $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};              $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
Line 2698  sub get_domain_defaults { Line 2758  sub get_domain_defaults {
         }          }
         if ($domconfig{'coursedefaults'}{'texengine'}) {          if ($domconfig{'coursedefaults'}{'texengine'}) {
             $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};              $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
         }           }
           if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {
               $domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};
           }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 2773  sub get_domain_defaults { Line 2836  sub get_domain_defaults {
     }      }
     if (ref($domconfig{'autoenroll'}) eq 'HASH') {      if (ref($domconfig{'autoenroll'}) eq 'HASH') {
         $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};          $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
           $domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
     }      }
     if (ref($domconfig{'helpsettings'}) eq 'HASH') {      if (ref($domconfig{'helpsettings'}) eq 'HASH') {
         $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};          $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
Line 2786  sub get_domain_defaults { Line 2850  sub get_domain_defaults {
                 $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};                  $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
             }              }
         }          }
     }       }
       if (ref($domconfig{'ltisec'}) eq 'HASH') {
           if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {
               $domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};
               $domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};
               $domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};
           }
           if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {
               if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {
                   $domdefaults{'privhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
               }
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2851  sub retrieve_instcodes { Line 2927  sub retrieve_instcodes {
 }  }
   
 sub course_portal_url {  sub course_portal_url {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom,$r) = @_;
     my $chome = &homeserver($cnum,$cdom);      my $chome = &homeserver($cnum,$cdom);
     my $hostname = &hostname($chome);      my $hostname = &hostname($chome);
     my $protocol = $protocol{$chome};      my $protocol = $protocol{$chome};
Line 2861  sub course_portal_url { Line 2937  sub course_portal_url {
     if ($domdefaults{'portal_def'}) {      if ($domdefaults{'portal_def'}) {
         $firsturl = $domdefaults{'portal_def'};          $firsturl = $domdefaults{'portal_def'};
     } else {      } else {
           my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
           $hostname = $alias if ($alias ne '');
         $firsturl = $protocol.'://'.$hostname;          $firsturl = $protocol.'://'.$hostname;
     }      }
     return $firsturl;      return $firsturl;
Line 4657  sub bubblesheet_converter { Line 4735  sub bubblesheet_converter {
                     next if (($num == 1) && ($csvoptions{'hdr'} == 1));                      next if (($num == 1) && ($csvoptions{'hdr'} == 1));
                     $line =~ s{[\r\n]+$}{};                      $line =~ s{[\r\n]+$}{};
                     my %found;                      my %found;
                     my @values = split(/,/,$line);                      my @values = split(/,/,$line,-1);
                     my ($qstart,$record);                      my ($qstart,$record);
                     for (my $i=0; $i<@values; $i++) {                      for (my $i=0; $i<@values; $i++) {
                         if ((($qstart ne '') && ($i > $qstart)) ||                          if ((($qstart ne '') && ($i > $qstart)) ||
Line 4961  sub flushcourselogs { Line 5039  sub flushcourselogs {
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $env{'request.course.id'};                  my $cid = $env{'request.course.id'};
   #
   # FIXME 11/29/2021
   # Typo in rev. 1.458 (2003/12/09)??
   # These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
   #
   # While these ramain as  $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
   # $dom and $name will always be null, so the &inc() call will default to storing this data
   # in a nohist_accesscount.db file for the user rather than the course.
   #
   # That said there is a lot of noise in the data being stored.
   # So counts for prtspool/  and adm/ etc. are recorded.
   #
   # A review of which items ending '___count' are written to %accesshash should likely be 
   # made before deciding whether to set these to 'course.' instead of 'request.'
   #
   # Under the current scheme each user receives a nohist_accesscount.db file listing 
   # accesses for things which are not published resources, regardless of course, and
   # there is not a nohist_accesscount.db file in a course, which might log accesses from
   # anyone in the course for things which are not published resources.
   #
   # For an author, nohist_accesscount.db ends up having records for other items
   # mixed up with the legitimate access counts for the author's published resources.
   #
                 $dom  = $env{'request.'.$cid.'.domain'};                  $dom  = $env{'request.'.$cid.'.domain'};
                 $name = $env{'request.'.$cid.'.num'};                  $name = $env{'request.'.$cid.'.num'};
             }              }
Line 7112  sub unserialize { Line 7213  sub unserialize {
 # see Lond::dump_with_regexp  # see Lond::dump_with_regexp
 # if $escapedkeys hash keys won't get unescaped.  # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
Line 7128  sub dump { Line 7229  sub dump {
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep;
       if ($encrypt) {
           $rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
       } else {
           $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
       }
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
Line 7275  sub inc { Line 7381  sub inc {
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 7284  sub put { Line 7390  sub put {
        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     if ($encrypt) {
          return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
      } else {
          return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
      }
 }  }
   
 # ------------------------------------------------------------ newput interface  # ------------------------------------------------------------ newput interface
Line 7549  sub portfolio_access { Line 7659  sub portfolio_access {
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             my ($startblock,$endblock) =              my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);                  &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
             if ($startblock && $endblock) {              if (($startblock && $endblock) || ($by_ip)) {
                 return 'B';                  return 'B';
             }              }
         } else {          } else {
             my ($startblock,$endblock) =              my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
                 &Apache::loncommon::blockcheck(\%setters,'port');                  &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
             if ($startblock && $endblock) {              if (($startblock && $endblock) || ($by_ip)) {
                 return 'B';                  return 'B';
             }              }
         }          }
Line 8018  sub check_can_request { Line 8128  sub check_can_request {
     my @options = ('approval','validate','autolimit');      my @options = ('approval','validate','autolimit');
     my $optregex = join('|',@options);      my $optregex = join('|',@options);
     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {      if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
           my %willtrust;
         foreach my $type (@{$types}) {          foreach my $type (@{$types}) {
             if (&usertools_access($uname,$udom,$type,undef,              if (&usertools_access($uname,$udom,$type,undef,
                                   'requestcourses')) {                                    'requestcourses')) {
Line 8037  sub check_can_request { Line 8148  sub check_can_request {
                         if (ref($request_domains) eq 'HASH') {                          if (ref($request_domains) eq 'HASH') {
                             my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);                              my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/);
                             if ($otherdom ne '') {                              if ($otherdom ne '') {
                                 if (ref($request_domains->{$type}) eq 'ARRAY') {                                  unless (exists($willtrust{$otherdom})) {
                                     unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {                                      $willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom);
                                   }
                                   if ($willtrust{$otherdom}) {
                                       if (ref($request_domains->{$type}) eq 'ARRAY') {
                                           unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) {
                                               push(@{$request_domains->{$type}},$otherdom);
                                           }
                                       } else {
                                         push(@{$request_domains->{$type}},$otherdom);                                          push(@{$request_domains->{$type}},$otherdom);
                                     }                                      }
                                 } else {  
                                     push(@{$request_domains->{$type}},$otherdom);  
                                 }                                  }
                             }                              }
                         }                          }
Line 8112  sub customaccess { Line 8228  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
     if ($priv eq 'evb') {      if ($priv eq 'evb') {
 # Evade communication block restrictions for specified role in a course  # Evade communication block restrictions for specified role in a course or domain
         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {          if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
             return $1;              return $1;
         } else {          } else {
Line 8140  sub allowed { Line 8256  sub allowed {
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         my %setters;          my %setters;
         my ($startblock,$endblock) =           my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = 
             &Apache::loncommon::blockcheck(\%setters,'port');              &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
         if ($startblock && $endblock) {          if (($startblock && $endblock) || ($by_ip)) {
             return 'B';              return 'B';
         } else {          } else {
             return 'F';              return 'F';
Line 8238  sub allowed { Line 8354  sub allowed {
                         my $adom = $1;                          my $adom = $1;
                         foreach my $key (keys(%env)) {                          foreach my $key (keys(%env)) {
                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {                              if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
                                 my ($start,$end) = split('.',$env{$key});                                  my ($start,$end) = split(/\./,$env{$key});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 8251  sub allowed { Line 8367  sub allowed {
                         foreach my $role ('ca','aa') {                           foreach my $role ('ca','aa') { 
                             if ($env{"user.role.$role./$adom/$aname"}) {                              if ($env{"user.role.$role./$adom/$aname"}) {
                                 my ($start,$end) =                                  my ($start,$end) =
                                     split('.',$env{"user.role.$role./$adom/$aname"});                                      split(/\./,$env{"user.role.$role./$adom/$aname"});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 8337  sub allowed { Line 8453  sub allowed {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;                  my $value = $1;
                 my $deeplinkblock = &deeplink_check($priv,$symb,$uri);                  my $deeplinkblock;
                   unless ($nodeeplinkcheck) {
                       $deeplinkblock = &deeplink_check($priv,$symb,$uri);
                   }
                 if ($deeplinkblock) {                  if ($deeplinkblock) {
                     $thisallowed='D';                      $thisallowed='D';
                 } elsif ($noblockcheck) {                  } elsif ($noblockcheck) {
Line 8360  sub allowed { Line 8479  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);                          my $deeplinkblock;
                           unless ($nodeeplinkcheck) {
                               $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
                           }
                         if ($deeplinkblock) {                          if ($deeplinkblock) {
                             $thisallowed='D';                              $thisallowed='D';
                         } elsif ($noblockcheck) {                          } elsif ($noblockcheck) {
Line 8436  sub allowed { Line 8558  sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;                 my $value = $1;
                if ($priv eq 'bre') {                 if ($priv eq 'bre') {
                    if ($noblockcheck) {                     my $deeplinkblock;
                      unless ($nodeeplinkcheck) {
                          $deeplinkblock = &deeplink_check($priv,$symb,$uri);
                      }
                      if ($deeplinkblock) {
                          $thisallowed = 'D';
                      } elsif ($noblockcheck) {
                        $thisallowed.=$value;                         $thisallowed.=$value;
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);                         my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8478  sub allowed { Line 8606  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    if ($priv eq 'bre') {
                       my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);                        my $deeplinkblock;
                         unless ($nodeeplinkcheck) {
                             $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
                         }
                       if ($deeplinkblock) {                        if ($deeplinkblock) {
                           $thisallowed = 'D';                            $thisallowed = 'D';
                       } elsif ($noblockcheck) {                        } elsif ($noblockcheck) {
Line 8526  sub allowed { Line 8657  sub allowed {
 #  #
   
 # Possibly locked functionality, check all courses  # Possibly locked functionality, check all courses
   # In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
 # Locks might take effect only after 10 minutes cache expiration for other  # Locks might take effect only after 10 minutes cache expiration for other
 # courses, and 2 minutes for current course  # courses, and 2 minutes for current course, in which user has st or ta role
   # which is neither expired nor a future role (unless current course).
   
     my $envkey;      my ($needlockcheck,$now,$crsonly);
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys(%env)) {          $now = time;
           if ($priv eq 'bre') {
               if ($uri ne '') {
                   if ($orguri =~ m{^/+res/}) {
                       if ($uri =~ m{^lib/templates/}) {
                           if ($env{'request.course.id'}) {
                               $crsonly = 1;
                               $needlockcheck = 1;
                           }
                       } else {
                           $needlockcheck = 1;
                       }
                   } elsif ($env{'request.course.id'}) {
                       my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
                       if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
                           ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
                           $crsonly = 1;
                       }
                       $needlockcheck = 1;
                   }
               }
           } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
               $needlockcheck = 1;
           }
       }
       if ($needlockcheck) {
           foreach my $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                $courseid=~s/^\///;                 $courseid=~s/^\///;
                  unless ($env{'request.role'} eq $roleid) {
                      my ($start,$end) = split(/\./,$env{$envkey});
                      next unless (($now >= $start) && (!$end || $end > $now));
                  }
                my $expiretime=600;                 my $expiretime=600;
                if ($env{'request.role'} eq $roleid) {                 if ($env{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 8558  sub allowed { Line 8721  sub allowed {
                }                 }
                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($env{'priv.'.$priv.'.lock.expire'}>time) {     if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
                        &log($env{'user.domain'},$env{'user.name'},                         &log($env{'user.domain'},$env{'user.name'},
                             $env{'user.home'},                              $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
Line 8629  sub allowed { Line 8792  sub allowed {
        }         }
    }     }
   
   # Restricted for deeplinked session?
   
       if ($env{'request.deeplink.login'}) {
           if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {
               if (!$symb) { $symb=&symbread($uri,1); }
               if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {
                   return '';
               }
           }
       }
   
 # Restricted by state or randomout?  # Restricted by state or randomout?
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
Line 8786  sub get_commblock_resources { Line 8960  sub get_commblock_resources {
     my ($blocks) = @_;      my ($blocks) = @_;
     my %blockers = ();      my %blockers = ();
     return %blockers unless ($env{'request.course.id'});      return %blockers unless ($env{'request.course.id'});
     return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);      my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
       if ($env{'request.course.sec'}) {
           $courseurl .= '/'.$env{'request.course.sec'};
       }
       return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
     my %commblocks;      my %commblocks;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %commblocks = %{$blocks};          %commblocks = %{$blocks};
Line 8818  sub get_commblock_resources { Line 8996  sub get_commblock_resources {
             }              }
         } elsif ($block =~ /^firstaccess____(.+)$/) {          } elsif ($block =~ /^firstaccess____(.+)$/) {
             my $item = $1;              my $item = $1;
             my @to_test;  
             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                 if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {                  if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                     my @interval;                      my (@interval,$mapname);
                     my $type = 'map';                      my $type = 'map';
                     if ($item eq 'course') {                      if ($item eq 'course') {
                         $type = 'course';                          $type = 'course';
Line 8830  sub get_commblock_resources { Line 9007  sub get_commblock_resources {
                         if ($item =~ /___\d+___/) {                          if ($item =~ /___\d+___/) {
                             $type = 'resource';                              $type = 'resource';
                             @interval=&EXT("resource.0.interval",$item);                              @interval=&EXT("resource.0.interval",$item);
                             if (ref($navmap)) {                          
                                 my $res = $navmap->getBySymb($item);   
                                 push(@to_test,$res);  
                             }  
                         } else {                          } else {
                             my $mapsymb = &symbread($item,1);                              $mapname = &deversion($item);
                             if ($mapsymb) {                              if (ref($navmap)) {
                                 if (ref($navmap)) {                                  my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
                                     my $mapres = $navmap->getBySymb($mapsymb);                                  @interval = ($timelimit,'map');
                                     if (ref($mapres)) {  
                                         my $first = $mapres->map_start();  
                                         my $finish = $mapres->map_finish();  
                                         my $it = $navmap->getIterator($first,$finish,undef,0,0);  
                                         if (ref($it)) {  
                                             my $res;  
                                             while ($res = $it->next(undef,1)) {  
                                                 next unless (ref($res));  
                                                 my $symb = $res->symb();  
                                                 next if (($symb eq $mapsymb) || ($symb eq ''));  
                                                 @interval=&EXT("resource.0.interval",$symb);  
                                                 if ($interval[1] eq 'map') {  
                                                     if ($res->answerable()) {  
                                                         push(@to_test,$res);  
                                                         last;  
                                                     }  
                                                 }  
                                             }  
                                         }  
                                     }  
                                 }  
                             }                              }
                         }                          }
                     }                      }
Line 8877  sub get_commblock_resources { Line 9029  sub get_commblock_resources {
                             my $timesup = $first_access+$timelimit;                              my $timesup = $first_access+$timelimit;
                             if ($timesup > $now) {                              if ($timesup > $now) {
                                 my $activeblock;                                  my $activeblock;
                                 foreach my $res (@to_test) {                                  if ($type eq 'resource') {
                                     if ($res->answerable()) {                                      if (ref($navmap)) {
                                         $activeblock = 1;                                          my $res = $navmap->getBySymb($item);
                                         last;                                          if ($res->answerable()) {
                                               $activeblock = 1;
                                           }
                                       }
                                   } elsif ($type eq 'map') {
                                       my $mapsymb = &symbread($mapname,1);
                                       if (($mapsymb) && (ref($navmap))) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           if (ref($mapres)) {
                                               my $first = $mapres->map_start();
                                               my $finish = $mapres->map_finish();
                                               my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                               if (ref($it)) {
                                                   my $res;
                                                   while ($res = $it->next(undef,1)) {
                                                       next unless (ref($res));
                                                       my $symb = $res->symb();
                                                       next if (($symb eq $mapsymb) || ($symb eq ''));
                                                       @interval=&EXT("resource.0.interval",$symb);
                                                       if ($interval[1] eq 'map') {
                                                           if ($res->answerable()) {
                                                               $activeblock = 1;
                                                               last;
                                                           }
                                                       }
                                                   }
                                               }
                                           }
                                     }                                      }
                                 }                                  }
                                 if ($activeblock) {                                  if ($activeblock) {
Line 8910  sub has_comm_blocking { Line 9089  sub has_comm_blocking {
     my @blockers;      my @blockers;
     return unless ($env{'request.course.id'});      return unless ($env{'request.course.id'});
     return unless ($priv eq 'bre');      return unless ($priv eq 'bre');
     return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);  
     return if ($env{'request.state'} eq 'construct');      return if ($env{'request.state'} eq 'construct');
       my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
       if ($env{'request.course.sec'}) {
           $courseurl .= '/'.$env{'request.course.sec'};
       }
       return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
     my %blockinfo;      my %blockinfo;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %blockinfo = &get_commblock_resources($blocks);          %blockinfo = &get_commblock_resources($blocks);
Line 8986  sub deeplink_check { Line 9169  sub deeplink_check {
         @symbs = keys(%possibles);          @symbs = keys(%possibles);
     }      }
   
     my ($login,$switchrole,$allow);      my ($deeplink_symb,$allow);
     if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {      if ($env{'request.deeplink.login'}) {
         my $key = $1;          $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
         my $tinyurl;  
         my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);  
         if (defined($cached)) {  
              $tinyurl = $result;  
         } else {  
              my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);  
              my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);  
              if ($currtiny{$key} ne '') {  
                  $tinyurl = $currtiny{$key};  
                  &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);  
              }  
         }  
         if ($tinyurl ne '') {  
             my ($cnumreq,$posslogin) = split(/\&/,$tinyurl);  
             if ($cnumreq eq $cnum) {  
                 $login = $posslogin;  
             } else {  
                 $switchrole = 1;  
             }  
         }  
     }      }
     foreach my $symb (@symbs) {      foreach my $symb (@symbs) {
         last if ($allow);          last if ($allow);
Line 9016  sub deeplink_check { Line 9179  sub deeplink_check {
         if ($deeplink eq '') {          if ($deeplink eq '') {
             $allow = 1;              $allow = 1;
         } else {          } else {
             my ($listed,$scope,$access) = split(/,/,$deeplink);              my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
             if ($access eq 'any') {              if ($state ne 'only') {
                 $allow = 1;                  $allow = 1;
             } elsif ($login) {              } else {
                 if ($access eq 'only') {                  my $check_deeplink_entry;
                   if ($protect ne 'none') {
                       my ($acctype,$item) = split(/:/,$protect);
                       if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {
                           if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {
                               $check_deeplink_entry = 1
                           }
                       } elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {
                           if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {
                               $check_deeplink_entry = 1;
                           }
                       } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
                           if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
                               $check_deeplink_entry = 1;
                           }
                       }
                   }
                   if (($protect eq 'none') || ($check_deeplink_entry)) {
                     if ($scope eq 'res') {                      if ($scope eq 'res') {
                         if ($symb eq $login) {                          if ($symb eq $deeplink_symb) {
                             $allow = 1;                              $allow = 1;
                         }                          }
                     } elsif ($scope eq 'map') {                      } elsif (($scope eq 'map') || ($scope eq 'rec')) {
 #FIXME Compare map for $env{'request.deeplink.login'} with map for $symb                          my ($map_from_symb,$map_from_login);
                     } elsif ($scope eq 'rec') {                          $map_from_symb = &deversion((&decode_symb($symb))[0]);
 #FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb                          if ($deeplink_symb =~ /\.(page|sequence)$/) {
                     }                              $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
                 } else {                          } else {
                     my ($acctype,$item) = split(/:/,$access);                              $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
                     if (($acctype eq 'lti') && ($env{'user.linkprotector'})) {  
                         if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) {  
                             my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);  
                             if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) {  
                                 $allow = 1;  
                             }  
                         }                          }
                     } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {                          if (($map_from_symb) && ($map_from_login)) {
                         if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {                              if ($map_from_symb eq $map_from_login) {
                             my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);  
                             if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) {  
                                 $allow = 1;                                  $allow = 1;
                               } elsif ($scope eq 'rec') {
                                   my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});
                                   if (grep(/^\Q$map_from_login\E$/,@recurseup)) {
                                       $allow = 1;
                                   }
                             }                              }
                         }                          }
                     }                      }
Line 9316  sub fetch_enrollment_query { Line 9493  sub fetch_enrollment_query {
 }  }
   
 sub get_query_reply {  sub get_query_reply {
     my ($queryid,$sleep,$loopmax) = @_;;      my ($queryid,$sleep,$loopmax) = @_;
     if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {      if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
         $sleep = 0.2;          $sleep = 0.2;
     }      }
Line 9739  sub auto_validate_class_sec { Line 9916  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_instsec_reformat {
       my ($cdom,$action,$instsecref) = @_;
       return unless(($action eq 'clutter') || ($action eq 'declutter'));
       my @homeservers;
       if (defined(&domain($cdom,'primary'))) {
           push(@homeservers,&domain($cdom,'primary'));
       } else {
           my %servers = &get_servers($cdom,'library');
           foreach my $tryserver (keys(%servers)) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $response;
       my %reformatted = %{$instsecref};
       foreach my $server (@homeservers) {
           if (ref($instsecref) eq 'HASH') {
               my $info = &freeze_escape($instsecref);
               my $response=&reply('autoinstsecreformat:'.$cdom.':'.
                                   $action.':'.$info,$server);
               next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split(/=/,$item);
                   $reformatted{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return %reformatted;
   }
   
 sub auto_validate_instclasses {  sub auto_validate_instclasses {
     my ($cdom,$cnum,$owners,$classesref) = @_;      my ($cdom,$cnum,$owners,$classesref) = @_;
     my ($homeserver,%validations);      my ($homeserver,%validations);
Line 12086  sub resdata { Line 12295  sub resdata {
   
 sub get_domain_lti {  sub get_domain_lti {
     my ($cdom,$context) = @_;      my ($cdom,$context) = @_;
     my ($name,%lti);      my ($name,$cachename,%lti);
     if ($context eq 'consumer') {      if ($context eq 'consumer') {
         $name = 'ltitools';          $name = 'ltitools';
     } elsif ($context eq 'provider') {      } elsif ($context eq 'provider') {
         $name = 'lti';          $name = 'lti';
       } elsif ($context eq 'linkprot') {
           $name = 'ltisec';
     } else {      } else {
         return %lti;          return %lti;
     }      }
     my ($result,$cached)=&is_cached_new($name,$cdom);  
       if ($context eq 'linkprot') {
           $cachename = $context;
       } else {
           $cachename = $name;
       }
       
       my ($result,$cached)=&is_cached_new($cachename,$cdom);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             %lti = %{$result};              %lti = %{$result};
Line 12102  sub get_domain_lti { Line 12320  sub get_domain_lti {
     } else {      } else {
         my %domconfig = &get_dom('configuration',[$name],$cdom);          my %domconfig = &get_dom('configuration',[$name],$cdom);
         if (ref($domconfig{$name}) eq 'HASH') {          if (ref($domconfig{$name}) eq 'HASH') {
             %lti = %{$domconfig{$name}};              if ($context eq 'linkprot') {
             my %encdomconfig = &get_dom('encconfig',[$name],$cdom);                  if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
             if (ref($encdomconfig{$name}) eq 'HASH') {                      %lti = %{$domconfig{$name}{'linkprot'}};
                 foreach my $id (keys(%lti)) {                  }
                     if (ref($encdomconfig{$name}{$id}) eq 'HASH') {              } else {
                         foreach my $item ('key','secret') {                  %lti = %{$domconfig{$name}};
                             $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};              }
               if (($context eq 'consumer') && (keys(%lti))) {
                   my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);
                   if (ref($encdomconfig{$name}) eq 'HASH') {
                       foreach my $id (keys(%lti)) {
                           if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
                               foreach my $item ('key','secret') {
                                   $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
                               }
                         }                          }
                     }                      }
                 }                  }
             }              }
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new($name,$cdom,\%lti,$cachetime);          &do_cache_new($cachename,$cdom,\%lti,$cachetime);
     }      }
     return %lti;      return %lti;
 }  }
   
   sub get_course_lti {
       my ($cnum,$cdom) = @_;
       my $hashid=$cdom.'_'.$cnum;
       my %courselti;
       my ($result,$cached)=&is_cached_new('courselti',$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %courselti = %{$result};
           }
       } else {
           %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);
           my $cachetime = 24*60*60;
           &do_cache_new('courselti',$hashid,\%courselti,$cachetime);
       }
       return %courselti;
   }
   
   sub courselti_itemid {
       my ($cnum,$cdom,$url,$method,$params,$context) = @_;
       my ($chome,$itemid);
       $chome = &homeserver($cnum,$cdom);
       return if ($chome eq 'no_host');
       if (ref($params) eq 'HASH') {
           my $items = &freeze_escape($params);
           my $rep;
           if (grep { $_ eq $chome } current_machine_ids()) {
               $rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});
           } else {
               my $escurl = &escape($url);
               my $escmethod = &escape($method);
               my $items = &freeze_escape($params);
               $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);
           }
           unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
                   ($rep eq 'unknown_cmd')) {
               $itemid = $rep;
           }
       }
       return $itemid;
   }
   
   sub domainlti_itemid {
       my ($cdom,$url,$method,$params,$context) = @_;
       my ($primary_id,$itemid);
       $primary_id = &domain($cdom,'primary');
       return if ($primary_id eq '');
       if (ref($params) eq 'HASH') {
           my $items = &freeze_escape($params);
           my $rep;
           if (grep { $_ eq $primary_id } current_machine_ids()) {
               $rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});
           } else {
               my $cnum = '';
               my $escurl = &escape($url);
               my $escmethod = &escape($method);
               my $items = &freeze_escape($params);
               $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);
           }
           unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
                   ($rep eq 'unknown_cmd')) {
               $itemid = $rep;
           }
       }
       return $itemid;
   }
   
 sub get_numsuppfiles {  sub get_numsuppfiles {
     my ($cnum,$cdom,$ignorecache)=@_;      my ($cnum,$cdom,$ignorecache)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
Line 12179  sub EXT_cache_set { Line 12471  sub EXT_cache_set {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
   
     my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;      my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
Line 12211  sub EXT { Line 12503  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  # if we are in the middle of processing the resource the   # if we are in the middle of processing the resource the
  # get the value we are planning on committing   # get the value we are planning on committing
                 if (defined($Apache::lonhomework::results{$qualifierrest})) {                  if (defined($Apache::lonhomework::results{$qualifierrest})) {
Line 12333  sub EXT { Line 12625  sub EXT {
         }          }
   
  my ($section, $group, @groups, @recurseup, $recursed);   my ($section, $group, @groups, @recurseup, $recursed);
           if (ref($recurseupref) eq 'ARRAY') {
               @recurseup = @{$recurseupref};
               $recursed = 1;
           }
  my ($courselevelm,$courseleveli,$courselevel,$mapp);   my ($courselevelm,$courseleveli,$courselevel,$mapp);
         if (($courseid eq '') && ($cid)) {          if (($courseid eq '') && ($cid)) {
             $courseid = $cid;              $courseid = $cid;
Line 13453  sub symbread { Line 13749  sub symbread {
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
     if (($env{'request.course.fn'}) && ($thisfn)) {      if (($env{'request.course.fn'}) && ($thisfn)) {
         my $targetfn = $thisfn;  
         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {  
             $targetfn = 'adm/wrapper/'.$thisfn;  
         }  
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {  
     $targetfn=$1;  
  }  
         unless ($ignoresymbdb) {          unless ($ignoresymbdb) {
             if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',              if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                           &GDBM_READER(),0640)) {                            &GDBM_READER(),0640)) {
         $syval=$hash{$targetfn};          $syval=$hash{$thisfn};
                 untie(%hash);                  untie(%hash);
             }              }
             if ($syval && $checkforblock) {              if ($syval && $checkforblock) {
Line 14271  sub machine_ids { Line 14560  sub machine_ids {
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @domains;      my @domains;
     open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");      if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
     while( my $line = <$fh>) {          if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
         $line =~ s/\s//g;              while (my $line = <$fh>) {
         push(@domains,$line);                  chomp($line);           
                   $line =~ s/\s//g;
                   push(@domains,$line);
               }
               close($fh);
           }
     }      }
     return @domains;      return @domains;
 }  }
Line 14453  sub ip_match { Line 14747  sub ip_match {
 }  }
   
 sub get_proxy_alias {  sub get_proxy_alias {
     my $lonhost = $perlvar{'lonHostID'};      my ($lonid) = @_;
     if ($lonhost ne '') {      if ($lonid eq '') {
         my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost);          $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
         if ($cached) {          if ($cached) {
             return $alias;              return $alias;
         }          }
         my $dom = &Apache::lonnet::host_domain($lonhost);          my $dom = &Apache::lonnet::host_domain($lonid);
         if ($dom ne '') {          if ($dom ne '') {
             my $cachetime = 60*60*24;              my $cachetime = 60*60*24;
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);                  &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
             my $alias;  
             if (ref($domconfig{'wafproxy'}) eq 'HASH') {              if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                 if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {                  if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
                     $alias = $domconfig{'wafproxy'}{'alias'}{$lonhost};                      $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
                 }                  }
             }              }
             return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime);              return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
         }          }
     }      }
     return;      return;
 }  }
   
   sub use_proxy_alias {
       my ($r,$lonid) = @_;
       my $alias = &get_proxy_alias($lonid);
       if ($alias) {
           my $dom = &host_domain($lonid);
           if ($dom ne '') {
               my $proxyinfo = &get_proxy_settings($dom);
               my ($vpnint,$remote_ip);
               if (ref($proxyinfo) eq 'HASH') {
                   $vpnint = $proxyinfo->{'vpnint'};
                   if ($vpnint) {
                       $remote_ip = &get_requestor_ip($r,1,1);
                   }
               }
               unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
                   return $alias;
               }
           }
       }
       return;
   }
   
   sub alias_sso {
       my ($lonid) = @_;
       if ($lonid eq '') {
           $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid);
           if ($cached) {
               return $use_alias;
           }
           my $dom = &Apache::lonnet::host_domain($lonid);
           if ($dom ne '') {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
                       $use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
                   }
               }
               return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime);
           }
       }
       return;
   }
   
   sub get_saml_landing {
       my ($lonid) = @_;
       if ($lonid eq '') {
           my $defdom = &default_login_domain();
           my @hosts = &current_machine_ids();
           if (@hosts > 1) {
               foreach my $hostid (@hosts) {
                   if (&host_domain($hostid) eq $defdom) {
                       $lonid = $hostid;
                       last;
                   }
               }
           } else {
               $lonid = $perlvar{'lonHostID'};
           }
           if ($lonid) {
               unless (&Apache::lonnet::host_domain($lonid) eq $defdom) {
                   return;
               }
           } else {
               return;
           }
       } elsif (!defined(&hostname($lonid))) {
           return;
       }
       my ($landing,$cached) = &is_cached_new('samllanding',$lonid);
       if ($cached) {
           return $landing;
       }
       my $dom = &Apache::lonnet::host_domain($lonid);
       if ($dom ne '') {
           my $cachetime = 60*60*24;
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['login'],$dom);
           if (ref($domconfig{'login'}) eq 'HASH') {
               if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
                   if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
                       $landing = 1;
                   }
               }
           }
           return &do_cache_new('samllanding',$lonid,$landing,$cachetime);
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 14615  sub get_dns { Line 15011  sub get_dns {
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");          my ($contents,@content);
         my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);          if ($dns eq Sys::Hostname::FQDN::fqdn()) {
         delete($alldns{$dns});              my $command = (split('/',$url))[3];
  next if ($response->is_error());              my ($dir,$file) = &parse_getdns_url($command,$url);
               delete($alldns{$dns});
               next if (($dir eq '') || ($file eq ''));
               if (open(my $config,'<',"$dir/$file")) {
                   @content = <$config>;
                   close($config);
               }
               if ($url eq '/adm/dns/loncapaCRL') {
                   $contents = join('',@content);
               }
           } else {
       my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
               my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
               delete($alldns{$dns});
       next if ($response->is_error());
               if ($url eq '/adm/dns/loncapaCRL') {
                   $contents = $response->content;
               } else {
                   @content = split("\n",$response->content);
               }
           }
         if ($url eq '/adm/dns/loncapaCRL') {          if ($url eq '/adm/dns/loncapaCRL') {
             return &$func($response);              return &$func($contents);
         } else {          } else {
     my @content = split("\n",$response->content);  
     unless ($nocache) {      unless ($nocache) {
         &do_cache_new('dns',$url,\@content,30*24*60*60);          &do_cache_new('dns',$url,\@content,30*24*60*60);
     }      }
Line 14710  sub fetch_crl_pemfile { Line 15125  sub fetch_crl_pemfile {
 }  }
   
 sub save_crl_pem {  sub save_crl_pem {
     my ($response) = @_;      my ($content) = @_;
     my ($msg,$hadchanges);      my ($msg,$hadchanges);
     if (ref($response)) {      if ($content ne '') {
         my $now = time;          my $now = time;
         my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};          my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
         my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';          my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
         if (open(my $fh,'>',"$tmpcrl")) {          if (open(my $fh,'>',"$tmpcrl")) {
             print $fh $response->content;              print $fh $content;
             close($fh);              close($fh);
             if (-e $lonca) {              if (-e $lonca) {
                 if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {                  if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
Line 14778  sub save_crl_pem { Line 15193  sub save_crl_pem {
     return ($msg,$hadchanges);      return ($msg,$hadchanges);
 }  }
   
   sub parse_getdns_url {
       my ($command,$url) = @_;
       my $dir = $perlvar{'lonTabDir'};
       my $file;
       if ($command eq 'hosts') {
           $file = 'dns_hosts.tab';
       } elsif ($command eq 'domain') {
           $file = 'dns_domain.tab';
       } elsif ($command eq 'checksums') {
           my $version = (split('/',$url))[4];
           $file = "dns_checksums/$version.tab",
       } elsif ($command eq 'loncapaCRL') {
           $dir = $perlvar{'lonCertificateDirectory'};
           $file = $perlvar{'lonnetCertRevocationList'};
       }
       return ($dir,$file);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Removed from v.1.1449  
changed lines
  Added in v.1.1487

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