version 1.1172.2.93.4.10, 2018/04/29 00:56:53
|
version 1.1172.2.107, 2019/08/01 19:13:26
|
Line 74 use strict;
|
Line 74 use strict;
|
use LWP::UserAgent(); |
use LWP::UserAgent(); |
use HTTP::Date; |
use HTTP::Date; |
use Image::Magick; |
use Image::Magick; |
|
use CGI::Cookie; |
|
|
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir |
use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
$_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease |
%managerstab); |
%managerstab); |
|
|
Line 639 sub check_for_valid_session {
|
Line 640 sub check_for_valid_session {
|
|
|
if (!defined($disk_env{'user.name'}) |
if (!defined($disk_env{'user.name'}) |
|| !defined($disk_env{'user.domain'})) { |
|| !defined($disk_env{'user.domain'})) { |
|
untie(%disk_env); |
return undef; |
return undef; |
} |
} |
|
|
Line 646 sub check_for_valid_session {
|
Line 648 sub check_for_valid_session {
|
$userhashref->{'name'} = $disk_env{'user.name'}; |
$userhashref->{'name'} = $disk_env{'user.name'}; |
$userhashref->{'domain'} = $disk_env{'user.domain'}; |
$userhashref->{'domain'} = $disk_env{'user.domain'}; |
} |
} |
|
untie(%disk_env); |
|
|
return $handle; |
return $handle; |
} |
} |
Line 670 sub timed_flock {
|
Line 673 sub timed_flock {
|
} |
} |
} |
} |
|
|
|
sub get_sessionfile_vars { |
|
my ($handle,$lonidsdir,$storearr) = @_; |
|
my %returnhash; |
|
unless (ref($storearr) eq 'ARRAY') { |
|
return %returnhash; |
|
} |
|
if (-l "$lonidsdir/$handle.id") { |
|
my $link = readlink("$lonidsdir/$handle.id"); |
|
if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { |
|
$handle = $1; |
|
} |
|
} |
|
if ((-e "$lonidsdir/$handle.id") && |
|
($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { |
|
my ($possuname,$possudom,$possuhome) = ($1,$2,$3); |
|
if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { |
|
if (open(my $idf,'+<',"$lonidsdir/$handle.id")) { |
|
flock($idf,LOCK_SH); |
|
if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id", |
|
&GDBM_READER(),0640)) { |
|
foreach my $item (@{$storearr}) { |
|
$returnhash{$item} = $disk_env{$item}; |
|
} |
|
untie(%disk_env); |
|
} |
|
} |
|
} |
|
} |
|
return %returnhash; |
|
} |
|
|
# ---------------------------------------------------------- Append Environment |
# ---------------------------------------------------------- Append Environment |
|
|
sub appenv { |
sub appenv { |
Line 695 sub appenv {
|
Line 729 sub appenv {
|
$env{$key}=$newenv->{$key}; |
$env{$key}=$newenv->{$key}; |
} |
} |
} |
} |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
my $lonids = $perlvar{'lonIDsDir'}; |
if ($opened |
if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { |
&& &timed_flock($env_file,LOCK_EX) |
my $opened = open(my $env_file,'+<',$env{'user.environment'}); |
&& |
if ($opened |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
&& &timed_flock($env_file,LOCK_EX) |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
&& |
while (my ($key,$value) = each(%{$newenv})) { |
tie(my %disk_env,'GDBM_File',$env{'user.environment'}, |
$disk_env{$key} = $value; |
(&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { |
} |
while (my ($key,$value) = each(%{$newenv})) { |
untie(%disk_env); |
$disk_env{$key} = $value; |
|
} |
|
untie(%disk_env); |
|
} |
} |
} |
} |
} |
return 'ok'; |
return 'ok'; |
Line 948 sub find_existing_session {
|
Line 985 sub find_existing_session {
|
return; |
return; |
} |
} |
|
|
|
# check if user's browser sent load balancer cookie and server still has session |
|
# and is not overloaded. |
|
sub check_for_balancer_cookie { |
|
my ($r,$update_mtime) = @_; |
|
my ($otherserver,$cookie); |
|
my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); |
|
if (exists($cookies{'balanceID'})) { |
|
my $balid = $cookies{'balanceID'}; |
|
$cookie=&LONCAPA::clean_handle($balid->value); |
|
my $balancedir=$r->dir_config('lonBalanceDir'); |
|
if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) { |
|
if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) { |
|
my ($possudom,$possuname) = ($1,$2); |
|
my $has_session = 0; |
|
if ((&domain($possudom) ne '') && |
|
(&homeserver($possuname,$possudom) ne 'no_host')) { |
|
my $try_server; |
|
my $opened = open(my $idf,'+<',"$balancedir/$cookie.id"); |
|
if ($opened) { |
|
flock($idf,LOCK_SH); |
|
while (my $line = <$idf>) { |
|
chomp($line); |
|
if (&hostname($line) ne '') { |
|
$try_server = $line; |
|
last; |
|
} |
|
} |
|
close($idf); |
|
if (($try_server) && |
|
(&has_user_session($try_server,$possudom,$possuname))) { |
|
my $lowest_load = 30000; |
|
($otherserver,$lowest_load) = |
|
&compare_server_load($try_server,undef,$lowest_load); |
|
if ($otherserver ne '' && $lowest_load < 100) { |
|
$has_session = 1; |
|
} else { |
|
undef($otherserver); |
|
} |
|
} |
|
} |
|
} |
|
if ($has_session) { |
|
if ($update_mtime) { |
|
my $atime = my $mtime = time; |
|
utime($atime,$mtime,"$balancedir/$cookie.id"); |
|
} |
|
} else { |
|
unlink("$balancedir/$cookie.id"); |
|
} |
|
} |
|
} |
|
} |
|
return ($otherserver,$cookie); |
|
} |
|
|
|
sub delbalcookie { |
|
my ($cookie,$balancer) =@_; |
|
if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) { |
|
my ($udom,$uname) = ($1,$2); |
|
my $uprimary_id = &domain($udom,'primary'); |
|
my $uintdom = &internet_dom($uprimary_id); |
|
my $intdom = &internet_dom($balancer); |
|
my $serverhomedom = &host_domain($balancer); |
|
if (($uintdom ne '') && ($uintdom eq $intdom)) { |
|
return &reply("delbalcookie:$cookie",$balancer); |
|
} |
|
} |
|
} |
|
|
# -------------------------------- ask if server already has a session for user |
# -------------------------------- ask if server already has a session for user |
sub has_user_session { |
sub has_user_session { |
my ($lonid,$udom,$uname) = @_; |
my ($lonid,$udom,$uname) = @_; |
Line 1285 sub get_lonbalancer_config {
|
Line 1391 sub get_lonbalancer_config {
|
sub check_loadbalancing { |
sub check_loadbalancing { |
my ($uname,$udom,$caller) = @_; |
my ($uname,$udom,$caller) = @_; |
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, |
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, |
$rule_in_effect,$offloadto,$otherserver); |
$rule_in_effect,$offloadto,$otherserver,$setcookie); |
my $lonhost = $perlvar{'lonHostID'}; |
my $lonhost = $perlvar{'lonHostID'}; |
my @hosts = ¤t_machine_ids(); |
my @hosts = ¤t_machine_ids(); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); |
Line 1312 sub check_loadbalancing {
|
Line 1418 sub check_loadbalancing {
|
} |
} |
} |
} |
if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
($is_balancer,$currtargets,$currrules) = |
($is_balancer,$currtargets,$currrules,$setcookie) = |
&check_balancer_result($result,@hosts); |
&check_balancer_result($result,@hosts); |
if ($is_balancer) { |
if ($is_balancer) { |
if (ref($currrules) eq 'HASH') { |
if (ref($currrules) eq 'HASH') { |
Line 1373 sub check_loadbalancing {
|
Line 1479 sub check_loadbalancing {
|
} |
} |
} |
} |
if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
($is_balancer,$currtargets,$currrules) = |
($is_balancer,$currtargets,$currrules,$setcookie) = |
&check_balancer_result($result,@hosts); |
&check_balancer_result($result,@hosts); |
if ($is_balancer) { |
if ($is_balancer) { |
if (ref($currrules) eq 'HASH') { |
if (ref($currrules) eq 'HASH') { |
Line 1439 sub check_loadbalancing {
|
Line 1545 sub check_loadbalancing {
|
$is_balancer = 0; |
$is_balancer = 0; |
if ($uname ne '' && $udom ne '') { |
if ($uname ne '' && $udom ne '') { |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { |
|
|
&appenv({'user.loadbalexempt' => $lonhost, |
&appenv({'user.loadbalexempt' => $lonhost, |
'user.loadbalcheck.time' => time}); |
'user.loadbalcheck.time' => time}); |
} |
} |
} |
} |
} |
} |
} |
} |
|
unless ($homeintdom) { |
|
undef($setcookie); |
|
} |
} |
} |
return ($is_balancer,$otherserver); |
return ($is_balancer,$otherserver,$setcookie); |
} |
} |
|
|
sub check_balancer_result { |
sub check_balancer_result { |
my ($result,@hosts) = @_; |
my ($result,@hosts) = @_; |
my ($is_balancer,$currtargets,$currrules); |
my ($is_balancer,$currtargets,$currrules,$setcookie); |
if (ref($result) eq 'HASH') { |
if (ref($result) eq 'HASH') { |
if ($result->{'lonhost'} ne '') { |
if ($result->{'lonhost'} ne '') { |
my $currbalancer = $result->{'lonhost'}; |
my $currbalancer = $result->{'lonhost'}; |
Line 1468 sub check_balancer_result {
|
Line 1576 sub check_balancer_result {
|
$is_balancer = 1; |
$is_balancer = 1; |
$currrules = $result->{$key}{'rules'}; |
$currrules = $result->{$key}{'rules'}; |
$currtargets = $result->{$key}{'targets'}; |
$currtargets = $result->{$key}{'targets'}; |
|
$setcookie = $result->{$key}{'cookie'}; |
last; |
last; |
} |
} |
} |
} |
} |
} |
} |
} |
return ($is_balancer,$currtargets,$currrules); |
return ($is_balancer,$currtargets,$currrules,$setcookie); |
} |
} |
|
|
sub get_loadbalancer_targets { |
sub get_loadbalancer_targets { |
Line 1697 sub get_dom {
|
Line 1806 sub get_dom {
|
} |
} |
} |
} |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
if ($udom && $uhome && ($uhome ne 'no_host')) { |
my $rep; |
my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
if ($namespace =~ /^enc/) { |
|
$rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
$rep=&reply("getdom:$udom:$namespace:$items",$uhome); |
|
} |
|
my %returnhash; |
my %returnhash; |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
if ($rep eq '' || $rep =~ /^error: 2 /) { |
return %returnhash; |
return %returnhash; |
Line 1746 sub put_dom {
|
Line 1850 sub put_dom {
|
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; |
} |
} |
$items=~s/\&$//; |
$items=~s/\&$//; |
if ($namespace =~ /^enc/) { |
return &reply("putdom:$udom:$namespace:$items",$uhome); |
return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); |
|
} else { |
|
return &reply("putdom:$udom:$namespace:$items",$uhome); |
|
} |
|
} else { |
} else { |
&logthis("put_dom failed - no homeserver and/or domain"); |
&logthis("put_dom failed - no homeserver and/or domain"); |
} |
} |
Line 1841 sub inst_directory_query {
|
Line 1941 sub inst_directory_query {
|
my $homeserver = &domain($udom,'primary'); |
my $homeserver = &domain($udom,'primary'); |
my $outcome; |
my $outcome; |
if ($homeserver ne '') { |
if ($homeserver ne '') { |
unless ($homeserver eq $perlvar{'lonHostID'}) { |
|
if ($srch->{'srchby'} eq 'email') { |
|
my $lcrev = &get_server_loncaparev(undef,$homeserver); |
|
my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/); |
|
if (($major eq '' && $minor eq '') || ($major < 2) || |
|
(($major == 2) && ($minor < 11)) || |
|
(($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/))) { |
|
return; |
|
} |
|
} |
|
} |
|
my $queryid=&reply("querysend:instdirsearch:". |
my $queryid=&reply("querysend:instdirsearch:". |
&escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchby'}).':'. |
&escape($srch->{'srchterm'}).':'. |
&escape($srch->{'srchterm'}).':'. |
Line 1893 sub usersearch {
|
Line 1982 sub usersearch {
|
my $query = 'usersearch'; |
my $query = 'usersearch'; |
foreach my $tryserver (keys(%libserv)) { |
foreach my $tryserver (keys(%libserv)) { |
if (&host_domain($tryserver) eq $dom) { |
if (&host_domain($tryserver) eq $dom) { |
unless ($tryserver eq $perlvar{'lonHostID'}) { |
|
if ($srch->{'srchby'} eq 'email') { |
|
my $lcrev = &get_server_loncaparev(undef,$tryserver); |
|
my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/); |
|
next if (($major eq '' && $minor eq '') || ($major < 2) || |
|
(($major == 2) && ($minor < 11)) || |
|
(($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/))); |
|
} |
|
} |
|
my $host=&hostname($tryserver); |
my $host=&hostname($tryserver); |
my $queryid= |
my $queryid= |
&reply("querysend:".&escape($query).':'. |
&reply("querysend:".&escape($query).':'. |
Line 2219 sub get_domain_defaults {
|
Line 2299 sub get_domain_defaults {
|
} elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
} elsif ($domconfig{'coursedefaults'}{'canclone'}) { |
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
$domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; |
} |
} |
|
if ($domconfig{'coursedefaults'}{'texengine'}) { |
|
$domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; |
|
} |
} |
} |
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 2282 sub get_domain_defaults {
|
Line 2365 sub get_domain_defaults {
|
return %domdefaults; |
return %domdefaults; |
} |
} |
|
|
sub course_portal_url { |
sub get_dom_cats { |
my ($cnum,$cdom) = @_; |
my ($dom) = @_; |
my $chome = &homeserver($cnum,$cdom); |
return unless (&domain($dom)); |
my $hostname = &hostname($chome); |
my ($cats,$cached)=&is_cached_new('cats',$dom); |
my $protocol = $protocol{$chome}; |
unless (defined($cached)) { |
$protocol = 'http' if ($protocol ne 'https'); |
my %domconfig = &get_dom('configuration',['coursecategories'],$dom); |
my %domdefaults = &get_domain_defaults($cdom); |
if (ref($domconfig{'coursecategories'}) eq 'HASH') { |
my $firsturl; |
if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') { |
if ($domdefaults{'portal_def'}) { |
%{$cats} = %{$domconfig{'coursecategories'}{'cats'}}; |
$firsturl = $domdefaults{'portal_def'}; |
} else { |
} else { |
$cats = {}; |
$firsturl = $protocol.'://'.$hostname; |
} |
|
} else { |
|
$cats = {}; |
|
} |
|
&Apache::lonnet::do_cache_new('cats',$dom,$cats,3600); |
} |
} |
return $firsturl; |
return $cats; |
|
} |
|
|
|
sub get_dom_instcats { |
|
my ($dom) = @_; |
|
return unless (&domain($dom)); |
|
my ($instcats,$cached)=&is_cached_new('instcats',$dom); |
|
unless (defined($cached)) { |
|
my (%coursecodes,%codes,@codetitles,%cat_titles,%cat_order); |
|
my $totcodes = &retrieve_instcodes(\%coursecodes,$dom); |
|
if ($totcodes > 0) { |
|
my $caller = 'global'; |
|
if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes, |
|
\@codetitles,\%cat_titles,\%cat_order) eq 'ok') { |
|
$instcats = { |
|
codes => \%codes, |
|
codetitles => \@codetitles, |
|
cat_titles => \%cat_titles, |
|
cat_order => \%cat_order, |
|
}; |
|
&do_cache_new('instcats',$dom,$instcats,3600); |
|
} |
|
} |
|
} |
|
return $instcats; |
|
} |
|
|
|
sub retrieve_instcodes { |
|
my ($coursecodes,$dom) = @_; |
|
my $totcodes; |
|
my %courses = &courseiddump($dom,'.',1,'.','.','.',undef,undef,'Course'); |
|
foreach my $course (keys(%courses)) { |
|
if (ref($courses{$course}) eq 'HASH') { |
|
if ($courses{$course}{'inst_code'} ne '') { |
|
$$coursecodes{$course} = $courses{$course}{'inst_code'}; |
|
$totcodes ++; |
|
} |
|
} |
|
} |
|
return $totcodes; |
} |
} |
|
|
# --------------------------------------------------- Assign a key to a student |
# --------------------------------------------------- Assign a key to a student |
Line 2882 sub absolute_url {
|
Line 3008 sub absolute_url {
|
sub ssi { |
sub ssi { |
|
|
my ($fn,%form)=@_; |
my ($fn,%form)=@_; |
my $ua=new LWP::UserAgent; |
my ($request,$response); |
my $request; |
|
|
|
$form{'no_update_last_known'}=1; |
$form{'no_update_last_known'}=1; |
&Apache::lonenc::check_encrypt(\$fn); |
&Apache::lonenc::check_encrypt(\$fn); |
Line 2900 sub ssi {
|
Line 3025 sub ssi {
|
} |
} |
|
|
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
$request->header(Cookie => $ENV{'HTTP_COOKIE'}); |
my $response= $ua->request($request); |
|
|
if (($env{'request.course.id'}) && |
|
($form{'grade_courseid'} eq $env{'request.course.id'}) && |
|
($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && |
|
($form{'grade_symb'} ne '') && |
|
(&Apache::lonnet::allowed('mgr',$env{'request.course.id'}. |
|
($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { |
|
if (LWP::UserAgent->VERSION >= 5.834) { |
|
my $ua=new LWP::UserAgent; |
|
$ua->local_address('127.0.0.1'); |
|
$response = $ua->request($request); |
|
} else { |
|
{ |
|
require LWP::Protocol::http; |
|
local @LWP::Protocol::http::EXTRA_SOCK_OPTS = (LocalAddr => '127.0.0.1'); |
|
my $ua=new LWP::UserAgent; |
|
$response = $ua->request($request); |
|
@LWP::Protocol::http::EXTRA_SOCK_OPTS = (); |
|
} |
|
} |
|
} else { |
|
my $ua=new LWP::UserAgent; |
|
$response = $ua->request($request); |
|
} |
if (wantarray) { |
if (wantarray) { |
return ($response->content, $response); |
return ($response->content, $response); |
} else { |
} else { |
Line 2920 sub externalssi {
|
Line 3068 sub externalssi {
|
} |
} |
} |
} |
|
|
|
# If the local copy of a replicated resource is outdated, trigger a |
|
# connection from the homeserver to flush the delayed queue. If no update |
|
# happens, remove local copies of outdated resource (and corresponding |
|
# metadata file). |
|
|
|
sub remove_stale_resfile { |
|
my ($url) = @_; |
|
my $removed; |
|
if ($url=~m{^/res/($match_domain)/($match_username)/}) { |
|
my $audom = $1; |
|
my $auname = $2; |
|
unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { |
|
my $homeserver = &homeserver($auname,$audom); |
|
unless (($homeserver eq 'no_host') || |
|
(grep { $_ eq $homeserver } ¤t_machine_ids())) { |
|
my $fname = &filelocation('',$url); |
|
if (-e $fname) { |
|
my $ua=new LWP::UserAgent; |
|
$ua->timeout(5); |
|
my $protocol = $protocol{$homeserver}; |
|
$protocol = 'http' if ($protocol ne 'https'); |
|
my $hostname = &hostname($homeserver); |
|
if ($hostname) { |
|
my $uri = $protocol.'://'.$hostname.'/raw/'.&declutter($url); |
|
my $request=new HTTP::Request('HEAD',$uri); |
|
my $response=$ua->request($request); |
|
if ($response->is_success()) { |
|
my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); |
|
my $locmodtime = (stat($fname))[9]; |
|
if ($locmodtime < $remmodtime) { |
|
my $stale; |
|
my $answer = &reply('pong',$homeserver); |
|
if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { |
|
sleep(0.2); |
|
$locmodtime = (stat($fname))[9]; |
|
if ($locmodtime < $remmodtime) { |
|
my $posstransfer = $fname.'.in.transfer'; |
|
if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { |
|
$removed = 1; |
|
} else { |
|
$stale = 1; |
|
} |
|
} else { |
|
$removed = 1; |
|
} |
|
} else { |
|
$stale = 1; |
|
} |
|
if ($stale) { |
|
unlink($fname); |
|
if ($uri!~/\.meta$/) { |
|
unlink($fname.'.meta'); |
|
} |
|
&reply("unsub:$fname",$homeserver); |
|
$removed = 1; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return $removed; |
|
} |
|
|
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
# -------------------------------- Allow a /uploaded/ URI to be vouched for |
|
|
sub allowuploaded { |
sub allowuploaded { |
Line 3058 sub can_edit_resource {
|
Line 3272 sub can_edit_resource {
|
$forceedit = 1; |
$forceedit = 1; |
} |
} |
$cfile = $resurl; |
$cfile = $resurl; |
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
|
$incourse = 1; |
|
if ($env{'form.forceedit'}) { |
|
$forceview = 1; |
|
} else { |
|
$forceedit = 1; |
|
} |
|
$cfile = $resurl; |
|
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
$incourse = 1; |
$incourse = 1; |
if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
Line 3090 sub can_edit_resource {
|
Line 3296 sub can_edit_resource {
|
$forceedit = 1; |
$forceedit = 1; |
} |
} |
$cfile = $resurl; |
$cfile = $resurl; |
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { |
|
$incourse = 1; |
|
if ($env{'form.forceedit'}) { |
|
$forceview = 1; |
|
} else { |
|
$forceedit = 1; |
|
} |
|
$cfile = $resurl; |
|
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { |
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { |
$incourse = 1; |
$incourse = 1; |
$forceview = 1; |
$forceview = 1; |
Line 3107 sub can_edit_resource {
|
Line 3305 sub can_edit_resource {
|
$cfile = &clutter($res); |
$cfile = &clutter($res); |
} else { |
} else { |
$cfile = $env{'form.suppurl'}; |
$cfile = $env{'form.suppurl'}; |
my $escfile = &unescape($cfile); |
$cfile =~ s{^http://}{}; |
if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { |
$cfile = '/adm/wrapper/ext/'.$cfile; |
$cfile = '/adm/wrapper'.$escfile; |
|
} else { |
|
$escfile =~ s{^http://}{}; |
|
$cfile = &escape("/adm/wrapper/ext/$escfile"); |
|
} |
|
} |
} |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) { |
if ($env{'form.forceedit'}) { |
if ($env{'form.forceedit'}) { |
Line 3448 sub userfileupload {
|
Line 3641 sub userfileupload {
|
} else { |
} else { |
$docudom = $env{'user.domain'}; |
$docudom = $env{'user.domain'}; |
} |
} |
if ($destuname =~ /^$match_username$/) { |
if ($destuname =~ /^$match_username$/) { |
$docuname = $destuname; |
$docuname = $destuname; |
} else { |
} else { |
$docuname = $env{'user.name'}; |
$docuname = $env{'user.name'}; |
Line 4828 my %cachedtimes=();
|
Line 5021 my %cachedtimes=();
|
my $cachedtime=''; |
my $cachedtime=''; |
|
|
sub load_all_first_access { |
sub load_all_first_access { |
my ($uname,$udom,$ignorecache)=@_; |
my ($uname,$udom)=@_; |
if (($cachedkey eq $uname.':'.$udom) && |
if (($cachedkey eq $uname.':'.$udom) && |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && |
(abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) { |
(!$ignorecache)) { |
|
return; |
return; |
} |
} |
$cachedtime=time; |
$cachedtime=time; |
Line 4840 sub load_all_first_access {
|
Line 5032 sub load_all_first_access {
|
} |
} |
|
|
sub get_first_access { |
sub get_first_access { |
my ($type,$argsymb,$argmap,$ignorecache)=@_; |
my ($type,$argsymb,$argmap)=@_; |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
my ($symb,$courseid,$udom,$uname)=&whichuser(); |
if ($argsymb) { $symb=$argsymb; } |
if ($argsymb) { $symb=$argsymb; } |
my ($map,$id,$res)=&decode_symb($symb); |
my ($map,$id,$res)=&decode_symb($symb); |
Line 4852 sub get_first_access {
|
Line 5044 sub get_first_access {
|
} else { |
} else { |
$res=$symb; |
$res=$symb; |
} |
} |
&load_all_first_access($uname,$udom,$ignorecache); |
&load_all_first_access($uname,$udom); |
return $cachedtimes{"$courseid\0$res"}; |
return $cachedtimes{"$courseid\0$res"}; |
} |
} |
|
|
Line 4869 sub set_first_access {
|
Line 5061 sub set_first_access {
|
} |
} |
$cachedkey=''; |
$cachedkey=''; |
my $firstaccess=&get_first_access($type,$symb,$map); |
my $firstaccess=&get_first_access($type,$symb,$map); |
if (!$firstaccess) { |
if ($firstaccess) { |
|
&logthis("First access time already set ($firstaccess) when attempting ". |
|
"to set new value (type: $type, extent: $res) for $uname:$udom ". |
|
"in $courseid"); |
|
return 'already_set'; |
|
} else { |
my $start = time; |
my $start = time; |
my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start}, |
my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start}, |
$udom,$uname); |
$udom,$uname); |
Line 4882 sub set_first_access {
|
Line 5079 sub set_first_access {
|
'course.'.$courseid.'.timerinterval.'.$res => $interval, |
'course.'.$courseid.'.timerinterval.'.$res => $interval, |
} |
} |
); |
); |
|
if (($cachedtime) && (abs($start-$cachedtime) < 5)) { |
|
$cachedtimes{"$courseid\0$res"} = $start; |
|
} |
|
} elsif ($putres ne 'refused') { |
|
&logthis("Result: $putres when attempting to set first access time ". |
|
"(type: $type, extent: $res) for $uname:$udom in $courseid"); |
} |
} |
return $putres; |
return $putres; |
} |
} |
Line 6258 sub currentdump {
|
Line 6461 sub currentdump {
|
# |
# |
my %returnhash=(); |
my %returnhash=(); |
# |
# |
if ($rep eq 'unknown_cmd') { |
if ($rep eq "unknown_cmd") { |
# an old lond will not know currentdump |
# an old lond will not know currentdump |
# Do a dump and make it look like a currentdump |
# Do a dump and make it look like a currentdump |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); |
Line 7191 sub allowed {
|
Line 7394 sub allowed {
|
|
|
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } |
# Free bre access to adm and meta resources |
# Free bre access to adm and meta resources |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) |
if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) |
&& ($priv eq 'bre')) { |
&& ($priv eq 'bre')) { |
return 'F'; |
return 'F'; |
Line 7852 sub get_commblock_resources {
|
Line 8055 sub get_commblock_resources {
|
} |
} |
} |
} |
} |
} |
if ($interval[0] =~ /^(\d+)/) { |
if ($interval[0] =~ /^\d+$/) { |
my $timelimit = $1; |
|
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 7863 sub get_commblock_resources {
|
Line 8065 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+$timelimit; |
my $timesup = $first_access+$interval[0]; |
if ($timesup > $now) { |
if ($timesup > $now) { |
my $activeblock; |
my $activeblock; |
foreach my $res (@to_test) { |
foreach my $res (@to_test) { |
Line 9730 sub generate_coursenum {
|
Line 9932 sub generate_coursenum {
|
sub is_course { |
sub is_course { |
my ($cdom, $cnum) = scalar(@_) == 1 ? |
my ($cdom, $cnum) = scalar(@_) == 1 ? |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_; |
|
return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)); |
return unless $cdom and $cnum; |
my $uhome=&homeserver($cnum,$cdom); |
|
my $iscourse; |
my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef, |
if (grep { $_ eq $uhome } current_machine_ids()) { |
'.'); |
$iscourse = &LONCAPA::Lond::is_course($cdom,$cnum); |
|
} else { |
return unless(exists($courses{$cdom.'_'.$cnum})); |
my $hashid = $cdom.':'.$cnum; |
|
($iscourse,my $cached) = &is_cached_new('iscourse',$hashid); |
|
unless (defined($cached)) { |
|
my %courses = &courseiddump($cdom, '.', 1, '.', '.', |
|
$cnum,undef,undef,'.'); |
|
$iscourse = 0; |
|
if (exists($courses{$cdom.'_'.$cnum})) { |
|
$iscourse = 1; |
|
} |
|
&do_cache_new('iscourse',$hashid,$iscourse,3600); |
|
} |
|
} |
|
return unless($iscourse); |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum; |
} |
} |
|
|
Line 9918 sub files_not_in_path {
|
Line 10132 sub files_not_in_path {
|
my $filename = $user."savedfiles"; |
my $filename = $user."savedfiles"; |
my @return_files; |
my @return_files; |
my $path_part; |
my $path_part; |
open(IN,'<',LONCAPA::tempdir().$filename); |
open(IN, '<',LONCAPA::tempdir().$filename); |
while (my $line = <IN>) { |
while (my $line = <IN>) { |
#ok, I know it's clunky, but I want it to work |
#ok, I know it's clunky, but I want it to work |
my @paths_and_file = split(m|/|, $line); |
my @paths_and_file = split(m|/|, $line); |
Line 10578 sub get_userresdata {
|
Line 10792 sub get_userresdata {
|
# Parameters: |
# Parameters: |
# $name - Course/user name. |
# $name - Course/user name. |
# $domain - Name of the domain the user/course is registered on. |
# $domain - Name of the domain the user/course is registered on. |
# $type - Type of thing $name is (must be 'course' or 'user') |
# $type - Type of thing $name is (must be 'course' or 'user' |
# @which - Array of names of resources desired. |
# @which - Array of names of resources desired. |
# Returns: |
# Returns: |
# The value of the first reasource in @which that is found in the |
# The value of the first reasource in @which that is found in the |
Line 10597 sub resdata {
|
Line 10811 sub resdata {
|
} |
} |
if (!ref($result)) { return $result; } |
if (!ref($result)) { return $result; } |
foreach my $item (@which) { |
foreach my $item (@which) { |
if (ref($item) eq 'ARRAY') { |
if (defined($result->{$item->[0]})) { |
if (defined($result->{$item->[0]})) { |
return [$result->{$item->[0]},$item->[1]]; |
return [$result->{$item->[0]},$item->[1]]; |
} |
} |
|
} |
|
} |
} |
return undef; |
return undef; |
} |
} |
|
|
sub get_domain_ltitools { |
|
my ($cdom) = @_; |
|
my %ltitools; |
|
my ($result,$cached)=&is_cached_new('ltitools',$cdom); |
|
if (defined($cached)) { |
|
if (ref($result) eq 'HASH') { |
|
%ltitools = %{$result}; |
|
} |
|
} else { |
|
my %domconfig = &get_dom('configuration',['ltitools'],$cdom); |
|
if (ref($domconfig{'ltitools'}) eq 'HASH') { |
|
%ltitools = %{$domconfig{'ltitools'}}; |
|
my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom); |
|
if (ref($encdomconfig{'ltitools'}) eq 'HASH') { |
|
foreach my $id (keys(%ltitools)) { |
|
if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') { |
|
foreach my $item ('key','secret') { |
|
$ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item}; |
|
} |
|
} |
|
} |
|
} |
|
} |
|
my $cachetime = 24*60*60; |
|
&do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); |
|
} |
|
return %ltitools; |
|
} |
|
|
|
sub get_numsuppfiles { |
sub get_numsuppfiles { |
my ($cnum,$cdom,$ignorecache)=@_; |
my ($cnum,$cdom,$ignorecache)=@_; |
my $hashid=$cnum.':'.$cdom; |
my $hashid=$cnum.':'.$cdom; |
Line 11090 sub metadata {
|
Line 11273 sub metadata {
|
# if it is a non metadata possible uri return quickly |
# if it is a non metadata possible uri return quickly |
if (($uri eq '') || |
if (($uri eq '') || |
(($uri =~ m|^/*adm/|) && |
(($uri =~ m|^/*adm/|) && |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || |
($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { |
return undef; |
return undef; |
} |
} |
Line 12634 sub default_login_domain {
|
Line 12817 sub default_login_domain {
|
return $domain; |
return $domain; |
} |
} |
|
|
|
sub shared_institution { |
|
my ($dom) = @_; |
|
my $same_intdom; |
|
my $hostintdom = &internet_dom($perlvar{'lonHostID'}); |
|
if ($hostintdom ne '') { |
|
my %iphost = &get_iphost(); |
|
my $primary_id = &domain($dom,'primary'); |
|
my $primary_ip = &get_host_ip($primary_id); |
|
if (ref($iphost{$primary_ip}) eq 'ARRAY') { |
|
foreach my $id (@{$iphost{$primary_ip}}) { |
|
my $intdom = &internet_dom($id); |
|
if ($intdom eq $hostintdom) { |
|
$same_intdom = 1; |
|
last; |
|
} |
|
} |
|
} |
|
} |
|
return $same_intdom; |
|
} |
|
|
# ------------------------------------------------------------- Declutters URLs |
# ------------------------------------------------------------- Declutters URLs |
|
|
sub declutter { |
sub declutter { |
Line 12684 sub clutter {
|
Line 12888 sub clutter {
|
# &logthis("Got a blank emb style"); |
# &logthis("Got a blank emb style"); |
} |
} |
} |
} |
} elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { |
|
$thisfn='/adm/wrapper'.$thisfn; |
|
} |
} |
return $thisfn; |
return $thisfn; |
} |
} |
Line 12759 sub get_dns {
|
Line 12961 sub get_dns {
|
} |
} |
|
|
my %alldns; |
my %alldns; |
open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); |
if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { |
foreach my $dns (<$config>) { |
foreach my $dns (<$config>) { |
next if ($dns !~ /^\^(\S*)/x); |
next if ($dns !~ /^\^(\S*)/x); |
my $line = $1; |
my $line = $1; |
my ($host,$protocol) = split(/:/,$line); |
my ($host,$protocol) = split(/:/,$line); |
if ($protocol ne 'https') { |
if ($protocol ne 'https') { |
$protocol = 'http'; |
$protocol = 'http'; |
|
} |
|
$alldns{$host} = $protocol; |
} |
} |
$alldns{$host} = $protocol; |
close($config); |
} |
} |
while (%alldns) { |
while (%alldns) { |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
my ($dns) = sort { $b cmp $a } keys(%alldns); |
Line 12784 sub get_dns {
|
Line 12988 sub get_dns {
|
&$func(\@content,$hashref); |
&$func(\@content,$hashref); |
return; |
return; |
} |
} |
close($config); |
|
my $which = (split('/',$url))[3]; |
my $which = (split('/',$url))[3]; |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); |
open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab"); |
if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { |
my @content = <$config>; |
my @content = <$config>; |
&$func(\@content,$hashref); |
&$func(\@content,$hashref); |
|
} |
return; |
return; |
} |
} |
|
|
Line 13401 BEGIN {
|
Line 13605 BEGIN {
|
|
|
} |
} |
|
|
|
# ------------- set default texengine (domain default overrides this) |
|
{ |
|
$deftex = LONCAPA::texengine(); |
|
} |
|
|
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'], |
'compress_threshold'=> 20_000, |
'compress_threshold'=> 20_000, |
}); |
}); |