version 1.1453, 2021/05/10 18:13:50
|
version 1.1461, 2021/07/19 15:48:27
|
Line 97 use Digest::MD5;
|
Line 97 use Digest::MD5;
|
use Math::Random; |
use Math::Random; |
use File::MMagic; |
use File::MMagic; |
use Net::CIDR; |
use Net::CIDR; |
|
use Sys::Hostname::FQDN(); |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA qw(:DEFAULT :match); |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
use LONCAPA::lonmetadata; |
use LONCAPA::lonmetadata; |
Line 8116 sub customaccess {
|
Line 8117 sub customaccess {
|
# ------------------------------------------------- Check for a user privilege |
# ------------------------------------------------- Check for a user privilege |
|
|
sub allowed { |
sub allowed { |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_; |
my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_; |
my $ver_orguri=$uri; |
my $ver_orguri=$uri; |
$uri=&deversion($uri); |
$uri=&deversion($uri); |
my $orguri=$uri; |
my $orguri=$uri; |
Line 8341 sub allowed {
|
Line 8342 sub allowed {
|
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
if ($env{'user.priv.'.$env{'request.role'}.'./'} |
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
my $value = $1; |
my $value = $1; |
my $deeplinkblock = &deeplink_check($priv,$symb,$uri); |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$uri); |
|
} |
if ($deeplinkblock) { |
if ($deeplinkblock) { |
$thisallowed='D'; |
$thisallowed='D'; |
} elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
Line 8364 sub allowed {
|
Line 8368 sub allowed {
|
$refuri=&declutter($refuri); |
$refuri=&declutter($refuri); |
my ($match) = &is_on_map($refuri); |
my ($match) = &is_on_map($refuri); |
if ($match) { |
if ($match) { |
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
|
} |
if ($deeplinkblock) { |
if ($deeplinkblock) { |
$thisallowed='D'; |
$thisallowed='D'; |
} elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
Line 8440 sub allowed {
|
Line 8447 sub allowed {
|
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
my $value = $1; |
my $value = $1; |
if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
if ($noblockcheck) { |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$uri); |
|
} |
|
if ($deeplinkblock) { |
|
$thisallowed = 'D'; |
|
} elsif ($noblockcheck) { |
$thisallowed.=$value; |
$thisallowed.=$value; |
} else { |
} else { |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache); |
Line 8482 sub allowed {
|
Line 8495 sub allowed {
|
=~/\Q$priv\E\&([^\:]*)/) { |
=~/\Q$priv\E\&([^\:]*)/) { |
my $value = $1; |
my $value = $1; |
if ($priv eq 'bre') { |
if ($priv eq 'bre') { |
my $deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
my $deeplinkblock; |
|
unless ($nodeeplinkcheck) { |
|
$deeplinkblock = &deeplink_check($priv,$symb,$refuri); |
|
} |
if ($deeplinkblock) { |
if ($deeplinkblock) { |
$thisallowed = 'D'; |
$thisallowed = 'D'; |
} elsif ($noblockcheck) { |
} elsif ($noblockcheck) { |
Line 8530 sub allowed {
|
Line 8546 sub allowed {
|
# |
# |
|
|
# Possibly locked functionality, check all courses |
# Possibly locked functionality, check all courses |
|
# In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma. |
# Locks might take effect only after 10 minutes cache expiration for other |
# Locks might take effect only after 10 minutes cache expiration for other |
# courses, and 2 minutes for current course |
# courses, and 2 minutes for current course, in which user has st or ta role |
|
# which is neither expired nor a future role (unless current course). |
|
|
|
my ($needlockcheck,$now,$crsonly); |
if ($thisallowed=~/L/) { |
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)) { |
foreach my $envkey (keys(%env)) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
my $courseid=$2; |
my $courseid=$2; |
Line 8566 sub allowed {
|
Line 8610 sub allowed {
|
} |
} |
if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) |
if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) |
|| ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { |
|| ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { |
if ($env{'priv.'.$priv.'.lock.expire'}>time) { |
if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) { |
&log($env{'user.domain'},$env{'user.name'}, |
&log($env{'user.domain'},$env{'user.name'}, |
$env{'user.home'}, |
$env{'user.home'}, |
'Locked by priv: '.$priv.' for '.$uri.' due to '. |
'Locked by priv: '.$priv.' for '.$uri.' due to '. |
Line 8637 sub allowed {
|
Line 8681 sub allowed {
|
} |
} |
} |
} |
|
|
|
# Restricted for deeplinked session? |
|
|
|
if ($env{'request.deeplink.login'}) { |
|
if ($env{'acc.deeplinkout'} && !$nodeeplinkout) { |
|
if (!$symb) { $symb=&symbread($uri,1); } |
|
if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) { |
|
return ''; |
|
} |
|
} |
|
} |
|
|
# Restricted by state or randomout? |
# Restricted by state or randomout? |
|
|
if ($thisallowed=~/X/) { |
if ($thisallowed=~/X/) { |
Line 8994 sub deeplink_check {
|
Line 9049 sub deeplink_check {
|
@symbs = keys(%possibles); |
@symbs = keys(%possibles); |
} |
} |
|
|
my ($login,$switchrole,$allow); |
my ($deeplink_symb,$allow); |
if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) { |
if ($env{'request.deeplink.login'}) { |
my $key = $1; |
$deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom); |
my $tinyurl; |
|
my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key); |
|
if (defined($cached)) { |
|
$tinyurl = $result; |
|
} else { |
|
my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); |
|
my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname); |
|
if ($currtiny{$key} ne '') { |
|
$tinyurl = $currtiny{$key}; |
|
&Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600); |
|
} |
|
} |
|
if ($tinyurl ne '') { |
|
my ($cnumreq,$posslogin) = split(/\&/,$tinyurl); |
|
if ($cnumreq eq $cnum) { |
|
$login = $posslogin; |
|
} else { |
|
$switchrole = 1; |
|
} |
|
} |
|
} |
} |
foreach my $symb (@symbs) { |
foreach my $symb (@symbs) { |
last if ($allow); |
last if ($allow); |
Line 9027 sub deeplink_check {
|
Line 9062 sub deeplink_check {
|
my ($listed,$scope,$access) = split(/,/,$deeplink); |
my ($listed,$scope,$access) = split(/,/,$deeplink); |
if ($access eq 'any') { |
if ($access eq 'any') { |
$allow = 1; |
$allow = 1; |
} elsif ($login) { |
} elsif ($deeplink_symb) { |
if ($access eq 'only') { |
if ($access eq 'only') { |
if ($scope eq 'res') { |
if ($scope eq 'res') { |
if ($symb eq $login) { |
if ($symb eq $deeplink_symb) { |
$allow = 1; |
$allow = 1; |
} |
} |
} elsif ($scope eq 'map') { |
} elsif (($scope eq 'map') || ($scope eq 'rec')) { |
#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb |
my ($map_from_symb,$map_from_login); |
} elsif ($scope eq 'rec') { |
$map_from_symb = &deversion((&decode_symb($symb))[0]); |
#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb |
if ($deeplink_symb =~ /\.(page|sequence)$/) { |
|
$map_from_login = &deversion((&decode_symb($deeplink_symb))[2]); |
|
} else { |
|
$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; |
|
} |
|
} |
|
} |
} |
} |
} else { |
} else { |
my ($acctype,$item) = split(/:/,$access); |
my ($acctype,$item) = split(/:/,$access); |
Line 9747 sub auto_validate_class_sec {
|
Line 9796 sub auto_validate_class_sec {
|
return $response; |
return $response; |
} |
} |
|
|
|
sub auto_instsec_reformat { |
|
my ($cdom,$action,$instsecref) = @_; |
|
return unless(($action eq 'clutter') || ($action eq 'declutter')); |
|
my @homeservers; |
|
if (defined(&domain($cdom,'primary'))) { |
|
push(@homeservers,&domain($cdom,'primary')); |
|
} else { |
|
my %servers = &get_servers($cdom,'library'); |
|
foreach my $tryserver (keys(%servers)) { |
|
if (!grep(/^\Q$tryserver\E$/,@homeservers)) { |
|
push(@homeservers,$tryserver); |
|
} |
|
} |
|
} |
|
my $response; |
|
my %reformatted = %{$instsecref}; |
|
foreach my $server (@homeservers) { |
|
if (ref($instsecref) eq 'HASH') { |
|
my $info = &freeze_escape($instsecref); |
|
my $response=&reply('autoinstsecreformat:'.$cdom.':'. |
|
$action.':'.$info,$server); |
|
next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/); |
|
my @items = split(/&/,$response); |
|
foreach my $item (@items) { |
|
my ($key,$value) = split(/=/,$item); |
|
$reformatted{&unescape($key)} = &thaw_unescape($value); |
|
} |
|
} |
|
} |
|
return %reformatted; |
|
} |
|
|
sub auto_validate_instclasses { |
sub auto_validate_instclasses { |
my ($cdom,$cnum,$owners,$classesref) = @_; |
my ($cdom,$cnum,$owners,$classesref) = @_; |
my ($homeserver,%validations); |
my ($homeserver,%validations); |
Line 12187 sub EXT_cache_set {
|
Line 12268 sub EXT_cache_set {
|
# --------------------------------------------------------- Value of a Variable |
# --------------------------------------------------------- Value of a Variable |
sub EXT { |
sub EXT { |
|
|
my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; |
my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_; |
unless ($varname) { return ''; } |
unless ($varname) { return ''; } |
#get real user name/domain, courseid and symb |
#get real user name/domain, courseid and symb |
my $courseid; |
my $courseid; |
Line 12341 sub EXT {
|
Line 12422 sub EXT {
|
} |
} |
|
|
my ($section, $group, @groups, @recurseup, $recursed); |
my ($section, $group, @groups, @recurseup, $recursed); |
|
if (ref($recurseupref) eq 'ARRAY') { |
|
@recurseup = @{$recurseupref}; |
|
$recursed = 1; |
|
} |
my ($courselevelm,$courseleveli,$courselevel,$mapp); |
my ($courselevelm,$courseleveli,$courselevel,$mapp); |
if (($courseid eq '') && ($cid)) { |
if (($courseid eq '') && ($cid)) { |
$courseid = $cid; |
$courseid = $cid; |
Line 14651 sub get_dns {
|
Line 14736 sub get_dns {
|
} |
} |
while (%alldns) { |
while (%alldns) { |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my ($contents,@content); |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); |
if ($dns eq Sys::Hostname::FQDN::fqdn()) { |
delete($alldns{$dns}); |
my $command = (split('/',$url))[3]; |
next if ($response->is_error()); |
my ($dir,$file) = &parse_getdns_url($command,$url); |
|
delete($alldns{$dns}); |
|
next if (($dir eq '') || ($file eq '')); |
|
if (open(my $config,'<',"$dir/$file")) { |
|
@content = <$config>; |
|
close($config); |
|
} |
|
if ($url eq '/adm/dns/loncapaCRL') { |
|
$contents = join('',@content); |
|
} |
|
} else { |
|
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
|
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); |
|
delete($alldns{$dns}); |
|
next if ($response->is_error()); |
|
if ($url eq '/adm/dns/loncapaCRL') { |
|
$contents = $response->content; |
|
} else { |
|
@content = split("\n",$response->content); |
|
} |
|
} |
if ($url eq '/adm/dns/loncapaCRL') { |
if ($url eq '/adm/dns/loncapaCRL') { |
return &$func($response); |
return &$func($contents); |
} else { |
} else { |
my @content = split("\n",$response->content); |
|
unless ($nocache) { |
unless ($nocache) { |
&do_cache_new('dns',$url,\@content,30*24*60*60); |
&do_cache_new('dns',$url,\@content,30*24*60*60); |
} |
} |
Line 14746 sub fetch_crl_pemfile {
|
Line 14850 sub fetch_crl_pemfile {
|
} |
} |
|
|
sub save_crl_pem { |
sub save_crl_pem { |
my ($response) = @_; |
my ($content) = @_; |
my ($msg,$hadchanges); |
my ($msg,$hadchanges); |
if (ref($response)) { |
if ($content ne '') { |
my $now = time; |
my $now = time; |
my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'}; |
my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'}; |
my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp'; |
my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp'; |
if (open(my $fh,'>',"$tmpcrl")) { |
if (open(my $fh,'>',"$tmpcrl")) { |
print $fh $response->content; |
print $fh $content; |
close($fh); |
close($fh); |
if (-e $lonca) { |
if (-e $lonca) { |
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) { |
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) { |
Line 14814 sub save_crl_pem {
|
Line 14918 sub save_crl_pem {
|
return ($msg,$hadchanges); |
return ($msg,$hadchanges); |
} |
} |
|
|
|
sub parse_getdns_url { |
|
my ($command,$url) = @_; |
|
my $dir = $perlvar{'lonTabDir'}; |
|
my $file; |
|
if ($command eq 'hosts') { |
|
$file = 'dns_hosts.tab'; |
|
} elsif ($command eq 'domain') { |
|
$file = 'dns_domain.tab'; |
|
} elsif ($command eq 'checksums') { |
|
my $version = (split('/',$url))[4]; |
|
$file = "dns_checksums/$version.tab", |
|
} elsif ($command eq 'loncapaCRL') { |
|
$dir = $perlvar{'lonCertificateDirectory'}; |
|
$file = $perlvar{'lonnetCertRevocationList'}; |
|
} |
|
return ($dir,$file); |
|
} |
|
|
# ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
{ |
{ |
my $loaded; |
my $loaded; |