--- loncom/lonnet/perl/lonnet.pm	2011/08/01 22:13:49	1.1123
+++ loncom/lonnet/perl/lonnet.pm	2011/08/09 01:35:24	1.1129
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.1123 2011/08/01 22:13:49 raeburn Exp $
+# $Id: lonnet.pm,v 1.1129 2011/08/09 01:35:24 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -308,40 +308,48 @@ sub get_server_homeID {
 
 sub get_remote_globals {
     my ($lonhost,$whathash,$ignore_cache) = @_;
-    my (%returnhash,%whatneeded);
-    if (ref($whathash) eq 'ARRAY') {
+    my ($result,%returnhash,%whatneeded);
+    if (ref($whathash) eq 'HASH') {
         foreach my $what (sort(keys(%{$whathash}))) {
-            my $type = $whathash->{$what};
             my $hashid = $lonhost.'-'.$what;
-            my ($result,$cached); 
+            my ($response,$cached);
             unless ($ignore_cache) {
-                ($result,$cached)=&is_cached_new('lonnetglobal',$hashid);
-                $returnhash{$what} = $result;
+                ($response,$cached)=&is_cached_new('lonnetglobal',$hashid);
             }
             if (defined($cached)) {
-                $returnhash{$what} = $result;
+                $returnhash{$what} = $response;
             } else {
-                $whatneeded{$what} = $type;
+                $whatneeded{$what} = 1;
             }
         }
-        if (keys(%whatneeded) > 0) {
+        if (keys(%whatneeded) == 0) {
+            $result = 'ok';
+        } else {
             my $requested = &freeze_escape(\%whatneeded);
             my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
-            unless (($rep=~/^refused/) || ($rep=~/^rejected/) || ($rep eq 'con_lost')) {
+            if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
+                ($rep eq 'unknown_cmd')) {
+                $result = $rep;
+            } else {
+                $result = 'ok';
                 my @pairs=split(/\&/,$rep);
-                if ($rep !~ /^error/) {
-                    foreach my $item (@pairs) {
-                        my ($key,$value)=split(/=/,$item,2);
-                        my $what = &unescape($key);
-                        my $hashid = $lonhost.'-'.$what;
-                        $returnhash{$what}=&thaw_unescape($value);
-                        &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
-                    }
+                foreach my $item (@pairs) {
+                    my ($key,$value)=split(/=/,$item,2);
+                    my $what = &unescape($key);
+                    my $hashid = $lonhost.'-'.$what;
+                    $returnhash{$what}=&thaw_unescape($value);
+                    &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
                 }
             }
         }
     }
-    return %returnhash;
+    return ($result,\%returnhash);
+}
+
+sub remote_devalidate_cache {
+    my ($lonhost,$name,$id) = @_;
+    my $response = &reply('devalidatecache',&escape($name).':'.&escape($id),$lonhost);
+    return $response;
 }
 
 # -------------------------------------------------- Non-critical communication
@@ -1134,43 +1142,298 @@ sub spare_can_host {
 
 sub this_host_spares {
     my ($dom) = @_;
-    my $cachetime = 60*60*24;
+    my ($dom_in_use,$lonhost_in_use,$result);
     my @hosts = &current_machine_ids();
     foreach my $lonhost (@hosts) {
         if (&host_domain($lonhost) eq $dom) {
-            my ($result,$cached)=&is_cached_new('spares',$dom);
-            if (defined($cached)) {
-                return $result;
-            } else {
-                my %domconfig =
-                    &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
-                if (ref($domconfig{'usersessions'}) eq 'HASH') {
-                    if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
-                        if (ref($domconfig{'usersessions'}{'spares'}{$lonhost}) eq 'HASH') {
-                            return &do_cache_new('spares',$dom,$domconfig{'usersessions'}{'spares'}{$lonhost},$cachetime);
+            $dom_in_use = $dom;
+            $lonhost_in_use = $lonhost;
+            last;
+        }
+    }
+    if ($dom_in_use ne '') {
+        $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
+    }
+    if (ref($result) ne 'HASH') {
+        $lonhost_in_use = $perlvar{'lonHostID'};
+        $dom_in_use = &host_domain($lonhost_in_use);
+        $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
+        if (ref($result) ne 'HASH') {
+            $result = \%spareid;
+        }
+    }
+    return $result;
+}
+
+sub spares_for_offload  {
+    my ($dom_in_use,$lonhost_in_use) = @_;
+    my ($result,$cached)=&is_cached_new('spares',$dom_in_use);
+    if (defined($cached)) {
+        return $result;
+    } else {
+        my $cachetime = 60*60*24;
+        my %domconfig =
+            &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);
+        if (ref($domconfig{'usersessions'}) eq 'HASH') {
+            if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
+                if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
+                    return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime);
+                }
+            }
+        }
+    }
+    return;
+}
+
+sub get_lonbalancer_config {
+    my ($servers) = @_;
+    my ($currbalancer,$currtargets);
+    if (ref($servers) eq 'HASH') {
+        foreach my $server (keys(%{$servers})) {
+            my %what = (
+                         spareid => 1,
+                         perlvar => 1,
+                       );
+            my ($result,$returnhash) = &get_remote_globals($server,\%what);
+            if ($result eq 'ok') {
+                if (ref($returnhash) eq 'HASH') {
+                    if (ref($returnhash->{'perlvar'}) eq 'HASH') {
+                        if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') {
+                            $currbalancer = $server;
+                            $currtargets = {};
+                            if (ref($returnhash->{'spareid'}) eq 'HASH') {
+                                if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') {
+                                    $currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'};
+                                }
+                                if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') {
+                                    $currtargets->{'default'} = $returnhash->{'spareid'}->{'default'};
+                                }
+                            }
+                            last;
                         }
                     }
                 }
             }
-            last;
         }
     }
-    my $serverhomedom = &host_domain($perlvar{'lonHostID'});
-    my ($result,$cached)=&is_cached_new('spares',$serverhomedom);
-    if (defined($cached)) {
-        return $result;
+    return ($currbalancer,$currtargets);
+}
+
+sub check_loadbalancing {
+    my ($uname,$udom) = @_;
+    my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
+        $offloadto,$otherserver);
+    my $lonhost = $perlvar{'lonHostID'};
+    my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+    my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
+    my $intdom = &Apache::lonnet::internet_dom($lonhost);
+    my $serverhomedom = &host_domain($lonhost);
+
+    my $cachetime = 60*60*24;
+
+    if (($uintdom ne '') && ($uintdom eq $intdom)) {
+        $dom_in_use = $udom;
+        $homeintdom = 1;
+    } else {
+        $dom_in_use = $serverhomedom;
+    }
+    my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
+    unless (defined($cached)) {
+        my %domconfig =
+            &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
+        if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+            $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'usersessions'}{'loadbalancing'},$cachetime);
+        }
+    }
+    if (ref($result) eq 'HASH') {
+        my $currbalancer = $result->{'lonhost'};
+        my $currtargets = $result->{'targets'};
+        my $currrules = $result->{'rules'};
+        if ($currbalancer ne '') {
+            my @hosts = &current_machine_ids();
+            if (grep(/^\Q$currbalancer\E$/,@hosts)) {
+                $is_balancer = 1;
+            }
+        }
+        if ($is_balancer) {
+            if (ref($currrules) eq 'HASH') {
+                if ($homeintdom) {
+                    if ($uname ne '') {
+                        if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) {
+                            my ($is_adv,$is_author) = &is_advanced_user($udom,$uname);
+                            if (($currrules->{'_LC_author'} ne '') && ($is_author)) {
+                                $rule_in_effect = $currrules->{'_LC_author'};
+                            } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) {
+                                $rule_in_effect = $currrules->{'_LC_adv'}
+                            }
+                        }
+                        if ($rule_in_effect eq '') {
+                            my %userenv = &userenvironment($udom,$uname,'inststatus');
+                            if ($userenv{'inststatus'} ne '') {
+                                my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'});
+                                my ($othertitle,$usertypes,$types) =
+                                    &Apache::loncommon::sorted_inst_types($udom);
+                                if (ref($types) eq 'ARRAY') {
+                                    foreach my $type (@{$types}) {
+                                        if (grep(/^\Q$type\E$/,@statuses)) {
+                                            if (exists($currrules->{$type})) {
+                                                $rule_in_effect = $currrules->{$type};
+                                            }
+                                        }
+                                    }
+                                }
+                            } else {
+                                if (exists($currrules->{'default'})) {
+                                    $rule_in_effect = $currrules->{'default'};
+                                }
+                            }
+                        }
+                    } else {
+                        if (exists($currrules->{'default'})) {
+                            $rule_in_effect = $currrules->{'default'};
+                        }
+                    }
+                } else {
+                    if ($currrules->{'_LC_external'} ne '') {
+                        $rule_in_effect = $currrules->{'_LC_external'};
+                    }
+                }
+                $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
+                                                       $uname,$udom);
+            }
+        }
+    } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
+        my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
+        unless (defined($cached)) {
+            my %domconfig =
+                &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
+            if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+                $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'usersessions'}{'loadbalancing'},$cachetime);
+            }
+        }
+        if (ref($result) eq 'HASH') {
+            my $currbalancer = $result->{'lonhost'};
+            my $currtargets = $result->{'targets'};
+            my $currrules = $result->{'rules'};
+
+            if ($currbalancer eq $lonhost) {
+                $is_balancer = 1;
+                if (ref($currrules) eq 'HASH') {
+                    if ($currrules->{'_LC_internetdom'} ne '') {
+                        $rule_in_effect = $currrules->{'_LC_internetdom'};
+                    }
+                }
+                $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
+                                                       $uname,$udom);
+            }
+        } else {
+            if ($perlvar{'lonBalancer'} eq 'yes') {
+                $is_balancer = 1;
+                $offloadto = &this_host_spares($dom_in_use);
+            }
+        }
     } else {
-        my %homedomconfig =
-            &Apache::lonnet::get_dom('configuration',['usersessions'],$serverhomedom);
-        if (ref($homedomconfig{'usersessions'}) eq 'HASH') {
-            if (ref($homedomconfig{'usersessions'}{'spares'}) eq 'HASH') {
-                if (ref($homedomconfig{'usersessions'}{'spares'}{$perlvar{'lonHostID'}}) eq 'HASH') {
-                    return &do_cache_new('spares',$serverhomedom,$homedomconfig{'usersessions'}{'spares'}{$perlvar{'lonHostID'}},$cachetime);
+        if ($perlvar{'lonBalancer'} eq 'yes') {
+            $is_balancer = 1;
+            $offloadto = &this_host_spares($dom_in_use);
+        }
+    }
+    my $lowest_load = 30000;
+    if (ref($offloadto) eq 'HASH') {
+        if (ref($offloadto->{'primary'}) eq 'ARRAY') {
+            foreach my $try_server (@{$offloadto->{'primary'}}) {
+                ($otherserver,$lowest_load) =
+                    &compare_server_load($try_server,$otherserver,$lowest_load);
+            }
+        }
+        my $found_server = ($otherserver ne '' && $lowest_load < 100);
+
+        if (!$found_server) {
+            if (ref($offloadto->{'default'}) eq 'ARRAY') {
+                foreach my $try_server (@{$offloadto->{'default'}}) {
+                    ($otherserver,$lowest_load) =
+                        &compare_server_load($try_server,$otherserver,$lowest_load);
                 }
             }
         }
+    } elsif (ref($offloadto) eq 'ARRAY') {
+        if (@{$offloadto} == 1) {
+            $otherserver = $offloadto->[0];
+        } elsif (@{$offloadto} > 1) {
+            foreach my $try_server (@{$offloadto}) {
+                ($otherserver,$lowest_load) =
+                    &compare_server_load($try_server,$otherserver,$lowest_load);
+            }
+        }
+    }
+    return ($is_balancer,$otherserver);
+}
+
+sub get_loadbalancer_targets {
+    my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
+    my $offloadto;
+    if ($rule_in_effect eq '') {
+        $offloadto = $currtargets;
+    } else {
+        if ($rule_in_effect eq 'homeserver') {
+            my $homeserver = &homeserver($uname,$udom);
+            if ($homeserver ne 'no_host') {
+                $offloadto = [$homeserver];
+            }
+        } elsif ($rule_in_effect eq 'externalbalancer') {
+            my %domconfig =
+                &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+            if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+                if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
+                    if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
+                        $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}];
+                    }
+                }
+            } else {
+                my %servers = &dom_servers($udom);
+                my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
+                if (&hostname($remotebalancer) ne '') {
+                    $offloadto = [$remotebalancer];
+                }
+            }
+        } elsif (&hostname($rule_in_effect) ne '') {
+            $offloadto = [$rule_in_effect];
+        }
+    }
+    return $offloadto;
+}
+
+sub internet_dom_servers {
+    my ($dom) = @_;
+    my (%uniqservers,%servers);
+    my $primaryserver = &hostname(&domain($dom,'primary'));
+    my @machinedoms = &machine_domains($primaryserver);
+    foreach my $mdom (@machinedoms) {
+        my %currservers = %servers;
+        my %server = &get_servers($mdom);
+        %servers = (%currservers,%server);
+    }
+    my %by_hostname;
+    foreach my $id (keys(%servers)) {
+        push(@{$by_hostname{$servers{$id}}},$id);
+    }
+    foreach my $hostname (sort(keys(%by_hostname))) {
+        if (@{$by_hostname{$hostname}} > 1) {
+            my $match = 0;
+            foreach my $id (@{$by_hostname{$hostname}}) {
+                if (&host_domain($id) eq $dom) {
+                    $uniqservers{$id} = $hostname;
+                    $match = 1;
+                }
+            }
+            unless ($match) {
+                $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
+            }
+        } else {
+            $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
+        }
     }
-    return \%spareid;
+    return %uniqservers;
 }
 
 # ---------------------- Find the homebase for a user from domain's lib servers
@@ -5333,12 +5596,16 @@ sub is_advanced_user {
     my ($udom,$uname) = @_;
     if ($udom ne '' && $uname ne '') {
         if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
-            return $env{'user.adv'};  
+            if (wantarray) {
+                return ($env{'user.adv'},$env{'user.author'});
+            } else {
+                return $env{'user.adv'};
+            }
         }
     }
     my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
     my %allroles;
-    my $is_adv;
+    my ($is_adv,$is_author);
     foreach my $role (keys(%roleshash)) {
         my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
         my $area = '/'.$tdomain.'/'.$trest;
@@ -5352,6 +5619,9 @@ sub is_advanced_user {
             } elsif ($trole ne 'gr') {
                 &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
             }
+            if ($trole eq 'au') {
+                $is_author = 1;
+            }
         }
     }
     foreach my $role (keys(%allroles)) {
@@ -5366,6 +5636,9 @@ sub is_advanced_user {
             }
         }
     }
+    if (wantarray) {
+        return ($is_adv,$is_author);
+    }
     return $is_adv;
 }