--- loncom/interface/loncommon.pm 2020/07/17 22:17:17 1.1075.2.127.2.11
+++ loncom/interface/loncommon.pm 2020/11/12 01:18:26 1.1075.2.149
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1075.2.127.2.11 2020/07/17 22:17:17 raeburn Exp $
+# $Id: loncommon.pm,v 1.1075.2.149 2020/11/12 01:18:26 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -71,6 +71,7 @@ use Apache::lonuserutils();
use Apache::lonuserstate();
use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);
+use HTTP::Request;
use DateTime::TimeZone;
use DateTime::Locale;
use Encode();
@@ -82,8 +83,6 @@ use Crypt::DES;
use DynaLoader; # for Crypt::DES version
use File::Copy();
use File::Path();
-use String::CRC32();
-use Short::URL();
# ---------------------------------------------- Designs
use vars qw(%defaultdesign);
@@ -429,7 +428,7 @@ sub studentbrowser_javascript {
OFFLOAD
- }
}
}
}
@@ -8173,6 +8305,10 @@ $args - additional optional args support
to lonhtmlcommon::breadcrumbs
group -> includes the current group, if page is for a
specific group
+ use_absolute -> for request for external resource or syllabus, this
+ will contain https:// if server uses
+ https (as per hosts.tab), but request is for http
+ hostname -> hostname, originally from $r->hostname(), (optional).
=back
@@ -8374,8 +8510,7 @@ sub modal_link {
$target_attr = 'target="'.$target.'"';
}
return <<"ENDLINK";
-
- $linktext
+$linktext
ENDLINK
}
@@ -8478,8 +8613,9 @@ sub end_togglebox {
}
sub LCprogressbar_script {
- my ($id)=@_;
- return(<
//
ENDPROGRESS
+ } else {
+ return(<
+//
+
+ENDPROGRESS
+ }
}
sub LCprogressbarUpdate_script {
return(<
.ui-progressbar { position:relative; }
+.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; }
.pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; }
@@ -8518,37 +8676,54 @@ my $LCidcnt;
my $LCcurrentid;
sub LCprogressbar {
- my ($r)=(@_);
+ my ($r,$number_to_do,$preamble)=@_;
$LClastpercent=0;
$LCidcnt++;
$LCcurrentid=$$.'_'.$LCidcnt;
- my $starting=&mt('Starting');
- my $content=(<
$starting
ENDPROGBAR
- &r_print($r,$content.&LCprogressbar_script($LCcurrentid));
+ } else {
+ $starting=&mt('Loading...');
+ $LClastpercent='false';
+ $content=(<
+ $starting
+
+ENDPROGBAR
+ }
+ &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do));
}
sub LCprogressbarUpdate {
- my ($r,$val,$text)=@_;
- unless ($val) {
- if ($LClastpercent) {
- $val=$LClastpercent;
- } else {
- $val=0;
- }
+ my ($r,$val,$text,$number_to_do)=@_;
+ if ($number_to_do) {
+ unless ($val) {
+ if ($LClastpercent) {
+ $val=$LClastpercent;
+ } else {
+ $val=0;
+ }
+ }
+ if ($val<0) { $val=0; }
+ if ($val>100) { $val=0; }
+ $LClastpercent=$val;
+ unless ($text) { $text=$val.'%'; }
+ } else {
+ $val = 'false';
}
- if ($val<0) { $val=0; }
- if ($val>100) { $val=0; }
- $LClastpercent=$val;
- unless ($text) { $text=$val.'%'; }
$text=&js_ready($text);
&r_print($r,<
//
ENDUPDATE
@@ -12193,8 +12368,7 @@ sub process_decompression {
if (ref($newdirlistref) eq 'ARRAY') {
foreach my $dir_line (@{$newdirlistref}) {
my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5);
- unless (($item =~ /^\.+$/) || ($item eq $file) ||
- ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) {
+ unless (($item =~ /^\.+$/) || ($item eq $file)) {
push(@newitems,$item);
if ($dirptr&$testdir) {
$is_dir{$item} = 1;
@@ -12782,7 +12956,7 @@ sub process_extracted_files {
$newseqid{$i} = $newidx;
unless ($errtext) {
$result .= ''.&mt('Folder: [_1] added to course',
- &HTML::Entities::encode($docstitle,'<>&"')).
+ &HTML::Entities::encode($docstitle,'<>&"'))..
''."\n";
}
}
@@ -12807,7 +12981,7 @@ sub process_extracted_files {
$fetch =~ s/^\Q$prefix$dir\E//;
$prompttofetch{$fetch} = 1;
}
- }
+ }
}
$LONCAPA::map::resources[$newidx]=
$docstitle.':'.$url.':false:normal:res';
@@ -12907,11 +13081,11 @@ sub process_extracted_files {
$result .= ''.&mt('[_1] included as a dependency',
&HTML::Entities::encode($showpath,'<>&"')).
''."\n";
- }
- unless ($ishome) {
- my $fetch = "$fullpath/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ unless ($ishome) {
+ my $fetch = "$fullpath/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
}
}
}
@@ -13198,9 +13372,10 @@ sub upfile_store {
$env{'form.upfile'}=~s/\n+$//gs;
my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
- '_enroll_'.$env{'request.course.id'}.'_'.
+ '_enroll_'.$env{'request.course.id'}.'_'.
time.'_'.$$);
return if ($datatoken eq '');
+
{
my $datafile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';
@@ -14139,7 +14314,6 @@ $requdom domain of requester (if mailing
$reqemail e-mail address of requester (if mailing type is helpdeskmail)
-
Returns: comma separated list of addresses to which to send e-mail.
=back
@@ -14281,7 +14455,6 @@ sub build_recipient_list {
} elsif ($origmail ne '') {
$lastresort = $origmail;
}
-
if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {
unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
@@ -14467,6 +14640,8 @@ jsarray (reference to array of categorie
subcats (reference to hash of arrays containing all subcategories within each
category, -recursive)
+maxd (reference to hash used to hold max depth for all top-level categories).
+
Returns: nothing
Side effects: populates trails and allitems hash references.
@@ -14474,7 +14649,7 @@ Side effects: populates trails and allit
=cut
sub extract_categories {
- my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
+ my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_;
if (ref($categories) eq 'HASH') {
&gather_categories($categories,$cats,$idx,$jsarray);
if (ref($cats->[0]) eq 'ARRAY') {
@@ -14500,12 +14675,15 @@ sub extract_categories {
if (ref($subcats) eq 'HASH') {
push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
}
- &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
+ &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd);
}
} else {
if (ref($subcats) eq 'HASH') {
$subcats->{$item} = [];
}
+ if (ref($maxd) eq 'HASH') {
+ $maxd->{$name} = 1;
+ }
}
}
}
@@ -14543,7 +14721,7 @@ Side effects: populates trails and allit
=cut
sub recurse_categories {
- my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
+ my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_;
my $shallower = $depth - 1;
if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
@@ -14570,16 +14748,21 @@ sub recurse_categories {
}
}
&recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
- $subcats);
+ $subcats,$maxd);
pop(@{$parents});
}
} else {
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
- my $trailstr = join(' -> ',(@{$parents},$category));
+ my $trailstr = join(' » ',(@{$parents},$category));
if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;
}
+ if (ref($maxd) eq 'HASH') {
+ if ($depth > $maxd->{$parents->[0]}) {
+ $maxd->{$parents->[0]} = $depth;
+ }
+ }
}
return;
}
@@ -14611,8 +14794,8 @@ sub assign_categories_table {
my ($cathash,$currcat,$type,$disabled) = @_;
my $output;
if (ref($cathash) eq 'HASH') {
- my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
- &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
+ my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth);
+ &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd);
$maxdepth = scalar(@cats);
if (@cats > 0) {
my $itemcount = 0;
@@ -14934,8 +15117,7 @@ sub check_clone {
my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
- my $clonetitle;
- my @clonemsg;
+ my $clonemsg;
my $can_clone = 0;
my $lctype = lc($args->{'crstype'});
if ($lctype ne 'community') {
@@ -14943,38 +15125,16 @@ sub check_clone {
}
if ($clonehome eq 'no_host') {
if ($args->{'crstype'} eq 'Community') {
- push(@clonemsg,({
- mt => 'No new community created.',
- args => [],
- },
- {
- mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',
- args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}],
- }));
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
} else {
- push(@clonemsg,({
- mt => 'No new course created.',
- args => [],
- },
- {
- mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',
- args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
- }));
- }
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
+ }
} else {
my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
- $clonetitle = $clonedesc{'description'};
if ($args->{'crstype'} eq 'Community') {
if ($clonedesc{'type'} ne 'Community') {
- push(@clonemsg,({
- mt => 'No new community created.',
- args => [],
- },
- {
- mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',
- args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}],
- }));
- return ($can_clone,\@clonemsg,$cloneid,$clonehome);
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
+ return ($can_clone, $clonemsg, $cloneid, $clonehome);
}
}
if (($env{'request.role.domain'} eq $args->{'clonedomain'}) &&
@@ -15063,34 +15223,20 @@ sub check_clone {
}
unless ($can_clone) {
if ($args->{'crstype'} eq 'Community') {
- push(@clonemsg,({
- mt => 'No new community created.',
- args => [],
- },
- {
- mt => 'The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',
- args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
- }));
+ $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
} else {
- push(@clonemsg,({
- mt => 'No new course created.',
- args => [],
- },
- {
- mt => 'The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',
- args => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}],
- }));
- }
+ $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
+ }
}
}
}
- return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle);
+ return ($can_clone, $clonemsg, $cloneid, $clonehome);
}
sub construct_course {
my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,
- $cnum,$category,$coderef,$callercontext,$user_lh) = @_;
- my ($outcome,$msgref,$clonemsgref);
+ $cnum,$category,$coderef) = @_;
+ my $outcome;
my $linefeed = '
'."\n";
if ($context eq 'auto') {
$linefeed = "\n";
@@ -15099,11 +15245,18 @@ sub construct_course {
#
# Are we cloning?
#
- my ($can_clone,$cloneid,$clonehome,$clonetitle);
+ my ($can_clone, $clonemsg, $cloneid, $clonehome);
if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
- ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed);
+ ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
+ if ($context ne 'auto') {
+ if ($clonemsg ne '') {
+ $clonemsg = ''.$clonemsg.'';
+ }
+ }
+ $outcome .= $clonemsg.$linefeed;
+
if (!$can_clone) {
- return (0,$outcome,$clonemsgref);
+ return (0,$outcome);
}
}
@@ -15121,20 +15274,15 @@ sub construct_course {
$args->{'ccuname'}.':'.
$args->{'ccdomain'},
$args->{'crstype'},
- $cnum,$context,$category,
- $callercontext);
+ $cnum,$context,$category);
# Note: The testing routines depend on this being output; see
# Utils::Course. This needs to at least be output as a comment
# if anyone ever decides to not show this, and Utils::Course::new
# will need to be suitably modified.
- if (($callercontext eq 'auto') && ($user_lh ne '')) {
- $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
- } else {
- $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
- }
+ $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
if ($$courseid =~ /^error:/) {
- return (0,$outcome,$clonemsgref);
+ return (0,$outcome);
}
#
@@ -15143,37 +15291,23 @@ sub construct_course {
($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
if ($crsuhome eq 'no_host') {
- if (($callercontext eq 'auto') && ($user_lh ne '')) {
- $outcome .= &mt_user($user_lh,
- 'Course creation failed, unrecognized course home server.');
- } else {
- $outcome .= &mt('Course creation failed, unrecognized course home server.');
- }
- $outcome .= $linefeed;
- return (0,$outcome,$clonemsgref);
+ $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed;
+ return (0,$outcome);
}
$outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
#
# Do the cloning
#
- my @clonemsg;
if ($can_clone && $cloneid) {
- push(@clonemsg,
- {
- mt => 'Created [_1] by cloning from [_2]',
- args => [$crstype,$clonetitle],
- });
+ $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
+ if ($context ne 'auto') {
+ $clonemsg = ''.$clonemsg.'';
+ }
+ $outcome .= $clonemsg.$linefeed;
my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
# Copy all files
- my @info =
- &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},
- $args->{'dateshift'},$args->{'crscode'},
- $args->{'ccuname'}.':'.$args->{'ccdomain'},
- $args->{'tinyurls'});
- if (@info) {
- push(@clonemsg,@info);
- }
+ &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
# Restore URL
$cenv{'url'}=$oldcenv{'url'};
# Restore title
@@ -15440,12 +15574,17 @@ sub construct_course {
# Open all assignments
#
if ($args->{'openall'}) {
+ my $opendate = time;
+ if ($args->{'openallfrom'} =~ /^\d+$/) {
+ $opendate = $args->{'openallfrom'};
+ }
my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
- my %storecontent = ($storeunder => time,
+ my %storecontent = ($storeunder => $opendate,
$storeunder.'.type' => 'date_start');
-
- $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
- ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
+ $outcome .= &mt('All assignments open starting [_1]',
+ &Apache::lonlocal::locallocaltime($opendate)).': '.
+ &Apache::lonnet::cput
+ ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
}
#
# Set first page
@@ -15475,7 +15614,7 @@ sub construct_course {
$outcome .= ($fatal?$errtext:'write ok').$linefeed;
}
- return (1,$outcome,\@clonemsg);
+ return (1,$outcome);
}
sub make_unique_code {
@@ -15679,7 +15818,23 @@ sub init_user_environment {
opendir(DIR,$lonids);
while ($filename=readdir(DIR)) {
if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
- unlink($lonids.'/'.$filename);
+ if (tie(my %oldenv,'GDBM_File',"$lonids/$filename",
+ &GDBM_READER(),0640)) {
+ my $linkedfile;
+ if (exists($oldenv{'user.linkedenv'})) {
+ $linkedfile = $oldenv{'user.linkedenv'};
+ }
+ untie(%oldenv);
+ if (unlink("$lonids/$filename")) {
+ if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
+ if (-l "$lonids/$linkedfile.id") {
+ unlink("$lonids/$linkedfile.id");
+ }
+ }
+ }
+ } else {
+ unlink($lonids.'/'.$filename);
+ }
}
}
closedir(DIR);
@@ -15714,7 +15869,8 @@ sub init_user_environment {
my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
my ($tmp) = keys(%userenv);
- if ($tmp =~ /^(con_lost|error|no_such_host)/i) {
+ if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
+ } else {
undef(%userenv);
}
if (($userenv{'interface'}) && (!$form->{'interface'})) {
@@ -16607,12 +16763,8 @@ sub needs_coursereinit {
$interval = 600;
}
if (($now-$env{'request.course.timechecked'})>$interval) {
- &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
- my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1);
- if ($blocked) {
- return ();
- }
my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum);
+ &Apache::lonnet::appenv({'request.course.timechecked'=>$now});
if ($lastchange > $env{'request.course.tied'}) {
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
if ($curr_reqd_hash{'internal.releaserequired'} ne '') {
@@ -16815,10 +16967,10 @@ sub symb_to_docspath {
}
sub captcha_display {
- my ($context,$lonhost) = @_;
+ my ($context,$lonhost,$defdom) = @_;
my ($output,$error);
my ($captcha,$pubkey,$privkey,$version) =
- &get_captcha_config($context,$lonhost);
+ &get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {
$output = &create_captcha();
unless ($output) {
@@ -16834,9 +16986,9 @@ sub captcha_display {
}
sub captcha_response {
- my ($context,$lonhost) = @_;
+ my ($context,$lonhost,$defdom) = @_;
my ($captcha_chk,$captcha_error);
- my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost);
+ my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom);
if ($captcha eq 'original') {
($captcha_chk,$captcha_error) = &check_captcha();
} elsif ($captcha eq 'recaptcha') {
@@ -16848,7 +17000,7 @@ sub captcha_response {
}
sub get_captcha_config {
- my ($context,$lonhost) = @_;
+ my ($context,$lonhost,$dom_in_effect) = @_;
my ($captcha,$pubkey,$privkey,$version,$hashtocheck);
my $hostname = &Apache::lonnet::hostname($lonhost);
my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname);
@@ -16896,6 +17048,27 @@ sub get_captcha_config {
} elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') {
$captcha = 'original';
}
+ } elsif ($context eq 'passwords') {
+ if ($dom_in_effect) {
+ my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect);
+ if ($passwdconf{'captcha'} eq 'recaptcha') {
+ if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') {
+ $pubkey = $passwdconf{'recaptchakeys'}{'public'};
+ $privkey = $passwdconf{'recaptchakeys'}{'private'};
+ }
+ if ($privkey && $pubkey) {
+ $captcha = 'recaptcha';
+ $version = $passwdconf{'recaptchaversion'};
+ if ($version ne '2') {
+ $version = 1;
+ }
+ } else {
+ $captcha = 'original';
+ }
+ } elsif ($passwdconf{'captcha'} ne 'notused') {
+ $captcha = 'original';
+ }
+ }
}
return ($captcha,$pubkey,$privkey,$version);
}
@@ -17047,25 +17220,9 @@ sub cleanup_html {
# Checks for critical messages and returns a redirect url if one exists.
# $interval indicates how often to check for messages.
-# $context is the calling context -- roles, grades, contents, menu or flip.
sub critical_redirect {
- my ($interval,$context) = @_;
+ my ($interval) = @_;
if ((time-$env{'user.criticalcheck.time'})>$interval) {
- if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) {
- my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
- my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
- my $blocked = &blocking_status('alert',$cnum,$cdom,undef,1);
- if ($blocked) {
- my $checkrole = "cm./$cdom/$cnum";
- if ($env{'request.course.sec'} ne '') {
- $checkrole .= "/$env{'request.course.sec'}";
- }
- unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) &&
- ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) {
- return;
- }
- }
- }
my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},
$env{'user.name'});
&Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
@@ -17131,155 +17288,157 @@ sub des_decrypt {
return $plaintext;
}
-sub get_requested_shorturls {
- my ($cdom,$cnum,$navmap) = @_;
- return unless (ref($navmap));
- my ($numnew,$errors);
- my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny');
- if (@toshorten) {
- my (%maps,%resources,%titles);
- &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles,
- 'shorturls',$cdom,$cnum);
- if (keys(%resources)) {
- my %tocreate;
- foreach my $item (sort {$a <=> $b} (@toshorten)) {
- my $symb = $resources{$item};
- if ($symb) {
- $tocreate{$cnum.'&'.$symb} = 1;
- }
- }
- if (keys(%tocreate)) {
- ($numnew,$errors) = &make_short_symbs($cdom,$cnum,
- \%tocreate);
- }
- }
- }
- return ($numnew,$errors);
-}
-
-sub make_short_symbs {
- my ($cdom,$cnum,$tocreateref,$lockuser) = @_;
- my ($numnew,@errors);
- if (ref($tocreateref) eq 'HASH') {
- my %tocreate = %{$tocreateref};
- if (keys(%tocreate)) {
- my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum);
- my $su = Short::URL->new(no_vowels => 1);
- my $init = '';
- my (%newunique,%addcourse,%courseonly,%failed);
- # get lock on tiny db
- my $now = time;
- if ($lockuser eq '') {
- $lockuser = $env{'user.name'}.':'.$env{'user.domain'};
- }
- my $lockhash = {
- "lock\0$now" => $lockuser,
- };
- my $tries = 0;
- my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
- my ($code,$error);
- while (($gotlock ne 'ok') && ($tries<3)) {
- $tries ++;
- sleep 1;
- $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
- }
- if ($gotlock eq 'ok') {
- $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
- \%addcourse,\%courseonly,\%failed);
- if (keys(%failed)) {
- my $numfailed = scalar(keys(%failed));
- push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed));
- }
- if (keys(%newunique)) {
- my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom);
- if ($putres eq 'ok') {
- $numnew = scalar(keys(%newunique));
- my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum);
- unless ($newputres eq 'ok') {
- push(@errors,&mt('error: could not store course look-up of short URLs'));
- }
- } else {
- push(@errors,&mt('error: could not store unique six character URLs'));
- }
- }
- my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom);
- unless ($dellockres eq 'ok') {
- push(@errors,&mt('error: could not release lockfile'));
- }
+sub is_nonframeable {
+ my ($url,$absolute,$hostname,$ip,$nocache) = @_;
+ my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i);
+ return if (($remprotocol eq '') || ($remhost eq ''));
+
+ $remprotocol = lc($remprotocol);
+ $remhost = lc($remhost);
+ my $remport = 80;
+ if ($remprotocol eq 'https') {
+ $remport = 443;
+ }
+ my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport);
+ if ($cached) {
+ unless ($nocache) {
+ if ($result) {
+ return 1;
} else {
- push(@errors,&mt('error: could not obtain lockfile'));
- }
- if (keys(%courseonly)) {
- my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum);
- if ($result ne 'ok') {
- push(@errors,&mt('error: could not update course look-up of short URLs'));
- }
+ return 0;
}
}
}
- return ($numnew,\@errors);
-}
-
-sub shorten_symbs {
- my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_;
- return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') &&
- (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') &&
- (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH'));
- my (%possibles,%collisions);
- foreach my $key (keys(%{$tocreate})) {
- my $num = String::CRC32::crc32($key);
- my $tiny = $su->encode($num,$init);
- if ($tiny) {
- $possibles{$tiny} = $key;
- }
- }
- if (!$init) {
- $init = 1;
- } else {
- $init ++;
- }
- if (keys(%possibles)) {
- my @posstiny = keys(%possibles);
- my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
- my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname);
- if (keys(%currtiny)) {
- foreach my $key (keys(%currtiny)) {
- next if ($currtiny{$key} eq '');
- if ($currtiny{$key} eq $possibles{$key}) {
- my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key});
- unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
- $courseonly->{$tsymb} = $key;
- }
- } else {
- $collisions{$possibles{$key}} = 1;
+ my $uselink;
+ my $request = new HTTP::Request('HEAD',$url);
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(5);
+ my $response=$ua->request($request);
+ if ($response->is_success()) {
+ my $secpolicy = lc($response->header('content-security-policy'));
+ my $xframeop = lc($response->header('x-frame-options'));
+ $secpolicy =~ s/^\s+|\s+$//g;
+ $xframeop =~ s/^\s+|\s+$//g;
+ if (($secpolicy ne '') || ($xframeop ne '')) {
+ my $remotehost = $remprotocol.'://'.$remhost;
+ my ($origin,$protocol,$port);
+ if ($ENV{'SERVER_PORT'} =~/^\d+$/) {
+ $port = $ENV{'SERVER_PORT'};
+ } else {
+ $port = 80;
+ }
+ if ($absolute eq '') {
+ $protocol = 'http:';
+ if ($port == 443) {
+ $protocol = 'https:';
}
- delete($possibles{$key});
+ $origin = $protocol.'//'.lc($hostname);
+ } else {
+ $origin = lc($absolute);
+ ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$});
}
- }
- foreach my $key (keys(%possibles)) {
- $newunique->{$key} = $possibles{$key};
- my ($tcnum,$tsymb) = split(/\&/,$possibles{$key});
- unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) {
- $addcourse->{$tsymb} = $key;
+ if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) {
+ my $framepolicy = $1;
+ $framepolicy =~ s/^\s+|\s+$//g;
+ my @policies = split(/\s+/,$framepolicy);
+ if (@policies) {
+ if (grep(/^\Q'none'\E$/,@policies)) {
+ $uselink = 1;
+ } else {
+ $uselink = 1;
+ if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) ||
+ (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) ||
+ (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) {
+ undef($uselink);
+ }
+ if ($uselink) {
+ if (grep(/^\Q'self'\E$/,@policies)) {
+ if (($origin ne '') && ($remotehost eq $origin)) {
+ undef($uselink);
+ }
+ }
+ }
+ if ($uselink) {
+ my @possok;
+ if ($ip ne '') {
+ push(@possok,$ip);
+ }
+ my $hoststr = '';
+ foreach my $part (reverse(split(/\./,$hostname))) {
+ if ($hoststr eq '') {
+ $hoststr = $part;
+ } else {
+ $hoststr = "$part.$hoststr";
+ }
+ if ($hoststr eq $hostname) {
+ push(@possok,$hostname);
+ } else {
+ push(@possok,"*.$hoststr");
+ }
+ }
+ if (@possok) {
+ foreach my $poss (@possok) {
+ last if (!$uselink);
+ foreach my $policy (@policies) {
+ if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) {
+ undef($uselink);
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } elsif ($xframeop ne '') {
+ $uselink = 1;
+ my @policies = split(/\s*,\s*/,$xframeop);
+ if (@policies) {
+ unless (grep(/^deny$/,@policies)) {
+ if ($origin ne '') {
+ if (grep(/^sameorigin$/,@policies)) {
+ if ($remotehost eq $origin) {
+ undef($uselink);
+ }
+ }
+ if ($uselink) {
+ foreach my $policy (@policies) {
+ if ($policy =~ /^allow-from\s*(.+)$/) {
+ my $allowfrom = $1;
+ if (($allowfrom ne '') && ($allowfrom eq $origin)) {
+ undef($uselink);
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
}
}
}
- if (keys(%collisions)) {
- if ($init <5) {
- if (!$init) {
- $init = 1;
- } else {
- $init ++;
+ if ($nocache) {
+ if ($cached) {
+ my $devalidate;
+ if ($uselink && !$result) {
+ $devalidate = 1;
+ } elsif (!$uselink && $result) {
+ $devalidate = 1;
}
- $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions,
- $newunique,$addcourse,$courseonly,$failed);
- } else {
- foreach my $key (keys(%collisions)) {
- $failed->{$key} = 1;
+ if ($devalidate) {
+ &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport);
}
}
+ } else {
+ if ($uselink) {
+ $result = 1;
+ } else {
+ $result = 0;
+ }
+ &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600);
}
- return $init;
+ return $uselink;
}
1;