version 1.1056.4.21, 2011/01/25 09:56:17
|
version 1.1056.4.33.2.2, 2012/02/08 01:05:20
|
Line 76 use HTTP::Date;
|
Line 76 use HTTP::Date;
|
use Image::Magick; |
use Image::Magick; |
|
|
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease); |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
|
%managerstab); |
|
|
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
%userrolehash, $processmarker, $dumpcount, %coursedombuf, |
Line 196 sub get_server_timezone {
|
Line 197 sub get_server_timezone {
|
} |
} |
} |
} |
|
|
|
sub get_server_distarch { |
|
my ($lonhost,$ignore_cache) = @_; |
|
if (defined($lonhost)) { |
|
if (!defined(&hostname($lonhost))) { |
|
return; |
|
} |
|
my $cachetime = 12*3600; |
|
if (!$ignore_cache) { |
|
my ($distarch,$cached)=&is_cached_new('serverdistarch',$lonhost); |
|
if (defined($cached)) { |
|
return $distarch; |
|
} |
|
} |
|
my $rep = &reply('serverdistarch',$lonhost); |
|
unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' || |
|
$rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' || |
|
$rep eq '') { |
|
return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime); |
|
} |
|
} |
|
return; |
|
} |
|
|
sub get_server_loncaparev { |
sub get_server_loncaparev { |
my ($dom,$lonhost,$ignore_cache,$caller) = @_; |
my ($dom,$lonhost,$ignore_cache,$caller) = @_; |
if (defined($lonhost)) { |
if (defined($lonhost)) { |
Line 612 sub appenv {
|
Line 636 sub appenv {
|
# ----------------------------------------------------- Delete from Environment |
# ----------------------------------------------------- Delete from Environment |
|
|
sub delenv { |
sub delenv { |
my ($delthis,$regexp) = @_; |
my ($delthis,$regexp,$roles) = @_; |
if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) { |
if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) { |
&logthis("<font color=\"blue\">WARNING: ". |
my $refused = 1; |
"Attempt to delete from environment ".$delthis); |
if (ref($roles) eq 'ARRAY') { |
return 'error'; |
my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./); |
|
if (grep(/^\Q$role\E$/,@{$roles})) { |
|
$refused = 0; |
|
} |
|
} |
|
if ($refused) { |
|
&logthis("<font color=\"blue\">WARNING: ". |
|
"Attempt to delete from environment ".$delthis); |
|
return 'error'; |
|
} |
} |
} |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
if ($opened |
if ($opened |
Line 752 sub overloaderror {
|
Line 785 sub overloaderror {
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
|
|
sub spareserver { |
sub spareserver { |
my ($loadpercent,$userloadpercent,$want_server_name) = @_; |
my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; |
my $spare_server; |
my $spare_server; |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
if ($userloadpercent !~ /\d/) { $userloadpercent=0; } |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent |
: $userloadpercent; |
: $userloadpercent; |
my ($uint_dom,$remotesessions); |
my ($uint_dom,$remotesessions); |
if ($env{'user.domain'}) { |
if (($udom ne '') && (&domain($udom) ne '')) { |
my $uprimary_id = &Apache::lonnet::domain($env{'user.domain'},'primary'); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
$uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'}); |
my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); |
$remotesessions = $udomdefaults{'remotesessions'}; |
$remotesessions = $udomdefaults{'remotesessions'}; |
} |
} |
foreach my $try_server (@{ $spareid{'primary'} }) { |
foreach my $try_server (@{ $spareid{'primary'} }) { |
if ($uint_dom) { |
if ($uint_dom) { |
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
$remotesessions,$try_server)); |
$try_server)); |
} |
} |
($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
&compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
Line 778 sub spareserver {
|
Line 811 sub spareserver {
|
if (!$found_server) { |
if (!$found_server) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
foreach my $try_server (@{ $spareid{'default'} }) { |
if ($uint_dom) { |
if ($uint_dom) { |
next unless (&spare_can_host($env{'user.domain'},$uint_dom, |
next unless (&spare_can_host($udom,$uint_dom,$remotesessions, |
$remotesessions,$try_server)); |
$try_server)); |
} |
} |
($spare_server, $lowest_load) = |
($spare_server, $lowest_load) = |
&compare_server_load($try_server, $spare_server, $lowest_load); |
&compare_server_load($try_server, $spare_server, $lowest_load); |
Line 808 sub compare_server_load {
|
Line 841 sub compare_server_load {
|
my $userloadans = &reply('userload',$try_server); |
my $userloadans = &reply('userload',$try_server); |
|
|
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
if ($loadans !~ /\d/ && $userloadans !~ /\d/) { |
return; #didn't get a number from the server |
return ($spare_server, $lowest_load); #didn't get a number from the server |
} |
} |
|
|
my $load; |
my $load; |
Line 854 sub has_user_session {
|
Line 887 sub has_user_session {
|
# --------- determine least loaded server in a user's domain which allows login |
# --------- determine least loaded server in a user's domain which allows login |
|
|
sub choose_server { |
sub choose_server { |
my ($udom) = @_; |
my ($udom,$checkloginvia) = @_; |
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
my %domconfhash = &Apache::loncommon::get_domainconf($udom); |
my %servers = &get_servers($udom); |
my %servers = &get_servers($udom); |
my $lowest_load = 30000; |
my $lowest_load = 30000; |
my ($login_host,$hostname); |
my ($login_host,$hostname,$portal_path,$isredirect); |
foreach my $lonhost (keys(%servers)) { |
foreach my $lonhost (keys(%servers)) { |
my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; |
my $loginvia; |
if ($loginvia eq '') { |
if ($checkloginvia) { |
|
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; |
|
if ($loginvia) { |
|
my ($server,$path) = split(/:/,$loginvia); |
|
($login_host, $lowest_load) = |
|
&compare_server_load($lonhost, $login_host, $lowest_load); |
|
if ($login_host eq $server) { |
|
$portal_path = $path; |
|
$isredirect = 1; |
|
} |
|
} else { |
|
($login_host, $lowest_load) = |
|
&compare_server_load($lonhost, $login_host, $lowest_load); |
|
if ($login_host eq $lonhost) { |
|
$portal_path = ''; |
|
$isredirect = ''; |
|
} |
|
} |
|
} else { |
($login_host, $lowest_load) = |
($login_host, $lowest_load) = |
&compare_server_load($lonhost, $login_host, $lowest_load); |
&compare_server_load($lonhost, $login_host, $lowest_load); |
} |
} |
} |
} |
if ($login_host ne '') { |
if ($login_host ne '') { |
$hostname = $servers{$login_host}; |
$hostname = &hostname($login_host); |
} |
} |
return ($login_host,$hostname); |
return ($login_host,$hostname,$portal_path,$isredirect); |
} |
} |
|
|
# --------------------------------------------- Try to change a user's password |
# --------------------------------------------- Try to change a user's password |
Line 1010 sub can_host_session {
|
Line 1061 sub can_host_session {
|
} |
} |
if ($canhost) { |
if ($canhost) { |
if (ref($hostedsessions) eq 'HASH') { |
if (ref($hostedsessions) eq 'HASH') { |
|
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
|
my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); |
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { |
if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { |
if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) { |
if (($uint_dom ne '') && |
|
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) { |
$canhost = 0; |
$canhost = 0; |
} else { |
} else { |
$canhost = 1; |
$canhost = 1; |
} |
} |
} |
} |
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { |
if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { |
if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) { |
if (($uint_dom ne '') && |
|
(grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) { |
$canhost = 1; |
$canhost = 1; |
} else { |
} else { |
$canhost = 0; |
$canhost = 0; |
Line 1532 sub get_domain_defaults {
|
Line 1587 sub get_domain_defaults {
|
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
$domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; |
|
$domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; |
} else { |
} else { |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'lang_def'} = &domain($domain,'lang_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
$domdefaults{'auth_def'} = &domain($domain,'auth_def'); |
Line 3178 sub get_my_roles {
|
Line 3234 sub get_my_roles {
|
if (!grep(/^cr$/,@{$roles})) { |
if (!grep(/^cr$/,@{$roles})) { |
next; |
next; |
} |
} |
|
} elsif ($role =~ /^gr\//) { |
|
if (!grep(/^gr$/,@{$roles})) { |
|
next; |
|
} |
} else { |
} else { |
next; |
next; |
} |
} |
Line 3671 sub hashref2str {
|
Line 3731 sub hashref2str {
|
$result.='='; |
$result.='='; |
#print("Got a ref of ".(ref($key))." skipping."); |
#print("Got a ref of ".(ref($key))." skipping."); |
} else { |
} else { |
if ($key) {$result.=&escape($key).'=';} else { last; } |
if (defined($key)) {$result.=&escape($key).'=';} else { last; } |
} |
} |
|
|
if(ref($hashref->{$key}) eq 'ARRAY') { |
if(ref($hashref->{$key}) eq 'ARRAY') { |
Line 4190 sub rolesinit {
|
Line 4250 sub rolesinit {
|
} |
} |
my %allroles=(); |
my %allroles=(); |
my %allgroups=(); |
my %allgroups=(); |
my $group_privs; |
|
|
|
if ($rolesdump ne '') { |
if ($rolesdump ne '') { |
foreach my $entry (split(/&/,$rolesdump)) { |
foreach my $entry (split(/&/,$rolesdump)) { |
Line 4207 sub rolesinit {
|
Line 4266 sub rolesinit {
|
} |
} |
} elsif ($role =~ m|^gr/|) { |
} elsif ($role =~ m|^gr/|) { |
($trole,$tend,$tstart) = split(/_/,$role); |
($trole,$tend,$tstart) = split(/_/,$role); |
|
next if ($tstart eq '-1'); |
($trole,$group_privs) = split(/\//,$trole); |
($trole,$group_privs) = split(/\//,$trole); |
$group_privs = &unescape($group_privs); |
$group_privs = &unescape($group_privs); |
} else { |
} else { |
Line 4359 sub set_userprivs {
|
Line 4419 sub set_userprivs {
|
} |
} |
} |
} |
my $thesestr=''; |
my $thesestr=''; |
foreach my $priv (keys(%thesepriv)) { |
foreach my $priv (sort(keys(%thesepriv))) { |
$thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
$thesestr.=':'.$priv.'&'.$thesepriv{$priv}; |
} |
} |
$userroles->{'user.priv.'.$role} = $thesestr; |
$userroles->{'user.priv.'.$role} = $thesestr; |
Line 4368 sub set_userprivs {
|
Line 4428 sub set_userprivs {
|
} |
} |
|
|
sub role_status { |
sub role_status { |
my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_; |
my @pwhere = (); |
my @pwhere = (); |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
if (exists($env{$rolekey}) && $env{$rolekey} ne '') { |
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey); |
(undef,undef,$$role,@pwhere)=split(/\./,$rolekey); |
Line 4377 sub role_status {
|
Line 4437 sub role_status {
|
$$trolecode=$$role.'.'.$$where; |
$$trolecode=$$role.'.'.$$where; |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
($$tstart,$$tend)=split(/\./,$env{$rolekey}); |
$$tstatus='is'; |
$$tstatus='is'; |
if ($$tstart && $$tstart>$then) { |
if ($$tstart && $$tstart>$update) { |
$$tstatus='future'; |
$$tstatus='future'; |
if ($$tstart<$now) { |
if ($$tstart<$now) { |
if ($$tstart && $$tstart>$refresh) { |
if ($$tstart && $$tstart>$refresh) { |
Line 4402 sub role_status {
|
Line 4462 sub role_status {
|
$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); |
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) { |
&get_groups_roles($tdomain,$trest, |
my ($tnum) = ($trest =~ /^($match_courseid)/); |
\%course_roles,\@rolecodes, |
if ($tdomain ne '' && $tnum ne '') { |
\%groups_roles); |
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); |
push(@rolecodes,$$role); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
&standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); |
Line 4441 sub role_status {
|
Line 4478 sub role_status {
|
} |
} |
} |
} |
if ($$tend) { |
if ($$tend) { |
if ($$tend<$then) { |
if ($$tend<$update) { |
$$tstatus='expired'; |
$$tstatus='expired'; |
} elsif ($$tend<$now) { |
} elsif ($$tend<$now) { |
$$tstatus='will_not'; |
$$tstatus='will_not'; |
Line 4451 sub role_status {
|
Line 4488 sub role_status {
|
} |
} |
} |
} |
|
|
|
sub get_groups_roles { |
|
my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_; |
|
return unless((ref($cdom_courseroles) eq 'HASH') && |
|
(ref($rolecodes) eq 'ARRAY') && |
|
(ref($groups_roles) eq 'HASH')); |
|
if (keys(%{$cdom_courseroles}) > 0) { |
|
my ($cnum) = ($rest =~ /^($match_courseid)/); |
|
if ($cdom ne '' && $cnum ne '') { |
|
foreach my $key (keys(%{$cdom_courseroles})) { |
|
if ($key =~ /^\Q$cnum\E:\Q$cdom\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./$cdom/$cnum"; |
|
if ($crssec ne '') { |
|
$rolekey .= "/$crssec"; |
|
} |
|
$rolekey .= './'; |
|
$groups_roles->{$rolekey} = $rolecodes; |
|
} |
|
} |
|
} |
|
} |
|
return; |
|
} |
|
|
|
sub delete_env_groupprivs { |
|
my ($where,$courseroles,$possroles) = @_; |
|
return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY')); |
|
my ($dummy,$udom,$uname,$group) = split(/\//,$where); |
|
unless (ref($courseroles->{$udom}) eq 'HASH') { |
|
%{$courseroles->{$udom}} = |
|
&get_my_roles('','','userroles',['active'], |
|
$possroles,[$udom],1); |
|
} |
|
if (ref($courseroles->{$udom}) eq 'HASH') { |
|
foreach my $item (keys(%{$courseroles->{$udom}})) { |
|
my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item); |
|
my $area = '/'.$cdom.'/'.$cnum; |
|
my $privkey = "user.priv.$crsrole.$area"; |
|
if ($crssec ne '') { |
|
$privkey .= '/'.$crssec; |
|
} |
|
$privkey .= ".$area/$group"; |
|
&Apache::lonnet::delenv($privkey,undef,[$crsrole]); |
|
} |
|
} |
|
return; |
|
} |
|
|
sub check_adhoc_privs { |
sub check_adhoc_privs { |
my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_; |
my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; |
if ($env{$cckey}) { |
if ($env{$cckey}) { |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); |
&role_status($cckey,$then,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
&role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); |
&set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); |
} |
} |
Line 5754 sub allowed {
|
Line 5849 sub allowed {
|
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} |
=~/\Q$rolecode\E/) { |
=~/\Q$rolecode\E/) { |
if ($priv ne 'pch') { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. |
$env{'request.course.id'}); |
$env{'request.course.id'}); |
Line 5764 sub allowed {
|
Line 5859 sub allowed {
|
|
|
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} |
=~/\Q$unamedom\E/) { |
=~/\Q$unamedom\E/) { |
if ($priv ne 'pch') { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. |
$env{'request.course.id'}); |
$env{'request.course.id'}); |
Line 5778 sub allowed {
|
Line 5873 sub allowed {
|
if ($thisallowed=~/R/) { |
if ($thisallowed=~/R/) { |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
my $rolecode=(split(/\./,$env{'request.role'}))[0]; |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) { |
if ($priv ne 'pch') { |
if (($priv ne 'pch') && ($priv ne 'plc')) { |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
&logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode); |
} |
} |
Line 6705 sub assignrole {
|
Line 6800 sub assignrole {
|
return 'refused'; |
return 'refused'; |
} |
} |
} |
} |
|
} elsif ($role eq 'au') { |
|
if ($url ne '/'.$udom.'/') { |
|
&logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}. |
|
' to assign author role for '.$uname.':'.$udom. |
|
' in domain: '.$url.' refused (wrong domain).'); |
|
return 'refused'; |
|
} |
} |
} |
$mrole=$role; |
$mrole=$role; |
} |
} |
Line 7350 sub store_userdata {
|
Line 7452 sub store_userdata {
|
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
$namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; |
} |
} |
$namevalue=~s/\&$//; |
$namevalue=~s/\&$//; |
$result = &reply("store:$env{'user.domain'}:$env{'user.name'}:". |
$result = &reply("store:$udom:$uname:$namespace:$datakey:". |
"$namespace:$datakey:$namevalue",$uhome); |
$namevalue,$uhome); |
} |
} |
} else { |
} else { |
$result = 'error: data to store was not a hash reference'; |
$result = 'error: data to store was not a hash reference'; |
Line 8578 sub metadata {
|
Line 8680 sub metadata {
|
if (($uri eq '') || |
if (($uri eq '') || |
(($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$}) || ($uri =~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
return undef; |
return undef; |
} |
} |
if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) |
if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) |
Line 8620 sub metadata {
|
Line 8722 sub metadata {
|
&Apache::lonnet::ssi_body($which, |
&Apache::lonnet::ssi_body($which, |
('grade_target' => 'meta')); |
('grade_target' => 'meta')); |
$cachetime = 1; # only want this cached in the child not long term |
$cachetime = 1; # only want this cached in the child not long term |
} elsif ($uri !~ m -^(editupload)/-) { |
} elsif (($uri !~ m -^(editupload)/-) && |
|
($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { |
my $file=&filelocation('',&clutter($filename)); |
my $file=&filelocation('',&clutter($filename)); |
#push(@{$metaentry{$uri.'.file'}},$file); |
#push(@{$metaentry{$uri.'.file'}},$file); |
$metastring=&getfile($file); |
$metastring=&getfile($file); |
Line 9978 sub get_dns {
|
Line 10081 sub get_dns {
|
while (%alldns) { |
while (%alldns) { |
my ($dns) = keys(%alldns); |
my ($dns) = keys(%alldns); |
my $ua=new LWP::UserAgent; |
my $ua=new LWP::UserAgent; |
|
$ua->timeout(30); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); |
my $response=$ua->request($request); |
my $response=$ua->request($request); |
delete($alldns{$dns}); |
delete($alldns{$dns}); |
Line 10062 sub get_dns {
|
Line 10166 sub get_dns {
|
my $loaded; |
my $loaded; |
my %name_to_host; |
my %name_to_host; |
my %internetdom; |
my %internetdom; |
|
my %LC_dns_serv; |
|
|
sub parse_hosts_tab { |
sub parse_hosts_tab { |
my ($file) = @_; |
my ($file) = @_; |
foreach my $configline (@$file) { |
foreach my $configline (@$file) { |
next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^(\#|\s*$ )/x); |
next if ($configline =~ /^\^/); |
chomp($configline); |
chomp($configline); |
if ($configline =~ /^\^/) { |
|
if ($configline =~ /^\^([\w.\-]+)/) { |
|
$LC_dns_serv{$1} = 1; |
|
} |
|
next; |
|
} |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); |
$name=~s/\s//g; |
$name=~s/\s//g; |
if ($id && $domain && $role && $name) { |
if ($id && $domain && $role && $name) { |
Line 10204 sub get_dns {
|
Line 10314 sub get_dns {
|
my ($lonid) = @_; |
my ($lonid) = @_; |
return $internetdom{$lonid}; |
return $internetdom{$lonid}; |
} |
} |
|
|
|
sub is_LC_dns { |
|
&load_hosts_tab() if (!$loaded); |
|
|
|
my ($hostname) = @_; |
|
return exists($LC_dns_serv{$hostname}); |
|
} |
|
|
} |
} |
|
|
{ |
{ |
Line 10479 BEGIN {
|
Line 10597 BEGIN {
|
} |
} |
} |
} |
|
|
|
# ---------------------------------------------------------- Read managers table |
|
{ |
|
if (-e "$perlvar{'lonTabDir'}/managers.tab") { |
|
if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { |
|
while (my $configline=<$config>) { |
|
chomp($configline); |
|
next if ($configline =~ /^\#/); |
|
if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) { |
|
$managerstab{$configline} = 1; |
|
} |
|
} |
|
close($config); |
|
} |
|
} |
|
} |
|
|
# ------------- set up temporary directory |
# ------------- set up temporary directory |
{ |
{ |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
$tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; |
Line 11372 splitting on '&', supports elements that
|
Line 11506 splitting on '&', supports elements that
|
|
|
=head2 Logging Routines |
=head2 Logging Routines |
|
|
=over 4 |
|
|
|
These routines allow one to make log messages in the lonnet.log and |
These routines allow one to make log messages in the lonnet.log and |
lonnet.perm logfiles. |
lonnet.perm logfiles. |
|
|
|
=over 4 |
|
|
=item * |
=item * |
|
|
logtouch() : make sure the logfile, lonnet.log, exists |
logtouch() : make sure the logfile, lonnet.log, exists |