--- loncom/lonnet/perl/lonnet.pm 2021/02/07 21:33:09 1.1172.2.138
+++ loncom/lonnet/perl/lonnet.pm 2023/01/22 17:32:08 1.1172.2.146.2.10
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.138 2021/02/07 21:33:09 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.146.2.10 2023/01/22 17:32:08 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -95,6 +95,8 @@ use Cache::Memcached;
use Digest::MD5;
use Math::Random;
use File::MMagic;
+use Net::CIDR;
+use Sys::Hostname::FQDN();
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
use LONCAPA::lonmetadata;
@@ -125,7 +127,7 @@ our @EXPORT = qw(%env);
$logid ++;
my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;
- my $ip = &get_requestor_ip();
+ my $ip = &get_requestor_ip();
my $logentry = {
$id => {
'exe_uname' => $env{'user.name'},
@@ -689,6 +691,9 @@ sub check_for_valid_session {
if (ref($userhashref) eq 'HASH') {
$userhashref->{'name'} = $disk_env{'user.name'};
$userhashref->{'domain'} = $disk_env{'user.domain'};
+ if ($disk_env{'request.role'}) {
+ $userhashref->{'role'} = $disk_env{'request.role'};
+ }
}
untie(%disk_env);
@@ -917,7 +922,7 @@ sub userload {
# ------------------------------ Find server with least workload from spare.tab
sub spareserver {
- my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
+ my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
my $spare_server;
if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent
@@ -962,6 +967,8 @@ sub spareserver {
if ($protocol{$spare_server} eq 'https') {
$protocol = $protocol{$spare_server};
}
+ my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
+ $hostname = $alias if ($alias ne '');
$spare_server = $protocol.'://'.$hostname;
}
}
@@ -1247,7 +1254,7 @@ sub changepass {
sub queryauthenticate {
my ($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");
return 'no_host';
}
@@ -1296,12 +1303,35 @@ sub authenticate {
}
if ($answer eq 'non_authorized') {
&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");
return 'no_host';
}
+sub can_switchserver {
+ my ($udom,$home) = @_;
+ my ($canswitch,@intdoms);
+ my $internet_names = &get_internet_names($home);
+ if (ref($internet_names) eq 'ARRAY') {
+ @intdoms = @{$internet_names};
+ }
+ my $uint_dom = &internet_dom(&domain($udom,'primary'));
+ if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
+ $canswitch = 1;
+ } else {
+ my $serverhomeID = &get_server_homeID(&hostname($home));
+ my $serverhomedom = &host_domain($serverhomeID);
+ my %defdomdefaults = &get_domain_defaults($serverhomedom);
+ my %udomdefaults = &get_domain_defaults($udom);
+ my $remoterev = &get_server_loncaparev('',$home);
+ $canswitch = &can_host_session($udom,$home,$remoterev,
+ $udomdefaults{'remotesessions'},
+ $defdomdefaults{'hostedsessions'});
+ }
+ return $canswitch;
+}
+
sub can_host_session {
my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
my $canhost = 1;
@@ -1875,7 +1905,7 @@ sub dump_dom {
# ------------------------------------------ get items from domain db files
sub get_dom {
- my ($namespace,$storearr,$udom,$uhome)=@_;
+ my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
return if ($udom eq 'public');
my $items='';
foreach my $item (@$storearr) {
@@ -1898,7 +1928,17 @@ sub get_dom {
}
}
if ($udom && $uhome && ($uhome ne 'no_host')) {
- my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ my $rep;
+ if (grep { $_ eq $uhome } ¤t_machine_ids()) {
+ # domain information is hosted on this machine
+ $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
+ } else {
+ if ($encrypt) {
+ $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
+ } else {
+ $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ }
+ }
my %returnhash;
if ($rep eq '' || $rep =~ /^error: 2 /) {
return %returnhash;
@@ -1921,7 +1961,7 @@ sub get_dom {
# -------------------------------------------- put items in domain db files
sub put_dom {
- my ($namespace,$storehash,$udom,$uhome)=@_;
+ my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
if (!$udom) {
$udom=$env{'user.domain'};
if (defined(&domain($udom,'primary'))) {
@@ -1942,7 +1982,11 @@ sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
- return &reply("putdom:$udom:$namespace:$items",$uhome);
+ if ($encrypt) {
+ return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
+ } else {
+ return &reply("putdom:$udom:$namespace:$items",$uhome);
+ }
} else {
&logthis("put_dom failed - no homeserver and/or domain");
}
@@ -1976,6 +2020,57 @@ 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
sub get_domainconfiguser {
my ($udom) = @_;
@@ -2018,7 +2113,7 @@ sub retrieve_inst_usertypes {
sub is_domainimage {
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 '') {
return '1';
}
@@ -2254,6 +2349,10 @@ sub inst_rulecheck {
$response=&unescape(&reply('instidrulecheck:'.&escape($udom).
':'.&escape($id).':'.$rulestr,
$homeserver));
+ } elsif ($item eq 'unamemap') {
+ $response=&unescape(&reply('instunamemapcheck:'.
+ &escape($udom).':'.&escape($uname).
+ ':'.$rulestr,$homeserver));
} elsif ($item eq 'selfcreate') {
$response=&unescape(&reply('instselfcreatecheck:'.
&escape($udom).':'.&escape($uname).
@@ -2287,6 +2386,9 @@ sub inst_userrules {
} elsif ($check eq 'email') {
$response=&reply('instemailrules:'.&escape($udom),
$homeserver);
+ } elsif ($check eq 'unamemap') {
+ $response=&reply('unamemaprules:'.&escape($udom),
+ $homeserver);
} else {
$response=&reply('instuserrules:'.&escape($udom),
$homeserver);
@@ -2333,7 +2435,7 @@ sub get_domain_defaults {
'coursedefaults','usersessions',
'requestauthor','selfenrollment',
'coursecategories','autoenroll',
- 'helpsettings'],$domain);
+ 'helpsettings','wafproxy','ltisec'],$domain);
my @coursetypes = ('official','unofficial','community','textbook');
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
@@ -2345,6 +2447,7 @@ sub get_domain_defaults {
$domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
$domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
$domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
+ $domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
} else {
$domdefaults{'lang_def'} = &domain($domain,'lang_def');
$domdefaults{'auth_def'} = &domain($domain,'auth_def');
@@ -2381,6 +2484,7 @@ sub get_domain_defaults {
}
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
$domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
+ $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
$domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
$domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
@@ -2414,6 +2518,9 @@ sub get_domain_defaults {
if ($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'}{'remote'}) eq 'HASH') {
@@ -2469,6 +2576,7 @@ sub get_domain_defaults {
}
if (ref($domconfig{'autoenroll'}) eq 'HASH') {
$domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
+ $domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
}
if (ref($domconfig{'helpsettings'}) eq 'HASH') {
$domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
@@ -2476,6 +2584,25 @@ sub get_domain_defaults {
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
}
}
+ if (ref($domconfig{'wafproxy'}) eq 'HASH') {
+ foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
+ if ($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);
return %domdefaults;
}
@@ -2512,6 +2639,7 @@ sub get_dom_instcats {
if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
\@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
$instcats = {
+ totcodes => $totcodes,
codes => \%codes,
codetitles => \@codetitles,
cat_titles => \%cat_titles,
@@ -2562,6 +2690,24 @@ sub get_passwdconf {
return %passwdconf;
}
+sub course_portal_url {
+ my ($cnum,$cdom,$r) = @_;
+ my $chome = &homeserver($cnum,$cdom);
+ my $hostname = &hostname($chome);
+ my $protocol = $protocol{$chome};
+ $protocol = 'http' if ($protocol ne 'https');
+ my %domdefaults = &get_domain_defaults($cdom);
+ my $firsturl;
+ if ($domdefaults{'portal_def'}) {
+ $firsturl = $domdefaults{'portal_def'};
+ } else {
+ my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
+ $hostname = $alias if ($alias ne '');
+ $firsturl = $protocol.'://'.$hostname;
+ }
+ return $firsturl;
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -3146,11 +3292,29 @@ sub ssi_body {
# --------------------------------------------------------- Server Side Include
sub absolute_url {
- my ($host_name) = @_;
+ my ($host_name,$unalias,$keep_proto) = @_;
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
if ($host_name eq '') {
$host_name = $ENV{'SERVER_NAME'};
}
+ if ($unalias) {
+ my $alias = &get_proxy_alias();
+ if ($alias eq $host_name) {
+ my $lonhost = $perlvar{'lonHostID'};
+ my $hostname = &hostname($lonhost);
+ my $lcproto;
+ if (($keep_proto) || ($hostname eq '')) {
+ $lcproto = $protocol;
+ } else {
+ $lcproto = $protocol{$lonhost};
+ $lcproto = 'http' if ($lcproto ne 'https');
+ $lcproto .= '://';
+ }
+ unless ($hostname eq '') {
+ return $lcproto.$hostname;
+ }
+ }
+ }
return $protocol.$host_name;
}
@@ -3167,12 +3331,13 @@ sub absolute_url {
sub ssi {
my ($fn,%form)=@_;
- my ($request,$response);
+ my ($host,$request,$response);
+ $host = &absolute_url('',1);
$form{'no_update_last_known'}=1;
&Apache::lonenc::check_encrypt(\$fn);
if (%form) {
- $request=new HTTP::Request('POST',&absolute_url().$fn);
+ $request=new HTTP::Request('POST',$host.$fn);
$request->content(join('&',map {
my $name = escape($_);
"$name=" . ( ref($form{$_}) eq 'ARRAY'
@@ -3180,7 +3345,7 @@ sub ssi {
: &escape($form{$_}) );
} keys(%form)));
} else {
- $request=new HTTP::Request('GET',&absolute_url().$fn);
+ $request=new HTTP::Request('GET',$host.$fn);
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
@@ -3449,6 +3614,14 @@ sub can_edit_resource {
$cfile = '/adm/wrapper'.$resurl;
}
}
+ } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = $resurl;
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -3473,6 +3646,14 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
+ } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = $resurl;
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
$incourse = 1;
$forceview = 1;
@@ -3482,8 +3663,13 @@ sub can_edit_resource {
$cfile = &clutter($res);
} else {
$cfile = $env{'form.suppurl'};
- $cfile =~ s{^http://}{};
- $cfile = '/adm/wrapper/ext/'.$cfile;
+ my $escfile = &unescape($cfile);
+ if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+ $cfile = '/adm/wrapper'.$escfile;
+ } else {
+ $escfile =~ s{^http://}{};
+ $cfile = &escape("/adm/wrapper/ext/$escfile");
+ }
}
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
if ($env{'form.forceedit'}) {
@@ -3730,6 +3916,10 @@ sub clean_filename {
# Replace all .\d. sequences with _\d. so they no longer look like version
# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;
+# Replace three or more adjacent underscores with one for consistency
+# with loncfile::filename_check() so complete url can be extracted by
+# lonnet::decode_symb()
+ $fname=~s/_{3,}/_/g;
return $fname;
}
@@ -4287,7 +4477,7 @@ sub bubblesheet_converter {
next if (($num == 1) && ($csvoptions{'hdr'} == 1));
$line =~ s{[\r\n]+$}{};
my %found;
- my @values = split(/,/,$line);
+ my @values = split(/,/,$line,-1);
my ($qstart,$record);
for (my $i=0; $i<@values; $i++) {
if ((($qstart ne '') && ($i > $qstart)) ||
@@ -4470,6 +4660,7 @@ sub get_scantronformat_file {
close($fh);
}
}
+ chomp(@lines);
}
return @lines;
}
@@ -4591,6 +4782,29 @@ sub flushcourselogs {
if (! defined($dom) || $dom eq '' ||
! defined($name) || $name eq '') {
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'};
$name = $env{'request.'.$cid.'.num'};
}
@@ -5460,9 +5674,10 @@ my %cachedtimes=();
my $cachedtime='';
sub load_all_first_access {
- my ($uname,$udom)=@_;
+ my ($uname,$udom,$ignorecache)=@_;
if (($cachedkey eq $uname.':'.$udom) &&
- (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
+ (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
+ (!$ignorecache)) {
return;
}
$cachedtime=time;
@@ -5471,7 +5686,7 @@ sub load_all_first_access {
}
sub get_first_access {
- my ($type,$argsymb,$argmap)=@_;
+ my ($type,$argsymb,$argmap,$ignorecache)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
@@ -5483,7 +5698,7 @@ sub get_first_access {
} else {
$res=$symb;
}
- &load_all_first_access($uname,$udom);
+ &load_all_first_access($uname,$udom,$ignorecache);
return $cachedtimes{"$courseid\0$res"};
}
@@ -6463,31 +6678,31 @@ sub course_adhocrole_privs {
$full{$priv} = $restrict;
}
foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
- next if ($item eq '');
- my ($rule,$rest) = split(/=/,$item);
- next unless (($rule eq 'off') || ($rule eq 'on'));
- foreach my $priv (split(/:/,$rest)) {
- if ($priv ne '') {
- if ($rule eq 'off') {
- $possremove{$priv} = 1;
- } else {
- $possadd{$priv} = 1;
- }
- }
- }
- }
- foreach my $priv (sort(keys(%full))) {
- if (exists($currprivs{$priv})) {
- unless (exists($possremove{$priv})) {
- $storeprivs{$priv} = $currprivs{$priv};
- }
- } elsif (exists($possadd{$priv})) {
- $storeprivs{$priv} = $full{$priv};
- }
- }
- $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
- }
- return $coursepriv;
+ next if ($item eq '');
+ my ($rule,$rest) = split(/=/,$item);
+ next unless (($rule eq 'off') || ($rule eq 'on'));
+ foreach my $priv (split(/:/,$rest)) {
+ if ($priv ne '') {
+ if ($rule eq 'off') {
+ $possremove{$priv} = 1;
+ } else {
+ $possadd{$priv} = 1;
+ }
+ }
+ }
+ }
+ foreach my $priv (sort(keys(%full))) {
+ if (exists($currprivs{$priv})) {
+ unless (exists($possremove{$priv})) {
+ $storeprivs{$priv} = $currprivs{$priv};
+ }
+ } elsif (exists($possadd{$priv})) {
+ $storeprivs{$priv} = $full{$priv};
+ }
+ }
+ $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
+ }
+ return $coursepriv;
}
sub group_roleprivs {
@@ -6751,7 +6966,8 @@ sub set_adhoc_privileges {
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
- unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
+ unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||
+ ($caller eq 'tiny')) {
&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,
'request.course.sec' => $sec,
@@ -6826,7 +7042,7 @@ sub unserialize {
# see Lond::dump_with_regexp
# if $escapedkeys hash keys won't get unescaped.
sub dump {
- my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
+ my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -6842,7 +7058,12 @@ sub dump {
$uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
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 %returnhash=();
if (!($rep =~ /^error/ )) {
@@ -6988,7 +7209,7 @@ sub inc {
# --------------------------------------------------------------- put interface
sub put {
- my ($namespace,$storehash,$udomain,$uname)=@_;
+ my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -6997,7 +7218,11 @@ sub put {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$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
@@ -7262,15 +7487,15 @@ sub portfolio_access {
if ($result) {
my %setters;
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
- my ($startblock,$endblock) =
- &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);
- if ($startblock && $endblock) {
+ my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
+ &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
+ if (($startblock && $endblock) || ($by_ip)) {
return 'B';
}
} else {
- my ($startblock,$endblock) =
- &Apache::loncommon::blockcheck(\%setters,'port');
- if ($startblock && $endblock) {
+ my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =
+ &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
+ if (($startblock && $endblock) || ($by_ip)) {
return 'B';
}
}
@@ -7534,6 +7759,7 @@ sub usertools_access {
blog => 1,
webdav => 1,
portfolio => 1,
+ timezone => 1,
);
}
return if (!defined($tools{$tool}));
@@ -7819,14 +8045,14 @@ sub customaccess {
# ------------------------------------------------- Check for a user privilege
sub allowed {
- my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
+ my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
$uri=&declutter($uri);
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\&([^\:]*)/) {
return $1;
} else {
@@ -7836,7 +8062,7 @@ sub allowed {
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme)$}))
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$}))
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
&& ($priv eq 'bre')) {
return 'F';
@@ -7847,9 +8073,9 @@ sub allowed {
if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
my %setters;
- my ($startblock,$endblock) =
- &Apache::loncommon::blockcheck(\%setters,'port');
- if ($startblock && $endblock) {
+ my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
+ &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
+ if (($startblock && $endblock) || ($by_ip)) {
return 'B';
} else {
return 'F';
@@ -7884,7 +8110,10 @@ sub allowed {
# Free bre to public access
if ($priv eq 'bre') {
- my $copyright=&metadata($uri,'copyright');
+ my $copyright;
+ unless ($uri =~ /ext\.tool/) {
+ $copyright=&metadata($uri,'copyright');
+ }
if (($copyright eq 'public') && (!$env{'request.course.id'})) {
return 'F';
}
@@ -7942,8 +8171,8 @@ sub allowed {
my $adom = $1;
foreach my $key (keys(%env)) {
if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
- my ($start,$end) = split('.',$env{$key});
- if (($now >= $start) && (!$end || $end < $now)) {
+ my ($start,$end) = split(/\./,$env{$key});
+ if (($now >= $start) && (!$end || $end > $now)) {
$ownaccess = 1;
last;
}
@@ -7955,8 +8184,8 @@ sub allowed {
foreach my $role ('ca','aa') {
if ($env{"user.role.$role./$adom/$aname"}) {
my ($start,$end) =
- split('.',$env{"user.role.$role./$adom/$aname"});
- if (($now >= $start) && (!$end || $end < $now)) {
+ split(/\./,$env{"user.role.$role./$adom/$aname"});
+ if (($now >= $start) && (!$end || $end > $now)) {
$ownaccess = 1;
last;
}
@@ -8041,7 +8270,13 @@ sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
- if ($noblockcheck) {
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+ }
+ if ($deeplinkblock) {
+ $thisallowed='D';
+ } elsif ($noblockcheck) {
$thisallowed.=$value;
} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
@@ -8061,7 +8296,13 @@ sub allowed {
$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);
if ($match) {
- if ($noblockcheck) {
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ }
+ if ($deeplinkblock) {
+ $thisallowed='D';
+ } elsif ($noblockcheck) {
$thisallowed='F';
} else {
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
@@ -8134,7 +8375,13 @@ sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
if ($priv eq 'bre') {
- if ($noblockcheck) {
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+ }
+ if ($deeplinkblock) {
+ $thisallowed = 'D';
+ } elsif ($noblockcheck) {
$thisallowed.=$value;
} else {
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
@@ -8176,7 +8423,13 @@ sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
if ($priv eq 'bre') {
- if ($noblockcheck) {
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ }
+ if ($deeplinkblock) {
+ $thisallowed = 'D';
+ } elsif ($noblockcheck) {
$thisallowed.=$value;
} else {
my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
@@ -8221,16 +8474,48 @@ sub allowed {
#
# 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
-# 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/) {
- 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)\.([^\.]*)/) {
my $courseid=$2;
my $roleid=$1.'.'.$2;
$courseid=~s/^\///;
+ unless ($env{'request.role'} eq $roleid) {
+ my ($start,$end) = split(/\./,$env{$envkey});
+ next unless (($now >= $start) && (!$end || $end > $now));
+ }
my $expiretime=600;
if ($env{'request.role'} eq $roleid) {
$expiretime=120;
@@ -8253,7 +8538,7 @@ sub allowed {
}
if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
|| ($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'},
$env{'user.home'},
'Locked by priv: '.$priv.' for '.$uri.' due to '.
@@ -8324,6 +8609,17 @@ 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?
if ($thisallowed=~/X/) {
@@ -8344,6 +8640,8 @@ sub allowed {
return 'A';
} elsif ($thisallowed eq 'B') {
return 'B';
+ } elsif ($thisallowed eq 'D') {
+ return 'D';
}
return 'F';
}
@@ -8470,7 +8768,11 @@ sub get_commblock_resources {
my ($blocks) = @_;
my %blockers = ();
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;
if (ref($blocks) eq 'HASH') {
%commblocks = %{$blocks};
@@ -8502,10 +8804,9 @@ sub get_commblock_resources {
}
} elsif ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;
- my @to_test;
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
- my @interval;
+ my (@interval,$mapname);
my $type = 'map';
if ($item eq 'course') {
$type = 'course';
@@ -8514,40 +8815,16 @@ sub get_commblock_resources {
if ($item =~ /___\d+___/) {
$type = 'resource';
@interval=&EXT("resource.0.interval",$item);
- if (ref($navmap)) {
- my $res = $navmap->getBySymb($item);
- push(@to_test,$res);
- }
} else {
- my $mapsymb = &symbread($item,1);
- if ($mapsymb) {
- if (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()) {
- push(@to_test,$res);
- last;
- }
- }
- }
- }
- }
- }
+ $mapname = &deversion($item);
+ if (ref($navmap)) {
+ my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
+ @interval = ($timelimit,'map');
}
}
}
- if ($interval[0] =~ /^\d+$/) {
+ if ($interval[0] =~ /^(\d+)/) {
+ my $timelimit = $1;
my $first_access;
if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);
@@ -8557,13 +8834,40 @@ sub get_commblock_resources {
$first_access=&get_first_access($interval[1]);
}
if ($first_access) {
- my $timesup = $first_access+$interval[0];
+ my $timesup = $first_access+$timelimit;
if ($timesup > $now) {
my $activeblock;
- foreach my $res (@to_test) {
- if ($res->answerable()) {
- $activeblock = 1;
- last;
+ if ($type eq 'resource') {
+ if (ref($navmap)) {
+ my $res = $navmap->getBySymb($item);
+ 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) {
@@ -8593,8 +8897,12 @@ sub has_comm_blocking {
my @blockers;
return unless ($env{'request.course.id'});
return unless ($priv eq 'bre');
- return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
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;
if (ref($blocks) eq 'HASH') {
%blockinfo = &get_commblock_resources($blocks);
@@ -8651,6 +8959,87 @@ sub has_comm_blocking {
}
}
+sub deeplink_check {
+ my ($priv,$symb,$uri) = @_;
+ return unless ($env{'request.course.id'});
+ return unless ($priv eq 'bre');
+ return if ($env{'request.state'} eq 'construct');
+ return if ($env{'request.role.adv'});
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ my (%possibles,@symbs);
+ if (!$symb) {
+ $symb = &symbread($uri,1,1,1,\%possibles);
+ }
+ if ($symb) {
+ @symbs = ($symb);
+ } elsif (keys(%possibles)) {
+ @symbs = keys(%possibles);
+ }
+
+ my ($deeplink_symb,$allow);
+ if ($env{'request.deeplink.login'}) {
+ $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);
+ }
+ foreach my $symb (@symbs) {
+ last if ($allow);
+ my $deeplink = &EXT("resource.0.deeplink",$symb);
+ if ($deeplink eq '') {
+ $allow = 1;
+ } else {
+ my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
+ if ($state ne 'only') {
+ $allow = 1;
+ } else {
+ 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 ($symb eq $deeplink_symb) {
+ $allow = 1;
+ }
+ } elsif (($scope eq 'map') || ($scope eq 'rec')) {
+ my ($map_from_symb,$map_from_login);
+ $map_from_symb = &deversion((&decode_symb($symb))[0]);
+ if ($deeplink_symb =~ /\.(page|sequence)$/) {
+ $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);
+ } else {
+ $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);
+ }
+ if (($map_from_symb) && ($map_from_login)) {
+ if ($map_from_symb eq $map_from_login) {
+ $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;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return if ($allow);
+ return 1;
+}
+
# -------------------------------- Deversion and split uri into path an filename
#
@@ -9045,6 +9434,25 @@ sub auto_validate_instcode {
return ($outcome,$description,$defaultcredits);
}
+sub auto_validate_inst_crosslist {
+ my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
+ my ($homeserver,$response);
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ if (!defined($homeserver)) {
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ }
+ unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
+ $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
+ &escape($instcode).':'.&escape($inst_xlist).':'.
+ &escape($coowner),$homeserver);
+ }
+ return $response;
+}
+
sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);
@@ -9316,6 +9724,38 @@ sub auto_validate_class_sec {
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 {
my ($cdom,$cnum,$owners,$classesref) = @_;
my ($homeserver,%validations);
@@ -9860,11 +10300,23 @@ sub autoupdate_coowners {
if ($domdesign{$cdom.'.autoassign.co-owners'}) {
my %coursehash = &coursedescription($cdom.'_'.$cnum);
my $instcode = $coursehash{'internal.coursecode'};
+ my $xlists = $coursehash{'internal.crosslistings'};
if ($instcode ne '') {
if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+ unless ($result eq 'valid') {
+ if ($xlists ne '') {
+ foreach my $xlist (split(',',$xlists)) {
+ my ($inst_crosslist,$lcsec) = split(':',$xlist);
+ $result =
+ &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
+ $inst_crosslist,$uname.':'.$udom);
+ last if ($result eq 'valid');
+ }
+ }
+ }
if ($result eq 'valid') {
if ($coursehash{'internal.co-owners'}) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
@@ -9877,18 +10329,16 @@ sub autoupdate_coowners {
} else {
push(@newcoowners,$uname.':'.$udom);
}
- } else {
- if ($coursehash{'internal.co-owners'}) {
- foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
- unless ($coowner eq $uname.':'.$udom) {
- push(@newcoowners,$coowner);
- }
- }
- unless (@newcoowners > 0) {
- $delcoowners = 1;
- $coowners = '';
+ } elsif ($coursehash{'internal.co-owners'}) {
+ foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+ unless ($coowner eq $uname.':'.$udom) {
+ push(@newcoowners,$coowner);
}
}
+ unless (@newcoowners > 0) {
+ $delcoowners = 1;
+ $coowners = '';
+ }
}
if (@newcoowners || $delcoowners) {
&store_coowners($cdom,$cnum,$coursehash{'home'},
@@ -10294,14 +10744,19 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype,$cnum,$context,$category)=@_;
+ $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
$url=&declutter($url);
my $cid='';
if ($context eq 'requestcourses') {
my $can_create = 0;
my ($ownername,$ownerdom) = split(':',$course_owner);
if ($udom eq $ownerdom) {
- if (&usertools_access($ownername,$ownerdom,$category,undef,
+ my $reload;
+ if (($callercontext eq 'auto') &&
+ ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
+ $reload = 'reload';
+ }
+ if (&usertools_access($ownername,$ownerdom,$category,$reload,
$context)) {
$can_create = 1;
}
@@ -11336,30 +11791,199 @@ sub resdata {
return undef;
}
-sub get_numsuppfiles {
- my ($cnum,$cdom,$ignorecache)=@_;
+sub get_domain_lti {
+ my ($cdom,$context) = @_;
+ my ($name,$cachename,%lti);
+ if ($context eq 'consumer') {
+ $name = 'ltitools';
+ } elsif ($context eq 'provider') {
+ $name = 'lti';
+ } elsif ($context eq 'linkprot') {
+ $name = 'ltisec';
+ } else {
+ return %lti;
+ }
+
+ if ($context eq 'linkprot') {
+ $cachename = $context;
+ } else {
+ $cachename = $name;
+ }
+
+ my ($result,$cached)=&is_cached_new($cachename,$cdom);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ %lti = %{$result};
+ }
+ } else {
+ my %domconfig = &get_dom('configuration',[$name],$cdom);
+ if (ref($domconfig{$name}) eq 'HASH') {
+ if ($context eq 'linkprot') {
+ if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
+ %lti = %{$domconfig{$name}{'linkprot'}};
+ }
+ } else {
+ %lti = %{$domconfig{$name}};
+ }
+ 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;
+ &do_cache_new($cachename,$cdom,\%lti,$cachetime);
+ }
+ 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 count_supptools {
+ my ($cnum,$cdom,$ignorecache,$reload)=@_;
my $hashid=$cnum.':'.$cdom;
- my ($suppcount,$cached);
+ my ($numexttools,$cached);
unless ($ignorecache) {
- ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
+ ($numexttools,$cached) = &is_cached_new('supptools',$hashid);
}
unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);
+ $numexttools = 0;
unless ($chome eq 'no_host') {
- ($suppcount,my $errors) = (0,0);
- my $suppmap = 'supplemental.sequence';
- ($suppcount,$errors) =
- &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
+ my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
+ if (ref($supplemental) eq 'HASH') {
+ if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
+ foreach my $key (keys(%{$supplemental->{'ids'}})) {
+ if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+ $numexttools ++;
+ }
+ }
+ }
+ }
}
- &do_cache_new('suppcount',$hashid,$suppcount,600);
+ &do_cache_new('supptools',$hashid,$numexttools,600);
}
- return $suppcount;
+ return $numexttools;
+}
+
+sub has_unhidden_suppfiles {
+ my ($cnum,$cdom,$ignorecache,$possdel)=@_;
+ my $hashid=$cnum.':'.$cdom;
+ my ($showsupp,$cached);
+ unless ($ignorecache) {
+ ($showsupp,$cached) = &is_cached_new('showsupp',$hashid);
+ }
+ unless (defined($cached)) {
+ my $chome=&homeserver($cnum,$cdom);
+ unless ($chome eq 'no_host') {
+ my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);
+ if (ref($supplemental) eq 'HASH') {
+ if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
+ foreach my $key (keys(%{$supplemental->{'ids'}})) {
+ next if ($key =~ /\.sequence$/);
+ if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {
+ foreach my $id (@{$supplemental->{'ids'}->{$key}}) {
+ unless ($supplemental->{'hidden'}->{$id}) {
+ $showsupp = 1;
+ last;
+ }
+ }
+ }
+ last if ($showsupp);
+ }
+ }
+ }
+ }
+ &do_cache_new('showsupp',$hashid,$showsupp,600);
+ }
+ return $showsupp;
}
#
# EXT resource caching routines
#
+{
+# Cache (5 seconds) of map hierarchy for speedup of navmaps display
+#
+# The course for which we cache
+my $cachedmapkey='';
+# The cached recursive maps for this course
+my %cachedmaps=();
+# When this was last done
+my $cachedmaptime='';
+
sub clear_EXT_cache_status {
&delenv('cache.EXT.');
}
@@ -11416,7 +12040,7 @@ sub EXT {
if ( (defined($Apache::lonhomework::parsing_a_problem)
|| defined($Apache::lonhomework::parsing_a_task))
&&
- ($symbparm eq &symbread()) ) {
+ ($symbparm eq &symbread()) ) {
# if we are in the middle of processing the resource the
# get the value we are planning on committing
if (defined($Apache::lonhomework::results{$qualifierrest})) {
@@ -11673,6 +12297,10 @@ sub EXT {
if ($space eq 'name') {
return $ENV{'SERVER_NAME'};
}
+ } elsif ($realm eq 'client') {
+ if ($space eq 'remote_addr') {
+ return &get_requestor_ip();
+ }
}
return '';
}
@@ -11706,6 +12334,30 @@ sub check_group_parms {
return $coursereply;
}
+sub get_map_hierarchy {
+ my ($mapname,$courseid) = @_;
+ my @recurseup = ();
+ if ($mapname) {
+ if (($cachedmapkey eq $courseid) &&
+ (abs($cachedmaptime-time)<5)) {
+ if (ref($cachedmaps{$mapname}) eq 'ARRAY') {
+ return @{$cachedmaps{$mapname}};
+ }
+ }
+ my $navmap = Apache::lonnavmaps::navmap->new();
+ if (ref($navmap)) {
+ @recurseup = $navmap->recurseup_maps($mapname);
+ undef($navmap);
+ $cachedmaps{$mapname} = \@recurseup;
+ $cachedmaptime=time;
+ $cachedmapkey=$courseid;
+ }
+ }
+ return @recurseup;
+}
+
+}
+
sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
my ($courseid,@groups) = @_;
@groups = sort(@groups);
@@ -11791,7 +12443,7 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
- ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
+ ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
@@ -12327,11 +12979,68 @@ sub get_coursechange {
}
sub devalidate_coursechange_cache {
- my ($cnum,$cdom)=@_;
- my $hashid=$cnum.':'.$cdom;
+ my ($cdom,$cnum)=@_;
+ my $hashid=$cdom.'_'.$cnum;
&devalidate_cache_new('crschange',$hashid);
}
+sub get_suppchange {
+ my ($cdom,$cnum) = @_;
+ if ($cdom eq '' || $cnum eq '') {
+ return unless ($env{'request.course.id'});
+ $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
+ my $hashid=$cdom.'_'.$cnum;
+ my ($change,$cached)=&is_cached_new('suppchange',$hashid);
+ if ((defined($cached)) && ($change ne '')) {
+ return $change;
+ } else {
+ my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);
+ if ($crshash{'internal.supplementalchange'} eq '') {
+ $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
+ if ($change eq '') {
+ %crshash = &get('environment',['internal.created'],$cdom,$cnum);
+ $change = $crshash{'internal.created'};
+ }
+ } else {
+ $change = $crshash{'internal.supplementalchange'};
+ }
+ my $cachetime = 600;
+ &do_cache_new('suppchange',$hashid,$change,$cachetime);
+ }
+ return $change;
+}
+
+sub devalidate_suppchange_cache {
+ my ($cdom,$cnum)=@_;
+ my $hashid=$cdom.'_'.$cnum;
+ &devalidate_cache_new('suppchange',$hashid);
+}
+
+sub update_supp_caches {
+ my ($cdom,$cnum) = @_;
+ my %servers = &internet_dom_servers($cdom);
+ my @ids=¤t_machine_ids();
+ foreach my $server (keys(%servers)) {
+ next if (grep(/^\Q$server\E$/,@ids));
+ my $hashid=$cnum.':'.$cdom;
+ my $cachekey = &escape('showsupp').':'.&escape($hashid);
+ &remote_devalidate_cache($server,[$cachekey]);
+ }
+ &has_unhidden_suppfiles($cnum,$cdom,1,1);
+ &count_supptools($cnum,$cdom,1);
+ my $now = time;
+ if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
+ &Apache::lonnet::appenv({'request.course.suppupdated' => $now});
+ }
+ &put('environment',{'internal.supplementalchange' => $now},
+ $cdom,$cnum);
+ &Apache::lonnet::appenv(
+ {'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});
+ &do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);
+}
+
# ------------------------------------------------- Update symbolic store links
sub symblist {
@@ -12518,17 +13227,10 @@ sub symbread {
my %bighash;
my $syval='';
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) {
if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
&GDBM_READER(),0640)) {
- $syval=$hash{$targetfn};
+ $syval=$hash{$thisfn};
untie(%hash);
}
if ($syval && $checkforblock) {
@@ -13337,10 +14039,15 @@ sub machine_ids {
sub additional_machine_domains {
my @domains;
- open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");
- while( my $line = <$fh>) {
- $line =~ s/\s//g;
- push(@domains,$line);
+ if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
+ if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
+ while( my $line = <$fh>) {
+ chomp($line);
+ $line =~ s/\s//g;
+ push(@domains,$line);
+ }
+ close($fh);
+ }
}
return @domains;
}
@@ -13421,17 +14128,230 @@ sub uses_sts {
return;
}
+sub waf_allssl {
+ my ($host_name) = @_;
+ my $alias = &get_proxy_alias();
+ if ($host_name eq '') {
+ $host_name = $ENV{'SERVER_NAME'};
+ }
+ if (($host_name ne '') && ($alias eq $host_name)) {
+ my $serverhomedom = &host_domain($perlvar{'lonHostID'});
+ my %defdomdefaults = &get_domain_defaults($serverhomedom);
+ if ($defdomdefaults{'waf_sslopt'}) {
+ return $defdomdefaults{'waf_sslopt'};
+ }
+ }
+ return;
+}
+
sub get_requestor_ip {
my ($r,$nolookup,$noproxy) = @_;
my $from_ip;
if (ref($r)) {
- $from_ip = $r->get_remote_host($nolookup);
+ if ($r->can('useragent_ip')) {
+ if ($noproxy && $r->can('client_ip')) {
+ $from_ip = $r->client_ip();
+ } else {
+ $from_ip = $r->useragent_ip();
+ }
+ } elsif ($r->connection->can('remote_ip')) {
+ $from_ip = $r->connection->remote_ip();
+ } else {
+ $from_ip = $r->get_remote_host($nolookup);
+ }
} else {
$from_ip = $ENV{'REMOTE_ADDR'};
}
+ return $from_ip if ($noproxy);
+ # Who controls proxy settings for server
+ my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
+ my $proxyinfo = &get_proxy_settings($dom_in_use);
+ if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
+ if ($proxyinfo->{'vpnint'}) {
+ if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
+ return $from_ip;
+ }
+ }
+ if ($proxyinfo->{'trusted'}) {
+ if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
+ my $ipheader = $proxyinfo->{'ipheader'};
+ my ($ip,$xfor);
+ if (ref($r)) {
+ if ($ipheader) {
+ $ip = $r->headers_in->{$ipheader};
+ }
+ $xfor = $r->headers_in->{'X-Forwarded-For'};
+ } else {
+ if ($ipheader) {
+ $ip = $ENV{'HTTP_'.uc($ipheader)};
+ }
+ $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
+ }
+ if (($ip eq '') && ($xfor ne '')) {
+ foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
+ unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
+ $ip = $poss_ip;
+ last;
+ }
+ }
+ }
+ if ($ip ne '') {
+ return $ip;
+ }
+ }
+ }
+ }
return $from_ip;
}
+sub get_proxy_settings {
+ my ($dom_in_use) = @_;
+ my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
+ my $proxyinfo = {
+ ipheader => $domdefaults{'waf_ipheader'},
+ trusted => $domdefaults{'waf_trusted'},
+ vpnint => $domdefaults{'waf_vpnint'},
+ vpnext => $domdefaults{'waf_vpnext'},
+ sslopt => $domdefaults{'waf_sslopt'},
+ };
+ return $proxyinfo;
+}
+
+sub ip_match {
+ my ($ip,$pattern_str) = @_;
+ $ip=Net::CIDR::cidrvalidate($ip);
+ if ($ip) {
+ return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
+ }
+ return;
+}
+
+sub get_proxy_alias {
+ my ($lonid) = @_;
+ if ($lonid eq '') {
+ $lonid = $perlvar{'lonHostID'};
+ }
+ if (!defined(&hostname($lonid))) {
+ return;
+ }
+ if ($lonid ne '') {
+ my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
+ if ($cached) {
+ return $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'}{'alias'}) eq 'HASH') {
+ $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
+ }
+ }
+ return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
+ }
+ }
+ 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 = ¤t_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
sub declutter {
@@ -13482,6 +14402,8 @@ sub clutter {
# &logthis("Got a blank emb style");
}
}
+ } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
+ $thisfn='/adm/wrapper'.$thisfn;
}
return $thisfn;
}
@@ -13569,13 +14491,25 @@ sub get_dns {
}
while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);
- my $ua=new LWP::UserAgent;
- $ua->timeout(30);
- my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
- my $response=$ua->request($request);
- delete($alldns{$dns});
- next if ($response->is_error());
- my @content = split("\n",$response->content);
+ my @content;
+ if ($dns eq Sys::Hostname::FQDN::fqdn()) {
+ my $command = (split('/',$url))[3];
+ 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);
+ }
+ } else {
+ my $ua=new LWP::UserAgent;
+ $ua->timeout(30);
+ my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
+ my $response=$ua->request($request);
+ delete($alldns{$dns});
+ next if ($response->is_error());
+ @content = split("\n",$response->content);
+ }
unless ($nocache) {
&do_cache_new('dns',$url,\@content,30*24*60*60);
}
@@ -13647,6 +14581,21 @@ sub fetch_dns_checksums {
return \%checksums;
}
+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",
+ }
+ return ($dir,$file);
+}
+
# ------------------------------------------------------------ Read domain file
{
my $loaded;
@@ -14526,6 +15475,7 @@ prevents recursive calls to &allowed.
2: browse allowed
A: passphrase authentication needed
B: access temporarily blocked because of a blocking event in a course.
+ D: access blocked because access is required via session initiated via deep-link
=item *
@@ -14818,10 +15768,6 @@ data base, returning a hash that is keye
values that are the resource value. I believe that the timestamps and
versions are also returned.
-get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
-supplemental content area. This routine caches the number of files for
-10 minutes.
-
=back
=head2 Course Modification