--- loncom/interface/loncommon.pm 2018/05/08 20:30:12 1.1318
+++ loncom/interface/loncommon.pm 2019/05/11 21:34:01 1.1332
@@ -1,7 +1,7 @@
# The LearningOnline Network with CAPA
# a pile of common routines
#
-# $Id: loncommon.pm,v 1.1318 2018/05/08 20:30:12 raeburn Exp $
+# $Id: loncommon.pm,v 1.1332 2019/05/11 21:34:01 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -72,6 +72,7 @@ use Apache::lonuserstate();
use Apache::courseclassifier();
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::LWPReq;
+use HTTP::Request;
use DateTime::TimeZone;
use DateTime::Locale;
use Encode();
@@ -3566,6 +3567,78 @@ sub get_assignable_auth {
return ($authnum,%can_assign);
}
+sub check_passwd_rules {
+ my ($domain,$plainpass) = @_;
+ my %passwdconf = &Apache::lonnet::get_passwdconf($domain);
+ my ($min,$max,@chars,@brokerule,$warning);
+ if (ref($passwdconf{'chars'}) eq 'ARRAY') {
+ if ($passwdconf{'min'} =~ /^\d+$/) {
+ $min = $passwdconf{'min'};
+ }
+ if ($passwdconf{'max'} =~ /^\d+$/) {
+ $max = $passwdconf{'max'};
+ }
+ @chars = @{$passwdconf{'chars'}};
+ } else {
+ $min = 7;
+ }
+ if (($min) && (length($plainpass) < $min)) {
+ push(@brokerule,'min');
+ }
+ if (($max) && (length($plainpass) > $max)) {
+ push(@brokerule,'max');
+ }
+ if (@chars) {
+ my %rules;
+ map { $rules{$_} = 1; } @chars;
+ if ($rules{'uc'}) {
+ unless ($plainpass =~ /[A-Z]/) {
+ push(@brokerule,'uc');
+ }
+ }
+ if ($rules{'lc'}) {
+ unless ($plainpass =~ /[a-z]/) {
+ push(@brokerule,'lc');
+ }
+ }
+ if ($rules{'num'}) {
+ unless ($plainpass =~ /\d/) {
+ push(@brokerule,'num');
+ }
+ }
+ if ($rules{'spec'}) {
+ unless ($plainpass =~ /[!"#$%&'()*+,\-.\/:;<=>?@[\\\]^_`{|}~]/) {
+ push(@brokerule,'spec');
+ }
+ }
+ }
+ if (@brokerule) {
+ my %rulenames = &Apache::lonlocal::texthash(
+ uc => 'At least one upper case letter',
+ lc => 'At least one lower case letter',
+ num => 'At least one number',
+ spec => 'At least one non-alphanumeric',
+ );
+ $rulenames{'uc'} .= ': ABCDEFGHIJKLMNOPQRSTUVWXYZ';
+ $rulenames{'lc'} .= ': abcdefghijklmnopqrstuvwxyz';
+ $rulenames{'num'} .= ': 0123456789';
+ $rulenames{'spec'} .= ': !"\#$%&\'()*+,-./:;<=>?@[\]^_\`{|}~';
+ $rulenames{'min'} = &mt('Minimum password length: [_1]',$min);
+ $rulenames{'max'} = &mt('Maximum password length: [_1]',$max);
+ $warning = &mt('Password did not satisfy the following:').'<ul>';
+ foreach my $rule ('min','max','uc','ls','num','spec') {
+ if (grep(/^$rule$/,@brokerule)) {
+ $warning .= '<li>'.$rulenames{$rule}.'</li>';
+ }
+ }
+ $warning .= '</ul>';
+ }
+ if (wantarray) {
+ return @brokerule;
+ }
+ return $warning;
+}
+
###############################################################
## Get Kerberos Defaults for Domain ##
###############################################################
@@ -13937,7 +14010,7 @@ sub load_tmp_file {
sub valid_datatoken {
my ($datatoken) = @_;
- if ($datatoken =~ /^$match_username\_$match_domain\_enroll_$match_domain\_$match_courseid\_\d+_\d+$/) {
+ if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) {
return $datatoken;
}
return;
@@ -15245,6 +15318,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.
@@ -15252,7 +15327,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') {
@@ -15280,12 +15355,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;
+ }
}
}
}
@@ -15323,13 +15401,13 @@ 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++) {
my $name = $cats->[$depth]{$category}[$k];
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;
@@ -15350,16 +15428,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;
}
@@ -15391,8 +15474,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;
@@ -16410,6 +16493,24 @@ sub compare_arrays {
return @difference;
}
+sub lon_status_items {
+ my %defaults = (
+ E => 100,
+ W => 4,
+ N => 1,
+ U => 5,
+ threshold => 200,
+ sysmail => 2500,
+ );
+ my %names = (
+ E => 'Errors',
+ W => 'Warnings',
+ N => 'Notices',
+ U => 'Unsent',
+ );
+ return (\%defaults,\%names);
+}
+
# -------------------------------------------------------- Initialize user login
sub init_user_environment {
my ($r, $username, $domain, $authhost, $form, $args) = @_;
@@ -16444,18 +16545,18 @@ sub init_user_environment {
opendir(DIR,$lonids);
while ($filename=readdir(DIR)) {
if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
- if ($ENV{'SERVER_PORT'} == 443) {
+ if (tie(my %oldenv,'GDBM_File',"$lonids/$filename",
+ &GDBM_READER(),0640)) {
my $linkedfile;
- if (tie(my %oldenv,'GDBM_File',"$lonids/$cookie.id",
- &GDBM_READER(),0640)) {
- if (exists($oldenv{'user.linkedenv'})) {
- $linkedfile = $oldenv{'user.linkedenv'};
- }
- untie(%oldenv);
+ if (exists($oldenv{'user.linkedenv'})) {
+ $linkedfile = $oldenv{'user.linkedenv'};
}
- if (unlink($lonids.'/'.$filename)) {
- if ($linkedfile =~ /^[a-f0-9]+_linked\.id$/) {
- unlink($lonids.'/'.$linkedfile);
+ untie(%oldenv);
+ if (unlink("$lonids/$filename")) {
+ if ($linkedfile =~ /^[a-f0-9]+_linked$/) {
+ if (-l "$lonids/$linkedfile.id") {
+ unlink("$lonids/$linkedfile.id");
+ }
}
}
} else {
@@ -17456,7 +17557,7 @@ sub needs_coursereinit {
}
sub update_content_constraints {
- my ($cdom,$cnum,$chome,$cid) = @_;
+ my ($cdom,$cnum,$chome,$cid,$keeporder) = @_;
my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired');
my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'});
my (%checkresponsetypes,%checkcrsrestypes);
@@ -17504,10 +17605,24 @@ sub update_content_constraints {
}
undef($navmap);
}
+ my (@resources,@order,@resparms,@zombies);
+ if ($keeporder) {
+ use LONCAPA::map;
+ @resources = @LONCAPA::map::resources;
+ @order = @LONCAPA::map::order;
+ @resparms = @LONCAPA::map::resparms;
+ @zombies = @LONCAPA::map::zombies;
+ }
my $suppmap = 'supplemental.sequence';
my ($suppcount,$supptools,$errors) = (0,0,0);
($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap,
$suppcount,$supptools,$errors);
+ if ($keeporder) {
+ @LONCAPA::map::resources = @resources;
+ @LONCAPA::map::order = @order;
+ @LONCAPA::map::resparms = @resparms;
+ @LONCAPA::map::zombies = @zombies;
+ }
if ($supptools) {
my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'});
if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) {
@@ -17534,7 +17649,7 @@ sub allmaps_incourse {
if ($lastchange > $env{'request.course.tied'}) {
my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum");
unless ($ferr) {
- &update_content_constraints($cdom,$cnum,$chome,$cid);
+ &update_content_constraints($cdom,$cnum,$chome,$cid,1);
}
}
my $navmap = Apache::lonnavmaps::navmap->new();
@@ -17668,10 +17783,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) {
@@ -17687,9 +17802,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') {
@@ -17701,7 +17816,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);
@@ -17749,7 +17864,28 @@ 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);
}
@@ -17773,6 +17909,9 @@ sub create_captcha {
last;
}
}
+ if ($output eq '') {
+ &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
+ }
return $output;
}
@@ -18024,7 +18163,7 @@ sub make_short_symbs {
while (($gotlock ne 'ok') && ($tries<3)) {
$tries ++;
sleep 1;
- $gotlock = &Apache::lonnet::newput_dom('uniquecodes',$lockhash,$cdom);
+ $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom);
}
if ($gotlock eq 'ok') {
$init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique,
@@ -18125,6 +18264,157 @@ sub shorten_symbs {
return $init;
}
+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 {
+ return 0;
+ }
+ }
+ }
+ my $uselink;
+ my $request = new HTTP::Request('HEAD',$url);
+ my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5);
+ 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:';
+ }
+ $origin = $protocol.'//'.lc($hostname);
+ } else {
+ $origin = lc($absolute);
+ ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$});
+ }
+ 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 ($nocache) {
+ if ($cached) {
+ my $devalidate;
+ if ($uselink && !$result) {
+ $devalidate = 1;
+ } elsif (!$uselink && $result) {
+ $devalidate = 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 $uselink;
+}
+
1;
__END__;