--- loncom/lonnet/perl/lonnet.pm 2021/02/08 14:10:17 1.1441
+++ loncom/lonnet/perl/lonnet.pm 2021/09/22 13:52:02 1.1466
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1441 2021/02/08 14:10:17 raeburn Exp $
+# $Id: lonnet.pm,v 1.1466 2021/09/22 13:52:02 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));
@@ -740,6 +742,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'};
+ }
$userhashref->{'lti'} = $disk_env{'request.lti.login'};
if ($userhashref->{'lti'}) {
$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
@@ -973,7 +978,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
@@ -1018,6 +1023,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;
}
}
@@ -2140,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) {
@@ -2164,10 +2171,15 @@ sub get_dom {
}
if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep;
- if ($namespace =~ /^enc/) {
- $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
+ if (grep { $_ eq $uhome } ¤t_machine_ids()) {
+ # domain information is hosted on this machine
+ $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
} else {
- $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ 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 /) {
@@ -2191,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'))) {
@@ -2212,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);
@@ -2769,7 +2781,7 @@ sub get_domain_defaults {
}
}
if (ref($domconfig{'wafproxy'}) eq 'HASH') {
- foreach my $item ('ipheader','trusted','vpnint','vpnext') {
+ foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
if ($domconfig{'wafproxy'}{$item}) {
$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
}
@@ -2839,7 +2851,7 @@ sub retrieve_instcodes {
}
sub course_portal_url {
- my ($cnum,$cdom) = @_;
+ my ($cnum,$cdom,$r) = @_;
my $chome = &homeserver($cnum,$cdom);
my $hostname = &hostname($chome);
my $protocol = $protocol{$chome};
@@ -2849,6 +2861,8 @@ sub course_portal_url {
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;
@@ -3473,11 +3487,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;
}
@@ -3494,12 +3526,13 @@ sub absolute_url {
sub ssi {
my ($fn,%form)=@_;
- my $request;
+ 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'
@@ -3507,7 +3540,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'});
@@ -3521,8 +3554,8 @@ sub ssi {
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
$islocal = 1;
}
- my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
- '','','',$islocal);
+ $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
+ '','','',$islocal);
if (wantarray) {
return ($response->content, $response);
@@ -4065,6 +4098,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;
}
@@ -7077,7 +7114,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);
@@ -7093,7 +7130,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/ )) {
@@ -7240,7 +7282,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);
@@ -7249,7 +7291,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
@@ -8077,7 +8123,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;
@@ -8203,8 +8249,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;
}
@@ -8216,8 +8262,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;
}
@@ -8302,7 +8348,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) {
@@ -8325,7 +8374,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) {
@@ -8401,7 +8453,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);
@@ -8443,7 +8501,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) {
@@ -8491,16 +8552,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;
@@ -8523,7 +8616,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 '.
@@ -8594,6 +8687,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/) {
@@ -8951,29 +9055,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);
@@ -8981,34 +9065,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;
+ }
}
}
}
@@ -9414,6 +9512,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);
@@ -9685,6 +9802,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);
@@ -10235,11 +10384,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'})) {
@@ -10252,18 +10413,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'},
@@ -12039,7 +12198,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') {
@@ -12056,6 +12215,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;
@@ -12115,7 +12291,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;
@@ -12269,6 +12445,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;
@@ -14207,10 +14387,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;
}
@@ -14290,11 +14475,37 @@ 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'};
}
@@ -14348,6 +14559,7 @@ sub get_proxy_settings {
trusted => $domdefaults{'waf_trusted'},
vpnint => $domdefaults{'waf_vpnint'},
vpnext => $domdefaults{'waf_vpnext'},
+ sslopt => $domdefaults{'waf_sslopt'},
};
return $proxyinfo;
}
@@ -14362,29 +14574,102 @@ sub ip_match {
}
sub get_proxy_alias {
- my $lonhost = $perlvar{'lonHostID'};
- if ($lonhost ne '') {
- my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost);
+ 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($lonhost);
+ my $dom = &Apache::lonnet::host_domain($lonid);
if ($dom ne '') {
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'}{$lonhost};
+ $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
}
}
- return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime);
+ 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 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 {
@@ -14524,14 +14809,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);
}
@@ -14619,14 +14923,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 |")) {
@@ -14687,6 +14991,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;