[LON-CAPA-cvs] cvs: loncom(version_2_11_X) /lonnet/perl lonnet.pm
raeburn
raeburn at source.lon-capa.org
Thu Aug 1 15:13:28 EDT 2019
raeburn Thu Aug 1 19:13:28 2019 EDT
Modified files: (Branch: version_2_11_X)
/loncom/lonnet/perl lonnet.pm
Log:
- For 2.11
Backport 1.1389, 1.1392, 1.1394
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.1172.2.106 loncom/lonnet/perl/lonnet.pm:1.1172.2.107
--- loncom/lonnet/perl/lonnet.pm:1.1172.2.106 Fri Jul 26 19:09:16 2019
+++ loncom/lonnet/perl/lonnet.pm Thu Aug 1 19:13:26 2019
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.106 2019/07/26 19:09:16 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.107 2019/08/01 19:13:26 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -74,6 +74,7 @@
use LWP::UserAgent();
use HTTP::Date;
use Image::Magick;
+use CGI::Cookie;
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
@@ -639,6 +640,7 @@
if (!defined($disk_env{'user.name'})
|| !defined($disk_env{'user.domain'})) {
+ untie(%disk_env);
return undef;
}
@@ -646,6 +648,7 @@
$userhashref->{'name'} = $disk_env{'user.name'};
$userhashref->{'domain'} = $disk_env{'user.domain'};
}
+ untie(%disk_env);
return $handle;
}
@@ -670,6 +673,37 @@
}
}
+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 {
@@ -951,6 +985,75 @@
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) = @_;
@@ -1288,7 +1391,7 @@
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);
my $lonhost = $perlvar{'lonHostID'};
my @hosts = ¤t_machine_ids();
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
@@ -1315,7 +1418,7 @@
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules) =
+ ($is_balancer,$currtargets,$currrules,$setcookie) =
&check_balancer_result($result, at hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1376,7 +1479,7 @@
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules) =
+ ($is_balancer,$currtargets,$currrules,$setcookie) =
&check_balancer_result($result, at hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1442,20 +1545,22 @@
$is_balancer = 0;
if ($uname ne '' && $udom ne '') {
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
-
&appenv({'user.loadbalexempt' => $lonhost,
'user.loadbalcheck.time' => time});
}
}
}
}
+ unless ($homeintdom) {
+ undef($setcookie);
+ }
}
- return ($is_balancer,$otherserver);
+ return ($is_balancer,$otherserver,$setcookie);
}
sub check_balancer_result {
my ($result, at hosts) = @_;
- my ($is_balancer,$currtargets,$currrules);
+ my ($is_balancer,$currtargets,$currrules,$setcookie);
if (ref($result) eq 'HASH') {
if ($result->{'lonhost'} ne '') {
my $currbalancer = $result->{'lonhost'};
@@ -1471,12 +1576,13 @@
$is_balancer = 1;
$currrules = $result->{$key}{'rules'};
$currtargets = $result->{$key}{'targets'};
+ $setcookie = $result->{$key}{'cookie'};
last;
}
}
}
}
- return ($is_balancer,$currtargets,$currrules);
+ return ($is_balancer,$currtargets,$currrules,$setcookie);
}
sub get_loadbalancer_targets {
More information about the LON-CAPA-cvs
mailing list