--- loncom/lonnet/perl/lonnet.pm 2019/02/15 20:56:18 1.1405
+++ loncom/lonnet/perl/lonnet.pm 2019/07/25 20:23:59 1.1414
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1405 2019/02/15 20:56:18 raeburn Exp $
+# $Id: lonnet.pm,v 1.1414 2019/07/25 20:23:59 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -101,6 +101,7 @@ use LONCAPA::Configuration;
use LONCAPA::lonmetadata;
use LONCAPA::Lond;
use LONCAPA::LWPReq;
+use LONCAPA::transliterate;
use File::Copy;
@@ -1081,6 +1082,19 @@ sub find_existing_session {
return;
}
+sub delusersession {
+ my ($lonid,$udom,$uname) = @_;
+ my $uprimary_id = &domain($udom,'primary');
+ my $uintdom = &internet_dom($uprimary_id);
+ my $intdom = &internet_dom($lonid);
+ my $serverhomedom = &host_domain($lonid);
+ if (($uintdom ne '') && ($uintdom eq $intdom)) {
+ return &reply(join(':','delusersession',
+ map {&escape($_)} ($udom,$uname)),$lonid);
+ }
+ return;
+}
+
# check if user's browser sent load balancer cookie and server still has session
# and is not overloaded.
sub check_for_balancer_cookie {
@@ -1251,6 +1265,9 @@ sub changepass {
} elsif ($answer =~ "invalid_client") {
&logthis("$server refused to change $uname in $udom password because ".
"it was a reset by e-mail originating from an invalid server.");
+ } elsif ($answer =~ "^prioruse") {
+ &logthis("$server refused to change $uname in $udom password because ".
+ "the password had been used before");
}
return $answer;
}
@@ -2665,7 +2682,7 @@ sub get_domain_defaults {
if (ref($domconfig{'coursecategories'}) eq 'HASH') {
$domdefaults{'catauth'} = 'std';
$domdefaults{'catunauth'} = 'std';
- if ($domconfig{'coursecategories'}{'auth'}) {
+ if ($domconfig{'coursecategories'}{'auth'}) {
$domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
}
if ($domconfig{'coursecategories'}{'unauth'}) {
@@ -2704,6 +2721,65 @@ sub get_domain_defaults {
return %domdefaults;
}
+sub get_dom_cats {
+ my ($dom) = @_;
+ return unless (&domain($dom));
+ my ($cats,$cached)=&is_cached_new('cats',$dom);
+ unless (defined($cached)) {
+ my %domconfig = &get_dom('configuration',['coursecategories'],$dom);
+ if (ref($domconfig{'coursecategories'}) eq 'HASH') {
+ if (ref($domconfig{'coursecategories'}{'cats'}) eq 'HASH') {
+ %{$cats} = %{$domconfig{'coursecategories'}{'cats'}};
+ } else {
+ $cats = {};
+ }
+ } else {
+ $cats = {};
+ }
+ &Apache::lonnet::do_cache_new('cats',$dom,$cats,3600);
+ }
+ 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;
+}
+
sub course_portal_url {
my ($cnum,$cdom) = @_;
my $chome = &homeserver($cnum,$cdom);
@@ -2720,6 +2796,29 @@ sub course_portal_url {
return $firsturl;
}
+# --------------------------------------------- Get domain config for passwords
+
+sub get_passwdconf {
+ my ($dom) = @_;
+ my (%passwdconf,$gotconf,$lookup);
+ my ($result,$cached)=&is_cached_new('passwdconf',$dom);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ %passwdconf = %{$result};
+ $gotconf = 1;
+ }
+ }
+ unless ($gotconf) {
+ my %domconfig = &get_dom('configuration',['passwords'],$dom);
+ if (ref($domconfig{'passwords'}) eq 'HASH') {
+ %passwdconf = %{$domconfig{'passwords'}};
+ }
+ my $cachetime = 24*60*60;
+ &do_cache_new('passwdconf',$dom,\%passwdconf,$cachetime);
+ }
+ return %passwdconf;
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -3856,6 +3955,9 @@ sub clean_filename {
}
# Replace spaces by underscores
$fname=~s/\s+/\_/g;
+# Transliterate non-ascii text to ascii
+ my $lang = &Apache::lonlocal::current_language();
+ $fname = &LONCAPA::transliterate::fname_to_ascii($fname,$lang);
# Replace all other weird characters by nothing
$fname=~s{[^/\w\.\-]}{}g;
# Replace all .\d. sequences with _\d. so they no longer look like version
@@ -3863,6 +3965,7 @@ sub clean_filename {
$fname=~s/\.(\d+)(?=\.)/_$1/g;
return $fname;
}
+
# This Function checks if an Image's dimensions exceed either $resizewidth (width)
# or $resizeheight (height) - both pixels. If so, the image is scaled to produce an
# image with the same aspect ratio as the original, but with dimensions which do
@@ -3937,6 +4040,14 @@ sub userfileupload {
$fname=&clean_filename($fname);
# See if there is anything left
unless ($fname) { return 'error: no uploaded file'; }
+ # If filename now begins with a . prepend unix timestamp _ milliseconds
+ if ($fname =~ /^\./) {
+ my ($s,$usec) = &gettimeofday();
+ while (length($usec) < 6) {
+ $usec = '0'.$usec;
+ }
+ $fname = $s.'_'.substr($usec,0,3).$fname;
+ }
# Files uploaded to help request form, or uploaded to "create course" page are handled differently
if ((($formname eq 'screenshot') && ($subdir eq 'helprequests')) ||
(($formname eq 'coursecreatorxml') && ($subdir eq 'batchupload')) ||
@@ -8044,8 +8155,34 @@ sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseuri}
=~/\Q$priv\E\&([^\:]*)/) {
- unless (($priv eq 'bro') && (!$ownaccess)) {
- $thisallowed.=$1;
+ if ($priv eq 'mip') {
+ my $rem = $1;
+ if (($uri ne '') && ($env{'request.course.id'} eq $uri) &&
+ ($env{'course.'.$env{'request.course.id'}.'.internal.courseowner'} eq $env{'user.name'}.':'.$env{'user.domain'})) {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ if ($cdom ne '') {
+ my %passwdconf = &get_passwdconf($cdom);
+ if (ref($passwdconf{'crsownerchg'}) eq 'HASH') {
+ if (ref($passwdconf{'crsownerchg'}{'by'}) eq 'ARRAY') {
+ if (@{$passwdconf{'crsownerchg'}{'by'}}) {
+ my @inststatuses = split(':',$env{'environment.inststatus'});
+ unless (@inststatuses) {
+ @inststatuses = ('default');
+ }
+ foreach my $status (@inststatuses) {
+ if (grep(/^\Q$status\E$/,@{$passwdconf{'crsownerchg'}{'by'}})) {
+ $thisallowed.=$rem;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } else {
+ unless (($priv eq 'bro') && (!$ownaccess)) {
+ $thisallowed.=$1;
+ }
}
}
@@ -8134,6 +8271,16 @@ sub allowed {
if ($env{'request.course.id'}) {
+# If this is modifying password (internal auth) domains must match for user and user's role.
+
+ if ($priv eq 'mip') {
+ if ($env{'user.domain'} eq $env{'request.role.domain'}) {
+ return $thisallowed;
+ } else {
+ return '';
+ }
+ }
+
$courseprivid=$env{'request.course.id'};
if ($env{'request.course.sec'}) {
$courseprivid.='/'.$env{'request.course.sec'};
@@ -10038,7 +10185,22 @@ sub store_coowners {
sub modifyuserauth {
my ($udom,$uname,$umode,$upass)=@_;
my $uhome=&homeserver($uname,$udom);
- unless (&allowed('mau',$udom)) { return 'refused'; }
+ my $allowed;
+ if (&allowed('mau',$udom)) {
+ $allowed = 1;
+ } elsif (($umode eq 'internal') && ($udom eq $env{'user.domain'}) &&
+ ($env{'request.course.id'}) && (&allowed('mip',$env{'request.course.id'})) &&
+ (!$env{'course.'.$env{'request.course.id'}.'.internal.nopasswdchg'})) {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ if (($cdom ne '') && ($cnum ne '')) {
+ my $is_owner = &is_course_owner($cdom,$cnum);
+ if ($is_owner) {
+ $allowed = 1;
+ }
+ }
+ }
+ unless ($allowed) { return 'refused'; }
&logthis('Call to modify user authentication '.$udom.', '.$uname.', '.
$umode.' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
' in domain '.$env{'request.role.domain'});
@@ -13905,6 +14067,27 @@ sub default_login_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;
+}
+
sub uses_sts {
my ($ignore_cache) = @_;
my $lonhost = $perlvar{'lonHostID'};