--- loncom/lonnet/perl/lonnet.pm 2021/05/10 18:13:50 1.1453
+++ loncom/lonnet/perl/lonnet.pm 2021/11/30 15:55:40 1.1473
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1453 2021/05/10 18:13:50 raeburn Exp $
+# $Id: lonnet.pm,v 1.1473 2021/11/30 15:55:40 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -97,6 +97,7 @@ 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;
@@ -467,14 +468,15 @@ sub reply {
my $subcmd = $1;
if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
($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);
if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
splice(@rest,2,1,'Hidden');
} elsif ($subcmd eq 'passwd') {
splice(@rest,2,2,('Hidden','Hidden'));
} elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
- ($subcmd eq 'autoexportgrades')) {
+ ($subcmd eq 'autoexportgrades') || ($subcmd eq 'put')) {
splice(@rest,3,1,'Hidden');
}
$logged = join(':',('encrypt:'.$subcmd,@rest));
@@ -2145,7 +2147,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) {
@@ -2171,13 +2173,9 @@ sub get_dom {
my $rep;
if (grep { $_ eq $uhome } ¤t_machine_ids()) {
# domain information is hosted on this machine
- my $cmd = 'getdom';
- if ($namespace =~ /^enc/) {
- $cmd = 'egetdom';
- }
- $rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items");
+ $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
} else {
- if ($namespace =~ /^enc/) {
+ if ($encrypt) {
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
} else {
$rep=&reply("getdom:$udom:$namespace:$items",$uhome);
@@ -2205,7 +2203,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'))) {
@@ -2226,7 +2224,7 @@ sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
- if ($namespace =~ /^enc/) {
+ if ($encrypt) {
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
} else {
return &reply("putdom:$udom:$namespace:$items",$uhome);
@@ -2306,7 +2304,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';
}
@@ -4965,6 +4963,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'};
}
@@ -7116,7 +7137,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);
@@ -7132,7 +7153,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/ )) {
@@ -7279,7 +7305,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);
@@ -7288,7 +7314,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
@@ -7553,15 +7583,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,$blockdom) =
+ &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
+ if (($startblock && $endblock) || ($by_ip)) {
return 'B';
}
}
@@ -8116,7 +8146,7 @@ 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;
@@ -8144,9 +8174,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';
@@ -8341,7 +8371,10 @@ sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
- my $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+ }
if ($deeplinkblock) {
$thisallowed='D';
} elsif ($noblockcheck) {
@@ -8364,7 +8397,10 @@ sub allowed {
$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);
if ($match) {
- my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ }
if ($deeplinkblock) {
$thisallowed='D';
} elsif ($noblockcheck) {
@@ -8440,7 +8476,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);
@@ -8482,7 +8524,10 @@ sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
if ($priv eq 'bre') {
- my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ my $deeplinkblock;
+ unless ($nodeeplinkcheck) {
+ $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ }
if ($deeplinkblock) {
$thisallowed = 'D';
} elsif ($noblockcheck) {
@@ -8530,11 +8575,39 @@ 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 ($needlockcheck,$now,$crsonly);
if ($thisallowed=~/L/) {
- my $now = time;
+ $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;
@@ -8566,7 +8639,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 '.
@@ -8637,6 +8710,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/) {
@@ -8794,7 +8878,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};
@@ -8826,10 +8914,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';
@@ -8838,36 +8925,11 @@ 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');
}
}
}
@@ -8885,10 +8947,37 @@ sub get_commblock_resources {
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) {
@@ -8918,8 +9007,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);
@@ -8994,29 +9087,9 @@ sub deeplink_check {
@symbs = keys(%possibles);
}
- my ($login,$switchrole,$allow);
- if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {
- my $key = $1;
- 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;
- }
- }
+ 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);
@@ -9024,34 +9097,48 @@ sub deeplink_check {
if ($deeplink eq '') {
$allow = 1;
} else {
- my ($listed,$scope,$access) = split(/,/,$deeplink);
- if ($access eq 'any') {
+ my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);
+ if ($state ne 'only') {
$allow = 1;
- } elsif ($login) {
- if ($access eq 'only') {
+ } 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 $login) {
+ if ($symb eq $deeplink_symb) {
$allow = 1;
}
- } elsif ($scope eq 'map') {
-#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb
- } elsif ($scope eq 'rec') {
-#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb
- }
- } else {
- my ($acctype,$item) = split(/:/,$access);
- 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 (($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]);
}
- } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
- if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
- my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
- if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) {
+ 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;
+ }
}
}
}
@@ -9324,7 +9411,7 @@ sub fetch_enrollment_query {
}
sub get_query_reply {
- my ($queryid,$sleep,$loopmax) = @_;;
+ my ($queryid,$sleep,$loopmax) = @_;
if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
$sleep = 0.2;
}
@@ -9747,6 +9834,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);
@@ -12111,7 +12230,7 @@ sub get_domain_lti {
my %domconfig = &get_dom('configuration',[$name],$cdom);
if (ref($domconfig{$name}) eq 'HASH') {
%lti = %{$domconfig{$name}};
- my %encdomconfig = &get_dom('encconfig',[$name],$cdom);
+ 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') {
@@ -12128,6 +12247,23 @@ sub get_domain_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 get_numsuppfiles {
my ($cnum,$cdom,$ignorecache)=@_;
my $hashid=$cnum.':'.$cdom;
@@ -12187,7 +12323,7 @@ sub EXT_cache_set {
# --------------------------------------------------------- Value of a Variable
sub EXT {
- my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
+ my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_;
unless ($varname) { return ''; }
#get real user name/domain, courseid and symb
my $courseid;
@@ -12219,7 +12355,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})) {
@@ -12341,6 +12477,10 @@ sub EXT {
}
my ($section, $group, @groups, @recurseup, $recursed);
+ if (ref($recurseupref) eq 'ARRAY') {
+ @recurseup = @{$recurseupref};
+ $recursed = 1;
+ }
my ($courselevelm,$courseleveli,$courselevel,$mapp);
if (($courseid eq '') && ($cid)) {
$courseid = $cid;
@@ -14279,10 +14419,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;
}
@@ -14478,7 +14623,6 @@ sub get_proxy_alias {
my $cachetime = 60*60*24;
my %domconfig =
&Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
- my $alias;
if (ref($domconfig{'wafproxy'}) eq 'HASH') {
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
$alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
@@ -14496,7 +14640,7 @@ sub use_proxy_alias {
if ($alias) {
my $dom = &host_domain($lonid);
if ($dom ne '') {
- my $proxyinfo = &get_proxy_settings($dom );
+ my $proxyinfo = &get_proxy_settings($dom);
my ($vpnint,$remote_ip);
if (ref($proxyinfo) eq 'HASH') {
$vpnint = $proxyinfo->{'vpnint'};
@@ -14512,6 +14656,81 @@ sub use_proxy_alias {
return;
}
+sub alias_shibboleth {
+ 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 {
@@ -14651,14 +14870,33 @@ sub get_dns {
}
while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);
- 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());
+ my ($contents,@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);
+ }
+ 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') {
- return &$func($response);
+ return &$func($contents);
} else {
- my @content = split("\n",$response->content);
unless ($nocache) {
&do_cache_new('dns',$url,\@content,30*24*60*60);
}
@@ -14746,14 +14984,14 @@ sub fetch_crl_pemfile {
}
sub save_crl_pem {
- my ($response) = @_;
+ my ($content) = @_;
my ($msg,$hadchanges);
- if (ref($response)) {
+ if ($content ne '') {
my $now = time;
my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
if (open(my $fh,'>',"$tmpcrl")) {
- print $fh $response->content;
+ print $fh $content;
close($fh);
if (-e $lonca) {
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
@@ -14814,6 +15052,24 @@ sub save_crl_pem {
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
{
my $loaded;