--- loncom/lonnet/perl/lonnet.pm 2016/09/21 04:47:57 1.1322 +++ loncom/lonnet/perl/lonnet.pm 2021/03/31 02:19:59 1.1444 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1322 2016/09/21 04:47:57 raeburn Exp $ +# $Id: lonnet.pm,v 1.1444 2021/03/31 02:19:59 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,16 +71,15 @@ delayed. package Apache::lonnet; use strict; -use LWP::UserAgent(); 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, @@ -97,10 +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, @@ -146,7 +149,7 @@ our @EXPORT = qw(%env); sub logtouch { my $execdir=$perlvar{'lonDaemons'}; unless (-e "$execdir/logs/lonnet.log") { - open(my $fh,">>$execdir/logs/lonnet.log"); + open(my $fh,">>","$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; @@ -158,7 +161,7 @@ sub logthis { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - if (open(my $fh,">>$execdir/logs/lonnet.log")) { + if (open(my $fh,">>","$execdir/logs/lonnet.log")) { my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. print $fh $logstring; close($fh); @@ -171,7 +174,7 @@ sub logperm { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { + if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { print $fh "$now:$message:$local\n"; close($fh); } @@ -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,30 +233,38 @@ 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 =~ /^(?:centos|redhat|scientific)(\d+)$/) { + if ($distro eq '') { + $uselocal = 0; + } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { if ($1 < 6) { $uselocal = 0; } + } elsif ($distro =~ /^(?:sles)(\d+)$/) { + if ($1 < 12) { + $uselocal = 0; + } } } 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; @@ -303,13 +314,12 @@ sub get_server_loncaparev { $answer = &reply('serverloncaparev',$lonhost); if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { if ($caller eq 'loncron') { - my $ua=new LWP::UserAgent; - $ua->timeout(4); + 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=$ua->request($request); + my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); unless ($response->is_error()) { my $content = $response->content; if ($content =~ /

