version 1.1445, 2021/04/09 00:57:31
|
version 1.1457, 2021/06/06 23:18:59
|
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 740 sub check_for_valid_session {
|
Line 741 sub check_for_valid_session {
|
if (ref($userhashref) eq 'HASH') { |
if (ref($userhashref) eq 'HASH') { |
$userhashref->{'name'} = $disk_env{'user.name'}; |
$userhashref->{'name'} = $disk_env{'user.name'}; |
$userhashref->{'domain'} = $disk_env{'user.domain'}; |
$userhashref->{'domain'} = $disk_env{'user.domain'}; |
|
if ($disk_env{'request.role'}) { |
|
$userhashref->{'role'} = $disk_env{'request.role'}; |
|
} |
$userhashref->{'lti'} = $disk_env{'request.lti.login'}; |
$userhashref->{'lti'} = $disk_env{'request.lti.login'}; |
if ($userhashref->{'lti'}) { |
if ($userhashref->{'lti'}) { |
$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; |
$userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; |
Line 973 sub userload {
|
Line 977 sub userload {
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; |
my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_; |
my $spare_server; |
my $spare_server; |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
Line 1018 sub spareserver {
|
Line 1022 sub spareserver {
|
if ($protocol{$spare_server} eq 'https') { |
if ($protocol{$spare_server} eq 'https') { |
$protocol = $protocol{$spare_server}; |
$protocol = $protocol{$spare_server}; |
} |
} |
|
my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server); |
|
$hostname = $alias if ($alias ne ''); |
$spare_server = $protocol.'://'.$hostname; |
$spare_server = $protocol.'://'.$hostname; |
} |
} |
} |
} |
Line 2778 sub get_domain_defaults {
|
Line 2784 sub get_domain_defaults {
|
} |
} |
} |
} |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
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}) { |
if ($domconfig{'wafproxy'}{$item}) { |
$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item}; |
$domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item}; |
} |
} |
Line 2848 sub retrieve_instcodes {
|
Line 2854 sub retrieve_instcodes {
|
} |
} |
|
|
sub course_portal_url { |
sub course_portal_url { |
my ($cnum,$cdom) = @_; |
my ($cnum,$cdom,$r) = @_; |
my $chome = &homeserver($cnum,$cdom); |
my $chome = &homeserver($cnum,$cdom); |
my $hostname = &hostname($chome); |
my $hostname = &hostname($chome); |
my $protocol = $protocol{$chome}; |
my $protocol = $protocol{$chome}; |
Line 2858 sub course_portal_url {
|
Line 2864 sub course_portal_url {
|
if ($domdefaults{'portal_def'}) { |
if ($domdefaults{'portal_def'}) { |
$firsturl = $domdefaults{'portal_def'}; |
$firsturl = $domdefaults{'portal_def'}; |
} else { |
} else { |
|
my $alias = &Apache::lonnet::use_proxy_alias($r,$chome); |
|
$hostname = $alias if ($alias ne ''); |
$firsturl = $protocol.'://'.$hostname; |
$firsturl = $protocol.'://'.$hostname; |
} |
} |
return $firsturl; |
return $firsturl; |
Line 3482 sub ssi_body {
|
Line 3490 sub ssi_body {
|
# --------------------------------------------------------- Server Side Include |
# --------------------------------------------------------- Server Side Include |
|
|
sub absolute_url { |
sub absolute_url { |
my ($host_name) = @_; |
my ($host_name,$unalias,$keep_proto) = @_; |
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); |
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); |
if ($host_name eq '') { |
if ($host_name eq '') { |
$host_name = $ENV{'SERVER_NAME'}; |
$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; |
return $protocol.$host_name; |
} |
} |
|
|
Line 3503 sub absolute_url {
|
Line 3529 sub absolute_url {
|
sub ssi { |
sub ssi { |
|
|
my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
my $request; |
my ($host,$request,$response); |
|
$host = &absolute_url('',1); |
|
|
$form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
&Apache::lonenc::check_encrypt(\$fn); |
&Apache::lonenc::check_encrypt(\$fn); |
if (%form) { |
if (%form) { |
$request=new HTTP::Request('POST',&absolute_url().$fn); |
$request=new HTTP::Request('POST',$host.$fn); |
$request->content(join('&',map { |
$request->content(join('&',map { |
my $name = escape($_); |
my $name = escape($_); |
"$name=" . ( ref($form{$_}) eq 'ARRAY' |
"$name=" . ( ref($form{$_}) eq 'ARRAY' |
Line 3516 sub ssi {
|
Line 3543 sub ssi {
|
: &escape($form{$_}) ); |
: &escape($form{$_}) ); |
} keys(%form))); |
} keys(%form))); |
} else { |
} else { |
$request=new HTTP::Request('GET',&absolute_url().$fn); |
$request=new HTTP::Request('GET',$host.$fn); |
} |
} |
|
|
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
Line 3530 sub ssi {
|
Line 3557 sub ssi {
|
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { |
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { |
$islocal = 1; |
$islocal = 1; |
} |
} |
my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, |
$response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, |
'','','',$islocal); |
'','','',$islocal); |
|
|
if (wantarray) { |
if (wantarray) { |
return ($response->content, $response); |
return ($response->content, $response); |
Line 8216 sub allowed {
|
Line 8243 sub allowed {
|
my $adom = $1; |
my $adom = $1; |
foreach my $key (keys(%env)) { |
foreach my $key (keys(%env)) { |
if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { |
if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { |
my ($start,$end) = split('.',$env{$key}); |
my ($start,$end) = split(/\./,$env{$key}); |
if (($now >= $start) && (!$end || $end < $now)) { |
if (($now >= $start) && (!$end || $end > $now)) { |
$ownaccess = 1; |
$ownaccess = 1; |
last; |
last; |
} |
} |
Line 8229 sub allowed {
|
Line 8256 sub allowed {
|
foreach my $role ('ca','aa') { |
foreach my $role ('ca','aa') { |
if ($env{"user.role.$role./$adom/$aname"}) { |
if ($env{"user.role.$role./$adom/$aname"}) { |
my ($start,$end) = |
my ($start,$end) = |
split('.',$env{"user.role.$role./$adom/$aname"}); |
split(/\./,$env{"user.role.$role./$adom/$aname"}); |
if (($now >= $start) && (!$end || $end < $now)) { |
if (($now >= $start) && (!$end || $end > $now)) { |
$ownaccess = 1; |
$ownaccess = 1; |
last; |
last; |
} |
} |
Line 8504 sub allowed {
|
Line 8531 sub allowed {
|
# |
# |
|
|
# Possibly locked functionality, check all courses |
# Possibly locked functionality, check all courses |
|
# In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma. |
# Locks might take effect only after 10 minutes cache expiration for other |
# Locks might take effect only after 10 minutes cache expiration for other |
# courses, and 2 minutes for current course |
# courses, and 2 minutes for current course, in which user has st or ta role |
|
# which is neither expired nor a future role (unless current course). |
|
|
my $envkey; |
my ($needlockcheck,$now,$crsonly); |
if ($thisallowed=~/L/) { |
if ($thisallowed=~/L/) { |
foreach $envkey (keys(%env)) { |
$now = time; |
|
if ($priv eq 'bre') { |
|
if ($uri ne '') { |
|
if ($orguri =~ m{^/+res/}) { |
|
if ($uri =~ m{^lib/templates/}) { |
|
if ($env{'request.course.id'}) { |
|
$crsonly = 1; |
|
$needlockcheck = 1; |
|
} |
|
} else { |
|
$needlockcheck = 1; |
|
} |
|
} elsif ($env{'request.course.id'}) { |
|
my ($crsdom,$crsnum) = split('_',$env{'request.course.id'}); |
|
if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) || |
|
($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) { |
|
$crsonly = 1; |
|
} |
|
$needlockcheck = 1; |
|
} |
|
} |
|
} elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) { |
|
$needlockcheck = 1; |
|
} |
|
} |
|
if ($needlockcheck) { |
|
foreach my $envkey (keys(%env)) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { |
my $courseid=$2; |
my $courseid=$2; |
my $roleid=$1.'.'.$2; |
my $roleid=$1.'.'.$2; |
$courseid=~s/^\///; |
$courseid=~s/^\///; |
|
unless ($env{'request.role'} eq $roleid) { |
|
my ($start,$end) = split(/\./,$env{$envkey}); |
|
next unless (($now >= $start) && (!$end || $end > $now)); |
|
} |
my $expiretime=600; |
my $expiretime=600; |
if ($env{'request.role'} eq $roleid) { |
if ($env{'request.role'} eq $roleid) { |
$expiretime=120; |
$expiretime=120; |
Line 8536 sub allowed {
|
Line 8595 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 10278 sub autoupdate_coowners {
|
Line 10337 sub autoupdate_coowners {
|
foreach my $xlist (split(',',$xlists)) { |
foreach my $xlist (split(',',$xlists)) { |
my ($inst_crosslist,$lcsec) = split(':',$xlist); |
my ($inst_crosslist,$lcsec) = split(':',$xlist); |
$result = |
$result = |
&Apache::lonnet::auto_validate_inst_crosslist($cnum,$cdom,$instcode, |
&auto_validate_inst_crosslist($cnum,$cdom,$instcode, |
$inst_crosslist,$uname.':'.$udom); |
$inst_crosslist,$uname.':'.$udom); |
last if ($result eq 'valid'); |
last if ($result eq 'valid'); |
} |
|
} |
} |
} |
} |
} |
} |
Line 14333 sub uses_sts {
|
Line 14391 sub uses_sts {
|
return; |
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 { |
sub get_requestor_ip { |
my ($r,$nolookup,$noproxy) = @_; |
my ($r,$nolookup,$noproxy) = @_; |
my $from_ip; |
my $from_ip; |
if (ref($r)) { |
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 { |
} else { |
$from_ip = $ENV{'REMOTE_ADDR'}; |
$from_ip = $ENV{'REMOTE_ADDR'}; |
} |
} |
Line 14391 sub get_proxy_settings {
|
Line 14475 sub get_proxy_settings {
|
trusted => $domdefaults{'waf_trusted'}, |
trusted => $domdefaults{'waf_trusted'}, |
vpnint => $domdefaults{'waf_vpnint'}, |
vpnint => $domdefaults{'waf_vpnint'}, |
vpnext => $domdefaults{'waf_vpnext'}, |
vpnext => $domdefaults{'waf_vpnext'}, |
|
sslopt => $domdefaults{'waf_sslopt'}, |
}; |
}; |
return $proxyinfo; |
return $proxyinfo; |
} |
} |
Line 14405 sub ip_match {
|
Line 14490 sub ip_match {
|
} |
} |
|
|
sub get_proxy_alias { |
sub get_proxy_alias { |
my $lonhost = $perlvar{'lonHostID'}; |
my ($lonid) = @_; |
if ($lonhost ne '') { |
if ($lonid eq '') { |
my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost); |
$lonid = $perlvar{'lonHostID'}; |
|
} |
|
if (!defined(&hostname($lonid))) { |
|
return; |
|
} |
|
if ($lonid ne '') { |
|
my ($alias,$cached) = &is_cached_new('proxyalias',$lonid); |
if ($cached) { |
if ($cached) { |
return $alias; |
return $alias; |
} |
} |
my $dom = &Apache::lonnet::host_domain($lonhost); |
my $dom = &Apache::lonnet::host_domain($lonid); |
if ($dom ne '') { |
if ($dom ne '') { |
my $cachetime = 60*60*24; |
my $cachetime = 60*60*24; |
my %domconfig = |
my %domconfig = |
Line 14419 sub get_proxy_alias {
|
Line 14510 sub get_proxy_alias {
|
my $alias; |
my $alias; |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
if (ref($domconfig{'wafproxy'}) eq 'HASH') { |
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') { |
if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') { |
$alias = $domconfig{'wafproxy'}{'alias'}{$lonhost}; |
$alias = $domconfig{'wafproxy'}{'alias'}{$lonid}; |
} |
} |
} |
} |
return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime); |
return &do_cache_new('proxyalias',$lonid,$alias,$cachetime); |
|
} |
|
} |
|
return; |
|
} |
|
|
|
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; |
return; |
Line 14567 sub get_dns {
|
Line 14680 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 14662 sub fetch_crl_pemfile {
|
Line 14794 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 14730 sub save_crl_pem {
|
Line 14862 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; |