version 1.1058, 2010/03/21 21:05:51
|
version 1.1068, 2010/06/03 01:46:43
|
Line 665 sub userload {
|
Line 665 sub userload {
|
return $userloadpercent; |
return $userloadpercent; |
} |
} |
|
|
# ------------------------------------------ Fight off request when overloaded |
|
|
|
sub overloaderror { |
|
my ($r,$checkserver)=@_; |
|
unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; } |
|
my $loadavg; |
|
if ($checkserver eq $perlvar{'lonHostID'}) { |
|
open(my $loadfile,'/proc/loadavg'); |
|
$loadavg=<$loadfile>; |
|
$loadavg =~ s/\s.*//g; |
|
$loadavg = 100*$loadavg/$perlvar{'lonLoadLim'}; |
|
close($loadfile); |
|
} else { |
|
$loadavg=&reply('load',$checkserver); |
|
} |
|
my $overload=$loadavg-100; |
|
if ($overload>0) { |
|
$r->err_headers_out->{'Retry-After'}=$overload; |
|
$r->log_error('Overload of '.$overload.' on '.$checkserver); |
|
return 413; |
|
} |
|
return ''; |
|
} |
|
|
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
Line 3943 sub standard_roleprivs {
|
Line 3919 sub standard_roleprivs {
|
} |
} |
|
|
sub set_userprivs { |
sub set_userprivs { |
my ($userroles,$allroles,$allgroups) = @_; |
my ($userroles,$allroles,$allgroups,$groups_roles) = @_; |
my $author=0; |
my $author=0; |
my $adv=0; |
my $adv=0; |
my %grouproles = (); |
my %grouproles = (); |
if (keys(%{$allgroups}) > 0) { |
if (keys(%{$allgroups}) > 0) { |
|
my @groupkeys; |
foreach my $role (keys(%{$allroles})) { |
foreach my $role (keys(%{$allroles})) { |
my ($trole,$area,$sec,$extendedarea); |
push(@groupkeys,$role); |
if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { |
} |
$trole = $1; |
if (ref($groups_roles) eq 'HASH') { |
$area = $2; |
foreach my $key (keys(%{$groups_roles})) { |
$sec = $3; |
unless (grep(/^\Q$key\E$/,@groupkeys)) { |
$extendedarea = $area.$sec; |
push(@groupkeys,$key); |
if (exists($$allgroups{$area})) { |
} |
foreach my $group (keys(%{$$allgroups{$area}})) { |
} |
my $spec = $trole.'.'.$extendedarea; |
} |
$grouproles{$spec.'.'.$area.'/'.$group} = |
if (@groupkeys > 0) { |
|
foreach my $role (@groupkeys) { |
|
my ($trole,$area,$sec,$extendedarea); |
|
if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) { |
|
$trole = $1; |
|
$area = $2; |
|
$sec = $3; |
|
$extendedarea = $area.$sec; |
|
if (exists($$allgroups{$area})) { |
|
foreach my $group (keys(%{$$allgroups{$area}})) { |
|
my $spec = $trole.'.'.$extendedarea; |
|
$grouproles{$spec.'.'.$area.'/'.$group} = |
$$allgroups{$area}{$group}; |
$$allgroups{$area}{$group}; |
|
} |
} |
} |
} |
} |
} |
} |
Line 4006 sub role_status {
|
Line 3995 sub role_status {
|
if ($$tstart<$now) { |
if ($$tstart<$now) { |
if ($$tstart && $$tstart>$refresh) { |
if ($$tstart && $$tstart>$refresh) { |
if (($$where ne '') && ($$role ne '')) { |
if (($$where ne '') && ($$role ne '')) { |
my (%allroles,%allgroups,$group_privs); |
my (%allroles,%allgroups,$group_privs, |
|
%groups_roles,@rolecodes); |
my %userroles = ( |
my %userroles = ( |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend |
); |
); |
|
@rolecodes = ('cm'); |
my $spec=$$role.'.'.$$where; |
my $spec=$$role.'.'.$$where; |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
my ($tdummy,$tdomain,$trest)=split(/\//,$$where); |
if ($$role =~ /^cr\//) { |
if ($$role =~ /^cr\//) { |
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); |
&custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where); |
|
push(@rolecodes,'cr'); |
} elsif ($$role eq 'gr') { |
} elsif ($$role eq 'gr') { |
|
push(@rolecodes,$$role); |
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, |
my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'}, |
$env{'user.name'}); |
$env{'user.name'}); |
my $trole = split('_',$rolehash{$$where.'_'.$$role},1); |
my ($trole) = split('_',$rolehash{$$where.'_'.$$role},2); |
(undef,my $group_privs) = split(/\//,$trole); |
(undef,my $group_privs) = split(/\//,$trole); |
$group_privs = &unescape($group_privs); |
$group_privs = &unescape($group_privs); |
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); |
&group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart); |
|
my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1); |
|
if (keys(%course_roles) > 0) { |
|
my ($tnum) = ($trest =~ /^($match_courseid)/); |
|
if ($tdomain ne '' && $tnum ne '') { |
|
foreach my $key (keys(%course_roles)) { |
|
if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) { |
|
my $crsrole = $1; |
|
my $crssec = $2; |
|
if ($crsrole =~ /^cr/) { |
|
unless (grep(/^cr$/,@rolecodes)) { |
|
push(@rolecodes,'cr'); |
|
} |
|
} else { |
|
unless(grep(/^\Q$crsrole\E$/,@rolecodes)) { |
|
push(@rolecodes,$crsrole); |
|
} |
|
} |
|
my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum; |
|
if ($crssec ne '') { |
|
$rolekey .= '/'.$crssec; |
|
} |
|
$rolekey .= './'; |
|
$groups_roles{$rolekey} = \@rolecodes; |
|
} |
|
} |
|
} |
|
} |
} else { |
} else { |
|
push(@rolecodes,$$role); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
} |
} |
my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups); |
my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); |
&appenv(\%userroles,[$$role,'cm']); |
&appenv(\%userroles,\@rolecodes); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); |
} |
} |
} |
} |
Line 4539 sub get_portfolio_access {
|
Line 4560 sub get_portfolio_access {
|
my (%allgroups,%allroles); |
my (%allgroups,%allroles); |
my ($start,$end,$role,$sec,$group); |
my ($start,$end,$role,$sec,$group); |
foreach my $envkey (%env) { |
foreach my $envkey (%env) { |
if ($envkey =~ m-^user\.role\.(gr|cc|in|ta|ep|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
if ($envkey =~ m-^user\.role\.(gr|cc|co|in|ta|ep|ad|st)\./($match_domain)/($match_courseid)/?([^/]*)$-) { |
my $cid = $2.'_'.$3; |
my $cid = $2.'_'.$3; |
if ($1 eq 'gr') { |
if ($1 eq 'gr') { |
$group = $4; |
$group = $4; |
Line 5727 sub auto_validate_instcode {
|
Line 5748 sub auto_validate_instcode {
|
$homeserver = &domain($cdom,'primary'); |
$homeserver = &domain($cdom,'primary'); |
} |
} |
} |
} |
my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. |
$response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'. |
&escape($instcode).':'.&escape($owner),$homeserver)); |
&escape($instcode).':'.&escape($owner),$homeserver)); |
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); |
my ($outcome,$description) = map { &unescape($_); } split('&',$response,2); |
return ($outcome,$description); |
return ($outcome,$description); |
} |
} |
Line 6234 sub assignrole {
|
Line 6255 sub assignrole {
|
if ($role eq 'cc' || $role eq 'co') { |
if ($role eq 'cc' || $role eq 'co') { |
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner')); |
if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { |
if (($role eq 'cc') && ($cnum !~ /^$match_community$/)) { |
|
|
if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { |
if ($env{'request.role'} eq 'cc./'.$cdom.'/'.$cnum) { |
if ($crsenv{'internal.courseowner'} eq |
if ($crsenv{'internal.courseowner'} eq |
$env{'user.name'}.':'.$env{'user.domain'}) { |
$env{'user.name'}.':'.$env{'user.domain'}) { |
Line 6443 sub modifyuser {
|
Line 6463 sub modifyuser {
|
$forceid, $desiredhome, $email, $inststatus, $candelete)=@_; |
$forceid, $desiredhome, $email, $inststatus, $candelete)=@_; |
$udom= &LONCAPA::clean_domain($udom); |
$udom= &LONCAPA::clean_domain($udom); |
$uname=&LONCAPA::clean_username($uname); |
$uname=&LONCAPA::clean_username($uname); |
|
my $showcandelete = 'none'; |
|
if (ref($candelete) eq 'ARRAY') { |
|
if (@{$candelete} > 0) { |
|
$showcandelete = join(', ',@{$candelete}); |
|
} |
|
} |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
&logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '. |
$umode.', '.$first.', '.$middle.', '. |
$umode.', '.$first.', '.$middle.', '. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$candelete.')'. |
$last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'. |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
(defined($desiredhome) ? ' desiredhome = '.$desiredhome : |
' desiredhome not specified'). |
' desiredhome not specified'). |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
' by '.$env{'user.name'}.' at '.$env{'user.domain'}. |
Line 8214 sub metadata {
|
Line 8240 sub metadata {
|
# This is not a package - some other kind of start tag |
# This is not a package - some other kind of start tag |
# |
# |
my $entry=$token->[1]; |
my $entry=$token->[1]; |
my $unikey; |
my $unikey=''; |
if ($entry eq 'import') { |
|
$unikey=''; |
|
} else { |
|
$unikey=$entry; |
|
} |
|
$unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
|
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
|
|
|
if ($entry eq 'import') { |
if ($entry eq 'import') { |
# |
# |
# Importing a library here |
# Importing a library here |
# |
# |
|
my $location=$parser->get_text('/import'); |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
|
|
my $importmode=$token->[2]->{'importmode'}; |
|
if ($importmode eq 'problem') { |
|
# Import as problem |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
} elsif ($importmode eq 'part') { |
|
# Import as part(s) |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'}); |
|
} else { |
|
# Normal import |
|
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
|
} |
|
|
|
#&logthis("About to use unikey $unikey"); |
|
|
if ($depthcount<20) { |
if ($depthcount<20) { |
my $location=$parser->get_text('/import'); |
|
my $dir=$filename; |
|
$dir=~s|[^/]*$||; |
|
$location=&filelocation($dir,$location); |
|
my $metadata = |
my $metadata = |
&metadata($uri,'keys', $location,$unikey, |
&metadata($uri,'keys', $location,$unikey, |
$depthcount+1); |
$depthcount+1); |
Line 8242 sub metadata {
|
Line 8276 sub metadata {
|
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metaentry{':'.$meta}=$metaentry{':'.$meta}; |
$metathesekeys{$meta}=1; |
$metathesekeys{$meta}=1; |
} |
} |
} |
|
} else { |
|
|
|
|
#&logthis("Metadata $metadata"); |
|
} |
|
} else { |
|
# |
|
# Not importing, some other kind of non-package, non-library start tag |
|
# |
|
$unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'}); |
|
if (defined($token->[2]->{'id'})) { |
|
$unikey.='_'.$token->[2]->{'id'}; |
|
} |
if (defined($token->[2]->{'name'})) { |
if (defined($token->[2]->{'name'})) { |
$unikey.='_'.$token->[2]->{'name'}; |
$unikey.='_'.$token->[2]->{'name'}; |
} |
} |
Line 9678 sub get_dns {
|
Line 9720 sub get_dns {
|
return %libserv; |
return %libserv; |
} |
} |
|
|
|
sub unique_library { |
|
#2x reverse removes all hostnames that appear more than once |
|
my %unique = reverse &all_library(); |
|
return reverse %unique; |
|
} |
|
|
sub get_servers { |
sub get_servers { |
&load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
|
|
Line 9701 sub get_dns {
|
Line 9749 sub get_dns {
|
return %result; |
return %result; |
} |
} |
|
|
|
sub get_unique_servers { |
|
my %unique = reverse &get_servers(@_); |
|
return reverse %unique; |
|
} |
|
|
sub host_domain { |
sub host_domain { |
&load_hosts_tab() if (!$loaded); |
&load_hosts_tab() if (!$loaded); |
|
|