--- loncom/lonnet/perl/lonnet.pm	2018/11/01 18:57:29	1.1172.2.102
+++ loncom/lonnet/perl/lonnet.pm	2019/08/03 23:36:09	1.1172.2.108
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1172.2.102 2018/11/01 18:57:29 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.108 2019/08/03 23:36:09 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -74,8 +74,9 @@ use strict;
 use LWP::UserAgent();
 use HTTP::Date;
 use Image::Magick;
+use CGI::Cookie;
 
-use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
+use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);
 
@@ -603,18 +604,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'));
-    if ($name eq '') {
-        $name = 'lonID';
-    }
-    my $lonid=$cookies{$name};
-    return undef if (!$lonid);
-
-    my $handle=&LONCAPA::clean_handle($lonid->value);
-    my $lonidsdir;
+    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';
+        if (exists($cookies{$secure})) {
+            $lonid=$cookies{$secure};
+        } elsif (exists($cookies{$name})) {
+            $lonid=$cookies{$name};
+        } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
+            $lonid=$cookies{$linkname};
+        } elsif (exists($cookies{$pubname})) {
+            $lonid=$cookies{$pubname};
+        }
+    } else {
+        $lonid=$cookies{$name};
+    }
+    return undef if (!$lonid);
+
+    my $handle=&LONCAPA::clean_handle($lonid->value);
+    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') &&
@@ -639,6 +661,7 @@ sub check_for_valid_session {
 
     if (!defined($disk_env{'user.name'})
 	|| !defined($disk_env{'user.domain'})) {
+        untie(%disk_env);
 	return undef;
     }
 
@@ -646,6 +669,7 @@ sub check_for_valid_session {
         $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};
     }
+    untie(%disk_env);
 
     return $handle;
 }
@@ -670,6 +694,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 {
@@ -951,6 +1006,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) = @_;
@@ -1288,7 +1412,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);
     my $lonhost = $perlvar{'lonHostID'};
     my @hosts = &current_machine_ids();
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
@@ -1315,7 +1439,7 @@ sub check_loadbalancing {
         }
     }
     if (ref($result) eq 'HASH') {
-        ($is_balancer,$currtargets,$currrules) =
+        ($is_balancer,$currtargets,$currrules,$setcookie) =
             &check_balancer_result($result,@hosts);
         if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {
@@ -1376,7 +1500,7 @@ sub check_loadbalancing {
             }
         }
         if (ref($result) eq 'HASH') {
-            ($is_balancer,$currtargets,$currrules) =
+            ($is_balancer,$currtargets,$currrules,$setcookie) =
                 &check_balancer_result($result,@hosts);
             if ($is_balancer) {
                 if (ref($currrules) eq 'HASH') {
@@ -1442,20 +1566,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,
                                  'user.loadbalcheck.time' => time});
                     }
                 }
             }
         }
+        unless ($homeintdom) {
+            undef($setcookie);
+        }
     }
-    return ($is_balancer,$otherserver);
+    return ($is_balancer,$otherserver,$setcookie);
 }
 
 sub check_balancer_result {
     my ($result,@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 +1597,13 @@ sub check_balancer_result {
                     $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 {
@@ -2193,6 +2320,9 @@ sub get_domain_defaults {
         } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
             $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
         }
+        if ($domconfig{'coursedefaults'}{'texengine'}) {
+            $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
+        }
     }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
@@ -2256,6 +2386,65 @@ sub get_domain_defaults {
     return %domdefaults;
 }
 
+sub get_dom_cats {
+    my ($dom) = @_;
+    return unless (&domain($dom));
+    my ($cats,$cached)=&is_cached_new('cats',$dom);
+    unless (defined($cached)) {
+        my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
+        if (ref($domconfig{'coursecategories'}) eq 'HASH') {
+            if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
+                %{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
+            } else {
+                $cats = {};
+            }
+        } else {
+            $cats = {};
+        }
+        &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
+    }
+    return $cats;
+}
+
+sub get_dom_instcats {
+    my ($dom) = @_;
+    return unless (&domain($dom));
+    my ($instcats,$cached)=&is_cached_new('instcats',$dom);
+    unless (defined($cached)) {
+        my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order);
+        my $totcodes = &retrieve_instcodes(\%coursecodes,$dom);
+        if ($totcodes > 0) {
+            my $caller = 'global';
+            if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
+                                      \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
+                $instcats = {
+                                codes => \%codes,
+                                codetitles => \@codetitles,
+                                cat_titles => \%cat_titles,
+                                cat_order => \%cat_order,
+                            };
+                &do_cache_new('instcats',$dom,$instcats,3600);
+            }
+        }
+    }
+    return $instcats;
+}
+
+sub retrieve_instcodes {
+    my ($coursecodes,$dom) = @_;
+    my $totcodes;
+    my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course');
+    foreach my $course (keys(%courses)) {
+        if (ref($courses{$course}) eq 'HASH') {
+            if ($courses{$course}{'inst_code'} ne '') {
+                $$coursecodes{$course} = $courses{$course}{'inst_code'};
+                $totcodes ++;
+            }
+        }
+    }
+    return $totcodes;
+}
+
 # --------------------------------------------------- Assign a key to a student
 
 sub assign_access_key {
@@ -12649,6 +12838,27 @@ sub default_login_domain {
     return $domain;
 }
 
+sub shared_institution {
+    my ($dom) = @_;
+    my $same_intdom;
+    my $hostintdom = &internet_dom($perlvar{'lonHostID'});
+    if ($hostintdom ne '') {
+        my %iphost = &get_iphost();
+        my $primary_id = &domain($dom,'primary');
+        my $primary_ip = &get_host_ip($primary_id);
+        if (ref($iphost{$primary_ip}) eq 'ARRAY') {
+            foreach my $id (@{$iphost{$primary_ip}}) {
+                my $intdom = &internet_dom($id);
+                if ($intdom eq $hostintdom) {
+                    $same_intdom = 1;
+                    last;
+                }
+            }
+        }
+    }
+    return $same_intdom;
+}
+
 # ------------------------------------------------------------- Declutters URLs
 
 sub declutter {
@@ -12799,12 +13009,12 @@ sub get_dns {
 	&$func(\@content,$hashref);
 	return;
     }
-    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);
+    if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
+        my @content = <$config>;
+        &$func(\@content,$hashref);
+    }
     return;
 }
 
@@ -13416,6 +13626,11 @@ BEGIN {
 
 }
 
+# ------------- set default texengine (domain default overrides this)
+{
+    $deftex = LONCAPA::texengine();
+}
+
 $memcache=new Cache::Memcached({'servers'           => ['127.0.0.1:11211'],
 				'compress_threshold'=> 20_000,
  			        });