--- loncom/lonnet/perl/lonnet.pm 2018/11/24 16:19:20 1.1389 +++ loncom/lonnet/perl/lonnet.pm 2018/12/27 20:10:56 1.1398 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1389 2018/11/24 16:19:20 raeburn Exp $ +# $Id: lonnet.pm,v 1.1398 2018/12/27 20:10:56 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -311,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()) { @@ -458,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; } @@ -711,6 +730,7 @@ sub check_for_valid_session { if (!defined($disk_env{'user.name'}) || !defined($disk_env{'user.domain'})) { + untie(%disk_env); return undef; } @@ -723,6 +743,7 @@ sub check_for_valid_session { $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; } } + untie(%disk_env); return $handle; } @@ -747,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 { @@ -900,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++; } } @@ -955,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; } } @@ -1434,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,$setcookie); + $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'); @@ -1461,7 +1514,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules,$setcookie) = + ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1522,7 +1575,7 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules,$setcookie) = + ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1598,12 +1651,12 @@ sub check_loadbalancing { undef($setcookie); } } - return ($is_balancer,$otherserver,$setcookie); + return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); } sub check_balancer_result { my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules,$setcookie); + my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); if (ref($result) eq 'HASH') { if ($result->{'lonhost'} ne '') { my $currbalancer = $result->{'lonhost'}; @@ -1612,20 +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'}; - $setcookie = $result->{$key}{'cookie'}; - 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,$setcookie); + return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); } sub get_loadbalancer_targets { @@ -1703,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'); @@ -1725,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'}}; } } @@ -1759,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}}); } } } @@ -3319,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); @@ -5317,8 +5375,8 @@ sub set_first_access { my $firstaccess=&get_first_access($type,$symb,$map); if ($firstaccess) { &logthis("First access time already set ($firstaccess) when attempting ". - "to set new value (type: $type, extent: $res) for $uname:$udom ". - "in $courseid"); + "to set new value (type: $type, extent: $res) for $uname:$udom ". + "in $courseid"); return 'already_set'; } else { my $start = time; @@ -13300,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()) { @@ -13326,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 { @@ -13344,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; @@ -13499,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 {