version 1.1375, 2018/04/14 02:30:01
|
version 1.1379, 2018/07/18 13:45:03
|
Line 652 sub transfer_profile_to_env {
|
Line 652 sub transfer_profile_to_env {
|
sub check_for_valid_session { |
sub check_for_valid_session { |
my ($r,$name,$userhashref,$domref) = @_; |
my ($r,$name,$userhashref,$domref) = @_; |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
my ($linkname,$pubname); |
my ($lonidsdir,$linkname,$pubname,$secure,$lonid); |
if ($name eq '') { |
if ($name eq 'lonDAV') { |
$name = 'lonID'; |
$lonidsdir=$r->dir_config('lonDAVsessDir'); |
|
} else { |
|
$lonidsdir=$r->dir_config('lonIDsDir'); |
|
if ($name eq '') { |
|
$name = 'lonID'; |
|
} |
|
} |
|
if ($name eq 'lonID') { |
|
$secure = 'lonSID'; |
$linkname = 'lonLinkID'; |
$linkname = 'lonLinkID'; |
$pubname = 'lonPubID'; |
$pubname = 'lonPubID'; |
} |
if (exists($cookies{$secure})) { |
my $lonid=$cookies{$name}; |
$lonid=$cookies{$secure}; |
if (!$lonid) { |
} elsif (exists($cookies{$name})) { |
if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) { |
$lonid=$cookies{$name}; |
|
} elsif (exists($cookies{$linkname})) { |
$lonid=$cookies{$linkname}; |
$lonid=$cookies{$linkname}; |
|
} elsif (exists($cookies{$pubname})) { |
|
$lonid=$cookies{$pubname}; |
} |
} |
if (!$lonid) { |
} else { |
if (($name eq 'lonID') && ($pubname)) { |
$lonid=$cookies{$name}; |
$lonid=$cookies{$pubname}; |
|
} |
|
} |
|
} |
} |
return undef if (!$lonid); |
return undef if (!$lonid); |
|
|
my $handle=&LONCAPA::clean_handle($lonid->value); |
my $handle=&LONCAPA::clean_handle($lonid->value); |
my $lonidsdir; |
if (-l "$lonidsdir/$handle.id") { |
if ($name eq 'lonDAV') { |
my $link = readlink("$lonidsdir/$handle.id"); |
$lonidsdir=$r->dir_config('lonDAVsessDir'); |
if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { |
} else { |
$handle = $1; |
$lonidsdir=$r->dir_config('lonIDsDir'); |
} |
} |
} |
if (!-e "$lonidsdir/$handle.id") { |
if (!-e "$lonidsdir/$handle.id") { |
if ((ref($domref)) && ($name eq 'lonID') && |
if ((ref($domref)) && ($name eq 'lonID') && |
Line 762 sub appenv {
|
Line 770 sub appenv {
|
$env{$key}=$newenv->{$key}; |
$env{$key}=$newenv->{$key}; |
} |
} |
} |
} |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
my $lonids = $perlvar{'lonIDsDir'}; |
if ($opened |
if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { |
&& &timed_flock($env_file,LOCK_EX) |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
&& |
if ($opened |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
&& &timed_flock($env_file,LOCK_EX) |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
&& |
while (my ($key,$value) = each(%{$newenv})) { |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
$disk_env{$key} = $value; |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
} |
while (my ($key,$value) = each(%{$newenv})) { |
untie(%disk_env); |
$disk_env{$key} = $value; |
|
} |
|
untie(%disk_env); |
|
} |
} |
} |
} |
} |
return 'ok'; |
return 'ok'; |
Line 9287 sub assignrole {
|
Line 9298 sub assignrole {
|
} |
} |
if ($refused) { |
if ($refused) { |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$}); |
if (!$selfenroll && $context eq 'course') { |
if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) { |
my %crsenv; |
my %crsenv; |
if ($role eq 'cc' || $role eq 'co') { |
if ($role eq 'cc' || $role eq 'co') { |
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
Line 9310 sub assignrole {
|
Line 9321 sub assignrole {
|
} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
} elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { |
if ($role eq 'st') { |
if ($role eq 'st') { |
$refused = ''; |
$refused = ''; |
} elsif (($context eq 'ltienroll') && ($env{'request.lti'})) { |
} elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { |
$refused = ''; |
$refused = ''; |
} |
} |
} elsif ($context eq 'requestcourses') { |
} elsif ($context eq 'requestcourses') { |
Line 13508 sub get_dns {
|
Line 13519 sub get_dns {
|
} |
} |
|
|
my %alldns; |
my %alldns; |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { |
foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
my $line = $1; |
my $line = $1; |
my ($host,$protocol) = split(/:/,$line); |
my ($host,$protocol) = split(/:/,$line); |
if ($protocol ne 'https') { |
if ($protocol ne 'https') { |
$protocol = 'http'; |
$protocol = 'http'; |
|
} |
|
$alldns{$host} = $protocol; |
} |
} |
$alldns{$host} = $protocol; |
close($config); |
} |
} |
while (%alldns) { |
while (%alldns) { |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
Line 13524 sub get_dns {
|
Line 13537 sub get_dns {
|
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); |
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); |
delete($alldns{$dns}); |
delete($alldns{$dns}); |
next if ($response->is_error()); |
next if ($response->is_error()); |
my @content = split("\n",$response->content); |
if ($url eq '/adm/dns/loncapaCRL') { |
unless ($nocache) { |
return &$func($response); |
&do_cache_new('dns',$url,\@content,30*24*60*60); |
} else { |
} |
my @content = split("\n",$response->content); |
&$func(\@content,$hashref); |
unless ($nocache) { |
return; |
&do_cache_new('dns',$url,\@content,30*24*60*60); |
} |
} |
close($config); |
&$func(\@content,$hashref); |
my $which = (split('/',$url))[3]; |
return; |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
} |
open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab"); |
} |
my @content = <$config>; |
my $which = (split('/',$url,4))[3]; |
&$func(\@content,$hashref); |
if ($which eq 'loncapaCRL') { |
|
my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; |
|
if (-e $diskfile) { |
|
&logthis("unable to contact DNS, on disk file $diskfile not updated"); |
|
} else { |
|
&logthis("unable to contact DNS, no on disk file $diskfile available"); |
|
} |
|
} else { |
|
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
|
if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { |
|
my @content = <$config>; |
|
close($config); |
|
&$func(\@content,$hashref); |
|
} |
|
} |
return; |
return; |
} |
} |
|
|
Line 13596 sub fetch_dns_checksums {
|
Line 13623 sub fetch_dns_checksums {
|
return \%checksums; |
return \%checksums; |
} |
} |
|
|
|
sub fetch_crl_pemfile { |
|
return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1); |
|
} |
|
|
|
sub save_crl_pem { |
|
my ($response) = @_; |
|
my $msg; |
|
if (ref($response)) { |
|
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; |
|
close($fh); |
|
if (-e $lonca) { |
|
if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) { |
|
my $check = <PIPE>; |
|
close(PIPE); |
|
chomp($check); |
|
if ($check eq 'verify OK') { |
|
my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; |
|
if (-e $dest) { |
|
&File::Copy::move($dest,"$dest.bak"); |
|
} |
|
if (&File::Copy::move($tmpcrl,$dest)) { |
|
$msg = 'ok'; |
|
} |
|
} else { |
|
unlink($tmpcrl); |
|
} |
|
} else { |
|
unlink($tmpcrl); |
|
} |
|
} else { |
|
unlink($tmpcrl); |
|
} |
|
} |
|
} |
|
return $msg; |
|
} |
|
|
# ------------------------------------------------------------ Read domain file |
# ------------------------------------------------------------ Read domain file |
{ |
{ |
my $loaded; |
my $loaded; |