VERSION\:\s*([\w.\-]+)<\/p>/) { @@ -452,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; } @@ -481,7 +509,7 @@ sub reconlonc { &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; - if (open(my $fh,"<$loncfile")) { + if (open(my $fh,"<",$loncfile)) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { @@ -521,7 +549,7 @@ sub critical { $dumpcount++; { my $dfh; - if (open($dfh,">$dfilename")) { + if (open($dfh,">",$dfilename)) { print $dfh "$cmd\n"; close($dfh); } @@ -530,7 +558,7 @@ sub critical { my $wcmd=''; { my $dfh; - if (open($dfh,"<$dfilename")) { + if (open($dfh,"<",$dfilename)) { $wcmd=<$dfh>; close($dfh); } @@ -646,22 +674,52 @@ sub transfer_profile_to_env { # ---------------------------------------------------- Check for valid session sub check_for_valid_session { - my ($r,$name,$userhashref) = @_; + my ($r,$name,$userhashref,$domref) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - if ($name eq '') { - $name = 'lonID'; - } - my $lonid=$cookies{$name}; - return undef if (!$lonid); - - my $handle=&LONCAPA::clean_handle($lonid->value); - my $lonidsdir; + 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'; + 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}; + } + } else { + $lonid=$cookies{$name}; + } + return undef if (!$lonid); + + my $handle=&LONCAPA::clean_handle($lonid->value); + 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') && + ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { + my ($possuname,$possudom,$possuhome) = ($1,$2,$3); + if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { + $$domref = $possudom; + } + } + return undef; } - return undef if (!-e "$lonidsdir/$handle.id"); my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); return undef if (!$opened); @@ -675,13 +733,20 @@ 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'}; + $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; } @@ -706,6 +771,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 { @@ -731,16 +827,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'; @@ -856,6 +955,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++; } } @@ -911,13 +1011,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; } } @@ -984,6 +1084,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) = @_; @@ -1019,7 +1216,7 @@ sub choose_server { if (ref($balancers) eq 'HASH') { next if (exists($balancers->{$lonhost})); } - } + } my $loginvia; if ($checkloginvia) { $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; @@ -1047,7 +1244,29 @@ sub choose_server { if ($login_host ne '') { $hostname = &hostname($login_host); } - return ($login_host,$hostname,$portal_path,$isredirect); + 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 @@ -1085,6 +1304,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; } @@ -1223,6 +1445,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); @@ -1319,9 +1550,9 @@ sub get_lonbalancer_config { } sub check_loadbalancing { - my ($uname,$udom) = @_; + 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'); @@ -1348,7 +1579,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') { @@ -1409,7 +1640,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') { @@ -1441,7 +1672,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') { @@ -1470,23 +1701,27 @@ sub check_loadbalancing { } } } - if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { - $is_balancer = 0; - if ($uname ne '' && $udom ne '') { - if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - - &appenv({'user.loadbalexempt' => $lonhost, - 'user.loadbalcheck.time' => time}); + unless ($caller eq 'login') { + if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { + $is_balancer = 0; + if ($uname ne '' && $udom ne '') { + if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { + &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'}; @@ -1495,19 +1730,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 { @@ -1579,6 +1819,101 @@ sub internet_dom_servers { return %uniqservers; } +sub trusted_domains { + my ($cmdtype,$calldom) = @_; + my ($trusted,$untrusted); + if (&domain($calldom) eq '') { + return ($trusted,$untrusted); + } + unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) { + return ($trusted,$untrusted); + } + my $callprimary = &domain($calldom,'primary'); + my $intcalldom = &Apache::lonnet::internet_dom($callprimary); + if ($intcalldom eq '') { + return ($trusted,$untrusted); + } + + my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); + unless (defined($cached)) { + my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom); + &Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600); + $trustconfig = $domconfig{'trust'}; + } + if (ref($trustconfig)) { + my (%possexc,%possinc,@allexc,@allinc); + if (ref($trustconfig->{$cmdtype}) eq 'HASH') { + if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') { + map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; + } + if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { + $possinc{$intcalldom} = 1; + map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; + } + } + if (keys(%possexc)) { + if (keys(%possinc)) { + foreach my $key (sort(keys(%possexc))) { + next if ($key eq $intcalldom); + unless ($possinc{$key}) { + push(@allexc,$key); + } + } + } else { + @allexc = sort(keys(%possexc)); + } + } + if (keys(%possinc)) { + $possinc{$intcalldom} = 1; + @allinc = sort(keys(%possinc)); + } + if ((@allexc > 0) || (@allinc > 0)) { + my %doms_by_intdom; + my %allintdoms = &all_host_intdom(); + my %alldoms = &all_host_domain(); + foreach my $key (%allintdoms) { + if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') { + unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) { + push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key}); + } + } else { + $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; + } + } + foreach my $exc (@allexc) { + if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { + push(@{$untrusted},@{$doms_by_intdom{$exc}}); + } + } + foreach my $inc (@allinc) { + if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { + push(@{$trusted},@{$doms_by_intdom{$inc}}); + } + } + } + } + return ($trusted,$untrusted); +} + +sub will_trust { + my ($cmdtype,$domain,$possdom) = @_; + return 1 if ($domain eq $possdom); + my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom); + my $willtrust; + if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) { + if (grep(/^\Q$domain\E$/,@{$trustedref})) { + $willtrust = 1; + } + } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) { + unless (grep(/^\Q$domain\E$/,@{$untrustedref})) { + $willtrust = 1; + } + } else { + $willtrust = 1; + } + return $willtrust; +} + # ---------------------- Find the homebase for a user from domain's lib servers my %homecache; @@ -1828,7 +2163,21 @@ sub get_dom { } } if ($udom && $uhome && ($uhome ne 'no_host')) { - my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my $rep; + 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 { + 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 /) { return %returnhash; @@ -1872,7 +2221,11 @@ sub put_dom { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; - return &reply("putdom:$udom:$namespace:$items",$uhome); + if ($namespace =~ /^enc/) { + return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); + } else { + return &reply("putdom:$udom:$namespace:$items",$uhome); + } } else { &logthis("put_dom failed - no homeserver and/or domain"); } @@ -1963,13 +2316,23 @@ sub inst_directory_query { my $homeserver = &domain($udom,'primary'); my $outcome; if ($homeserver ne '') { + unless ($homeserver eq $perlvar{'lonHostID'}) { + if ($srch->{'srchby'} eq 'email') { + 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))) { + return; + } + } + } my $queryid=&reply("querysend:instdirsearch:". &escape($srch->{'srchby'}).':'. &escape($srch->{'srchterm'}).':'. &escape($srch->{'srchtype'}),$homeserver); my $host=&hostname($homeserver); if ($queryid !~/^\Q$host\E\_/) { - &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); return; } my $response = &get_query_reply($queryid); @@ -2004,6 +2367,14 @@ sub usersearch { my $query = 'usersearch'; foreach my $tryserver (keys(%libserv)) { if (&host_domain($tryserver) eq $dom) { + unless ($tryserver eq $perlvar{'lonHostID'}) { + if ($srch->{'srchby'} eq 'email') { + 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))); + } + } my $host=&hostname($tryserver); my $queryid= &reply("querysend:".&escape($query).':'. @@ -2243,7 +2614,7 @@ sub get_domain_defaults { 'coursedefaults','usersessions', 'requestauthor','selfenrollment', 'coursecategories','ssl','autoenroll', - 'trust'],$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'}; @@ -2252,6 +2623,9 @@ sub get_domain_defaults { $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; + $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; + $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; + $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -2319,6 +2693,9 @@ sub get_domain_defaults { } elsif ($domconfig{'coursedefaults'}{'canclone'}) { $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; } + if ($domconfig{'coursedefaults'}{'texengine'}) { + $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; + } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -2330,6 +2707,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') { @@ -2362,7 +2742,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'}) { @@ -2373,8 +2753,11 @@ sub get_domain_defaults { if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; } - if (ref($domconfig{'ssl'}{'connect'}) eq 'HASH') { - $domdefaults{'connect'} = $domconfig{'ssl'}{'connect'}; + if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; + } + if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; } } if (ref($domconfig{'trust'}) eq 'HASH') { @@ -2388,10 +2771,82 @@ sub get_domain_defaults { if (ref($domconfig{'autoenroll'}) eq 'HASH') { $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; } + if (ref($domconfig{'helpsettings'}) eq 'HASH') { + $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; + if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { + $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; + } + } + if (ref($domconfig{'wafproxy'}) eq 'HASH') { + foreach my $item ('ipheader','trusted','vpnint','vpnext') { + 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); @@ -2408,6 +2863,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 { @@ -2915,9 +3393,13 @@ sub repcopy { mkdir($path,0777); } } - my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',"$remoteurl"); - my $response=$ua->request($request,$transname); + my $response; + if ($remoteurl =~ m{/raw/}) { + $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1); + } else { + $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1); + } if ($response->is_error()) { unlink($transname); my $message=$response->status_line; @@ -2927,7 +3409,12 @@ sub repcopy { } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); - my $mresponse=$ua->request($mrequest,$filename.'.meta'); + my $mresponse; + if ($remoteurl =~ m{/raw/}) { + $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1); + } else { + $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1); + } if ($mresponse->is_error()) { unlink($filename.'.meta'); &logthis( @@ -2941,6 +3428,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)=@_; @@ -2990,7 +3503,6 @@ sub absolute_url { sub ssi { my ($fn,%form)=@_; - my $ua=new LWP::UserAgent; my $request; $form{'no_update_last_known'}=1; @@ -3008,22 +3520,30 @@ sub ssi { } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); - my $response= $ua->request($request); - my $content = $response->content; - + my $lonhost = $perlvar{'lonHostID'}; + 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; + } + my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, + '','','',$islocal); if (wantarray) { - return ($content, $response); + return ($response->content, $response); } else { - return $content; + return $response->content; } } sub externalssi { my ($url)=@_; - my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',$url); - my $response=$ua->request($request); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar); if (wantarray) { return ($response->content, $response); } else { @@ -3031,6 +3551,77 @@ sub externalssi { } } + +# If the local copy of a replicated resource is outdated, trigger a +# connection from the homeserver to flush the delayed queue. If no update +# happens, remove local copies of outdated resource (and corresponding +# metadata file). + +sub remove_stale_resfile { + my ($url) = @_; + my $removed; + if ($url=~m{^/res/($match_domain)/($match_username)/}) { + my $audom = $1; + my $auname = $2; + unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { + my $homeserver = &homeserver($auname,$audom); + unless (($homeserver eq 'no_host') || + (grep { $_ eq $homeserver } ¤t_machine_ids())) { + my $fname = &filelocation('',$url); + if (-e $fname) { + my $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); + if ($response->is_success()) { + my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); + my $locmodtime = (stat($fname))[9]; + if ($locmodtime < $remmodtime) { + my $stale; + my $answer = &reply('pong',$homeserver); + if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { + sleep(0.2); + $locmodtime = (stat($fname))[9]; + if ($locmodtime < $remmodtime) { + my $posstransfer = $fname.'.in.transfer'; + if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { + $removed = 1; + } else { + $stale = 1; + } + } else { + $removed = 1; + } + } else { + $stale = 1; + } + if ($stale) { + 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; + } + } + } + } + } + } + } + } + } + return $removed; +} + # -------------------------------- Allow a /uploaded/ URI to be vouched for sub allowuploaded { @@ -3169,7 +3760,19 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) { + } 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'}) { $forceview = 1; @@ -3194,14 +3797,14 @@ 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; - } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { + $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'}) { $forceview = 1; @@ -3219,7 +3822,7 @@ sub can_edit_resource { } else { $cfile = $env{'form.suppurl'}; my $escfile = &unescape($cfile); - if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) { + if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { $cfile = '/adm/wrapper'.$escfile; } else { $escfile =~ s{^http://}{}; @@ -3380,7 +3983,7 @@ sub process_coursefile { $home); } } elsif ($action eq 'uploaddoc') { - open(my $fh,'>'.$filepath.'/'.$fname); + open(my $fh,'>',$filepath.'/'.$fname); print $fh $env{'form.'.$source}; close($fh); if ($parser eq 'parse') { @@ -3438,7 +4041,7 @@ sub store_edited_file { ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); $fpath=$docudom.'/'.$docuname.'/'.$fpath; my $filepath = &build_filepath($fpath); - open(my $fh,'>'.$filepath.'/'.$fname); + open(my $fh,'>',$filepath.'/'.$fname); print $fh $content; close($fh); my $home=&homeserver($docuname,$docudom); @@ -3463,13 +4066,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 @@ -3512,13 +4123,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 @@ -3541,6 +4155,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')) || @@ -3554,12 +4176,12 @@ sub userfileupload { '_'.$env{'user.domain'}.'/pending'; } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { my ($docuname,$docudom); - if ($destudom) { + if ($destudom =~ /^$match_domain$/) { $docudom = $destudom; } else { $docudom = $env{'user.domain'}; } - if ($destuname) { + if ($destuname =~ /^$match_username$/) { $docuname = $destuname; } else { $docuname = $env{'user.name'}; @@ -3589,7 +4211,7 @@ sub userfileupload { mkdir($fullpath,0777); } } - open(my $fh,'>'.$fullpath.'/'.$fname); + open(my $fh,'>',$fullpath.'/'.$fname); print $fh $env{'form.'.$formname}; close($fh); if ($context eq 'existingfile') { @@ -3664,7 +4286,7 @@ sub finishuserfileupload { # Save the file { - if (!open(FH,'>'.$filepath.'/'.$file)) { + if (!open(FH,'>',$filepath.'/'.$file)) { &logthis('Failed to create '.$filepath.'/'.$file); print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); return '/adm/notfound.html'; @@ -3708,7 +4330,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); @@ -3717,12 +4339,16 @@ 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; my $output = $filepath.'/'.'tn-'.$file; my $thumbsize = $thumbwidth.'x'.$thumbheight; - system("convert -sample $thumbsize $input $output"); + my @args = ('convert','-sample',$thumbsize,$input,$output); + system({$args[0]} @args); if (-e $filepath.'/'.'tn-'.$file) { $fetchthumb = 1; } @@ -3956,6 +4582,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); @@ -4106,7 +4972,7 @@ sub flushcourselogs { } } # -# Reverse lookup of domain roles (dc, ad, li, sc, au) +# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) # my %domrolebuffer = (); foreach my $entry (keys(%domainrolehash)) { @@ -4121,10 +4987,19 @@ sub flushcourselogs { delete $domainrolehash{$entry}; } foreach my $dom (keys(%domrolebuffer)) { - my %servers = &get_servers($dom,'library'); + my %servers; + if (defined(&domain($dom,'primary'))) { + my $primary=&domain($dom,'primary'); + my $hostname=&hostname($primary); + $servers{$primary} = $hostname; + } else { + %servers = &get_servers($dom,'library'); + } foreach my $tryserver (keys(%servers)) { - unless (&reply('domroleput:'.$dom.':'. - $domrolebuffer{$dom},$tryserver) eq 'ok') { + if (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { + last; + } else { &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); } } @@ -4173,7 +5048,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}; + } } } } @@ -4244,7 +5123,7 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} =$tend.':'.$tstart; } - if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) { + if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $domainrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} @@ -4471,6 +5350,195 @@ sub get_my_roles { return %returnhash; } +sub get_all_adhocroles { + my ($dom) = @_; + my @roles_by_num = (); + my %domdefaults = &get_domain_defaults($dom); + my (%description,%access_in_dom,%access_info); + if (ref($domdefaults{'adhocroles'}) eq 'HASH') { + my $count = 0; + my %domcurrent = %{$domdefaults{'adhocroles'}}; + my %ordered; + foreach my $role (sort(keys(%domcurrent))) { + my ($order,$desc,$access_in_dom); + if (ref($domcurrent{$role}) eq 'HASH') { + $order = $domcurrent{$role}{'order'}; + $desc = $domcurrent{$role}{'desc'}; + $access_in_dom{$role} = $domcurrent{$role}{'access'}; + $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; + } + if ($order eq '') { + $order = $count; + } + $ordered{$order} = $role; + if ($desc ne '') { + $description{$role} = $desc; + } else { + $description{$role}= $role; + } + $count++; + } + foreach my $item (sort {$a <=> $b } (keys(%ordered))) { + push(@roles_by_num,$ordered{$item}); + } + } + return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); +} + +sub get_my_adhocroles { + my ($cid,$checkreg) = @_; + my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); + if ($env{'request.course.id'} eq $cid) { + $cdom = $env{'course.'.$cid.'.domain'}; + $cnum = $env{'course.'.$cid.'.num'}; + $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; + } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { + $cdom = $1; + $cnum = $2; + %info = &Apache::lonnet::get('environment',['internal.coursecode'], + $cdom,$cnum); + } + if (($info{'internal.coursecode'} ne '') && ($checkreg)) { + my $user = $env{'user.name'}.':'.$env{'user.domain'}; + my %rosterhash = &get('classlist',[$user],$cdom,$cnum); + if ($rosterhash{$user} ne '') { + my $type = (split(/:/,$rosterhash{$user}))[5]; + return ([],{}) if ($type eq 'auto'); + } + } + if (($cdom ne '') && ($cnum ne '')) { + if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { + my $then=$env{'user.login.time'}; + my $update=$env{'user.update.time'}; + if (!$update) { + $update = $then; + } + my @liveroles; + foreach my $role ('dh','da') { + if ($env{"user.role.$role./$cdom/"}) { + my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); + my $limit = $update; + if ($env{'request.role'} eq "$role./$cdom/") { + $limit = $then; + } + my $activerole = 1; + if ($tstart && $tstart>$limit) { $activerole = 0; } + if ($tend && $tend <$limit) { $activerole = 0; } + if ($activerole) { + push(@liveroles,$role); + } + } + } + if (@liveroles) { + if (&homeserver($cnum,$cdom) ne 'no_host') { + my ($accessref,$accessinfo,%access_in_dom); + ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); + if (ref($roles_by_num) eq 'ARRAY') { + if (@{$roles_by_num}) { + my %settings; + if ($env{'request.course.id'} eq $cid) { + foreach my $envkey (keys(%env)) { + if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) { + $settings{$1} = $env{$envkey}; + } + } + } else { + %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc'); + } + my %setincrs; + if ($settings{'internal.adhocaccess'}) { + map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'}); + } + my @statuses; + if ($env{'environment.inststatus'}) { + @statuses = split(/,/,$env{'environment.inststatus'}); + } + my $user = $env{'user.name'}.':'.$env{'user.domain'}; + if (ref($accessref) eq 'HASH') { + %access_in_dom = %{$accessref}; + } + foreach my $role (@{$roles_by_num}) { + my ($curraccess,@okstatus,@personnel); + if ($setincrs{$role}) { + ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); + if ($curraccess eq 'status') { + @okstatus = split(/\&/,$rest); + } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { + @personnel = split(/\&/,$rest); + } + } else { + $curraccess = $access_in_dom{$role}; + if (ref($accessinfo) eq 'HASH') { + if ($curraccess eq 'status') { + if (ref($accessinfo->{$role}) eq 'ARRAY') { + @okstatus = @{$accessinfo->{$role}}; + } + } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { + if (ref($accessinfo->{$role}) eq 'ARRAY') { + @personnel = @{$accessinfo->{$role}}; + } + } + } + } + if ($curraccess eq 'none') { + next; + } elsif ($curraccess eq 'all') { + push(@possroles,$role); + } elsif ($curraccess eq 'dh') { + if (grep(/^dh$/,@liveroles)) { + push(@possroles,$role); + } else { + next; + } + } elsif ($curraccess eq 'da') { + if (grep(/^da$/,@liveroles)) { + push(@possroles,$role); + } else { + next; + } + } elsif ($curraccess eq 'status') { + if (@okstatus) { + if (!@statuses) { + if (grep(/^default$/,@okstatus)) { + push(@possroles,$role); + } + } else { + foreach my $status (@okstatus) { + if (grep(/^\Q$status\E$/,@statuses)) { + push(@possroles,$role); + last; + } + } + } + } + } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { + if (grep(/^\Q$user\E$/,@personnel)) { + if ($curraccess eq 'exc') { + push(@possroles,$role); + } + } elsif ($curraccess eq 'inc') { + push(@possroles,$role); + } + } + } + } + } + } + } + } + } + unless (ref($description) eq 'HASH') { + if (ref($roles_by_num) eq 'ARRAY') { + my %desc; + map { $desc{$_} = $_; } (@{$roles_by_num}); + $description = \%desc; + } else { + $description = {}; + } + } + return (\@possroles,$description); +} + # ----------------------------------------------------- Frontpage Announcements # # @@ -4484,7 +5552,7 @@ sub postannounce { sub getannounce { - if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { + if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; while (my $line = <$fh>) { $announcement .= $line; } close($fh); @@ -4711,6 +5779,21 @@ sub get_domain_roles { return %personnel; } +sub get_active_domroles { + my ($dom,$roles) = @_; + return () unless (ref($roles) eq 'ARRAY'); + my $now = time; + my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now); + my %domroles; + foreach my $server (keys(%dompersonnel)) { + foreach my $user (sort(keys(%{$dompersonnel{$server}}))) { + my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user); + $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user}; + } + } + return %domroles; +} + # ----------------------------------------------------------- Interval timing { @@ -4766,7 +5849,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); @@ -4779,6 +5867,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; } @@ -5040,7 +6134,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; @@ -5077,7 +6171,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; @@ -5121,7 +6215,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; @@ -5177,7 +6271,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=''; @@ -5213,7 +6307,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=''; @@ -5565,9 +6659,10 @@ sub rolesinit { } } - @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, - \%allroles, \%allgroups); + @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, + \%allroles, \%allgroups); $env{'user.adv'} = $userroles{'user.adv'}; + $env{'user.rar'} = $userroles{'user.rar'}; return (\%userroles,\%firstaccenv,\%timerintenv); } @@ -5603,6 +6698,10 @@ sub custom_roleprivs { $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; } if (($trest ne '') && (defined($coursepriv))) { + if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) { + my $rolename = $1; + $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv); + } $$allroles{'cm.'.$area}.=':'.$coursepriv; $$allroles{$spec.'.'.$area}.=':'.$coursepriv; } @@ -5611,6 +6710,48 @@ sub custom_roleprivs { } } +sub course_adhocrole_privs { + my ($rolename,$cdom,$cnum,$coursepriv) = @_; + my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum); + if ($overrides{"internal.adhocpriv.$rolename"}) { + my (%currprivs,%storeprivs); + foreach my $item (split(/:/,$coursepriv)) { + my ($priv,$restrict) = split(/\&/,$item); + $currprivs{$priv} = $restrict; + } + my (%possadd,%possremove,%full); + foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) { + my ($priv,$restrict)=split(/\&/,$item); + $full{$priv} = $restrict; + } + foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) { + next if ($item eq ''); + my ($rule,$rest) = split(/=/,$item); + next unless (($rule eq 'off') || ($rule eq 'on')); + foreach my $priv (split(/:/,$rest)) { + if ($priv ne '') { + if ($rule eq 'off') { + $possremove{$priv} = 1; + } else { + $possadd{$priv} = 1; + } + } + } + } + foreach my $priv (sort(keys(%full))) { + if (exists($currprivs{$priv})) { + unless (exists($possremove{$priv})) { + $storeprivs{$priv} = $currprivs{$priv}; + } + } elsif (exists($possadd{$priv})) { + $storeprivs{$priv} = $full{$priv}; + } + } + $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs))); + } + return $coursepriv; +} + sub group_roleprivs { my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; my $access = 1; @@ -5645,6 +6786,7 @@ sub set_userprivs { my ($userroles,$allroles,$allgroups,$groups_roles) = @_; my $author=0; my $adv=0; + my $rar=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { my @groupkeys; @@ -5692,6 +6834,7 @@ sub set_userprivs { $thesepriv{$privilege}.=$restrictions; } if ($thesepriv{'adv'} eq 'F') { $adv=1; } + if ($thesepriv{'rar'} eq 'F') { $rar=1; } } } my $thesestr=''; @@ -5700,7 +6843,7 @@ sub set_userprivs { } $userroles->{'user.priv.'.$role} = $thesestr; } - return ($author,$adv); + return ($author,$adv,$rar); } sub role_status { @@ -5745,9 +6888,10 @@ sub role_status { push(@rolecodes,$$role); &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); } - my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); + my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, + \%groups_roles); &appenv(\%userroles,\@rolecodes); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); } } $$tstatus = 'is'; @@ -5823,39 +6967,57 @@ sub delete_env_groupprivs { } sub check_adhoc_privs { - my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; + my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_; my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; + if ($sec) { + $cckey .= '/'.$sec; + } my $setprivs; if ($env{$cckey}) { my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); + &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); $setprivs = 1; } } else { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); + &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); $setprivs = 1; } return $setprivs; } sub set_adhoc_privileges { -# role can be cc or ca - my ($dcdom,$pickedcourse,$role,$caller) = @_; +# role can be cc, ca, or cr//-domainconfig/role + my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_; my $area = '/'.$dcdom.'/'.$pickedcourse; + if ($sec ne '') { + $area .= '/'.$sec; + } my $spec = $role.'.'.$area; my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, $env{'user.name'},1); - my %ccrole = (); - &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); - my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); + my %rolehash = (); + if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) { + my $rolename = $1; + &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area); + my %domdef = &get_domain_defaults($dcdom); + if (ref($domdef{'adhocroles'}) eq 'HASH') { + if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') { + &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},}); + } + } + } else { + &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); + } + my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); &appenv(\%userroles,[$role,'cm']); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); - unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); + unless (($caller eq 'constructaccess' && $env{'request.course.id'}) || + ($caller eq 'tiny')) { &appenv( {'request.role' => $spec, 'request.role.domain' => $dcdom, - 'request.course.sec' => '' + 'request.course.sec' => $sec, } ); my $tadv=0; @@ -6005,7 +7167,7 @@ sub currentdump { # my %returnhash=(); # - if ($rep eq "unknown_cmd") { + if ($rep eq 'unknown_cmd') { # an old lond will not know currentdump # Do a dump and make it look like a currentdump my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); @@ -6140,7 +7302,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'}); @@ -6239,9 +7402,11 @@ sub tmpget { if (!defined($server)) { $server = $perlvar{'lonHostID'}; } my $rep=&reply("tmpget:$token",$server); my %returnhash; + if ($rep =~ /^(con_lost|error|no_such_host)/i) { + return %returnhash; + } foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); - next if ($key =~ /^error: 2 /); $returnhash{&unescape($key)}=&thaw_unescape($value); } return %returnhash; @@ -6624,6 +7789,7 @@ sub usertools_access { community => 1, textbook => 1, placement => 1, + lti => 1, ); } elsif ($context eq 'requestauthor') { %tools = ( @@ -6820,25 +7986,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) { @@ -6855,7 +8025,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; @@ -6920,7 +8090,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; @@ -6937,7 +8107,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)$})) + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) && ($priv eq 'bre')) { return 'F'; @@ -6985,7 +8155,10 @@ sub allowed { # Free bre to public access if ($priv eq 'bre') { - my $copyright=&metadata($uri,'copyright'); + my $copyright; + unless ($uri =~ /ext\.tool/) { + $copyright=&metadata($uri,'copyright'); + } if (($copyright eq 'public') && (!$env{'request.course.id'})) { return 'F'; } @@ -7102,8 +8275,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; + } } } @@ -7116,10 +8315,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 { @@ -7136,10 +8338,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 { @@ -7186,6 +8391,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'}; @@ -7202,7 +8417,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 { @@ -7215,7 +8430,7 @@ sub allowed { $checkreferer=0; } } - + if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { @@ -7241,10 +8456,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 { @@ -7330,7 +8548,7 @@ sub allowed { } } } - + # # Rest of the restrictions depend on selected course # @@ -7409,6 +8627,8 @@ sub allowed { return 'A'; } elsif ($thisallowed eq 'B') { return 'B'; + } elsif ($thisallowed eq 'D') { + return 'D'; } return 'F'; } @@ -7425,7 +8645,7 @@ sub constructaccess { my ($ownername,$ownerdomain,$ownerhome); ($ownerdomain,$ownername) = - ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/}); + ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)}); # The URL does not really point to any authorspace, forget it unless (($ownername) && ($ownerdomain)) { return ''; } @@ -7497,22 +8717,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 { @@ -7592,14 +8817,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; + } + } } } } @@ -7650,17 +8884,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); @@ -7671,37 +8911,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 # @@ -7773,7 +9104,7 @@ sub get_symb_from_alias { sub definerole { if (allowed('mcr','/')) { - my ($rolename,$sysrole,$domrole,$courole)=@_; + my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_; foreach my $role (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } @@ -7801,11 +9132,19 @@ sub definerole { } } } + my $uhome; + if (($uname ne '') && ($udom ne '')) { + $uhome = &homeserver($uname,$udom); + return $uhome if ($uhome eq 'no_host'); + } else { + $uname = $env{'user.name'}; + $udom = $env{'user.domain'}; + $uhome = $env{'user.home'}; + } my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". - "$env{'user.domain'}:$env{'user.name'}:". - "rolesdef_$rolename=". + "$udom:$uname:rolesdef_$rolename=". escape($sysrole.'_'.$domrole.'_'.$courole); - return reply($command,$env{'user.home'}); + return reply($command,$uhome); } else { return 'refused'; } @@ -7938,7 +9277,7 @@ sub fetch_enrollment_query { if ($xml_classlist =~ /^error/) { &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); } else { - if ( open(FILE,">$destname") ) { + if ( open(FILE,">",$destname) ) { print FILE &unescape($xml_classlist); close(FILE); } else { @@ -7967,7 +9306,7 @@ sub get_query_reply { for (1..$loopmax) { sleep($sleep); if (-e $replyfile.'.end') { - if (open(my $fh,$replyfile)) { + if (open(my $fh,"<",$replyfile)) { $reply = join('',<$fh>); close($fh); } else { return 'error: reply_file_error'; } @@ -8088,6 +9427,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); @@ -8359,6 +9717,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) = @_; @@ -8718,7 +10103,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')); @@ -8738,8 +10123,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 '')) { @@ -8854,7 +10243,8 @@ sub assignrole { &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $selfenroll,$context); } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || - ($role eq 'au') || ($role eq 'dc')) { + ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || + ($role eq 'da')) { &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $context); } elsif (($role eq 'ca') || ($role eq 'aa')) { @@ -8877,11 +10267,24 @@ 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 = + &Apache::lonnet::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'})) { @@ -8894,18 +10297,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'}, @@ -8958,19 +10359,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; @@ -9004,10 +10421,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; @@ -9295,14 +10716,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; } @@ -9452,12 +10878,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; } @@ -9474,7 +10913,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=''; @@ -9593,7 +11032,7 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - open (OUT, '>'.$tmpdir.$filename); + open (OUT,'>',LONCAPA::tempdir().$filename); foreach my $file (@files) { print (OUT $env{'form.currentpath'}.$file."\n"); } @@ -9607,7 +11046,7 @@ sub save_selected_files { sub clear_selected_files { my ($user) = @_; my $filename = $user."savedfiles"; - open (OUT, '>'.LONCAPA::tempdir().$filename); + open (OUT,'>',LONCAPA::tempdir().$filename); print (OUT undef); close (OUT); return ("ok"); @@ -9617,7 +11056,7 @@ sub files_in_path { my ($user, $path) = @_; my $filename = $user."savedfiles"; my %return_files; - open (IN, '<'.LONCAPA::tempdir().$filename); + open (IN,'<',LONCAPA::tempdir().$filename); while (my $line_in = ) { chomp ($line_in); my @paths_and_file = split (m!/!, $line_in); @@ -9639,7 +11078,7 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open(IN, '<'.LONCAPA::.$filename); + open(IN, '<',LONCAPA::tempdir().$filename); while (my $line = ) { #ok, I know it's clunky, but I want it to work my @paths_and_file = split(m|/|, $line); @@ -10624,23 +12063,40 @@ sub resdata { return undef; } -sub get_domain_ltitools { - my ($cdom) = @_; - my %ltitools; - my ($result,$cached)=&is_cached_new('ltitools',$cdom); +sub get_domain_lti { + my ($cdom,$context) = @_; + my ($name,%lti); + if ($context eq 'consumer') { + $name = 'ltitools'; + } elsif ($context eq 'provider') { + $name = 'lti'; + } else { + return %lti; + } + my ($result,$cached)=&is_cached_new($name,$cdom); if (defined($cached)) { if (ref($result) eq 'HASH') { - %ltitools = %{$result}; + %lti = %{$result}; } } else { - my %domconfig = &get_dom('configuration',['ltitools'],$cdom); - if (ref($domconfig{'ltitools'}) eq 'HASH') { - %ltitools = %{$domconfig{'ltitools'}}; + my %domconfig = &get_dom('configuration',[$name],$cdom); + if (ref($domconfig{$name}) eq 'HASH') { + %lti = %{$domconfig{$name}}; + my %encdomconfig = &get_dom('encconfig',[$name],$cdom); + if (ref($encdomconfig{$name}) eq 'HASH') { + foreach my $id (keys(%lti)) { + if (ref($encdomconfig{$name}{$id}) eq 'HASH') { + foreach my $item ('key','secret') { + $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; + } + } + } + } } my $cachetime = 24*60*60; - &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); + &do_cache_new($name,$cdom,\%lti,$cachetime); } - return %ltitools; + return %lti; } sub get_numsuppfiles { @@ -10653,10 +12109,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); } @@ -10946,9 +12403,13 @@ sub EXT { } else { $filename=$env{'request.filename'}; } - my $metadata=&metadata($filename,$what); + my $toolsymb; + if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { + $toolsymb = $symbparm; + } + my $metadata=&metadata($filename,$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } - $metadata=&metadata($filename,'parameter_'.$what); + $metadata=&metadata($filename,'parameter_'.$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } # ----------------------------------------------- fifth, look in rest of course @@ -10974,7 +12435,7 @@ sub EXT { if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } } if ($recurse) { return undef; } - my $pack_def=&packages_tab_default($filename,$varname); + my $pack_def=&packages_tab_default($filename,$varname,$toolsymb); if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -10999,6 +12460,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 ''; } @@ -11068,11 +12533,11 @@ sub sort_course_groups { # Sort groups b } sub packages_tab_default { - my ($uri,$varname)=@_; + my ($uri,$varname,$toolsymb)=@_; my (undef,$part,$name)=split(/\./,$varname); my (@extension,@specifics,$do_default); - foreach my $package (split(/,/,&metadata($uri,'packages'))) { + foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) { my ($pack_type,$pack_part)=split(/_/,$package,2); if ($pack_type eq 'default') { $do_default=1; @@ -11139,13 +12604,14 @@ sub add_prefix_and_part { my %metaentry; my %importedpartids; +my %importedrespids; sub metadata { - my ($uri,$what,$liburi,$prefix,$depthcount)=@_; + my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && - ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) || + ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -11164,11 +12630,72 @@ sub metadata { my ($result,$cached)=&is_cached_new('meta',$uri); if (defined($cached)) { return $result->{':'.$what}; } } + +# +# If the uri is for an external tool the file from +# which metadata should be retrieved depends on whether +# the tool had been configured to be gradable (set in the Course +# Editor or Resource Editor). +# +# If a valid symb has been included as the third arg in the call +# to &metadata() that can be used to retrieve the value of +# parameter_0_gradable set for the resource, and included in the +# 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 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 +# and the $what for which metadata is being requested is +# parameter_0_gradable or 0_gradable. +# + + if ($uri =~ /ext\.tool$/) { + if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) { + return; + } else { + my ($checked,$use_passback); + if ($toolsymb ne '') { + (undef,undef,my $tooluri) = &decode_symb($toolsymb); + if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) { + $checked = 1; + if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) { + $use_passback = 1; + } + } + } + unless ($checked) { + my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri); + $marker=~s/\D//g; + if ($marker) { + my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum); + $use_passback = $toolsettings{'gradable'}; + } + } + if ($use_passback) { + $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool'; + } else { + $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool'; + } + } + } + { # 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? # @@ -11263,27 +12790,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); @@ -11294,22 +12871,36 @@ 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', $location,$unikey, + &metadata($uri,'keys',$toolsymb,$location,$unikey, $depthcount+1); foreach my $meta (split(',',$metadata)) { $metaentry{':'.$meta}=$metaentry{':'.$meta}; $metathesekeys{$meta}=1; } - } } else { # @@ -11378,7 +12969,7 @@ sub metadata { $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); my $rights_metadata = - &metadata($uri,'keys',$location,'_rights', + &metadata($uri,'keys',$toolsymb,$location,'_rights', $depthcount+1); foreach my $rights (split(',',$rights_metadata)) { #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; @@ -11392,26 +12983,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}; @@ -11670,18 +13292,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)}; } @@ -11781,19 +13401,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'}; } @@ -11816,10 +13439,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) { @@ -11852,13 +13483,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')) { @@ -11877,12 +13513,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++; } @@ -11890,6 +13527,11 @@ sub symbread { $syval = $poss_syval; $realpossible++; } + if ($syval) { + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + } } } } @@ -12421,17 +14063,17 @@ sub repcopy_userfile { } # now the path exists for sure # get a user agent - my $ua=new LWP::UserAgent; my $transferfile=$file.'.in.transfer'; # FIXME: this should flock if (-e $transferfile) { return 'ok'; } 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); - my $response=$ua->request($request,$transferfile); + $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()) { unlink($transferfile); @@ -12454,9 +14096,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 { @@ -12472,12 +14115,12 @@ 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; - my $ua=new LWP::UserAgent; + $uri = $protocol.'://'.$hostname.'/raw/'.$uri; my $request=new HTTP::Request($reqtype,$uri); - my $response=$ua->request($request); + my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); $$rtncode = $response->code; if (! $response->is_success()) { return 'failed'; @@ -12494,7 +14137,7 @@ sub readfile { my $file = shift; if ( (! -e $file ) || ($file eq '') ) { return -1; }; my $fh; - open($fh,"<$file"); + open($fh,"<",$file); my $a=''; while (my $line = <$fh>) { $a .= $line; } return $a; @@ -12607,7 +14250,7 @@ sub machine_ids { sub additional_machine_domains { my @domains; - open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); + open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); while( my $line = <$fh>) { $line =~ s/\s//g; push(@domains,$line); @@ -12628,6 +14271,163 @@ 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 get_requestor_ip { + my ($r,$nolookup,$noproxy) = @_; + my $from_ip; + if (ref($r)) { + $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'}, + }; + 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 $lonhost = $perlvar{'lonHostID'}; + if ($lonhost ne '') { + my ($alias,$cached) = &is_cached_new('proxyalias',$lonhost); + if ($cached) { + return $alias; + } + my $dom = &Apache::lonnet::host_domain($lonhost); + 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'}{$lonhost}; + } + } + return &do_cache_new('proxyalias',$lonhost,$alias,$cachetime); + } + } + return; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -12678,7 +14478,7 @@ sub clutter { # &logthis("Got a blank emb style"); } } - } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) { + } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { $thisfn='/adm/wrapper'.$thisfn; } return $thisfn; @@ -12753,37 +14553,51 @@ 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); - my $ua=new LWP::UserAgent; - $ua->timeout(30); my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); - my $response=$ua->request($request); + 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; } @@ -12843,6 +14657,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; @@ -12874,7 +14761,7 @@ sub fetch_dns_checksums { my ($ignore_cache,$nocache) = @_; &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); my $fh; - if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { + if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { my @lines = <$fh>; &parse_domain_tab(\@lines); } @@ -12926,8 +14813,23 @@ sub fetch_dns_checksums { my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); $name=~s/\s//g; if ($id && $domain && $role && $name) { + if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { + my $curr = $hostname{$id}; + my $skip; + if (ref($name_to_host{$curr}) eq 'ARRAY') { + if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { + $skip = 1; + } else { + @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; + } + } + unless ($skip) { + push(@{$name_to_host{$name}},$id); + } + } else { + push(@{$name_to_host{$name}},$id); + } $hostname{$id}=$name; - push(@{$name_to_host{$name}}, $id); $hostdom{$id}=$domain; if ($role eq 'library') { $libserv{$id}=$name; } if (defined($protocol)) { @@ -12950,6 +14852,7 @@ sub fetch_dns_checksums { &purge_remembered(); &reset_domain_info(); &reset_hosts_ip_info(); + undef(%internetdom); undef(%name_to_host); undef(%hostname); undef(%hostdom); @@ -12960,7 +14863,7 @@ sub fetch_dns_checksums { sub load_hosts_tab { my ($ignore_cache,$nocache) = @_; &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); my @config = <$config>; &parse_hosts_tab(\@config); close($config); @@ -12992,6 +14895,11 @@ sub fetch_dns_checksums { return %hostdom; } + sub all_host_intdom { + &load_hosts_tab() if (!$loaded); + return %internetdom; + } + sub is_library { &load_hosts_tab() if (!$loaded); @@ -13226,7 +15134,7 @@ sub all_loncaparevs { { sub load_loncaparevs { if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { + if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) { while (my $configline=<$config>) { chomp($configline); my ($hostid,$loncaparev)=split(/:/,$configline); @@ -13242,7 +15150,7 @@ sub all_loncaparevs { { sub load_serverhomeIDs { if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { + if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { while (my $configline=<$config>) { chomp($configline); my ($name,$id)=split(/:/,$configline); @@ -13267,7 +15175,7 @@ BEGIN { # ------------------------------------------------------ Read spare server file { - open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13281,7 +15189,7 @@ BEGIN { } # ------------------------------------------------------------ Read permissions { - open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13295,7 +15203,7 @@ BEGIN { # -------------------------------------------- Read plain texts for permissions { - open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13315,7 +15223,7 @@ BEGIN { # ---------------------------------------------------------- Read package table { - open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { if ($configline !~ /\S/ || $configline=~/^#/) { next; } @@ -13369,7 +15277,7 @@ BEGIN { # ---------------------------------------------------------- Read managers table { if (-e "$perlvar{'lonTabDir'}/managers.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { + if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { while (my $configline=<$config>) { chomp($configline); next if ($configline =~ /^\#/); @@ -13388,6 +15296,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, }); @@ -13727,6 +15645,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 * @@ -13745,9 +15664,10 @@ in which case the null string is returne =item * -definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom -role rolename set privileges in format of lonTabs/roles.tab for system, domain, -and course level +definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role; +define a custom role rolename set privileges in format of lonTabs/roles.tab +for system, domain, and course level. $uname and $udom are optional (current +user's username and domain will be used when either of $uname or $udom are absent. =item * @@ -14056,6 +15976,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 @@ -14107,12 +16109,18 @@ condval($condidx) : value of condition i =item * -metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a resource's metadata, $what should be either a specific key, or either 'keys' (to get a list of possible keys) or 'packages' to get a list of -packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. +packages that this resource currently uses, the last 3 arguments are +only used internally for recursive metadata. + +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 * @@ -14747,6 +16755,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