--- loncom/lonnet/perl/lonnet.pm 2017/12/18 23:14:03 1.1362
+++ loncom/lonnet/perl/lonnet.pm 2021/05/03 15:27:45 1.1450
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1362 2017/12/18 23:14:03 raeburn Exp $
+# $Id: lonnet.pm,v 1.1450 2021/05/03 15:27:45 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -73,13 +73,13 @@ package Apache::lonnet;
use strict;
use HTTP::Date;
use Image::Magick;
-
+use CGI::Cookie;
use Encode;
-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
- %managerstab);
+ %managerstab $passwdmin);
my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
%userrolehash, $processmarker, $dumpcount, %coursedombuf,
@@ -96,11 +96,13 @@ use Cache::Memcached;
use Digest::MD5;
use Math::Random;
use File::MMagic;
+use Net::CIDR;
use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
use LONCAPA::lonmetadata;
use LONCAPA::Lond;
use LONCAPA::LWPReq;
+use LONCAPA::transliterate;
use File::Copy;
@@ -127,12 +129,13 @@ our @EXPORT = qw(%env);
$logid ++;
my $now = time();
my $id=$now.'00000'.$$.'00000'.$logid;
+ my $ip = &get_requestor_ip();
my $logentry = {
$id => {
'exe_uname' => $env{'user.name'},
'exe_udom' => $env{'user.domain'},
'exe_time' => $now,
- 'exe_ip' => $ENV{'REMOTE_ADDR'},
+ 'exe_ip' => $ip,
'delflag' => $delflag,
'logentry' => $storehash,
'uname' => $uname,
@@ -184,7 +187,7 @@ sub create_connection {
Type => SOCK_STREAM,
Timeout => 10);
return 0 if (!$client);
- print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
+ print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n");
my $result = <$client>;
chomp($result);
return 1 if ($result eq 'done');
@@ -230,12 +233,19 @@ sub get_server_distarch {
}
sub get_servercerts_info {
- my ($lonhost,$context) = @_;
+ my ($lonhost,$hostname,$context) = @_;
+ return if ($lonhost eq '');
+ if ($hostname eq '') {
+ $hostname = &hostname($lonhost);
+ }
+ return if ($hostname eq '');
my ($rep,$uselocal);
- if (grep { $_ eq $lonhost } ¤t_machine_ids()) {
+ if ($context eq 'install') {
+ $uselocal = 1;
+ } elsif (grep { $_ eq $lonhost } ¤t_machine_ids()) {
$uselocal = 1;
}
- if (($context ne 'cgi') && ($uselocal)) {
+ if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
if ($distro eq '') {
$uselocal = 0;
@@ -250,16 +260,11 @@ sub get_servercerts_info {
}
}
if ($uselocal) {
- $rep = LONCAPA::Lond::server_certs(\%perlvar);
+ $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
} else {
$rep=&reply('servercerts',$lonhost);
}
my ($result,%returnhash);
- if (defined($lonhost)) {
- if (!defined(&hostname($lonhost))) {
- return;
- }
- }
if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
($rep eq 'unknown_cmd')) {
$result = $rep;
@@ -309,9 +314,10 @@ sub get_server_loncaparev {
$answer = &reply('serverloncaparev',$lonhost);
if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) {
if ($caller eq 'loncron') {
+ my $hostname = &hostname($lonhost);
my $protocol = $protocol{$lonhost};
$protocol = 'http' if ($protocol ne 'https');
- my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html';
+ my $url = $protocol.'://'.$hostname.'/adm/about.html';
my $request=new HTTP::Request('GET',$url);
my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1);
unless ($response->is_error()) {
@@ -456,8 +462,26 @@ sub reply {
unless (defined(&hostname($server))) { return 'no_such_host'; }
my $answer=subreply($cmd,$server);
if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
- &logthis("WARNING:".
- " $cmd to $server returned $answer");
+ my $logged = $cmd;
+ if ($cmd =~ /^encrypt:([^:]+):/) {
+ my $subcmd = $1;
+ if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
+ ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
+ ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) {
+ (undef,undef,my @rest) = split(/:/,$cmd);
+ if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
+ splice(@rest,2,1,'Hidden');
+ } elsif ($subcmd eq 'passwd') {
+ splice(@rest,2,2,('Hidden','Hidden'));
+ } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
+ ($subcmd eq 'autoexportgrades')) {
+ splice(@rest,3,1,'Hidden');
+ }
+ $logged = join(':',('encrypt:'.$subcmd,@rest));
+ }
+ }
+ &logthis("WARNING:".
+ " $logged to $server returned $answer");
}
return $answer;
}
@@ -652,31 +676,39 @@ sub transfer_profile_to_env {
sub check_for_valid_session {
my ($r,$name,$userhashref,$domref) = @_;
my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
- my ($linkname,$pubname);
- if ($name eq '') {
- $name = 'lonID';
+ my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
+ if ($name eq 'lonDAV') {
+ $lonidsdir=$r->dir_config('lonDAVsessDir');
+ } else {
+ $lonidsdir=$r->dir_config('lonIDsDir');
+ if ($name eq '') {
+ $name = 'lonID';
+ }
+ }
+ if ($name eq 'lonID') {
+ $secure = 'lonSID';
$linkname = 'lonLinkID';
$pubname = 'lonPubID';
- }
- my $lonid=$cookies{$name};
- if (!$lonid) {
- if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) {
+ if (exists($cookies{$secure})) {
+ $lonid=$cookies{$secure};
+ } elsif (exists($cookies{$name})) {
+ $lonid=$cookies{$name};
+ } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) {
$lonid=$cookies{$linkname};
+ } elsif (exists($cookies{$pubname})) {
+ $lonid=$cookies{$pubname};
}
- if (!$lonid) {
- if (($name eq 'lonID') && ($pubname)) {
- $lonid=$cookies{$pubname};
- }
- }
+ } else {
+ $lonid=$cookies{$name};
}
return undef if (!$lonid);
my $handle=&LONCAPA::clean_handle($lonid->value);
- my $lonidsdir;
- if ($name eq 'lonDAV') {
- $lonidsdir=$r->dir_config('lonDAVsessDir');
- } else {
- $lonidsdir=$r->dir_config('lonIDsDir');
+ 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") {
if ((ref($domref)) && ($name eq 'lonID') &&
@@ -701,14 +733,23 @@ sub check_for_valid_session {
if (!defined($disk_env{'user.name'})
|| !defined($disk_env{'user.domain'})) {
+ untie(%disk_env);
return undef;
}
if (ref($userhashref) eq 'HASH') {
$userhashref->{'name'} = $disk_env{'user.name'};
$userhashref->{'domain'} = $disk_env{'user.domain'};
+ if ($disk_env{'request.role'}) {
+ $userhashref->{'role'} = $disk_env{'request.role'};
+ }
$userhashref->{'lti'} = $disk_env{'request.lti.login'};
+ if ($userhashref->{'lti'}) {
+ $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
+ $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
+ }
}
+ untie(%disk_env);
return $handle;
}
@@ -733,6 +774,37 @@ 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
sub appenv {
@@ -758,16 +830,19 @@ sub appenv {
$env{$key}=$newenv->{$key};
}
}
- my $opened = open(my $env_file,'+<',$env{'user.environment'});
- if ($opened
- && &timed_flock($env_file,LOCK_EX)
- &&
- tie(my %disk_env,'GDBM_File',$env{'user.environment'},
- (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
- while (my ($key,$value) = each(%{$newenv})) {
- $disk_env{$key} = $value;
- }
- untie(%disk_env);
+ my $lonids = $perlvar{'lonIDsDir'};
+ if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
+ my $opened = open(my $env_file,'+<',$env{'user.environment'});
+ if ($opened
+ && &timed_flock($env_file,LOCK_EX)
+ &&
+ tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+ (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
+ while (my ($key,$value) = each(%{$newenv})) {
+ $disk_env{$key} = $value;
+ }
+ untie(%disk_env);
+ }
}
}
return 'ok';
@@ -883,6 +958,7 @@ sub userload {
while ($filename=readdir(LONIDS)) {
next if ($filename eq '.' || $filename eq '..');
next if ($filename =~ /publicuser_\d+\.id/);
+ next if ($filename =~ /^[a-f0-9]+_linked\.id$/);
my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
if ($curtime-$mtime < 1800) { $numusers++; }
}
@@ -938,13 +1014,13 @@ sub spareserver {
}
if (!$want_server_name) {
- my $protocol = 'http';
- if ($protocol{$spare_server} eq 'https') {
- $protocol = $protocol{$spare_server};
- }
if (defined($spare_server)) {
my $hostname = &hostname($spare_server);
if (defined($hostname)) {
+ my $protocol = 'http';
+ if ($protocol{$spare_server} eq 'https') {
+ $protocol = $protocol{$spare_server};
+ }
$spare_server = $protocol.'://'.$hostname;
}
}
@@ -1011,6 +1087,103 @@ 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 {
+ 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 updatebalcookie {
+ my ($cookie,$balancer,$lastentry)=@_;
+ 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('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
+ }
+ }
+ return;
+}
+
+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:'.&escape($cookie),$balancer);
+ }
+ }
+}
+
# -------------------------------- ask if server already has a session for user
sub has_user_session {
my ($lonid,$udom,$uname) = @_;
@@ -1046,7 +1219,7 @@ sub choose_server {
if (ref($balancers) eq 'HASH') {
next if (exists($balancers->{$lonhost}));
}
- }
+ }
my $loginvia;
if ($checkloginvia) {
$loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
@@ -1077,6 +1250,28 @@ sub choose_server {
return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load);
}
+sub get_course_sessions {
+ my ($cnum,$cdom,$lastactivity) = @_;
+ my %servers = &internet_dom_servers($cdom);
+ my %returnhash;
+ foreach my $server (sort(keys(%servers))) {
+ my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server);
+ my @pairs=split(/\&/,$rep);
+ unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) {
+ foreach my $item (@pairs) {
+ my ($key,$value)=split(/=/,$item,2);
+ $key = &unescape($key);
+ next if ($key =~ /^error: 2 /);
+ if (exists($returnhash{$key})) {
+ next if ($value < $returnhash{$key});
+ }
+ $returnhash{$key}=$value;
+ }
+ }
+ }
+ return %returnhash;
+}
+
# --------------------------------------------- Try to change a user's password
sub changepass {
@@ -1112,6 +1307,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;
}
@@ -1250,6 +1448,15 @@ sub spare_can_host {
$canhost = 0;
}
}
+ if ($canhost) {
+ if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
+ if ($defdomdefaults{'offloadoth'}{$try_server}) {
+ unless (&shared_institution($udom,$try_server)) {
+ $canhost = 0;
+ }
+ }
+ }
+ }
if (($canhost) && ($uint_dom)) {
my @intdoms;
my $internet_names = &get_internet_names($try_server);
@@ -1348,7 +1555,7 @@ sub get_lonbalancer_config {
sub check_loadbalancing {
my ($uname,$udom,$caller) = @_;
my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
- $rule_in_effect,$offloadto,$otherserver);
+ $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
my $lonhost = $perlvar{'lonHostID'};
my @hosts = ¤t_machine_ids();
my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
@@ -1375,7 +1582,7 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules) =
+ ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1436,7 +1643,7 @@ sub check_loadbalancing {
}
}
if (ref($result) eq 'HASH') {
- ($is_balancer,$currtargets,$currrules) =
+ ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
&check_balancer_result($result,@hosts);
if ($is_balancer) {
if (ref($currrules) eq 'HASH') {
@@ -1468,7 +1675,7 @@ sub check_loadbalancing {
if ($domneedscache) {
&do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
}
- if ($is_balancer) {
+ if (($is_balancer) && ($caller ne 'switchserver')) {
my $lowest_load = 30000;
if (ref($offloadto) eq 'HASH') {
if (ref($offloadto->{'primary'}) eq 'ARRAY') {
@@ -1502,20 +1709,22 @@ sub check_loadbalancing {
$is_balancer = 0;
if ($uname ne '' && $udom ne '') {
if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
-
- &appenv({'user.loadbalexempt' => $lonhost,
+ &appenv({'user.loadbalexempt' => $lonhost,
'user.loadbalcheck.time' => time});
}
}
}
}
}
- return ($is_balancer,$otherserver);
+ if (($is_balancer) && (!$homeintdom)) {
+ undef($setcookie);
+ }
+ return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
}
sub check_balancer_result {
my ($result,@hosts) = @_;
- my ($is_balancer,$currtargets,$currrules);
+ my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
if (ref($result) eq 'HASH') {
if ($result->{'lonhost'} ne '') {
my $currbalancer = $result->{'lonhost'};
@@ -1524,19 +1733,24 @@ sub check_balancer_result {
$currtargets = $result->{'targets'};
$currrules = $result->{'rules'};
}
+ $dom_balancers = $currbalancer;
} else {
- foreach my $key (keys(%{$result})) {
- if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
- (ref($result->{$key}) eq 'HASH')) {
- $is_balancer = 1;
- $currrules = $result->{$key}{'rules'};
- $currtargets = $result->{$key}{'targets'};
- last;
+ if (keys(%{$result})) {
+ foreach my $key (keys(%{$result})) {
+ if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
+ (ref($result->{$key}) eq 'HASH')) {
+ $is_balancer = 1;
+ $currrules = $result->{$key}{'rules'};
+ $currtargets = $result->{$key}{'targets'};
+ $setcookie = $result->{$key}{'cookie'};
+ last;
+ }
}
+ $dom_balancers = join(',',sort(keys(%{$result})));
}
}
}
- return ($is_balancer,$currtargets,$currrules);
+ return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
}
sub get_loadbalancer_targets {
@@ -1614,7 +1828,7 @@ sub trusted_domains {
if (&domain($calldom) eq '') {
return ($trusted,$untrusted);
}
- unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) {
+ unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) {
return ($trusted,$untrusted);
}
my $callprimary = &domain($calldom,'primary');
@@ -1636,6 +1850,7 @@ sub trusted_domains {
map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}};
}
if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') {
+ $possinc{$intcalldom} = 1;
map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}};
}
}
@@ -1670,12 +1885,12 @@ sub trusted_domains {
}
foreach my $exc (@allexc) {
if (ref($doms_by_intdom{$exc}) eq 'ARRAY') {
- $untrusted = $doms_by_intdom{$exc};
+ push(@{$untrusted},@{$doms_by_intdom{$exc}});
}
}
foreach my $inc (@allinc) {
if (ref($doms_by_intdom{$inc}) eq 'ARRAY') {
- $trusted = $doms_by_intdom{$inc};
+ push(@{$trusted},@{$doms_by_intdom{$inc}});
}
}
}
@@ -1952,10 +2167,19 @@ sub get_dom {
}
if ($udom && $uhome && ($uhome ne 'no_host')) {
my $rep;
- if ($namespace =~ /^enc/) {
- $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
+ if (grep { $_ eq $uhome } ¤t_machine_ids()) {
+ # domain information is hosted on this machine
+ my $cmd = 'getdom';
+ if ($namespace =~ /^enc/) {
+ $cmd = 'egetdom';
+ }
+ $rep = &LONCAPA::Lond::get_dom("$cmd:$udom:$namespace:$items");
} else {
- $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;
if ($rep eq '' || $rep =~ /^error: 2 /) {
@@ -2097,7 +2321,7 @@ sub inst_directory_query {
if ($homeserver ne '') {
unless ($homeserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {
- my $lcrev = &get_server_loncaparev(undef,$homeserver);
+ my $lcrev = &get_server_loncaparev($udom,$homeserver);
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
if (($major eq '' && $minor eq '') || ($major < 2) ||
(($major == 2) && ($minor < 12))) {
@@ -2148,7 +2372,7 @@ sub usersearch {
if (&host_domain($tryserver) eq $dom) {
unless ($tryserver eq $perlvar{'lonHostID'}) {
if ($srch->{'srchby'} eq 'email') {
- my $lcrev = &get_server_loncaparev(undef,$tryserver);
+ my $lcrev = &get_server_loncaparev($dom,$tryserver);
my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
next if (($major eq '' && $minor eq '') || ($major < 2) ||
(($major == 2) && ($minor < 12)));
@@ -2393,7 +2617,7 @@ sub get_domain_defaults {
'coursedefaults','usersessions',
'requestauthor','selfenrollment',
'coursecategories','ssl','autoenroll',
- 'trust','helpsettings'],$domain);
+ 'trust','helpsettings','wafproxy'],$domain);
my @coursetypes = ('official','unofficial','community','textbook','placement');
if (ref($domconfig{'defaults'}) eq 'HASH') {
$domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};
@@ -2486,6 +2710,9 @@ sub get_domain_defaults {
if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
$domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
}
+ if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
+ $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
+ }
}
if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
@@ -2518,7 +2745,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'}) {
@@ -2553,10 +2780,76 @@ sub get_domain_defaults {
$domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
}
}
+ if (ref($domconfig{'wafproxy'}) eq 'HASH') {
+ foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
+ if ($domconfig{'wafproxy'}{$item}) {
+ $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
+ }
+ }
+ }
&do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
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);
@@ -2573,6 +2866,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 {
@@ -3115,6 +3431,32 @@ sub repcopy {
}
}
+# ------------------------------------------------- Unsubscribe from a resource
+
+sub unsubscribe {
+ my ($fname) = @_;
+ my $answer;
+ if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
+ $fname=~s/[\n\r]//g;
+ my $author=$fname;
+ $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
+ my ($udom,$uname)=split(/\//,$author);
+ my $home=homeserver($uname,$udom);
+ if ($home eq 'no_host') {
+ $answer = 'no_host';
+ } elsif (grep { $_ eq $home } ¤t_machine_ids()) {
+ $answer = 'home';
+ } else {
+ my $defdom = $perlvar{'lonDefDomain'};
+ if (&will_trust('content',$defdom,$udom)) {
+ $answer = reply("unsub:$fname",$home);
+ } else {
+ $answer = 'untrusted';
+ }
+ }
+ return $answer;
+}
+
# ------------------------------------------------ Get server side include body
sub ssi_body {
my ($filelink,%form)=@_;
@@ -3143,11 +3485,29 @@ sub ssi_body {
# --------------------------------------------------------- Server Side Include
sub absolute_url {
- my ($host_name) = @_;
+ my ($host_name,$unalias,$keep_proto) = @_;
my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
if ($host_name eq '') {
$host_name = $ENV{'SERVER_NAME'};
}
+ if ($unalias) {
+ my $alias = &get_proxy_alias();
+ if ($alias eq $host_name) {
+ my $lonhost = $perlvar{'lonHostID'};
+ my $hostname = &hostname($lonhost);
+ my $lcproto;
+ if (($keep_proto) || ($hostname eq '')) {
+ $lcproto = $protocol;
+ } else {
+ $lcproto = $protocol{$lonhost};
+ $lcproto = 'http' if ($lcproto ne 'https');
+ $lcproto .= '://';
+ }
+ unless ($hostname eq '') {
+ return $lcproto.$hostname;
+ }
+ }
+ }
return $protocol.$host_name;
}
@@ -3164,12 +3524,13 @@ sub absolute_url {
sub ssi {
my ($fn,%form)=@_;
- my $request;
+ my ($host,$request,$response);
+ $host = &absolute_url('',1);
$form{'no_update_last_known'}=1;
&Apache::lonenc::check_encrypt(\$fn);
if (%form) {
- $request=new HTTP::Request('POST',&absolute_url().$fn);
+ $request=new HTTP::Request('POST',$host.$fn);
$request->content(join('&',map {
my $name = escape($_);
"$name=" . ( ref($form{$_}) eq 'ARRAY'
@@ -3177,12 +3538,22 @@ sub ssi {
: &escape($form{$_}) );
} keys(%form)));
} else {
- $request=new HTTP::Request('GET',&absolute_url().$fn);
+ $request=new HTTP::Request('GET',$host.$fn);
}
$request->header(Cookie => $ENV{'HTTP_COOKIE'});
my $lonhost = $perlvar{'lonHostID'};
- my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar);
+ my $islocal;
+ 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'}:'')))) {
+ $islocal = 1;
+ }
+ $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
+ '','','',$islocal);
if (wantarray) {
return ($response->content, $response);
@@ -3220,10 +3591,10 @@ sub remove_stale_resfile {
(grep { $_ eq $homeserver } ¤t_machine_ids())) {
my $fname = &filelocation('',$url);
if (-e $fname) {
- my $protocol = $protocol{$homeserver};
- $protocol = 'http' if ($protocol ne 'https');
my $hostname = &hostname($homeserver);
if ($hostname) {
+ my $protocol = $protocol{$homeserver};
+ $protocol = 'http' if ($protocol ne 'https');
my $uri = &declutter($url);
my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri);
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1);
@@ -3250,12 +3621,18 @@ sub remove_stale_resfile {
$stale = 1;
}
if ($stale) {
- unlink($fname);
- if ($uri!~/\.meta$/) {
- unlink($fname.'.meta');
+ if (unlink($fname)) {
+ if ($uri!~/\.meta$/) {
+ if (-e $fname.'.meta') {
+ unlink($fname.'.meta');
+ }
+ }
+ my $unsubresult = &unsubscribe($fname);
+ unless ($unsubresult eq 'ok') {
+ &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
+ }
+ $removed = 1;
}
- &reply("unsub:$fname",$homeserver);
- $removed = 1;
}
}
}
@@ -3405,6 +3782,18 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
+ } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) {
+ my ($map,$id,$res) = &decode_symb($symb);
+ if ($map =~ /\.page$/) {
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ $cfile = $map;
+ } else {
+ $forceedit = 1;
+ $cfile = '/adm/wrapper'.$resurl;
+ }
+ }
} elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -3430,13 +3819,13 @@ sub can_edit_resource {
$cfile = $template;
}
} elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
- $incourse = 1;
- if ($env{'form.forceedit'}) {
- $forceview = 1;
- } else {
- $forceedit = 1;
- }
- $cfile = $resurl;
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = $resurl;
} elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -3699,13 +4088,21 @@ 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
# numbers
$fname=~s/\.(\d+)(?=\.)/_$1/g;
+# Replace three or more adjacent underscores with one for consistency
+# with loncfile::filename_check() so complete url can be extracted by
+# lonnet::decode_symb()
+ $fname=~s/_{3,}/_/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
@@ -3748,13 +4145,16 @@ sub resizeImage {
# input: $formname - the contents of the file are in $env{"form.$formname"}
# the desired filename is in $env{"form.$formname.filename"}
# $context - possible values: coursedoc, existingfile, overwrite,
-# canceloverwrite, or ''.
+# canceloverwrite, scantron or ''.
# if 'coursedoc': upload to the current course
# if 'existingfile': write file to tmp/overwrites directory
# if 'canceloverwrite': delete file written to tmp/overwrites directory
# $context is passed as argument to &finishuserfileupload
# $subdir - directory in userfile to store the file into
-# $parser - instruction to parse file for objects ($parser = parse)
+# $parser - instruction to parse file for objects ($parser = parse) or
+# if context is 'scantron', $parser is hashref of csv column mapping
+# (e.g.,{ PaperID => 0, LastName => 1, FirstName => 2, ID => 3,
+# Section => 4, CODE => 5, FirstQuestion => 9 }).
# $allfiles - reference to hash for embedded objects
# $codebase - reference to hash for codebase of java objects
# $desuname - username for permanent storage of uploaded file
@@ -3777,6 +4177,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')) ||
@@ -3944,7 +4352,7 @@ sub finishuserfileupload {
}
}
}
- if ($parser eq 'parse') {
+ if (($context ne 'scantron') && ($parser eq 'parse')) {
if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
my $parse_result = &extract_embedded_items($filepath.'/'.$file,
$allfiles,$codebase);
@@ -3953,6 +4361,9 @@ sub finishuserfileupload {
' for embedded media: '.$parse_result);
}
}
+ } elsif (($context eq 'scantron') && (ref($parser) eq 'HASH')) {
+ my $format = $env{'form.scantron_format'};
+ &bubblesheet_converter($docudom,$filepath.'/'.$file,$parser,$format);
}
if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
my $input = $filepath.'/'.$file;
@@ -4193,6 +4604,246 @@ sub embedded_dependency {
return;
}
+sub bubblesheet_converter {
+ my ($cdom,$fullpath,$config,$format) = @_;
+ if ((&domain($cdom) ne '') &&
+ ($fullpath =~ m{^\Q$perlvar{'lonDocRoot'}/userfiles/$cdom/\E$match_courseid/scantron_orig}) &&
+ (-e $fullpath) && (ref($config) eq 'HASH') && ($format ne '')) {
+ my (%csvcols,%csvoptions);
+ if (ref($config->{'fields'}) eq 'HASH') {
+ %csvcols = %{$config->{'fields'}};
+ }
+ if (ref($config->{'options'}) eq 'HASH') {
+ %csvoptions = %{$config->{'options'}};
+ }
+ my %csvbynum = reverse(%csvcols);
+ my %scantronconf = &get_scantron_config($format,$cdom);
+ if (keys(%scantronconf)) {
+ my %bynum = (
+ $scantronconf{CODEstart} => 'CODEstart',
+ $scantronconf{IDstart} => 'IDstart',
+ $scantronconf{PaperID} => 'PaperID',
+ $scantronconf{FirstName} => 'FirstName',
+ $scantronconf{LastName} => 'LastName',
+ $scantronconf{Qstart} => 'Qstart',
+ );
+ my @ordered;
+ foreach my $item (sort { $a <=> $b } keys(%bynum)) {
+ push(@ordered,$bynum{$item});
+ }
+ my %mapstart = (
+ CODEstart => 'CODE',
+ IDstart => 'ID',
+ PaperID => 'PaperID',
+ FirstName => 'FirstName',
+ LastName => 'LastName',
+ Qstart => 'FirstQuestion',
+ );
+ my %maplength = (
+ CODEstart => 'CODElength',
+ IDstart => 'IDlength',
+ PaperID => 'PaperIDlength',
+ FirstName => 'FirstNamelength',
+ LastName => 'LastNamelength',
+ );
+ if (open(my $fh,'<',$fullpath)) {
+ my $output;
+ my %lettdig = &letter_to_digits();
+ my %diglett = reverse(%lettdig);
+ my $numletts = scalar(keys(%lettdig));
+ my $num = 0;
+ while (my $line=<$fh>) {
+ $num ++;
+ next if (($num == 1) && ($csvoptions{'hdr'} == 1));
+ $line =~ s{[\r\n]+$}{};
+ my %found;
+ my @values = split(/,/,$line);
+ my ($qstart,$record);
+ for (my $i=0; $i<@values; $i++) {
+ if ((($qstart ne '') && ($i > $qstart)) ||
+ ($csvbynum{$i} eq 'FirstQuestion')) {
+ if ($values[$i] eq '') {
+ $values[$i] = $scantronconf{'Qoff'};
+ } elsif ($scantronconf{'Qon'} eq 'number') {
+ if ($values[$i] =~ /^[A-Ja-j]$/) {
+ $values[$i] = $lettdig{uc($values[$i])};
+ }
+ } elsif ($scantronconf{'Qon'} eq 'letter') {
+ if ($values[$i] =~ /^[0-9]$/) {
+ $values[$i] = $diglett{$values[$i]};
+ }
+ } else {
+ if ($values[$i] =~ /^[0-9A-Ja-j]$/) {
+ my $digit;
+ if ($values[$i] =~ /^[A-Ja-j]$/) {
+ $digit = $lettdig{uc($values[$i])}-1;
+ if ($values[$i] eq 'J') {
+ $digit += $numletts;
+ }
+ } elsif ($values[$i] =~ /^[0-9]$/) {
+ $digit = $values[$i]-1;
+ if ($values[$i] eq '0') {
+ $digit += $numletts;
+ }
+ }
+ my $qval='';
+ for (my $j=0; $j<$scantronconf{'Qlength'}; $j++) {
+ if ($j == $digit) {
+ $qval .= $scantronconf{'Qon'};
+ } else {
+ $qval .= $scantronconf{'Qoff'};
+ }
+ }
+ $values[$i] = $qval;
+ }
+ }
+ if (length($values[$i]) > $scantronconf{'Qlength'}) {
+ $values[$i] = substr($values[$i],0,$scantronconf{'Qlength'});
+ }
+ my $numblank = $scantronconf{'Qlength'} - length($values[$i]);
+ if ($numblank > 0) {
+ $values[$i] .= ($scantronconf{'Qoff'} x $numblank);
+ }
+ if ($csvbynum{$i} eq 'FirstQuestion') {
+ $qstart = $i;
+ $found{$csvbynum{$i}} = $values[$i];
+ } else {
+ $found{'FirstQuestion'} .= $values[$i];
+ }
+ } elsif (exists($csvbynum{$i})) {
+ if ($csvoptions{'rem'}) {
+ $values[$i] =~ s/^\s+//;
+ }
+ if (($csvbynum{$i} eq 'PaperID') && ($csvoptions{'pad'})) {
+ while (length($values[$i]) < $scantronconf{$maplength{$csvbynum{$i}}}) {
+ $values[$i] = '0'.$values[$i];
+ }
+ }
+ $found{$csvbynum{$i}} = $values[$i];
+ }
+ }
+ foreach my $item (@ordered) {
+ my $currlength = 1+length($record);
+ my $numspaces = $scantronconf{$item} - $currlength;
+ if ($numspaces > 0) {
+ $record .= (' ' x $numspaces);
+ }
+ if (($mapstart{$item} ne '') && (exists($found{$mapstart{$item}}))) {
+ unless ($item eq 'Qstart') {
+ if (length($found{$mapstart{$item}}) > $scantronconf{$maplength{$item}}) {
+ $found{$mapstart{$item}} = substr($found{$mapstart{$item}},0,$scantronconf{$maplength{$item}});
+ }
+ }
+ $record .= $found{$mapstart{$item}};
+ }
+ }
+ $output .= "$record\n";
+ }
+ close($fh);
+ if ($output) {
+ if (open(my $fh,'>',$fullpath)) {
+ print $fh $output;
+ close($fh);
+ }
+ }
+ }
+ }
+ return;
+ }
+}
+
+sub letter_to_digits {
+ my %lettdig = (
+ A => 1,
+ B => 2,
+ C => 3,
+ D => 4,
+ E => 5,
+ F => 6,
+ G => 7,
+ H => 8,
+ I => 9,
+ J => 0,
+ );
+ return %lettdig;
+}
+
+sub get_scantron_config {
+ my ($which,$cdom) = @_;
+ my @lines = &get_scantronformat_file($cdom);
+ my %config;
+ #FIXME probably should move to XML it has already gotten a bit much now
+ foreach my $line (@lines) {
+ my ($name,$descrip)=split(/:/,$line);
+ if ($name ne $which ) { next; }
+ chomp($line);
+ my @config=split(/:/,$line);
+ $config{'name'}=$config[0];
+ $config{'description'}=$config[1];
+ $config{'CODElocation'}=$config[2];
+ $config{'CODEstart'}=$config[3];
+ $config{'CODElength'}=$config[4];
+ $config{'IDstart'}=$config[5];
+ $config{'IDlength'}=$config[6];
+ $config{'Qstart'}=$config[7];
+ $config{'Qlength'}=$config[8];
+ $config{'Qoff'}=$config[9];
+ $config{'Qon'}=$config[10];
+ $config{'PaperID'}=$config[11];
+ $config{'PaperIDlength'}=$config[12];
+ $config{'FirstName'}=$config[13];
+ $config{'FirstNamelength'}=$config[14];
+ $config{'LastName'}=$config[15];
+ $config{'LastNamelength'}=$config[16];
+ $config{'BubblesPerRow'}=$config[17];
+ last;
+ }
+ return %config;
+}
+
+sub get_scantronformat_file {
+ my ($cdom) = @_;
+ if ($cdom eq '') {
+ $cdom= $env{'course.'.$env{'request.course.id'}.'.domain'};
+ }
+ my %domconfig = &get_dom('configuration',['scantron'],$cdom);
+ my $gottab = 0;
+ my @lines;
+ if (ref($domconfig{'scantron'}) eq 'HASH') {
+ if ($domconfig{'scantron'}{'scantronformat'} ne '') {
+ my $formatfile = &getfile($perlvar{'lonDocRoot'}.$domconfig{'scantron'}{'scantronformat'});
+ if ($formatfile ne '-1') {
+ @lines = split("\n",$formatfile,-1);
+ $gottab = 1;
+ }
+ }
+ }
+ if (!$gottab) {
+ my $confname = $cdom.'-domainconfig';
+ my $default = $perlvar{'lonDocRoot'}.'/res/'.$cdom.'/'.$confname.'/default.tab';
+ my $formatfile = &getfile($default);
+ if ($formatfile ne '-1') {
+ @lines = split("\n",$formatfile,-1);
+ $gottab = 1;
+ }
+ }
+ if (!$gottab) {
+ my @domains = ¤t_machine_domains();
+ if (grep(/^\Q$cdom\E$/,@domains)) {
+ if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/scantronformat.tab')) {
+ @lines = <$fh>;
+ close($fh);
+ }
+ } else {
+ if (open(my $fh,'<',$perlvar{'lonTabDir'}.'/default_scantronformat.tab')) {
+ @lines = <$fh>;
+ close($fh);
+ }
+ }
+ }
+ return @lines;
+}
+
sub removeuploadedurl {
my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
@@ -4419,7 +5070,11 @@ sub courseacclog {
if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
$what.=':'.$formitem.'='.$env{$key};
} elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
- $what.=':'.$formitem.'='.$env{$key};
+ if ($formitem eq 'proctorpassword') {
+ $what.=':'.$formitem.'=' . '*' x length($env{$key});
+ } else {
+ $what.=':'.$formitem.'='.$env{$key};
+ }
}
}
}
@@ -5216,7 +5871,12 @@ sub set_first_access {
}
$cachedkey='';
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 $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
$udom,$uname);
@@ -5229,6 +5889,12 @@ sub set_first_access {
'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;
}
@@ -5490,7 +6156,7 @@ sub tmpreset {
if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {
- $stuname=$ENV{'REMOTE_ADDR'};
+ $stuname=&get_requestor_ip();
}
my $path=LONCAPA::tempdir();
my %hash;
@@ -5527,7 +6193,7 @@ sub tmpstore {
if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {
- $stuname=$ENV{'REMOTE_ADDR'};
+ $stuname=&get_requestor_ip();
}
my $now=time;
my %hash;
@@ -5571,7 +6237,7 @@ sub tmprestore {
if (!$domain) { $domain=$env{'user.domain'}; }
if (!$stuname) { $stuname=$env{'user.name'}; }
if ($domain eq 'public' && $stuname eq 'public') {
- $stuname=$ENV{'REMOTE_ADDR'};
+ $stuname=&get_requestor_ip();
}
my %returnhash;
$namespace=~s/\//\_/g;
@@ -5627,7 +6293,7 @@ sub store {
}
if (!$home) { $home=$env{'user.home'}; }
- $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
+ $$storehash{'ip'}=&get_requestor_ip();
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
@@ -5663,7 +6329,7 @@ sub cstore {
}
if (!$home) { $home=$env{'user.home'}; }
- $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};
+ $$storehash{'ip'}=&get_requestor_ip();
$$storehash{'host'}=$perlvar{'lonHostID'};
my $namevalue='';
@@ -6369,7 +7035,8 @@ sub set_adhoc_privileges {
my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
&appenv(\%userroles,[$role,'cm']);
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
- unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
+ unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||
+ ($caller eq 'tiny')) {
&appenv( {'request.role' => $spec,
'request.role.domain' => $dcdom,
'request.course.sec' => $sec,
@@ -6657,7 +7324,8 @@ sub putstore {
foreach my $key (keys(%{$storehash})) {
$namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
}
- $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).
+ my $ip = &get_requestor_ip();
+ $namevalue .= 'ip='.&escape($ip).
'&host='.&escape($perlvar{'lonHostID'}).
'&version='.$esc_v.
'&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
@@ -7143,6 +7811,7 @@ sub usertools_access {
community => 1,
textbook => 1,
placement => 1,
+ lti => 1,
);
} elsif ($context eq 'requestauthor') {
%tools = (
@@ -7339,25 +8008,29 @@ sub is_advanced_user {
}
sub check_can_request {
- my ($dom,$can_request,$request_domains) = @_;
+ my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
my $canreq = 0;
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
+ $uname = $env{'user.name'};
+ $udom = $env{'user.domain'};
+ }
my ($types,$typename) = &Apache::loncommon::course_types();
my @options = ('approval','validate','autolimit');
my $optregex = join('|',@options);
if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
foreach my $type (@{$types}) {
- if (&usertools_access($env{'user.name'},
- $env{'user.domain'},
- $type,undef,'requestcourses')) {
+ if (&usertools_access($uname,$udom,$type,undef,
+ 'requestcourses')) {
$canreq ++;
if (ref($request_domains) eq 'HASH') {
- push(@{$request_domains->{$type}},$env{'user.domain'});
+ push(@{$request_domains->{$type}},$udom);
}
- if ($dom eq $env{'user.domain'}) {
+ if ($dom eq $udom) {
$can_request->{$type} = 1;
}
}
- if ($env{'environment.reqcrsotherdom.'.$type} ne '') {
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
+ ($env{'environment.reqcrsotherdom.'.$type} ne '')) {
my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
if (@curr > 0) {
foreach my $item (@curr) {
@@ -7374,7 +8047,7 @@ sub check_can_request {
}
}
}
- unless($dom eq $env{'user.domain'}) {
+ unless ($dom eq $env{'user.domain'}) {
$canreq ++;
if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
$can_request->{$type} = 1;
@@ -7439,7 +8112,7 @@ sub customaccess {
# ------------------------------------------------- Check for a user privilege
sub allowed {
- my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;
+ my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
@@ -7456,7 +8129,7 @@ sub allowed {
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$}))
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$}))
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
&& ($priv eq 'bre')) {
return 'F';
@@ -7624,8 +8297,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;
+ }
}
}
@@ -7638,10 +8337,13 @@ sub allowed {
if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
- if ($noblockcheck) {
+ my $deeplinkblock = &deeplink_check($priv,$symb,$uri);
+ if ($deeplinkblock) {
+ $thisallowed='D';
+ } elsif ($noblockcheck) {
$thisallowed.=$value;
} else {
- my @blockers = &has_comm_blocking($priv,$symb,$uri);
+ my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
if (@blockers > 0) {
$thisallowed = 'B';
} else {
@@ -7658,10 +8360,13 @@ sub allowed {
$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);
if ($match) {
- if ($noblockcheck) {
+ my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ if ($deeplinkblock) {
+ $thisallowed='D';
+ } elsif ($noblockcheck) {
$thisallowed='F';
} else {
- my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+ my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
if (@blockers > 0) {
$thisallowed = 'B';
} else {
@@ -7708,6 +8413,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'};
@@ -7724,7 +8439,7 @@ sub allowed {
if ($noblockcheck) {
$thisallowed.=$value;
} else {
- my @blockers = &has_comm_blocking($priv,$symb,$uri);
+ my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
if (@blockers > 0) {
$thisallowed = 'B';
} else {
@@ -7737,7 +8452,7 @@ sub allowed {
$checkreferer=0;
}
}
-
+
if ($checkreferer) {
my $refuri=$env{'httpref.'.$orguri};
unless ($refuri) {
@@ -7763,10 +8478,13 @@ sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
if ($priv eq 'bre') {
- if ($noblockcheck) {
+ my $deeplinkblock = &deeplink_check($priv,$symb,$refuri);
+ if ($deeplinkblock) {
+ $thisallowed = 'D';
+ } elsif ($noblockcheck) {
$thisallowed.=$value;
} else {
- my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+ my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
if (@blockers > 0) {
$thisallowed = 'B';
} else {
@@ -7852,7 +8570,7 @@ sub allowed {
}
}
}
-
+
#
# Rest of the restrictions depend on selected course
#
@@ -7931,6 +8649,8 @@ sub allowed {
return 'A';
} elsif ($thisallowed eq 'B') {
return 'B';
+ } elsif ($thisallowed eq 'D') {
+ return 'D';
}
return 'F';
}
@@ -8019,22 +8739,27 @@ sub constructaccess {
#
# User for whom data are being temporarily cached.
my $cacheduser='';
+# Course for which data are being temporarily cached.
+my $cachedcid='';
# Cached blockers for this user (a hash of blocking items).
my %cachedblockers=();
# When the data were last cached.
my $cachedlast='';
sub load_all_blockers {
- my ($uname,$udom,$blocks)=@_;
+ my ($uname,$udom)=@_;
if (($uname ne '') && ($udom ne '')) {
if (($cacheduser eq $uname.':'.$udom) &&
+ ($cachedcid eq $env{'request.course.id'}) &&
(abs($cachedlast-time)<5)) {
return;
}
}
$cachedlast=time;
$cacheduser=$uname.':'.$udom;
- %cachedblockers = &get_commblock_resources($blocks);
+ $cachedcid=$env{'request.course.id'};
+ %cachedblockers = &get_commblock_resources();
+ return;
}
sub get_comm_blocks {
@@ -8114,14 +8839,23 @@ sub get_commblock_resources {
if ($mapsymb) {
if (ref($navmap)) {
my $mapres = $navmap->getBySymb($mapsymb);
- @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);
- foreach my $res (@to_test) {
- my $symb = $res->symb();
- next if ($symb eq $mapsymb);
- if ($symb ne '') {
- @interval=&EXT("resource.0.interval",$symb);
- if ($interval[1] eq 'map') {
- last;
+ if (ref($mapres)) {
+ my $first = $mapres->map_start();
+ my $finish = $mapres->map_finish();
+ my $it = $navmap->getIterator($first,$finish,undef,0,0);
+ if (ref($it)) {
+ my $res;
+ while ($res = $it->next(undef,1)) {
+ next unless (ref($res));
+ my $symb = $res->symb();
+ next if (($symb eq $mapsymb) || ($symb eq ''));
+ @interval=&EXT("resource.0.interval",$symb);
+ if ($interval[1] eq 'map') {
+ if ($res->answerable()) {
+ push(@to_test,$res);
+ last;
+ }
+ }
}
}
}
@@ -8172,17 +8906,23 @@ sub get_commblock_resources {
}
sub has_comm_blocking {
- my ($priv,$symb,$uri,$blocks) = @_;
+ my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
my @blockers;
return unless ($env{'request.course.id'});
return unless ($priv eq 'bre');
return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
return if ($env{'request.state'} eq 'construct');
- &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);
- return unless (keys(%cachedblockers) > 0);
+ my %blockinfo;
+ if (ref($blocks) eq 'HASH') {
+ %blockinfo = &get_commblock_resources($blocks);
+ } else {
+ &load_all_blockers($env{'user.name'},$env{'user.domain'});
+ %blockinfo = %cachedblockers;
+ }
+ return unless (keys(%blockinfo) > 0);
my (%possibles,@symbs);
if (!$symb) {
- $symb = &symbread($uri,1,1,1,\%possibles);
+ $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
}
if ($symb) {
@symbs = ($symb);
@@ -8193,37 +8933,128 @@ sub has_comm_blocking {
foreach my $symb (@symbs) {
last if ($noblock);
my ($map,$resid,$resurl)=&decode_symb($symb);
- foreach my $block (keys(%cachedblockers)) {
+ foreach my $block (keys(%blockinfo)) {
if ($block =~ /^firstaccess____(.+)$/) {
my $item = $1;
- if (($item eq $map) || ($item eq $symb)) {
- $noblock = 1;
- last;
+ unless ($blocked) {
+ if (($item eq $map) || ($item eq $symb)) {
+ $noblock = 1;
+ last;
+ }
}
}
- if (ref($cachedblockers{$block}) eq 'HASH') {
- if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {
- if ($cachedblockers{$block}{'resources'}{$symb}) {
+ if (ref($blockinfo{$block}) eq 'HASH') {
+ if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
+ if ($blockinfo{$block}{'resources'}{$symb}) {
unless (grep(/^\Q$block\E$/,@blockers)) {
push(@blockers,$block);
}
}
}
- }
- if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {
- if ($cachedblockers{$block}{'maps'}{$map}) {
- unless (grep(/^\Q$block\E$/,@blockers)) {
- push(@blockers,$block);
+ if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
+ if ($blockinfo{$block}{'maps'}{$map}) {
+ unless (grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ }
}
}
}
}
}
- return if ($noblock);
- return @blockers;
+ unless ($noblock) {
+ return @blockers;
+ }
+ return;
}
}
+sub deeplink_check {
+ my ($priv,$symb,$uri) = @_;
+ return unless ($env{'request.course.id'});
+ return unless ($priv eq 'bre');
+ return if ($env{'request.state'} eq 'construct');
+ return if ($env{'request.role.adv'});
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ my (%possibles,@symbs);
+ if (!$symb) {
+ $symb = &symbread($uri,1,1,1,\%possibles);
+ }
+ if ($symb) {
+ @symbs = ($symb);
+ } elsif (keys(%possibles)) {
+ @symbs = keys(%possibles);
+ }
+
+ my ($login,$switchrole,$allow);
+ if ($env{'request.deeplink.login'} =~ m{^\Q/tiny/$cdom/\E(\w+)$}) {
+ my $key = $1;
+ my $tinyurl;
+ my ($result,$cached)=&Apache::lonnet::is_cached_new('tiny',$cdom."\0".$key);
+ if (defined($cached)) {
+ $tinyurl = $result;
+ } else {
+ my $configuname = &Apache::lonnet::get_domainconfiguser($cdom);
+ my %currtiny = &Apache::lonnet::get('tiny',[$key],$cdom,$configuname);
+ if ($currtiny{$key} ne '') {
+ $tinyurl = $currtiny{$key};
+ &Apache::lonnet::do_cache_new('tiny',$cdom."\0".$key,$currtiny{$key},600);
+ }
+ }
+ if ($tinyurl ne '') {
+ my ($cnumreq,$posslogin) = split(/\&/,$tinyurl);
+ if ($cnumreq eq $cnum) {
+ $login = $posslogin;
+ } else {
+ $switchrole = 1;
+ }
+ }
+ }
+ foreach my $symb (@symbs) {
+ last if ($allow);
+ my $deeplink = &EXT("resource.0.deeplink",$symb);
+ if ($deeplink eq '') {
+ $allow = 1;
+ } else {
+ my ($listed,$scope,$access) = split(/,/,$deeplink);
+ if ($access eq 'any') {
+ $allow = 1;
+ } elsif ($login) {
+ if ($access eq 'only') {
+ if ($scope eq 'res') {
+ if ($symb eq $login) {
+ $allow = 1;
+ }
+ } elsif ($scope eq 'map') {
+#FIXME Compare map for $env{'request.deeplink.login'} with map for $symb
+ } elsif ($scope eq 'rec') {
+#FIXME Recurse up for $env{'request.deeplink.login'} with map for $symb
+ }
+ } else {
+ my ($acctype,$item) = split(/:/,$access);
+ if (($acctype eq 'lti') && ($env{'user.linkprotector'})) {
+ if (grep(/^\Q$item\E$/,split(/,/,$env{'user.linkprotector'}))) {
+ my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
+ if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.linkproturis'}))) {
+ $allow = 1;
+ }
+ }
+ } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {
+ if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {
+ my %tinyurls = &get('tiny',[$symb],$cdom,$cnum);
+ if (grep(/\Q$tinyurls{$symb}\E$/,split(/,/,$env{'user.keyedlinkuri'}))) {
+ $allow = 1;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return if ($allow);
+ return 1;
+}
+
# -------------------------------- Deversion and split uri into path an filename
#
@@ -8618,6 +9449,25 @@ sub auto_validate_instcode {
return ($outcome,$description,$defaultcredits);
}
+sub auto_validate_inst_crosslist {
+ my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
+ my ($homeserver,$response);
+ if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
+ $homeserver = &homeserver($cnum,$cdom);
+ }
+ if (!defined($homeserver)) {
+ if ($cdom =~ /^$match_domain$/) {
+ $homeserver = &domain($cdom,'primary');
+ }
+ }
+ unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
+ $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
+ &escape($instcode).':'.&escape($inst_xlist).':'.
+ &escape($coowner),$homeserver);
+ }
+ return $response;
+}
+
sub auto_create_password {
my ($cnum,$cdom,$authparam,$udom) = @_;
my ($homeserver,$response);
@@ -8889,6 +9739,33 @@ sub auto_validate_class_sec {
return $response;
}
+sub auto_validate_instclasses {
+ my ($cdom,$cnum,$owners,$classesref) = @_;
+ my ($homeserver,%validations);
+ $homeserver = &homeserver($cnum,$cdom);
+ unless ($homeserver eq 'no_host') {
+ my $ownerlist;
+ if (ref($owners) eq 'ARRAY') {
+ $ownerlist = join(',',@{$owners});
+ } else {
+ $ownerlist = $owners;
+ }
+ if (ref($classesref) eq 'HASH') {
+ my $classes = &freeze_escape($classesref);
+ my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist).
+ ':'.$cdom.':'.$classes,$homeserver);
+ unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
+ my @items = split(/&/,$response);
+ foreach my $item (@items) {
+ my ($key,$value) = split('=',$item);
+ $validations{&unescape($key)} = &thaw_unescape($value);
+ }
+ }
+ }
+ }
+ return %validations;
+}
+
sub auto_crsreq_update {
my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
$code,$accessstart,$accessend,$inbound) = @_;
@@ -9248,7 +10125,7 @@ sub assignrole {
}
if ($refused) {
my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
- if (!$selfenroll && $context eq 'course') {
+ if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
my %crsenv;
if ($role eq 'cc' || $role eq 'co') {
%crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
@@ -9268,8 +10145,12 @@ sub assignrole {
}
}
}
- } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
- $refused = '';
+ } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
+ if ($role eq 'st') {
+ $refused = '';
+ } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
+ $refused = '';
+ }
} elsif ($context eq 'requestcourses') {
my @possroles = ('st','ta','ep','in','cc','co');
if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
@@ -9408,11 +10289,23 @@ sub autoupdate_coowners {
if ($domdesign{$cdom.'.autoassign.co-owners'}) {
my %coursehash = &coursedescription($cdom.'_'.$cnum);
my $instcode = $coursehash{'internal.coursecode'};
+ my $xlists = $coursehash{'internal.crosslistings'};
if ($instcode ne '') {
if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
+ unless ($result eq 'valid') {
+ if ($xlists ne '') {
+ foreach my $xlist (split(',',$xlists)) {
+ my ($inst_crosslist,$lcsec) = split(':',$xlist);
+ $result =
+ &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
+ $inst_crosslist,$uname.':'.$udom);
+ last if ($result eq 'valid');
+ }
+ }
+ }
if ($result eq 'valid') {
if ($coursehash{'internal.co-owners'}) {
foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
@@ -9425,18 +10318,16 @@ sub autoupdate_coowners {
} else {
push(@newcoowners,$uname.':'.$udom);
}
- } else {
- if ($coursehash{'internal.co-owners'}) {
- foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
- unless ($coowner eq $uname.':'.$udom) {
- push(@newcoowners,$coowner);
- }
- }
- unless (@newcoowners > 0) {
- $delcoowners = 1;
- $coowners = '';
+ } elsif ($coursehash{'internal.co-owners'}) {
+ foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
+ unless ($coowner eq $uname.':'.$udom) {
+ push(@newcoowners,$coowner);
}
}
+ unless (@newcoowners > 0) {
+ $delcoowners = 1;
+ $coowners = '';
+ }
}
if (@newcoowners || $delcoowners) {
&store_coowners($cdom,$cnum,$coursehash{'home'},
@@ -9489,19 +10380,35 @@ 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'});
my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
&escape($upass),$uhome);
+ my $ip = &get_requestor_ip();
&log($env{'user.domain'},$env{'user.name'},$env{'user.home'},
'Authentication changed for '.$udom.', '.$uname.', '.$umode.
- '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+ '(Remote '.$ip.'): '.$reply);
&log($udom,,$uname,$uhome,
'Authentication changed by '.$env{'user.domain'}.', '.
$env{'user.name'}.', '.$umode.
- '(Remote '.$ENV{'REMOTE_ADDR'}.'): '.$reply);
+ '(Remote '.$ip.'): '.$reply);
unless ($reply eq 'ok') {
&logthis('Authentication mode error: '.$reply);
return 'error: '.$reply;
@@ -9535,10 +10442,14 @@ sub modifyuser {
my $newuser;
if ($uhome eq 'no_host') {
$newuser = 1;
+ unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
+ ($umode eq 'lti')) {
+ return 'error: more information needed to create new user';
+ }
}
# ----------------------------------------------------------------- Create User
if (($uhome eq 'no_host') &&
- (($umode && $upass) || ($umode eq 'localauth'))) {
+ (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
my $unhome='';
if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {
$unhome = $desiredhome;
@@ -9826,14 +10737,19 @@ sub writecoursepref {
sub createcourse {
my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
- $course_owner,$crstype,$cnum,$context,$category)=@_;
+ $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
$url=&declutter($url);
my $cid='';
if ($context eq 'requestcourses') {
my $can_create = 0;
my ($ownername,$ownerdom) = split(':',$course_owner);
if ($udom eq $ownerdom) {
- if (&usertools_access($ownername,$ownerdom,$category,undef,
+ my $reload;
+ if (($callercontext eq 'auto') &&
+ ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
+ $reload = 'reload';
+ }
+ if (&usertools_access($ownername,$ownerdom,$category,$reload,
$context)) {
$can_create = 1;
}
@@ -9983,12 +10899,25 @@ sub is_course {
my ($cdom, $cnum) = scalar(@_) == 1 ?
($_[0] =~ /^($match_domain)_($match_courseid)$/) : @_;
- return unless $cdom and $cnum;
-
- my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
- '.');
-
- return unless(exists($courses{$cdom.'_'.$cnum}));
+ return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
+ my $uhome=&homeserver($cnum,$cdom);
+ my $iscourse;
+ if (grep { $_ eq $uhome } current_machine_ids()) {
+ $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
+ } else {
+ 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;
}
@@ -10005,7 +10934,7 @@ sub store_userdata {
if (($uhome eq '') || ($uhome eq 'no_host')) {
$result = 'error: no_host';
} else {
- $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
+ $storehash->{'ip'} = &get_requestor_ip();
$storehash->{'host'} = $perlvar{'lonHostID'};
my $namevalue='';
@@ -11201,10 +12130,11 @@ sub get_numsuppfiles {
unless (defined($cached)) {
my $chome=&homeserver($cnum,$cdom);
unless ($chome eq 'no_host') {
- ($suppcount,my $errors) = (0,0);
+ ($suppcount,my $supptools,my $errors) = (0,0,0);
my $suppmap = 'supplemental.sequence';
- ($suppcount,$errors) =
- &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
+ ($suppcount,$supptools,$errors) =
+ &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,
+ $supptools,$errors);
}
&do_cache_new('suppcount',$hashid,$suppcount,600);
}
@@ -11551,6 +12481,10 @@ sub EXT {
if ($space eq 'name') {
return $ENV{'SERVER_NAME'};
}
+ } elsif ($realm eq 'client') {
+ if ($space eq 'remote_addr') {
+ return &get_requestor_ip();
+ }
}
return '';
}
@@ -11691,6 +12625,7 @@ sub add_prefix_and_part {
my %metaentry;
my %importedpartids;
+my %importedrespids;
sub metadata {
my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
@@ -11729,7 +12664,15 @@ sub metadata {
# uploaded map containing the tool. The value is retrieved via
# &EXT(), if a valid symb is available. Otherwise the value of
# gradable in the exttool_$marker.db file for the tool instance
-# is retrived via &get().
+# is retrieved via &get().
+#
+# When lonuserstate::traceroute() calls lonnet::EXT() for
+# hiddenresource and encrypturl (during course initialization)
+# the map-level parameter for resource.0.gradable included in the
+# uploaded map containing the tool will not yet have been stored
+# in the user_course_parms.db file for the user's session, so in
+# this case fall back to retrieving gradable status from the
+# exttool_$marker.db file.
#
# In order to avoid an infinite loop, &metadata() will return
# before a call to &EXT(), if the uri is for an external tool
@@ -11744,7 +12687,7 @@ sub metadata {
my ($checked,$use_passback);
if ($toolsymb ne '') {
(undef,undef,my $tooluri) = &decode_symb($toolsymb);
- if ($tooluri eq $uri) {
+ if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
$checked = 1;
if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
$use_passback = 1;
@@ -11754,7 +12697,7 @@ sub metadata {
unless ($checked) {
my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
$marker=~s/\D//g;
- if (!$marker) {
+ if ($marker) {
my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
$use_passback = $toolsettings{'gradable'};
}
@@ -11769,9 +12712,11 @@ sub metadata {
{
# Imported parts would go here
- my %importedids=();
- my @origfileimportpartids=();
+ my @origfiletagids=();
my $importedparts=0;
+
+# Imported responseids would go here
+ my $importedresponses=0;
#
# Is this a recursive call for a library?
#
@@ -11866,27 +12811,77 @@ sub metadata {
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
-
+
+ my $importid=$token->[2]->{'id'};
my $importmode=$token->[2]->{'importmode'};
- if ($importmode eq 'problem') {
-# Import as problem/response
- $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
- } elsif ($importmode eq 'part') {
+#
+# Check metadata for imported file to
+# see if it contained response items
+#
+ my ($origfile,@libfilekeys);
+ my %currmetaentry = %metaentry;
+ @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
+ $depthcount+1));
+ if (grep(/^responseorder$/,@libfilekeys)) {
+ my $libresponseorder = &metadata($location,'responseorder',undef,undef,
+ undef,$depthcount+1);
+ if ($libresponseorder ne '') {
+ if ($#origfiletagids<0) {
+ undef(%importedrespids);
+ undef(%importedpartids);
+ }
+ my @respids = split(/\s*,\s*/,$libresponseorder);
+ if (@respids) {
+ $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
+ }
+ if ($importedrespids{$importid} ne '') {
+ $importedresponses = 1;
+# We need to get the original file and the imported file to get the response order correct
+# Load and inspect original file
+ if ($#origfiletagids<0) {
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ $origfile=&getfile($origfilelocation);
+ @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
+ }
+ }
+ }
+# Do not overwrite contents of %metaentry hash for resource itself with
+# hash populated for imported library file
+ %metaentry = %currmetaentry;
+ undef(%currmetaentry);
+ if ($importmode eq 'part') {
# Import as part(s)
$importedparts=1;
# We need to get the original file and the imported file to get the part order correct
# Good news: we do not need to worry about nested libraries, since parts cannot be nested
-# Load and inspect original file
- if ($#origfileimportpartids<0) {
- undef(%importedpartids);
- my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
- my $origfile=&getfile($origfilelocation);
- @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+# Load and inspect original file if we didn't do that already
+ if ($#origfiletagids<0) {
+ undef(%importedrespids);
+ undef(%importedpartids);
+ if ($origfile eq '') {
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ $origfile=&getfile($origfilelocation);
+ @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
+ }
+ my @impfilepartids;
+# If tag is included in metadata for the imported file
+# get the parts in the imported file from that.
+ if (grep(/^partorder$/,@libfilekeys)) {
+ %currmetaentry = %metaentry;
+ my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
+ $depthcount+1);
+ %metaentry = %currmetaentry;
+ undef(%currmetaentry);
+ if ($libpartorder ne '') {
+ @impfilepartids=split(/\s*,\s*/,$libpartorder);
+ }
+ } else {
+# If no tag available, load and inspect imported file
+ my $impfile=&getfile($location);
+ @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
}
-
-# Load and inspect imported file
- my $impfile=&getfile($location);
- my @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
if ($#impfilepartids>=0) {
# This problem had parts
$importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
@@ -11897,13 +12892,28 @@ sub metadata {
$importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
}
} else {
+# Import as problem or as normal import
+ $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+ unless ($importmode eq 'problem') {
# Normal import
- $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
- if (defined($token->[2]->{'id'})) {
- $unikey.='_'.$token->[2]->{'id'};
- }
+ if (defined($token->[2]->{'id'})) {
+ $unikey.='_'.$token->[2]->{'id'};
+ }
+ }
+# Check metadata for imported file to
+# see if it contained parts
+ if (grep(/^partorder$/,@libfilekeys)) {
+ %currmetaentry = %metaentry;
+ my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
+ $depthcount+1);
+ %metaentry = %currmetaentry;
+ undef(%currmetaentry);
+ if ($libpartorder ne '') {
+ $importedparts = 1;
+ $importedpartids{$token->[2]->{'id'}}=$libpartorder;
+ }
+ }
}
-
if ($depthcount<20) {
my $metadata =
&metadata($uri,'keys',$toolsymb,$location,$unikey,
@@ -11912,7 +12922,6 @@ sub metadata {
$metaentry{':'.$meta}=$metaentry{':'.$meta};
$metathesekeys{$meta}=1;
}
-
}
} else {
#
@@ -11995,26 +13004,57 @@ sub metadata {
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
$metaentry{':packages'} = join(',',@uniq_packages);
- if ($importedparts) {
+ if (($importedresponses) || ($importedparts)) {
+ if ($importedparts) {
# We had imported parts and need to rebuild partorder
- $metaentry{':partorder'}='';
- $metathesekeys{'partorder'}=1;
- for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
- if ($origfileimportpartids[$index] eq 'part') {
-# original part, part of the problem
- $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
- } else {
-# we have imported parts at this position
- $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
- }
- }
- $metaentry{':partorder'}=~s/^\,//;
+ $metaentry{':partorder'}='';
+ $metathesekeys{'partorder'}=1;
+ }
+ if ($importedresponses) {
+# We had imported responses and need to rebuil responseorder
+ $metaentry{':responseorder'}='';
+ $metathesekeys{'responseorder'}=1;
+ }
+ for (my $index=0;$index<$#origfiletagids;$index+=2) {
+ my $origid = $origfiletagids[$index+1];
+ if ($origfiletagids[$index] eq 'part') {
+# Original part, part of the problem
+ if ($importedparts) {
+ $metaentry{':partorder'}.=','.$origid;
+ }
+ } elsif ($origfiletagids[$index] eq 'import') {
+ if ($importedparts) {
+# We have imported parts at this position
+ if ($importedpartids{$origid} ne '') {
+ $metaentry{':partorder'}.=','.$importedpartids{$origid};
+ }
+ }
+ if ($importedresponses) {
+# We have imported responses at this position
+ if ($importedrespids{$origid} ne '') {
+ $metaentry{':responseorder'}.=','.$importedrespids{$origid};
+ }
+ }
+ } else {
+# Original response item, part of the problem
+ if ($importedresponses) {
+ $metaentry{':responseorder'}.=','.$origid;
+ }
+ }
+ }
+ if ($importedparts) {
+ $metaentry{':partorder'}=~s/^\,//;
+ }
+ if ($importedresponses) {
+ $metaentry{':responseorder'}=~s/^\,//;
+ }
}
-
$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
$metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
- &do_cache_new('meta',$uri,\%metaentry,$cachetime);
+ unless ($liburi) {
+ &do_cache_new('meta',$uri,\%metaentry,$cachetime);
+ }
# this is the end of "was not already recently cached
}
return $metaentry{':'.$what};
@@ -12273,18 +13313,16 @@ sub symbverify {
if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
&GDBM_READER(),0640)) {
- my $noclutter;
if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
$thisurl =~ s/\?.+$//;
if ($map =~ m{^uploaded/.+\.page$}) {
$thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
$thisurl =~ s{^\Qhttp://https://\E}{https://};
- $noclutter = 1;
}
}
my $ids;
- if ($noclutter) {
- $ids=$bighash{'ids_'.$thisurl};
+ if ($map =~ m{^uploaded/.+\.page$}) {
+ $ids=$bighash{'ids_'.&clutter_with_no_wrapper($thisurl)};
} else {
$ids=$bighash{'ids_'.&clutter($thisurl)};
}
@@ -12384,19 +13422,22 @@ sub deversion {
# ------------------------------------------------------ Return symb list entry
sub symbread {
- my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;
+ my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
+ $ignoresymbdb,$noenccheck)=@_;
my $cache_str='request.symbread.cached.'.$thisfn;
if (defined($env{$cache_str})) {
- if ($ignorecachednull) {
- return $env{$cache_str} unless ($env{$cache_str} eq '');
- } else {
- return $env{$cache_str};
+ unless (ref($possibles) eq 'HASH') {
+ if ($ignorecachednull) {
+ return $env{$cache_str} unless ($env{$cache_str} eq '');
+ } else {
+ return $env{$cache_str};
+ }
}
}
# no filename provided? try from environment
unless ($thisfn) {
if ($env{'request.symb'}) {
- return $env{$cache_str}=&symbclean($env{'request.symb'});
+ return $env{$cache_str}=&symbclean($env{'request.symb'});
}
$thisfn=$env{'request.filename'};
}
@@ -12419,10 +13460,18 @@ sub symbread {
if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
$targetfn=$1;
}
- if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
- &GDBM_READER(),0640)) {
- $syval=$hash{$targetfn};
- untie(%hash);
+ unless ($ignoresymbdb) {
+ if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
+ &GDBM_READER(),0640)) {
+ $syval=$hash{$targetfn};
+ untie(%hash);
+ }
+ if ($syval && $checkforblock) {
+ my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
+ if (@blockers) {
+ $syval='';
+ }
+ }
}
# ---------------------------------------------------------- There was an entry
if ($syval) {
@@ -12455,13 +13504,18 @@ sub symbread {
$syval=&encode_symb($bighash{'map_id_'.$mapid},
$resid,$thisfn);
if (ref($possibles) eq 'HASH') {
- $possibles->{$syval} = 1;
+ unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
+ $possibles->{$syval} = 1;
+ }
}
if ($checkforblock) {
- my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});
- if (@blockers) {
- $syval = '';
- return;
+ unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
+ my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
+ if (@blockers) {
+ $syval = '';
+ untie(%bighash);
+ return $env{$cache_str}='';
+ }
}
}
} elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
@@ -12480,12 +13534,13 @@ sub symbread {
if ($bighash{'map_type_'.$mapid} ne 'page') {
my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
$resid,$thisfn);
- if (ref($possibles) eq 'HASH') {
- $possibles->{$syval} = 1;
- }
+ next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
+ next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
if ($checkforblock) {
- my @blockers = &has_comm_blocking('bre',$poss_syval,$file);
- unless (@blockers > 0) {
+ my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
+ if (@blockers > 0) {
+ $syval = '';
+ } else {
$syval = $poss_syval;
$realpossible++;
}
@@ -12493,6 +13548,11 @@ sub symbread {
$syval = $poss_syval;
$realpossible++;
}
+ if ($syval) {
+ if (ref($possibles) eq 'HASH') {
+ $possibles->{$syval} = 1;
+ }
+ }
}
}
}
@@ -13030,9 +14090,10 @@ sub repcopy_userfile {
my $request;
$uri=~s/^\///;
my $homeserver = &homeserver($cnum,$cdom);
+ my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
- $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
+ $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri);
my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1);
# did it work?
if ($response->is_error()) {
@@ -13056,9 +14117,10 @@ sub tokenwrapper {
$file=~s|(\?\.*)*$||;
&appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
my $homeserver = &homeserver($uname,$udom);
+ my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
- return $protocol.'://'.&hostname($homeserver).'/'.$uri.
+ return $protocol.'://'.$hostname.'/'.$uri.
(($uri=~/\?/)?'&':'?').'token='.$token.
'&tokenissued='.$perlvar{'lonHostID'};
} else {
@@ -13074,9 +14136,10 @@ sub getuploaded {
my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
$uri=~s/^\///;
my $homeserver = &homeserver($cnum,$cdom);
+ my $hostname = &hostname($homeserver);
my $protocol = $protocol{$homeserver};
$protocol = 'http' if ($protocol ne 'https');
- $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
+ $uri = $protocol.'://'.$hostname.'/raw/'.$uri;
my $request=new HTTP::Request($reqtype,$uri);
my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1);
$$rtncode = $response->code;
@@ -13229,6 +14292,218 @@ sub default_login_domain {
return $domain;
}
+sub shared_institution {
+ my ($dom,$lonhost) = @_;
+ if ($lonhost eq '') {
+ $lonhost = $perlvar{'lonHostID'};
+ }
+ my $same_intdom;
+ my $hostintdom = &internet_dom($lonhost);
+ 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'};
+ my $hostname = &hostname($lonhost);
+ my $sts_on;
+ if ($protocol{$lonhost} eq 'https') {
+ my $cachetime = 12*3600;
+ if (!$ignore_cache) {
+ ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost);
+ if (defined($cached)) {
+ return $sts_on;
+ }
+ }
+ my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html';
+ my $request=new HTTP::Request('HEAD',$url);
+ my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1);
+ if ($response->is_success) {
+ my $has_sts = $response->header('Strict-Transport-Security');
+ if ($has_sts eq '') {
+ $sts_on = 0;
+ } else {
+ if ($has_sts =~ /\Qmax-age=\E(\d+)/) {
+ my $maxage = $1;
+ if ($maxage) {
+ $sts_on = 1;
+ } else {
+ $sts_on = 0;
+ }
+ } else {
+ $sts_on = 0;
+ }
+ }
+ return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime);
+ }
+ }
+ return;
+}
+
+sub waf_allssl {
+ my ($host_name) = @_;
+ my $alias = &get_proxy_alias();
+ if ($host_name eq '') {
+ $host_name = $ENV{'SERVER_NAME'};
+ }
+ if (($host_name ne '') && ($alias eq $host_name)) {
+ my $serverhomedom = &host_domain($perlvar{'lonHostID'});
+ my %defdomdefaults = &get_domain_defaults($serverhomedom);
+ if ($defdomdefaults{'waf_sslopt'}) {
+ return $defdomdefaults{'waf_sslopt'};
+ }
+ }
+ return;
+}
+
+sub get_requestor_ip {
+ my ($r,$nolookup,$noproxy) = @_;
+ my $from_ip;
+ if (ref($r)) {
+ if ($r->can('useragent_ip')) {
+ if ($noproxy && $r->can('client_ip')) {
+ $from_ip = $r->client_ip();
+ } else {
+ $from_ip = $r->useragent_ip();
+ }
+ } elsif ($r->connection->can('remote_ip')) {
+ $from_ip = $r->connection->remote_ip();
+ } else {
+ $from_ip = $r->get_remote_host($nolookup);
+ }
+ } else {
+ $from_ip = $ENV{'REMOTE_ADDR'};
+ }
+ return $from_ip if ($noproxy);
+ # Who controls proxy settings for server
+ my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
+ my $proxyinfo = &get_proxy_settings($dom_in_use);
+ if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
+ if ($proxyinfo->{'vpnint'}) {
+ if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
+ return $from_ip;
+ }
+ }
+ if ($proxyinfo->{'trusted'}) {
+ if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
+ my $ipheader = $proxyinfo->{'ipheader'};
+ my ($ip,$xfor);
+ if (ref($r)) {
+ if ($ipheader) {
+ $ip = $r->headers_in->{$ipheader};
+ }
+ $xfor = $r->headers_in->{'X-Forwarded-For'};
+ } else {
+ if ($ipheader) {
+ $ip = $ENV{'HTTP_'.uc($ipheader)};
+ }
+ $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
+ }
+ if (($ip eq '') && ($xfor ne '')) {
+ foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
+ unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
+ $ip = $poss_ip;
+ last;
+ }
+ }
+ }
+ if ($ip ne '') {
+ return $ip;
+ }
+ }
+ }
+ }
+ return $from_ip;
+}
+
+sub get_proxy_settings {
+ my ($dom_in_use) = @_;
+ my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
+ my $proxyinfo = {
+ ipheader => $domdefaults{'waf_ipheader'},
+ trusted => $domdefaults{'waf_trusted'},
+ vpnint => $domdefaults{'waf_vpnint'},
+ vpnext => $domdefaults{'waf_vpnext'},
+ sslopt => $domdefaults{'waf_sslopt'},
+ };
+ return $proxyinfo;
+}
+
+sub ip_match {
+ my ($ip,$pattern_str) = @_;
+ $ip=Net::CIDR::cidrvalidate($ip);
+ if ($ip) {
+ return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
+ }
+ return;
+}
+
+sub get_proxy_alias {
+ my ($lonid) = @_;
+ if ($lonid eq '') {
+ $lonid = $perlvar{'lonHostID'};
+ }
+ if (!defined(&hostname($lonid))) {
+ return;
+ }
+ if ($lonid ne '') {
+ my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
+ if ($cached) {
+ return $alias;
+ }
+ my $dom = &Apache::lonnet::host_domain($lonid);
+ if ($dom ne '') {
+ my $cachetime = 60*60*24;
+ my %domconfig =
+ &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
+ my $alias;
+ if (ref($domconfig{'wafproxy'}) eq 'HASH') {
+ if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
+ $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
+ }
+ }
+ return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
+ }
+ }
+ return;
+}
+
+sub use_proxy_alias {
+ my ($r,$lonid) = @_;
+ my $alias = &get_proxy_alias($lonid);
+ if ($alias) {
+ my $dom = &host_domain($lonid);
+ if ($dom ne '') {
+ my $proxyinfo = &get_proxy_settings($dom );
+ my ($vpnint,$remote_ip);
+ if (ref($proxyinfo) eq 'HASH') {
+ $vpnint = $proxyinfo->{'vpnint'};
+ if ($vpnint) {
+ $remote_ip = &get_requestor_ip($r,1,1);
+ }
+ }
+ unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
+ return $alias;
+ }
+ }
+ }
+ return;
+}
+
# ------------------------------------------------------------- Declutters URLs
sub declutter {
@@ -13354,15 +14629,17 @@ sub get_dns {
}
my %alldns;
- open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
- foreach my $dns (<$config>) {
- next if ($dns !~ /^\^(\S*)/x);
- my $line = $1;
- my ($host,$protocol) = split(/:/,$line);
- if ($protocol ne 'https') {
- $protocol = 'http';
+ if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
+ foreach my $dns (<$config>) {
+ next if ($dns !~ /^\^(\S*)/x);
+ my $line = $1;
+ my ($host,$protocol) = split(/:/,$line);
+ if ($protocol ne 'https') {
+ $protocol = 'http';
+ }
+ $alldns{$host} = $protocol;
}
- $alldns{$host} = $protocol;
+ close($config);
}
while (%alldns) {
my ($dns) = sort { $b cmp $a } keys(%alldns);
@@ -13370,19 +14647,33 @@ sub get_dns {
my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
delete($alldns{$dns});
next if ($response->is_error());
- my @content = split("\n",$response->content);
- unless ($nocache) {
- &do_cache_new('dns',$url,\@content,30*24*60*60);
- }
- &$func(\@content,$hashref);
- return;
+ if ($url eq '/adm/dns/loncapaCRL') {
+ return &$func($response);
+ } else {
+ my @content = split("\n",$response->content);
+ unless ($nocache) {
+ &do_cache_new('dns',$url,\@content,30*24*60*60);
+ }
+ &$func(\@content,$hashref);
+ return;
+ }
+ }
+ my $which = (split('/',$url,4))[3];
+ if ($which eq 'loncapaCRL') {
+ my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
+ if (-e $diskfile) {
+ &logthis("unable to contact DNS, on disk file $diskfile not updated");
+ } else {
+ &logthis("unable to contact DNS, no on disk file $diskfile available");
+ }
+ } else {
+ &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
+ if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
+ my @content = <$config>;
+ close($config);
+ &$func(\@content,$hashref);
+ }
}
- close($config);
- my $which = (split('/',$url))[3];
- &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
- open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab");
- my @content = <$config>;
- &$func(\@content,$hashref);
return;
}
@@ -13442,6 +14733,79 @@ sub fetch_dns_checksums {
return \%checksums;
}
+sub fetch_crl_pemfile {
+ return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1);
+}
+
+sub save_crl_pem {
+ my ($response) = @_;
+ my ($msg,$hadchanges);
+ if (ref($response)) {
+ my $now = time;
+ my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
+ my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
+ if (open(my $fh,'>',"$tmpcrl")) {
+ print $fh $response->content;
+ close($fh);
+ if (-e $lonca) {
+ if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
+ my $check = ;
+ close(PIPE);
+ chomp($check);
+ if ($check eq 'verify OK') {
+ my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
+ my $backup;
+ if (-e $dest) {
+ if (&File::Copy::move($dest,"$dest.bak")) {
+ $backup = 'ok';
+ }
+ }
+ if (&File::Copy::move($tmpcrl,$dest)) {
+ $msg = 'ok';
+ if ($backup) {
+ my (%oldnums,%newnums);
+ if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) {
+ while () {
+ $oldnums{(split(/:/))[1]} = 1;
+ }
+ close(PIPE);
+ }
+ if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) {
+ while() {
+ $newnums{(split(/:/))[1]} = 1;
+ }
+ close(PIPE);
+ }
+ foreach my $key (sort {$b <=> $a } (keys(%newnums))) {
+ unless (exists($oldnums{$key})) {
+ $hadchanges = 1;
+ last;
+ }
+ }
+ unless ($hadchanges) {
+ foreach my $key (sort {$b <=> $a } (keys(%oldnums))) {
+ unless (exists($newnums{$key})) {
+ $hadchanges = 1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ } else {
+ unlink($tmpcrl);
+ }
+ } else {
+ unlink($tmpcrl);
+ }
+ } else {
+ unlink($tmpcrl);
+ }
+ }
+ }
+ return ($msg,$hadchanges);
+}
+
# ------------------------------------------------------------ Read domain file
{
my $loaded;
@@ -14008,6 +15372,16 @@ BEGIN {
}
+# ------------- set default texengine (domain default overrides this)
+{
+ $deftex = LONCAPA::texengine();
+}
+
+# ------------- set default minimum length for passwords for internal auth users
+{
+ $passwdmin = LONCAPA::passwd_min();
+}
+
$memcache=new Cache::Memcached({'servers' => ['127.0.0.1:11211'],
'compress_threshold'=> 20_000,
});
@@ -14347,6 +15721,7 @@ prevents recursive calls to &allowed.
2: browse allowed
A: passphrase authentication needed
B: access temporarily blocked because of a blocking event in a course.
+ D: access blocked because access is required via session initiated via deep-link
=item *
@@ -14677,6 +16052,88 @@ Returns:
=back
+=head2 Bubblesheet Configuration
+
+=over 4
+
+=item *
+
+get_scantron_config($which)
+
+$which - the name of the configuration to parse from the file.
+
+Parses and returns the bubblesheet configuration line selected as a
+hash of configuration file fields.
+
+
+Returns:
+ If the named configuration is not in the file, an empty
+ hash is returned.
+
+ a hash with the fields
+ name - internal name for the this configuration setup
+ description - text to display to operator that describes this config
+ CODElocation - if 0 or the string 'none'
+ - no CODE exists for this config
+ if -1 || the string 'letter'
+ - a CODE exists for this config and is
+ a string of letters
+ Unsupported value (but planned for future support)
+ if a positive integer
+ - The CODE exists as the first n items from
+ the question section of the form
+ if the string 'number'
+ - The CODE exists for this config and is
+ a string of numbers
+ CODEstart - (only matter if a CODE exists) column in the line where
+ the CODE starts
+ CODElength - length of the CODE
+ IDstart - column where the student/employee ID starts
+ IDlength - length of the student/employee ID info
+ Qstart - column where the information from the bubbled
+ 'questions' start
+ Qlength - number of columns comprising a single bubble line from
+ the sheet. (usually either 1 or 10)
+ Qon - either a single character representing the character used
+ to signal a bubble was chosen in the positional setup, or
+ the string 'letter' if the letter of the chosen bubble is
+ in the final, or 'number' if a number representing the
+ chosen bubble is in the file (1->A 0->J)
+ Qoff - the character used to represent that a bubble was
+ left blank
+ PaperID - if the scanning process generates a unique number for each
+ sheet scanned the column that this ID number starts in
+ PaperIDlength - number of columns that comprise the unique ID number
+ for the sheet of paper
+ FirstName - column that the first name starts in
+ FirstNameLength - number of columns that the first name spans
+ LastName - column that the last name starts in
+ LastNameLength - number of columns that the last name spans
+ BubblesPerRow - number of bubbles available in each row used to
+ bubble an answer. (If not specified, 10 assumed).
+
+
+=item *
+
+get_scantronformat_file($cdom)
+
+$cdom - the course's domain (optional); if not supplied, uses
+domain for current $env{'request.course.id'}.
+
+Returns an array containing lines from the scantron format file for
+the domain of the course.
+
+If a url for a custom.tab file is listed in domain's configuration.db,
+lines are from this file.
+
+Otherwise, if a default.tab has been published in RES space by the
+domainconfig user, lines are from this file.
+
+Otherwise, fall back to getting lines from the legacy file on the
+local server: /home/httpd/lonTabs/default_scantronformat.tab
+
+=back
+
=head2 Resource Subroutines
=over 4
@@ -14737,7 +16194,9 @@ only used internally for recursive metad
the toolsymb is only used where the uri is for an external tool (for which
the uri as well as the symb are guaranteed to be unique).
-this function automatically caches all requests
+this function automatically caches all requests except any made recursively
+to retrieve a list of metadata keys for an imported library file ($liburi is
+defined).
=item *
@@ -15372,6 +16831,7 @@ userspace, probably shouldn't be called
formname: same as for userfileupload()
fname: filename (including subdirectories) for the file
parser: if 'parse', will parse (html) file to extract references to objects, links etc.
+ if hashref, and context is scantron, will convert csv format to standard format
allfiles: reference to hash used to store objects found by parser
codebase: reference to hash used for codebases of java objects found by parser
thumbwidth: width (pixels) of thumbnail to be created for uploaded image