--- loncom/lonnet/perl/lonnet.pm 2016/08/05 15:34:27 1.1172.2.72
+++ loncom/lonnet/perl/lonnet.pm 2016/09/24 16:30:49 1.1172.2.82
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.72 2016/08/05 15:34:27 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.82 2016/09/24 16:30:49 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -89,7 +89,7 @@ use GDBM_File;
use HTML::LCParser;
use Fcntl qw(:flock);
use Storable qw(thaw nfreeze);
-use Time::HiRes qw( gettimeofday tv_interval );
+use Time::HiRes qw( sleep gettimeofday tv_interval );
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
@@ -102,7 +102,7 @@ use LONCAPA::Lond;
use File::Copy;
my $readit;
-my $max_connection_retries = 10; # Or some such value.
+my $max_connection_retries = 20; # Or some such value.
require Exporter;
@@ -370,7 +370,7 @@ sub subreply {
my $lockfile=$peerfile.".lock";
while (-e $lockfile) { # Need to wait for the lockfile to disappear.
- sleep(1);
+ sleep(0.1);
}
# At this point, either a loncnew parent is listening or an old lonc
# or loncnew child is listening so we can connect or everything's dead.
@@ -388,7 +388,7 @@ sub subreply {
} else {
&create_connection(&hostname($server),$server);
}
- sleep(1); # Try again later if failed connection.
+ sleep(0.1); # Try again later if failed connection.
}
my $answer;
if ($client) {
@@ -481,7 +481,7 @@ sub critical {
close($dfh);
}
}
- sleep 2;
+ sleep 1;
my $wcmd='';
{
my $dfh;
@@ -1283,7 +1283,7 @@ sub check_loadbalancing {
my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
my $intdom = &Apache::lonnet::internet_dom($lonhost);
my $serverhomedom = &host_domain($lonhost);
-
+ my $domneedscache;
my $cachetime = 60*60*24;
if (($uintdom ne '') && ($uintdom eq $intdom)) {
@@ -1298,6 +1298,8 @@ sub check_loadbalancing {
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
$result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
+ } else {
+ $domneedscache = $dom_in_use;
}
}
if (ref($result) eq 'HASH') {
@@ -1356,7 +1358,9 @@ sub check_loadbalancing {
my %domconfig =
&Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
- $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
+ $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime);
+ } else {
+ $domneedscache = $serverhomedom;
}
}
if (ref($result) eq 'HASH') {
@@ -1376,12 +1380,21 @@ sub check_loadbalancing {
$is_balancer = 1;
$offloadto = &this_host_spares($dom_in_use);
}
+ unless (defined($cached)) {
+ $domneedscache = $serverhomedom;
+ }
}
} else {
if ($perlvar{'lonBalancer'} eq 'yes') {
$is_balancer = 1;
$offloadto = &this_host_spares($dom_in_use);
}
+ unless (defined($cached)) {
+ $domneedscache = $serverhomedom;
+ }
+ }
+ if ($domneedscache) {
+ &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
}
if ($is_balancer) {
my $lowest_load = 30000;
@@ -1554,7 +1567,7 @@ sub idget {
my %servers = &get_servers($udom,'library');
foreach my $tryserver (keys(%servers)) {
- my $idlist=join('&',@ids);
+ my $idlist=join('&', map { &escape($_); } @ids);
$idlist=~tr/A-Z/a-z/;
my $reply=&reply("idget:$udom:".$idlist,$tryserver);
my @answer=();
@@ -1564,7 +1577,7 @@ sub idget {
my $i;
for ($i=0;$i<=$#ids;$i++) {
if ($answer[$i]) {
- $returnhash{$ids[$i]}=$answer[$i];
+ $returnhash{$ids[$i]}=&unescape($answer[$i]);
}
}
}
@@ -1793,7 +1806,7 @@ sub retrieve_inst_usertypes {
sub is_domainimage {
my ($url) = @_;
- if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
+ if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) {
if (&domain($1) ne '') {
return '1';
}
@@ -2087,7 +2100,7 @@ sub get_domain_defaults {
'requestcourses','inststatus',
'coursedefaults','usersessions',
'requestauthor','selfenrollment',
- 'coursecategories'],$domain);
+ 'coursecategories','autoenroll'],$domain);
my @coursetypes = ('official','unofficial','community','textbook');
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
@@ -2212,6 +2225,9 @@ sub get_domain_defaults {
$domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
}
}
+ if (ref($domconfig{'autoenroll'}) eq 'HASH') {
+ $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
+ }
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
return %domdefaults;
}
@@ -2452,21 +2468,25 @@ sub make_key {
sub devalidate_cache_new {
my ($name,$id,$debug) = @_;
if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
+ my $remembered_id=$name.':'.$id;
$id=&make_key($name,$id);
$memcache->delete($id);
- delete($remembered{$id});
- delete($accessed{$id});
+ delete($remembered{$remembered_id});
+ delete($accessed{$remembered_id});
}
sub is_cached_new {
my ($name,$id,$debug) = @_;
- $id=&make_key($name,$id);
- if (exists($remembered{$id})) {
- if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
- $accessed{$id}=[&gettimeofday()];
+ my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for
+ # keys in %remembered hash, which persists for
+ # duration of request (no restriction on key length).
+ if (exists($remembered{$remembered_id})) {
+ if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
+ $accessed{$remembered_id}=[&gettimeofday()];
$hits++;
- return ($remembered{$id},1);
+ return ($remembered{$remembered_id},1);
}
+ $id=&make_key($name,$id);
my $value = $memcache->get($id);
if (!(defined($value))) {
if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
@@ -2476,13 +2496,14 @@ sub is_cached_new {
if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
$value=undef;
}
- &make_room($id,$value,$debug);
+ &make_room($remembered_id,$value,$debug);
if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
return ($value,1);
}
sub do_cache_new {
my ($name,$id,$value,$time,$debug) = @_;
+ my $remembered_id=$name.':'.$id;
$id=&make_key($name,$id);
my $setvalue=$value;
if (!defined($setvalue)) {
@@ -2498,17 +2519,17 @@ sub do_cache_new {
$memcache->disconnect_all();
}
# need to make a copy of $value
- &make_room($id,$value,$debug);
+ &make_room($remembered_id,$value,$debug);
return $value;
}
sub make_room {
- my ($id,$value,$debug)=@_;
+ my ($remembered_id,$value,$debug)=@_;
- $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
+ $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)
: $value;
if ($to_remember<0) { return; }
- $accessed{$id}=[&gettimeofday()];
+ $accessed{$remembered_id}=[&gettimeofday()];
if (scalar(keys(%remembered)) <= $to_remember) { return; }
my $to_kick;
my $max_time=0;
@@ -3902,10 +3923,19 @@ sub flushcourselogs {
delete $domainrolehash{$entry};
}
foreach my $dom (keys(%domrolebuffer)) {
- my %servers = &get_servers($dom,'library');
+ my %servers;
+ if (defined(&domain($dom,'primary'))) {
+ my $primary=&domain($dom,'primary');
+ my $hostname=&hostname($primary);
+ $servers{$primary} = $hostname;
+ } else {
+ %servers = &get_servers($dom,'library');
+ }
foreach my $tryserver (keys(%servers)) {
- unless (&reply('domroleput:'.$dom.':'.
- $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ if (&reply('domroleput:'.$dom.':'.
+ $domrolebuffer{$dom},$tryserver) eq 'ok') {
+ last;
+ } else {
&logthis('Put of domain roles failed for '.$dom.' and '.$tryserver);
}
}
@@ -6219,9 +6249,9 @@ sub sixnum_code {
# -------------------------------------------------- portfolio access checking
sub portfolio_access {
- my ($requrl) = @_;
+ my ($requrl,$clientip) = @_;
my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
- my $result = &get_portfolio_access($udom,$unum,$file_name,$group);
+ my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
if ($result) {
my %setters;
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
@@ -6247,7 +6277,7 @@ sub portfolio_access {
}
sub get_portfolio_access {
- my ($udom,$unum,$file_name,$group,$access_hash) = @_;
+ my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
if (!ref($access_hash)) {
my $current_perms = &get_portfile_permissions($udom,$unum);
@@ -6256,7 +6286,7 @@ sub get_portfolio_access {
$access_hash = $access_controls{$file_name};
}
- my ($public,$guest,@domains,@users,@courses,@groups);
+ my ($public,$guest,@domains,@users,@courses,@groups,@ips);
my $now = time;
if (ref($access_hash) eq 'HASH') {
foreach my $key (keys(%{$access_hash})) {
@@ -6280,10 +6310,25 @@ sub get_portfolio_access {
push(@courses,$key);
} elsif ($scope eq 'group') {
push(@groups,$key);
+ } elsif ($scope eq 'ip') {
+ push(@ips,$key);
}
}
if ($public) {
return 'ok';
+ } elsif (@ips > 0) {
+ my $allowed;
+ foreach my $ipkey (@ips) {
+ if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
+ if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
+ $allowed = 1;
+ last;
+ }
+ }
+ }
+ if ($allowed) {
+ return 'ok';
+ }
}
if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
if ($guest) {
@@ -7003,7 +7048,7 @@ sub allowed {
&& $thisallowed ne 'F'
&& $thisallowed ne '2'
&& &is_portfolio_url($uri)) {
- $thisallowed = &portfolio_access($uri);
+ $thisallowed = &portfolio_access($uri,$clientip);
}
# Full access at system, domain or course-wide level? Exit.
@@ -7724,10 +7769,12 @@ sub update_allusers_table {
sub fetch_enrollment_query {
my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
- my $homeserver;
+ my ($homeserver,$sleep,$loopmax);
my $maxtries = 1;
if ($context eq 'automated') {
$homeserver = $perlvar{'lonHostID'};
+ $sleep = 2;
+ $loopmax = 100;
$maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
} else {
$homeserver = &homeserver($cnum,$dom);
@@ -7745,17 +7792,17 @@ sub fetch_enrollment_query {
&logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);
return 'error: '.$queryid;
}
- my $reply = &get_query_reply($queryid);
+ my $reply = &get_query_reply($queryid,$sleep.$loopmax);
my $tries = 1;
while (($reply=~/^timeout/) && ($tries < $maxtries)) {
- $reply = &get_query_reply($queryid);
+ $reply = &get_query_reply($queryid,$sleep,$loopmax);
$tries ++;
}
if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
&logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
} else {
my @responses = split(/:/,$reply);
- if ($homeserver eq $perlvar{'lonHostID'}) {
+ if (grep { $_ eq $homeserver } ¤t_machine_ids()) {
foreach my $line (@responses) {
my ($key,$value) = split(/=/,$line,2);
$$replyref{$key} = $value;
@@ -7790,11 +7837,17 @@ sub fetch_enrollment_query {
}
sub get_query_reply {
- my $queryid=shift;
+ my ($queryid,$sleep,$loopmax) = @_;
+ if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
+ $sleep = 0.2;
+ }
+ if (($loopmax eq '') || ($loopmax =~ /\D/)) {
+ $loopmax = 100;
+ }
my $replyfile=LONCAPA::tempdir().$queryid;
my $reply='';
- for (1..100) {
- sleep 2;
+ for (1..$loopmax) {
+ sleep($sleep);
if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {
$reply = join('',<$fh>);
@@ -8216,6 +8269,33 @@ sub auto_crsreq_update {
return \%crsreqresponse;
}
+sub auto_export_grades {
+ my ($cdom,$cnum,$inforef,$gradesref) = @_;
+ my ($homeserver,%exportresponse);
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
+ my $info;
+ if (ref($inforef) eq 'HASH') {
+ $info = &freeze_escape($inforef);
+ }
+ if (ref($gradesref) eq 'HASH') {
+ my $grades = &freeze_escape($gradesref);
+ my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
+ $info.':'.$grades,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
+ my @items = split(/&/,$response);
+ foreach my $item (@items) {
+ my ($key,$value) = split('=',$item);
+ $exportresponse{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
+ }
+ return \%exportresponse;
+}
+
sub check_instcode_cloning {
my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
@@ -8959,7 +9039,7 @@ sub modifyuser {
sub modifystudent {
my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
$end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
- $selfenroll,$context,$inststatus,$credits)=@_;
+ $selfenroll,$context,$inststatus,$credits,$instsec)=@_;
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
return 'not_in_class';
@@ -8975,13 +9055,13 @@ sub modifystudent {
$uid = undef if (!$forceid);
$reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
$gene,$usec,$end,$start,$type,$locktype,
- $cid,$selfenroll,$context,$credits);
+ $cid,$selfenroll,$context,$credits,$instsec);
return $reply;
}
sub modify_student_enrollment {
my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
- $locktype,$cid,$selfenroll,$context,$credits) = @_;
+ $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_;
my ($cdom,$cnum,$chome);
if (!$cid) {
unless ($cid=$env{'request.course.id'}) {
@@ -9028,7 +9108,7 @@ sub modify_student_enrollment {
my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
my $reply=cput('classlist',
{$user =>
- join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },
+ join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) },
$cdom,$cnum);
if (($reply eq 'ok') || ($reply eq 'delayed')) {
&devalidate_getsection_cache($udom,$uname,$cid);
@@ -9552,9 +9632,9 @@ sub modify_access_controls {
my $tries = 0;
my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
- while (($gotlock ne 'ok') && $tries <3) {
+ while (($gotlock ne 'ok') && $tries < 10) {
$tries ++;
- sleep 1;
+ sleep(0.1);
$gotlock = &newput('file_permissions',$lockhash,$domain,$user);
}
if ($gotlock eq 'ok') {
@@ -9847,7 +9927,23 @@ sub dirlist {
foreach my $user (sort(keys(%allusers))) {
push(@alluserslist,$user.'&user');
}
- return (\@alluserslist);
+ if (!%listerror) {
+ # no errors
+ return (\@alluserslist);
+ } elsif (scalar(keys(%servers)) == 1) {
+ # one library server, one error
+ my ($key) = keys(%listerror);
+ return (\@alluserslist, $listerror{$key});
+ } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
+ # con_lost indicates that we might miss data from at least one
+ # library server
+ return (\@alluserslist, 'con_lost');
+ } else {
+ # multiple library servers and no con_lost -> data should be
+ # complete.
+ return (\@alluserslist);
+ }
+
} else {
return ([],'missing username');
}
@@ -13336,6 +13432,8 @@ Inputs:
=item $credits, number of credits student will earn from this class
+=item $instsec, institutional course section code for student
+
=back