--- loncom/lonnet/perl/lonnet.pm 2018/03/30 18:07:47 1.1370 +++ loncom/lonnet/perl/lonnet.pm 2018/12/29 16:41:24 1.1399 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1370 2018/03/30 18:07:47 raeburn Exp $ +# $Id: lonnet.pm,v 1.1399 2018/12/29 16:41:24 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -73,7 +73,7 @@ package Apache::lonnet; use strict; use HTTP::Date; use Image::Magick; - +use CGI::Cookie; use Encode; @@ -184,7 +184,7 @@ sub create_connection { Type => SOCK_STREAM, Timeout => 10); return 0 if (!$client); - print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n"); my $result = <$client>; chomp($result); return 1 if ($result eq 'done'); @@ -230,12 +230,19 @@ sub get_server_distarch { } sub get_servercerts_info { - my ($lonhost,$context) = @_; + my ($lonhost,$hostname,$context) = @_; + return if ($lonhost eq ''); + if ($hostname eq '') { + $hostname = &hostname($lonhost); + } + return if ($hostname eq ''); my ($rep,$uselocal); - if (grep { $_ eq $lonhost } ¤t_machine_ids()) { + if ($context eq 'install') { + $uselocal = 1; + } elsif (grep { $_ eq $lonhost } ¤t_machine_ids()) { $uselocal = 1; } - if (($context ne 'cgi') && ($uselocal)) { + if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) { my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; if ($distro eq '') { $uselocal = 0; @@ -250,16 +257,11 @@ sub get_servercerts_info { } } if ($uselocal) { - $rep = LONCAPA::Lond::server_certs(\%perlvar); + $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname); } else { $rep=&reply('servercerts',$lonhost); } my ($result,%returnhash); - if (defined($lonhost)) { - if (!defined(&hostname($lonhost))) { - return; - } - } if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || ($rep eq 'unknown_cmd')) { $result = $rep; @@ -309,9 +311,10 @@ sub get_server_loncaparev { $answer = &reply('serverloncaparev',$lonhost); if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { if ($caller eq 'loncron') { + my $hostname = &hostname($lonhost); my $protocol = $protocol{$lonhost}; $protocol = 'http' if ($protocol ne 'https'); - my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; + my $url = $protocol.'://'.$hostname.'/adm/about.html'; my $request=new HTTP::Request('GET',$url); my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); unless ($response->is_error()) { @@ -456,8 +459,26 @@ sub reply { unless (defined(&hostname($server))) { return 'no_such_host'; } my $answer=subreply($cmd,$server); if (($answer=~/^refused/) || ($answer=~/^rejected/)) { - &logthis("WARNING:". - " $cmd to $server returned $answer"); + my $logged = $cmd; + if ($cmd =~ /^encrypt:([^:]+):/) { + my $subcmd = $1; + if (($subcmd eq 'auth') || ($subcmd eq 'passwd') || + ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') || + ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) { + (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')) { + splice(@rest,3,1,'Hidden'); + } + $logged = join(':',('encrypt:'.$subcmd,@rest)); + } + } + &logthis("WARNING:". + " $logged to $server returned $answer"); } return $answer; } @@ -652,31 +673,39 @@ sub transfer_profile_to_env { sub check_for_valid_session { my ($r,$name,$userhashref,$domref) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - my ($linkname,$pubname); - if ($name eq '') { - $name = 'lonID'; + my ($lonidsdir,$linkname,$pubname,$secure,$lonid); + if ($name eq 'lonDAV') { + $lonidsdir=$r->dir_config('lonDAVsessDir'); + } else { + $lonidsdir=$r->dir_config('lonIDsDir'); + if ($name eq '') { + $name = 'lonID'; + } + } + if ($name eq 'lonID') { + $secure = 'lonSID'; $linkname = 'lonLinkID'; $pubname = 'lonPubID'; - } - my $lonid=$cookies{$name}; - if (!$lonid) { - if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) { + if (exists($cookies{$secure})) { + $lonid=$cookies{$secure}; + } elsif (exists($cookies{$name})) { + $lonid=$cookies{$name}; + } elsif (exists($cookies{$linkname})) { $lonid=$cookies{$linkname}; + } elsif (exists($cookies{$pubname})) { + $lonid=$cookies{$pubname}; } - if (!$lonid) { - if (($name eq 'lonID') && ($pubname)) { - $lonid=$cookies{$pubname}; - } - } + } else { + $lonid=$cookies{$name}; } return undef if (!$lonid); my $handle=&LONCAPA::clean_handle($lonid->value); - my $lonidsdir; - if ($name eq 'lonDAV') { - $lonidsdir=$r->dir_config('lonDAVsessDir'); - } else { - $lonidsdir=$r->dir_config('lonIDsDir'); + if (-l "$lonidsdir/$handle.id") { + my $link = readlink("$lonidsdir/$handle.id"); + if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { + $handle = $1; + } } if (!-e "$lonidsdir/$handle.id") { if ((ref($domref)) && ($name eq 'lonID') && @@ -701,6 +730,7 @@ sub check_for_valid_session { if (!defined($disk_env{'user.name'}) || !defined($disk_env{'user.domain'})) { + untie(%disk_env); return undef; } @@ -708,7 +738,12 @@ sub check_for_valid_session { $userhashref->{'name'} = $disk_env{'user.name'}; $userhashref->{'domain'} = $disk_env{'user.domain'}; $userhashref->{'lti'} = $disk_env{'request.lti.login'}; + if ($userhashref->{'lti'}) { + $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; + $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; + } } + untie(%disk_env); return $handle; } @@ -733,6 +768,37 @@ sub timed_flock { } } +sub get_sessionfile_vars { + my ($handle,$lonidsdir,$storearr) = @_; + my %returnhash; + unless (ref($storearr) eq 'ARRAY') { + return %returnhash; + } + if (-l "$lonidsdir/$handle.id") { + my $link = readlink("$lonidsdir/$handle.id"); + if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { + $handle = $1; + } + } + if ((-e "$lonidsdir/$handle.id") && + ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { + my ($possuname,$possudom,$possuhome) = ($1,$2,$3); + if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { + if (open(my $idf,'+<',"$lonidsdir/$handle.id")) { + flock($idf,LOCK_SH); + if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", + &GDBM_READER(),0640)) { + foreach my $item (@{$storearr}) { + $returnhash{$item} = $disk_env{$item}; + } + untie(%disk_env); + } + } + } + } + return %returnhash; +} + # ---------------------------------------------------------- Append Environment sub appenv { @@ -758,16 +824,19 @@ sub appenv { $env{$key}=$newenv->{$key}; } } - my $opened = open(my $env_file,'+<',$env{'user.environment'}); - if ($opened - && &timed_flock($env_file,LOCK_EX) - && - tie(my %disk_env,'GDBM_File',$env{'user.environment'}, - (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { - while (my ($key,$value) = each(%{$newenv})) { - $disk_env{$key} = $value; - } - untie(%disk_env); + my $lonids = $perlvar{'lonIDsDir'}; + if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { + my $opened = open(my $env_file,'+<',$env{'user.environment'}); + if ($opened + && &timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { + while (my ($key,$value) = each(%{$newenv})) { + $disk_env{$key} = $value; + } + untie(%disk_env); + } } } return 'ok'; @@ -883,6 +952,7 @@ sub userload { while ($filename=readdir(LONIDS)) { next if ($filename eq '.' || $filename eq '..'); next if ($filename =~ /publicuser_\d+\.id/); + next if ($filename =~ /^[a-f0-9]+_linked\.id$/); my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; if ($curtime-$mtime < 1800) { $numusers++; } } @@ -938,13 +1008,13 @@ sub spareserver { } if (!$want_server_name) { - my $protocol = 'http'; - if ($protocol{$spare_server} eq 'https') { - $protocol = $protocol{$spare_server}; - } if (defined($spare_server)) { my $hostname = &hostname($spare_server); if (defined($hostname)) { + my $protocol = 'http'; + if ($protocol{$spare_server} eq 'https') { + $protocol = $protocol{$spare_server}; + } $spare_server = $protocol.'://'.$hostname; } } @@ -1011,6 +1081,75 @@ sub find_existing_session { return; } +# check if user's browser sent load balancer cookie and server still has session +# and is not overloaded. +sub check_for_balancer_cookie { + my ($r,$update_mtime) = @_; + my ($otherserver,$cookie); + my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); + if (exists($cookies{'balanceID'})) { + my $balid = $cookies{'balanceID'}; + $cookie=&LONCAPA::clean_handle($balid->value); + my $balancedir=$r->dir_config('lonBalanceDir'); + if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) { + if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) { + my ($possudom,$possuname) = ($1,$2); + my $has_session = 0; + if ((&domain($possudom) ne '') && + (&homeserver($possuname,$possudom) ne 'no_host')) { + my $try_server; + my $opened = open(my $idf,'+<',"$balancedir/$cookie.id"); + if ($opened) { + flock($idf,LOCK_SH); + while (my $line = <$idf>) { + chomp($line); + if (&hostname($line) ne '') { + $try_server = $line; + last; + } + } + close($idf); + if (($try_server) && + (&has_user_session($try_server,$possudom,$possuname))) { + my $lowest_load = 30000; + ($otherserver,$lowest_load) = + &compare_server_load($try_server,undef,$lowest_load); + if ($otherserver ne '' && $lowest_load < 100) { + $has_session = 1; + } else { + undef($otherserver); + } + } + } + } + if ($has_session) { + if ($update_mtime) { + my $atime = my $mtime = time; + utime($atime,$mtime,"$balancedir/$cookie.id"); + } + } else { + unlink("$balancedir/$cookie.id"); + } + } + } + } + return ($otherserver,$cookie); +} + +sub delbalcookie { + my ($cookie,$balancer) =@_; + if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { + my ($udom,$uname) = ($1,$2); + my $uprimary_id = &domain($udom,'primary'); + my $uintdom = &internet_dom($uprimary_id); + my $intdom = &internet_dom($balancer); + my $serverhomedom = &host_domain($balancer); + if (($uintdom ne '') && ($uintdom eq $intdom)) { + return &reply("delbalcookie:$cookie",$balancer); + } + } +} + # -------------------------------- ask if server already has a session for user sub has_user_session { my ($lonid,$udom,$uname) = @_; @@ -1046,7 +1185,7 @@ sub choose_server { if (ref($balancers) eq 'HASH') { next if (exists($balancers->{$lonhost})); } - } + } my $loginvia; if ($checkloginvia) { $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; @@ -1348,7 +1487,7 @@ sub get_lonbalancer_config { sub check_loadbalancing { my ($uname,$udom,$caller) = @_; my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver); + $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers); my $lonhost = $perlvar{'lonHostID'}; my @hosts = ¤t_machine_ids(); my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); @@ -1375,7 +1514,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1436,7 +1575,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1502,20 +1641,22 @@ sub check_loadbalancing { $is_balancer = 0; if ($uname ne '' && $udom ne '') { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - - &appenv({'user.loadbalexempt' => $lonhost, + &appenv({'user.loadbalexempt' => $lonhost, 'user.loadbalcheck.time' => time}); } } } } + unless ($homeintdom) { + undef($setcookie); + } } - return ($is_balancer,$otherserver); + return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); } sub check_balancer_result { my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules); + my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); if (ref($result) eq 'HASH') { if ($result->{'lonhost'} ne '') { my $currbalancer = $result->{'lonhost'}; @@ -1524,19 +1665,24 @@ sub check_balancer_result { $currtargets = $result->{'targets'}; $currrules = $result->{'rules'}; } + $dom_balancers = $currbalancer; } else { - foreach my $key (keys(%{$result})) { - if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && - (ref($result->{$key}) eq 'HASH')) { - $is_balancer = 1; - $currrules = $result->{$key}{'rules'}; - $currtargets = $result->{$key}{'targets'}; - last; + if (keys(%{$result})) { + foreach my $key (keys(%{$result})) { + if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && + (ref($result->{$key}) eq 'HASH')) { + $is_balancer = 1; + $currrules = $result->{$key}{'rules'}; + $currtargets = $result->{$key}{'targets'}; + $setcookie = $result->{$key}{'cookie'}; + last; + } } + $dom_balancers = join(',',sort(keys(%{$result}))); } } } - return ($is_balancer,$currtargets,$currrules); + return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); } sub get_loadbalancer_targets { @@ -1614,7 +1760,7 @@ sub trusted_domains { if (&domain($calldom) eq '') { return ($trusted,$untrusted); } - unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { + unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) { return ($trusted,$untrusted); } my $callprimary = &domain($calldom,'primary'); @@ -1636,6 +1782,7 @@ sub trusted_domains { map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; } if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { + $possinc{$intcalldom} = 1; map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; } } @@ -1670,12 +1817,12 @@ sub trusted_domains { } foreach my $exc (@allexc) { if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { - $untrusted = $doms_by_intdom{$exc}; + push(@{$untrusted},@{$doms_by_intdom{$exc}}); } } foreach my $inc (@allinc) { if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { - $trusted = $doms_by_intdom{$inc}; + push(@{$trusted},@{$doms_by_intdom{$inc}}); } } } @@ -3182,7 +3329,17 @@ sub ssi { $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $lonhost = $perlvar{'lonHostID'}; - my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar); + my $islocal; + if (($env{'request.course.id'}) && + ($form{'grade_courseid'} eq $env{'request.course.id'}) && + ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && + ($form{'grade_symb'} ne '') && + (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}. + ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { + $islocal = 1; + } + my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, + '','','',$islocal); if (wantarray) { return ($response->content, $response); @@ -3220,10 +3377,10 @@ sub remove_stale_resfile { (grep { $_ eq $homeserver } ¤t_machine_ids())) { my $fname = &filelocation('',$url); if (-e $fname) { - my $protocol = $protocol{$homeserver}; - $protocol = 'http' if ($protocol ne 'https'); my $hostname = &hostname($homeserver); if ($hostname) { + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); my $uri = &declutter($url); my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); @@ -5216,7 +5373,12 @@ sub set_first_access { } $cachedkey=''; my $firstaccess=&get_first_access($type,$symb,$map); - if (!$firstaccess) { + if ($firstaccess) { + &logthis("First access time already set ($firstaccess) when attempting ". + "to set new value (type: $type, extent: $res) for $uname:$udom ". + "in $courseid"); + return 'already_set'; + } else { my $start = time; my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start}, $udom,$uname); @@ -5232,6 +5394,9 @@ sub set_first_access { if (($cachedtime) && (abs($start-$cachedtime) < 5)) { $cachedtimes{"$courseid\0$res"} = $start; } + } elsif ($putres ne 'refused') { + &logthis("Result: $putres when attempting to set first access time ". + "(type: $type, extent: $res) for $uname:$udom in $courseid"); } return $putres; } @@ -9283,7 +9448,7 @@ sub assignrole { } if ($refused) { 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; if ($role eq 'cc' || $role eq 'co') { %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); @@ -9306,7 +9471,7 @@ sub assignrole { } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { if ($role eq 'st') { $refused = ''; - } elsif (($context eq 'ltienroll') && ($env{'request.lti'})) { + } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { $refused = ''; } } elsif ($context eq 'requestcourses') { @@ -10026,12 +10191,25 @@ sub is_course { my ($cdom, $cnum) = scalar(@_) == 1 ? ($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; - return unless $cdom and $cnum; - - my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, - '.'); - - return unless(exists($courses{$cdom.'_'.$cnum})); + return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); + my $uhome=&homeserver($cnum,$cdom); + my $iscourse; + if (grep { $_ eq $uhome } current_machine_ids()) { + $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); + } else { + my $hashid = $cdom.':'.$cnum; + ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid); + unless (defined($cached)) { + my %courses = &courseiddump($cdom, '.', 1, '.', '.', + $cnum,undef,undef,'.'); + $iscourse = 0; + if (exists($courses{$cdom.'_'.$cnum})) { + $iscourse = 1; + } + &do_cache_new('iscourse',$hashid,$iscourse,3600); + } + } + return unless ($iscourse); return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; } @@ -11928,23 +12106,31 @@ sub metadata { # Check metadata for imported file to # see if it contained response items # + my ($origfile,@libfilekeys); my %currmetaentry = %metaentry; - my $libresponseorder = &metadata($location,'responseorder'); - my $origfile; - if ($libresponseorder ne '') { - if ($#origfiletagids<0) { - undef(%importedrespids); - undef(%importedpartids); - } - @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder); - if (@{$importedrespids{$importid}} > 0) { - $importedresponses = 1; + @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef, + $depthcount+1)); + if (grep(/^responseorder$/,@libfilekeys)) { + my $libresponseorder = &metadata($location,'responseorder',undef,undef, + undef,$depthcount+1); + if ($libresponseorder ne '') { + if ($#origfiletagids<0) { + undef(%importedrespids); + undef(%importedpartids); + } + my @respids = split(/\s*,\s*/,$libresponseorder); + if (@respids) { + $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids); + } + if ($importedrespids{$importid} ne '') { + $importedresponses = 1; # We need to get the original file and the imported file to get the response order correct # Load and inspect original file - if ($#origfiletagids<0) { - my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); - $origfile=&getfile($origfilelocation); - @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + if ($#origfiletagids<0) { + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + $origfile=&getfile($origfilelocation); + @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + } } } } @@ -11952,10 +12138,7 @@ sub metadata { # hash populated for imported library file %metaentry = %currmetaentry; undef(%currmetaentry); - if ($importmode eq 'problem') { -# Import as problem/response - $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - } elsif ($importmode eq 'part') { + if ($importmode eq 'part') { # Import as part(s) $importedparts=1; # We need to get the original file and the imported file to get the part order correct @@ -11970,10 +12153,23 @@ sub metadata { @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); } } - -# Load and inspect imported file - my $impfile=&getfile($location); - my @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + my @impfilepartids; +# If tag is included in metadata for the imported file +# get the parts in the imported file from that. + if (grep(/^partorder$/,@libfilekeys)) { + %currmetaentry = %metaentry; + my $libpartorder = &metadata($location,'partorder',undef,undef,undef, + $depthcount+1); + %metaentry = %currmetaentry; + undef(%currmetaentry); + if ($libpartorder ne '') { + @impfilepartids=split(/\s*,\s*/,$libpartorder); + } + } else { +# If no tag available, load and inspect imported file + my $impfile=&getfile($location); + @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + } if ($#impfilepartids>=0) { # This problem had parts $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); @@ -11984,13 +12180,28 @@ sub metadata { $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; } } else { +# Import as problem or as normal import + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + unless ($importmode eq 'problem') { # Normal import - $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } + } +# Check metadata for imported file to +# see if it contained parts + if (grep(/^partorder$/,@libfilekeys)) { + %currmetaentry = %metaentry; + my $libpartorder = &metadata($location,'partorder',undef,undef,undef, + $depthcount+1); + %metaentry = %currmetaentry; + undef(%currmetaentry); + if ($libpartorder ne '') { + $importedparts = 1; + $importedpartids{$token->[2]->{'id'}}=$libpartorder; + } + } } - if ($depthcount<20) { my $metadata = &metadata($uri,'keys',$toolsymb,$location,$unikey, @@ -12102,12 +12313,14 @@ sub metadata { } elsif ($origfiletagids[$index] eq 'import') { if ($importedparts) { # We have imported parts at this position - $metaentry{':partorder'}.=','.$importedpartids{$origid}; + if ($importedpartids{$origid} ne '') { + $metaentry{':partorder'}.=','.$importedpartids{$origid}; + } } if ($importedresponses) { # We have imported responses at this position - if (ref($importedrespids{$origid}) eq 'ARRAY') { - $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}}); + if ($importedrespids{$origid} ne '') { + $metaentry{':responseorder'}.=','.$importedrespids{$origid}; } } } else { @@ -12124,11 +12337,12 @@ sub metadata { $metaentry{':responseorder'}=~s/^\,//; } } - $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); - &do_cache_new('meta',$uri,\%metaentry,$cachetime); + unless ($liburi) { + &do_cache_new('meta',$uri,\%metaentry,$cachetime); + } # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -13144,9 +13358,10 @@ sub repcopy_userfile { my $request; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); + $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri); my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); # did it work? if ($response->is_error()) { @@ -13170,9 +13385,10 @@ sub tokenwrapper { $file=~s|(\?\.*)*$||; &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}}); my $homeserver = &homeserver($uname,$udom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - return $protocol.'://'.&hostname($homeserver).'/'.$uri. + return $protocol.'://'.$hostname.'/'.$uri. (($uri=~/\?/)?'&':'?').'token='.$token. '&tokenissued='.$perlvar{'lonHostID'}; } else { @@ -13188,9 +13404,10 @@ sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; + $uri = $protocol.'://'.$hostname.'/raw/'.$uri; my $request=new HTTP::Request($reqtype,$uri); my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); $$rtncode = $response->code; @@ -13343,6 +13560,44 @@ sub default_login_domain { return $domain; } +sub uses_sts { + my ($ignore_cache) = @_; + my $lonhost = $perlvar{'lonHostID'}; + my $hostname = &hostname($lonhost); + my $sts_on; + if ($protocol{$lonhost} eq 'https') { + my $cachetime = 12*3600; + if (!$ignore_cache) { + ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost); + if (defined($cached)) { + return $sts_on; + } + } + my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html'; + my $request=new HTTP::Request('HEAD',$url); + my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1); + if ($response->is_success) { + my $has_sts = $response->header('Strict-Transport-Security'); + if ($has_sts eq '') { + $sts_on = 0; + } else { + if ($has_sts =~ /\Qmax-age=\E(\d+)/) { + my $maxage = $1; + if ($maxage) { + $sts_on = 1; + } else { + $sts_on = 0; + } + } else { + $sts_on = 0; + } + } + return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime); + } + } + return; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -13468,15 +13723,17 @@ sub get_dns { } my %alldns; - open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); - foreach my $dns (<$config>) { - next if ($dns !~ /^\^(\S*)/x); - my $line = $1; - my ($host,$protocol) = split(/:/,$line); - if ($protocol ne 'https') { - $protocol = 'http'; + if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + my $line = $1; + my ($host,$protocol) = split(/:/,$line); + if ($protocol ne 'https') { + $protocol = 'http'; + } + $alldns{$host} = $protocol; } - $alldns{$host} = $protocol; + close($config); } while (%alldns) { my ($dns) = sort { $b cmp $a } keys(%alldns); @@ -13484,19 +13741,33 @@ sub get_dns { my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); delete($alldns{$dns}); next if ($response->is_error()); - my @content = split("\n",$response->content); - unless ($nocache) { - &do_cache_new('dns',$url,\@content,30*24*60*60); - } - &$func(\@content,$hashref); - return; + if ($url eq '/adm/dns/loncapaCRL') { + return &$func($response); + } else { + my @content = split("\n",$response->content); + unless ($nocache) { + &do_cache_new('dns',$url,\@content,30*24*60*60); + } + &$func(\@content,$hashref); + return; + } + } + my $which = (split('/',$url,4))[3]; + 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); + } } - close($config); - my $which = (split('/',$url))[3]; - &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); - open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab"); - my @content = <$config>; - &$func(\@content,$hashref); return; } @@ -13556,6 +13827,79 @@ sub fetch_dns_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,$hadchanges); + 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 = ; + close(PIPE); + chomp($check); + if ($check eq 'verify OK') { + my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; + my $backup; + if (-e $dest) { + if (&File::Copy::move($dest,"$dest.bak")) { + $backup = 'ok'; + } + } + if (&File::Copy::move($tmpcrl,$dest)) { + $msg = 'ok'; + if ($backup) { + my (%oldnums,%newnums); + if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) { + while () { + $oldnums{(split(/:/))[1]} = 1; + } + close(PIPE); + } + if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) { + while() { + $newnums{(split(/:/))[1]} = 1; + } + close(PIPE); + } + foreach my $key (sort {$b <=> $a } (keys(%newnums))) { + unless (exists($oldnums{$key})) { + $hadchanges = 1; + last; + } + } + unless ($hadchanges) { + foreach my $key (sort {$b <=> $a } (keys(%oldnums))) { + unless (exists($newnums{$key})) { + $hadchanges = 1; + last; + } + } + } + } + } + } else { + unlink($tmpcrl); + } + } else { + unlink($tmpcrl); + } + } else { + unlink($tmpcrl); + } + } + } + return ($msg,$hadchanges); +} + # ------------------------------------------------------------ Read domain file { my $loaded; @@ -14851,7 +15195,9 @@ only used internally for recursive metad the toolsymb is only used where the uri is for an external tool (for which the uri as well as the symb are guaranteed to be unique). -this function automatically caches all requests +this function automatically caches all requests except any made recursively +to retrieve a list of metadata keys for an imported library file ($liburi is +defined). =item *