version 1.1283, 2015/04/15 18:56:19
|
version 1.1295, 2015/10/26 16:03:42
|
Line 92 use GDBM_File;
|
Line 92 use GDBM_File;
|
use HTML::LCParser; |
use HTML::LCParser; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
use Storable qw(thaw nfreeze); |
use Storable qw(thaw nfreeze); |
use Time::HiRes qw( gettimeofday tv_interval ); |
use Time::HiRes qw( sleep gettimeofday tv_interval ); |
use Cache::Memcached; |
use Cache::Memcached; |
use Digest::MD5; |
use Digest::MD5; |
use Math::Random; |
use Math::Random; |
Line 105 use LONCAPA::Lond;
|
Line 105 use LONCAPA::Lond;
|
use File::Copy; |
use File::Copy; |
|
|
my $readit; |
my $readit; |
my $max_connection_retries = 10; # Or some such value. |
my $max_connection_retries = 20; # Or some such value. |
|
|
require Exporter; |
require Exporter; |
|
|
Line 375 sub subreply {
|
Line 375 sub subreply {
|
|
|
my $lockfile=$peerfile.".lock"; |
my $lockfile=$peerfile.".lock"; |
while (-e $lockfile) { # Need to wait for the lockfile to disappear. |
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 |
# 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. |
# or loncnew child is listening so we can connect or everything's dead. |
Line 393 sub subreply {
|
Line 393 sub subreply {
|
} else { |
} else { |
&create_connection(&hostname($server),$server); |
&create_connection(&hostname($server),$server); |
} |
} |
sleep(1); # Try again later if failed connection. |
sleep(0.1); # Try again later if failed connection. |
} |
} |
my $answer; |
my $answer; |
if ($client) { |
if ($client) { |
Line 422 sub reply {
|
Line 422 sub reply {
|
|
|
sub reconlonc { |
sub reconlonc { |
my ($lonid) = @_; |
my ($lonid) = @_; |
my $hostname = &hostname($lonid); |
|
if ($lonid) { |
if ($lonid) { |
|
my $hostname = &hostname($lonid); |
my $peerfile="$perlvar{'lonSockDir'}/$hostname"; |
my $peerfile="$perlvar{'lonSockDir'}/$hostname"; |
if ($hostname && -e $peerfile) { |
if ($hostname && -e $peerfile) { |
&logthis("Trying to reconnect lonc for $lonid ($hostname)"); |
&logthis("Trying to reconnect lonc for $lonid ($hostname)"); |
Line 448 sub reconlonc {
|
Line 448 sub reconlonc {
|
&logthis("lonc at pid $loncpid responding, sending USR1"); |
&logthis("lonc at pid $loncpid responding, sending USR1"); |
kill USR1 => $loncpid; |
kill USR1 => $loncpid; |
sleep 1; |
sleep 1; |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=\"blue\">WARNING:". |
"<font color=\"blue\">WARNING:". |
" lonc at pid $loncpid not responding, giving up</font>"); |
" lonc at pid $loncpid not responding, giving up</font>"); |
Line 469 sub critical {
|
Line 469 sub critical {
|
} |
} |
my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc($server); |
my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
my $now=time; |
my $now=time; |
Line 486 sub critical {
|
Line 486 sub critical {
|
close($dfh); |
close($dfh); |
} |
} |
} |
} |
sleep 2; |
sleep 1; |
my $wcmd=''; |
my $wcmd=''; |
{ |
{ |
my $dfh; |
my $dfh; |
Line 1939 sub get_instuser {
|
Line 1939 sub get_instuser {
|
return ($outcome,%userinfo); |
return ($outcome,%userinfo); |
} |
} |
|
|
|
sub get_multiple_instusers { |
|
my ($udom,$users,$caller) = @_; |
|
my ($outcome,$results); |
|
if (ref($users) eq 'HASH') { |
|
my $count = keys(%{$users}); |
|
my $requested = &freeze_escape($users); |
|
my $homeserver = &domain($udom,'primary'); |
|
if ($homeserver ne '') { |
|
my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver); |
|
my $host=&hostname($homeserver); |
|
if ($queryid !~/^\Q$host\E\_/) { |
|
&logthis('get_multiple_instusers invalid queryid: '.$queryid. |
|
' for host: '.$homeserver.'in domain '.$udom); |
|
return ($outcome,$results); |
|
} |
|
my $response = &get_query_reply($queryid); |
|
my $maxtries = 5; |
|
if ($count > 100) { |
|
$maxtries = 1+int($count/20); |
|
} |
|
my $tries = 1; |
|
while (($response=~/^timeout/) && ($tries <= $maxtries)) { |
|
$response = &get_query_reply($queryid); |
|
$tries ++; |
|
} |
|
if ($response eq '') { |
|
$results = {}; |
|
foreach my $key (keys(%{$users})) { |
|
my ($uname,$id); |
|
if ($caller eq 'id') { |
|
$id = $key; |
|
} else { |
|
$uname = $key; |
|
} |
|
my ($resp,%info) = &get_instuser($udom,$uname,$id); |
|
$outcome = $resp; |
|
if ($resp eq 'ok') { |
|
%{$results} = (%{$results}, %info); |
|
} else { |
|
last; |
|
} |
|
} |
|
} elsif(!&error($response) && ($response ne 'refused')) { |
|
if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) { |
|
$outcome = $response; |
|
} else { |
|
($outcome,my $userdata) = split(/=/,$response,2); |
|
if ($outcome eq 'ok') { |
|
$results = &thaw_unescape($userdata); |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return ($outcome,$results); |
|
} |
|
|
sub inst_rulecheck { |
sub inst_rulecheck { |
my ($udom,$uname,$id,$item,$rules) = @_; |
my ($udom,$uname,$id,$item,$rules) = @_; |
my %returnhash; |
my %returnhash; |
Line 2101 sub get_domain_defaults {
|
Line 2158 sub get_domain_defaults {
|
} |
} |
} |
} |
} |
} |
|
if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { |
|
if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { |
|
my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}}; |
|
if (@clonecodes) { |
|
$domdefaults{'canclone'} = join('+',@clonecodes); |
|
} |
|
} |
|
} elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
|
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
|
} |
} |
} |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { |
Line 4270 sub courseiddump {
|
Line 4337 sub courseiddump {
|
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, |
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, |
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, |
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, |
$hasuniquecode)=@_; |
$hasuniquecode,$reqcrsdom,$reqinstcode)=@_; |
my $as_hash = 1; |
my $as_hash = 1; |
my %returnhash; |
my %returnhash; |
if (!$domfilter) { $domfilter=''; } |
if (!$domfilter) { $domfilter=''; } |
Line 4293 sub courseiddump {
|
Line 4360 sub courseiddump {
|
&escape($catfilter), $showhidden, $caller, |
&escape($catfilter), $showhidden, $caller, |
&escape($cloner), &escape($cc_clone), $cloneonly, |
&escape($cloner), &escape($cc_clone), $cloneonly, |
&escape($createdbefore), &escape($createdafter), |
&escape($createdbefore), &escape($createdafter), |
&escape($creationcontext), $domcloner, $hasuniquecode))); |
&escape($creationcontext),$domcloner,$hasuniquecode, |
|
$reqcrsdom,&escape($reqinstcode)))); |
} else { |
} else { |
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
$sincefilter.':'.&escape($descfilter).':'. |
Line 4304 sub courseiddump {
|
Line 4372 sub courseiddump {
|
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
$showhidden.':'.$caller.':'.&escape($cloner).':'. |
&escape($cc_clone).':'.$cloneonly.':'. |
&escape($cc_clone).':'.$cloneonly.':'. |
&escape($createdbefore).':'.&escape($createdafter).':'. |
&escape($createdbefore).':'.&escape($createdafter).':'. |
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode, |
&escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. |
$tryserver); |
':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); |
} |
} |
|
|
my @pairs=split(/\&/,$rep); |
my @pairs=split(/\&/,$rep); |
Line 7318 sub get_commblock_resources {
|
Line 7386 sub get_commblock_resources {
|
} |
} |
} |
} |
} |
} |
if ($interval[0] =~ /^\d+$/) { |
if ($interval[0] =~ /^\d+/) { |
|
my ($timelimit) = split(/_/,$interval[0]); |
my $first_access; |
my $first_access; |
if ($type eq 'resource') { |
if ($type eq 'resource') { |
$first_access=&get_first_access($interval[1],$item); |
$first_access=&get_first_access($interval[1],$item); |
Line 7328 sub get_commblock_resources {
|
Line 7397 sub get_commblock_resources {
|
$first_access=&get_first_access($interval[1]); |
$first_access=&get_first_access($interval[1]); |
} |
} |
if ($first_access) { |
if ($first_access) { |
my $timesup = $first_access+$interval[0]; |
my $timesup = $first_access+$timelimit; |
if ($timesup > $now) { |
if ($timesup > $now) { |
my $activeblock; |
my $activeblock; |
foreach my $res (@to_test) { |
foreach my $res (@to_test) { |
Line 7667 sub get_query_reply {
|
Line 7736 sub get_query_reply {
|
my $replyfile=LONCAPA::tempdir().$queryid; |
my $replyfile=LONCAPA::tempdir().$queryid; |
my $reply=''; |
my $reply=''; |
for (1..100) { |
for (1..100) { |
sleep 2; |
sleep(0.2); |
if (-e $replyfile.'.end') { |
if (-e $replyfile.'.end') { |
if (open(my $fh,$replyfile)) { |
if (open(my $fh,$replyfile)) { |
$reply = join('',<$fh>); |
$reply = join('',<$fh>); |
Line 8090 sub auto_crsreq_update {
|
Line 8159 sub auto_crsreq_update {
|
return \%crsreqresponse; |
return \%crsreqresponse; |
} |
} |
|
|
|
sub check_instcode_cloning { |
|
my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; |
|
unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { |
|
return; |
|
} |
|
my $canclone; |
|
if (@{$code_order} > 0) { |
|
my $instcoderegexp ='^'; |
|
my @clonecodes = split(/\&/,$cloner); |
|
foreach my $item (@{$code_order}) { |
|
if (grep(/^\Q$item\E=/,@clonecodes)) { |
|
foreach my $pair (@clonecodes) { |
|
my ($key,$val) = split(/\=/,$pair,2); |
|
$val = &unescape($val); |
|
if ($key eq $item) { |
|
$instcoderegexp .= '('.$val.')'; |
|
last; |
|
} |
|
} |
|
} else { |
|
$instcoderegexp .= $codedefaults->{$item}; |
|
} |
|
} |
|
$instcoderegexp .= '$'; |
|
my (@from,@to); |
|
eval { |
|
(@from) = ($clonefromcode =~ /$instcoderegexp/); |
|
(@to) = ($clonetocode =~ /$instcoderegexp/); |
|
}; |
|
if ((@from > 0) && (@to > 0)) { |
|
my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); |
|
if (!@diffs) { |
|
$canclone = 1; |
|
} |
|
} |
|
} |
|
return $canclone; |
|
} |
|
|
|
sub default_instcode_cloning { |
|
my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; |
|
my (%codedefaults,@code_order,$canclone); |
|
if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { |
|
%codedefaults = %{$codedefaultsref}; |
|
@code_order = @{$codeorderref}; |
|
} elsif ($clonedom) { |
|
&auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); |
|
} |
|
if (($domdefclone) && (@code_order)) { |
|
my @clonecodes = split(/\+/,$domdefclone); |
|
my $instcoderegexp ='^'; |
|
foreach my $item (@code_order) { |
|
if (grep(/^\Q$item\E$/,@clonecodes)) { |
|
$instcoderegexp .= '('.$codedefaults{$item}.')'; |
|
} else { |
|
$instcoderegexp .= $codedefaults{$item}; |
|
} |
|
} |
|
$instcoderegexp .= '$'; |
|
my (@from,@to); |
|
eval { |
|
(@from) = ($clonefromcode =~ /$instcoderegexp/); |
|
(@to) = ($clonetocode =~ /$instcoderegexp/); |
|
}; |
|
if ((@from > 0) && (@to > 0)) { |
|
my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); |
|
if (!@diffs) { |
|
$canclone = 1; |
|
} |
|
} |
|
} |
|
return $canclone; |
|
} |
|
|
# ------------------------------------------------------- Course Group routines |
# ------------------------------------------------------- Course Group routines |
|
|
sub get_coursegroups { |
sub get_coursegroups { |
Line 9436 sub modify_access_controls {
|
Line 9579 sub modify_access_controls {
|
my $tries = 0; |
my $tries = 0; |
my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
|
|
while (($gotlock ne 'ok') && $tries <3) { |
while (($gotlock ne 'ok') && $tries < 10) { |
$tries ++; |
$tries ++; |
sleep 1; |
sleep(0.1); |
$gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
$gotlock = &newput('file_permissions',$lockhash,$domain,$user); |
} |
} |
if ($gotlock eq 'ok') { |
if ($gotlock eq 'ok') { |
Line 10031 sub get_userresdata {
|
Line 10174 sub get_userresdata {
|
} |
} |
#error 2 occurs when the .db doesn't exist |
#error 2 occurs when the .db doesn't exist |
if ($tmp!~/error: 2 /) { |
if ($tmp!~/error: 2 /) { |
&logthis("<font color=\"blue\">WARNING:". |
if ((!defined($cached)) || ($tmp ne 'con_lost')) { |
" Trying to get resource data for ". |
&logthis("<font color=\"blue\">WARNING:". |
$uname." at ".$udom.": ". |
" Trying to get resource data for ". |
$tmp."</font>"); |
$uname." at ".$udom.": ". |
|
$tmp."</font>"); |
|
} |
} elsif ($tmp=~/error: 2 /) { |
} elsif ($tmp=~/error: 2 /) { |
#&EXT_cache_set($udom,$uname); |
#&EXT_cache_set($udom,$uname); |
&do_cache_new('userres',$hashid,undef,600); |
&do_cache_new('userres',$hashid,undef,600); |
Line 12252 sub fetch_dns_checksums {
|
Line 12397 sub fetch_dns_checksums {
|
} |
} |
|
|
sub load_domain_tab { |
sub load_domain_tab { |
my ($ignore_cache) = @_; |
my ($ignore_cache,$nocache) = @_; |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); |
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); |
my $fh; |
my $fh; |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { |
my @lines = <$fh>; |
my @lines = <$fh>; |
Line 12339 sub fetch_dns_checksums {
|
Line 12484 sub fetch_dns_checksums {
|
} |
} |
|
|
sub load_hosts_tab { |
sub load_hosts_tab { |
my ($ignore_cache) = @_; |
my ($ignore_cache,$nocache) = @_; |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); |
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); |
my @config = <$config>; |
my @config = <$config>; |
&parse_hosts_tab(\@config); |
&parse_hosts_tab(\@config); |
Line 12362 sub fetch_dns_checksums {
|
Line 12507 sub fetch_dns_checksums {
|
} |
} |
|
|
sub all_names { |
sub all_names { |
&load_hosts_tab() if (!$loaded); |
my ($ignore_cache,$nocache) = @_; |
|
&load_hosts_tab($ignore_cache,$nocache) if (!$loaded); |
|
|
return %name_to_host; |
return %name_to_host; |
} |
} |
Line 12484 sub fetch_dns_checksums {
|
Line 12630 sub fetch_dns_checksums {
|
} |
} |
|
|
sub get_iphost { |
sub get_iphost { |
my ($ignore_cache) = @_; |
my ($ignore_cache,$nocache) = @_; |
|
|
if (!$ignore_cache) { |
if (!$ignore_cache) { |
if (%iphost) { |
if (%iphost) { |
Line 12508 sub fetch_dns_checksums {
|
Line 12654 sub fetch_dns_checksums {
|
%old_name_to_ip = %{$ip_info->[1]}; |
%old_name_to_ip = %{$ip_info->[1]}; |
} |
} |
|
|
my %name_to_host = &all_names(); |
my %name_to_host = &all_names($ignore_cache,$nocache); |
foreach my $name (keys(%name_to_host)) { |
foreach my $name (keys(%name_to_host)) { |
my $ip; |
my $ip; |
if (!exists($name_to_ip{$name})) { |
if (!exists($name_to_ip{$name})) { |
Line 12533 sub fetch_dns_checksums {
|
Line 12679 sub fetch_dns_checksums {
|
} |
} |
push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
push(@{$iphost{$ip}},@{$name_to_host{$name}}); |
} |
} |
&do_cache_new('iphost','iphost', |
unless ($nocache) { |
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
&do_cache_new('iphost','iphost', |
48*60*60); |
[\%iphost,\%name_to_ip,\%lonid_to_ip], |
|
48*60*60); |
|
} |
|
|
return %iphost; |
return %iphost; |
} |
} |
Line 12726 BEGIN {
|
Line 12874 BEGIN {
|
my $item = $token->[1]; |
my $item = $token->[1]; |
my $name = $token->[2]{'name'}; |
my $name = $token->[2]{'name'}; |
my $value = $token->[2]{'value'}; |
my $value = $token->[2]{'value'}; |
if ($item ne '' && $name ne '' && $value ne '') { |
my $valuematch = $token->[2]{'valuematch'}; |
|
if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) { |
my $release = $parser->get_text(); |
my $release = $parser->get_text(); |
$release =~ s/(^\s*|\s*$ )//gx; |
$release =~ s/(^\s*|\s*$ )//gx; |
$needsrelease{$item.':'.$name.':'.$value} = $release; |
$needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release; |
} |
} |
} |
} |
} |
} |
Line 13052 escaped strings of the action recorded i
|
Line 13201 escaped strings of the action recorded i
|
|
|
=item * |
=item * |
|
|
allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions |
allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; |
|
returns codes for allowed actions. |
|
|
|
The first argument is required, all others are optional. |
|
|
|
$priv is the privilege being checked. |
|
$uri contains additional information about what is being checked for access (e.g., |
|
URL, course ID etc.). |
|
$symb is the unique resource instance identifier in a course; if needed, |
|
but not provided, it will be retrieved via a call to &symbread(). |
|
$role is the role for which a priv is being checked (only used if priv is evb). |
|
$clientip is the user's IP address (only used when checking for access to portfolio |
|
files). |
|
$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This |
|
prevents recursive calls to &allowed. |
|
|
F: full access |
F: full access |
U,I,K: authentication modes (cxx only) |
U,I,K: authentication modes (cxx only) |
'': forbidden |
'': forbidden |
1: user needs to choose course |
1: user needs to choose course |
2: browse allowed |
2: browse allowed |
A: passphrase authentication needed |
A: passphrase authentication needed |
|
B: access temporarily blocked because of a blocking event in a course. |
|
|
=item * |
=item * |
|
|