--- loncom/lonnet/perl/lonnet.pm 2018/04/14 02:30:01 1.1375 +++ loncom/lonnet/perl/lonnet.pm 2023/04/11 20:35:19 1.1508 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1375 2018/04/14 02:30:01 raeburn Exp $ +# $Id: lonnet.pm,v 1.1508 2023/04/11 20:35:19 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -73,13 +73,13 @@ package Apache::lonnet; use strict; use HTTP::Date; use Image::Magick; - +use CGI::Cookie; use Encode; -use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir +use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $deftex $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease - %managerstab); + %managerstab $passwdmin); my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, @@ -96,11 +96,14 @@ use Cache::Memcached; use Digest::MD5; use Math::Random; use File::MMagic; +use Net::CIDR; +use Sys::Hostname::FQDN(); 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 +130,13 @@ our @EXPORT = qw(%env); $logid ++; my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; + my $ip = &get_requestor_ip(); my $logentry = { $id => { 'exe_uname' => $env{'user.name'}, 'exe_udom' => $env{'user.domain'}, 'exe_time' => $now, - 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'exe_ip' => $ip, 'delflag' => $delflag, 'logentry' => $storehash, 'uname' => $uname, @@ -184,7 +188,7 @@ sub create_connection { Type => SOCK_STREAM, Timeout => 10); return 0 if (!$client); - print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n"); + print $client (join(':',$hostname,$lonid,&machine_ids($hostname),$loncaparevs{$lonid})."\n"); my $result = <$client>; chomp($result); return 1 if ($result eq 'done'); @@ -230,12 +234,19 @@ sub get_server_distarch { } sub get_servercerts_info { - my ($lonhost,$context) = @_; + my ($lonhost,$hostname,$context) = @_; + return if ($lonhost eq ''); + if ($hostname eq '') { + $hostname = &hostname($lonhost); + } + return if ($hostname eq ''); my ($rep,$uselocal); - if (grep { $_ eq $lonhost } ¤t_machine_ids()) { + if ($context eq 'install') { + $uselocal = 1; + } elsif (grep { $_ eq $lonhost } ¤t_machine_ids()) { $uselocal = 1; } - if (($context ne 'cgi') && ($uselocal)) { + if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) { my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; if ($distro eq '') { $uselocal = 0; @@ -250,16 +261,11 @@ sub get_servercerts_info { } } if ($uselocal) { - $rep = LONCAPA::Lond::server_certs(\%perlvar); + $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname); } else { $rep=&reply('servercerts',$lonhost); } my ($result,%returnhash); - if (defined($lonhost)) { - if (!defined(&hostname($lonhost))) { - return; - } - } if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || ($rep eq 'unknown_cmd')) { $result = $rep; @@ -309,9 +315,10 @@ sub get_server_loncaparev { $answer = &reply('serverloncaparev',$lonhost); if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { if ($caller eq 'loncron') { + my $hostname = &hostname($lonhost); my $protocol = $protocol{$lonhost}; $protocol = 'http' if ($protocol ne 'https'); - my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; + my $url = $protocol.'://'.$hostname.'/adm/about.html'; my $request=new HTTP::Request('GET',$url); my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); unless ($response->is_error()) { @@ -456,8 +463,27 @@ 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') || + ($subcmd eq 'put')) { + (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') || ($subcmd eq 'put')) { + splice(@rest,3,1,'Hidden'); + } + $logged = join(':',('encrypt:'.$subcmd,@rest)); + } + } + &logthis("WARNING:". + " $logged to $server returned $answer"); } return $answer; } @@ -652,31 +678,39 @@ sub transfer_profile_to_env { sub check_for_valid_session { my ($r,$name,$userhashref,$domref) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - my ($linkname,$pubname); - if ($name eq '') { - $name = 'lonID'; + my ($lonidsdir,$linkname,$pubname,$secure,$lonid); + if ($name eq 'lonDAV') { + $lonidsdir=$r->dir_config('lonDAVsessDir'); + } else { + $lonidsdir=$r->dir_config('lonIDsDir'); + if ($name eq '') { + $name = 'lonID'; + } + } + if ($name eq 'lonID') { + $secure = 'lonSID'; $linkname = 'lonLinkID'; $pubname = 'lonPubID'; - } - my $lonid=$cookies{$name}; - if (!$lonid) { - if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) { + if (exists($cookies{$secure})) { + $lonid=$cookies{$secure}; + } elsif (exists($cookies{$name})) { + $lonid=$cookies{$name}; + } elsif ((exists($cookies{$linkname})) && ($ENV{'SERVER_PORT'} != 443)) { $lonid=$cookies{$linkname}; + } elsif (exists($cookies{$pubname})) { + $lonid=$cookies{$pubname}; } - if (!$lonid) { - if (($name eq 'lonID') && ($pubname)) { - $lonid=$cookies{$pubname}; - } - } + } else { + $lonid=$cookies{$name}; } return undef if (!$lonid); my $handle=&LONCAPA::clean_handle($lonid->value); - my $lonidsdir; - if ($name eq 'lonDAV') { - $lonidsdir=$r->dir_config('lonDAVsessDir'); - } else { - $lonidsdir=$r->dir_config('lonIDsDir'); + if (-l "$lonidsdir/$handle.id") { + my $link = readlink("$lonidsdir/$handle.id"); + if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { + $handle = $1; + } } if (!-e "$lonidsdir/$handle.id") { if ((ref($domref)) && ($name eq 'lonID') && @@ -701,18 +735,23 @@ sub check_for_valid_session { if (!defined($disk_env{'user.name'}) || !defined($disk_env{'user.domain'})) { + untie(%disk_env); return undef; } if (ref($userhashref) eq 'HASH') { $userhashref->{'name'} = $disk_env{'user.name'}; $userhashref->{'domain'} = $disk_env{'user.domain'}; + if ($disk_env{'request.role'}) { + $userhashref->{'role'} = $disk_env{'request.role'}; + } $userhashref->{'lti'} = $disk_env{'request.lti.login'}; if ($userhashref->{'lti'}) { $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; } } + untie(%disk_env); return $handle; } @@ -737,6 +776,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 { @@ -762,16 +832,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'; @@ -887,6 +960,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++; } } @@ -904,16 +978,16 @@ sub userload { # ------------------------------ Find server with least workload from spare.tab sub spareserver { - my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_; + my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_; my $spare_server; if ($userloadpercent !~ /\d/) { $userloadpercent=0; } my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent : $userloadpercent; my ($uint_dom,$remotesessions); if (($udom ne '') && (&domain($udom) ne '')) { - my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); - $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); - my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); + my $uprimary_id = &domain($udom,'primary'); + $uint_dom = &internet_dom($uprimary_id); + my %udomdefaults = &get_domain_defaults($udom); $remotesessions = $udomdefaults{'remotesessions'}; } my $spareshash = &this_host_spares($udom); @@ -942,13 +1016,15 @@ 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}; + } + my $alias = &use_proxy_alias($r,$spare_server); + $hostname = $alias if ($alias ne ''); $spare_server = $protocol.'://'.$hostname; } } @@ -1015,6 +1091,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) = @_; @@ -1038,7 +1211,7 @@ sub choose_server { unless (defined($cached)) { my $cachetime = 60*60*24; my %domconfig = - &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); + &get_dom('configuration',['loadbalancing'],$udom); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'}, $cachetime); @@ -1050,7 +1223,7 @@ sub choose_server { if (ref($balancers) eq 'HASH') { next if (exists($balancers->{$lonhost})); } - } + } my $loginvia; if ($checkloginvia) { $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; @@ -1081,6 +1254,28 @@ sub choose_server { return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); } +sub get_course_sessions { + my ($cnum,$cdom,$lastactivity) = @_; + my %servers = &internet_dom_servers($cdom); + my %returnhash; + foreach my $server (sort(keys(%servers))) { + my $rep = &reply("coursesessions:$cdom:$cnum:$lastactivity",$server); + my @pairs=split(/\&/,$rep); + unless (($rep eq 'unknown_cmd') || ($rep =~ /^error/)) { + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + $key = &unescape($key); + next if ($key =~ /^error: 2 /); + if (exists($returnhash{$key})) { + next if ($value < $returnhash{$key}); + } + $returnhash{$key}=$value; + } + } + } + return %returnhash; +} + # --------------------------------------------- Try to change a user's password sub changepass { @@ -1116,6 +1311,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; } @@ -1125,7 +1323,7 @@ sub changepass { sub queryauthenticate { my ($uname,$udom)=@_; my $uhome=&homeserver($uname,$udom); - if (!$uhome) { + if ((!$uhome) || ($uhome eq 'no_host')) { &logthis("User $uname at $udom is unknown when looking for authentication mechanism"); return 'no_host'; } @@ -1174,16 +1372,39 @@ sub authenticate { } if ($answer eq 'non_authorized') { &logthis("User $uname at $udom rejected by $uhome"); - return 'no_host'; + return 'no_host'; } &logthis("User $uname at $udom threw error $answer when checking authentication mechanism"); return 'no_host'; } +sub can_switchserver { + my ($udom,$home) = @_; + my ($canswitch,@intdoms); + my $internet_names = &get_internet_names($home); + if (ref($internet_names) eq 'ARRAY') { + @intdoms = @{$internet_names}; + } + my $uint_dom = &internet_dom(&domain($udom,'primary')); + if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) { + $canswitch = 1; + } else { + my $serverhomeID = &get_server_homeID(&hostname($home)); + my $serverhomedom = &host_domain($serverhomeID); + my %defdomdefaults = &get_domain_defaults($serverhomedom); + my %udomdefaults = &get_domain_defaults($udom); + my $remoterev = &get_server_loncaparev('',$home); + $canswitch = &can_host_session($udom,$home,$remoterev, + $udomdefaults{'remotesessions'}, + $defdomdefaults{'hostedsessions'}); + } + return $canswitch; +} + sub can_host_session { my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_; my $canhost = 1; - my $host_idn = &Apache::lonnet::internet_dom($lonhost); + my $host_idn = &internet_dom($lonhost); if (ref($remotesessions) eq 'HASH') { if (ref($remotesessions->{'excludedomain'}) eq 'ARRAY') { if (grep(/^\Q$host_idn\E$/,@{$remotesessions->{'excludedomain'}})) { @@ -1219,8 +1440,8 @@ sub can_host_session { } if ($canhost) { if (ref($hostedsessions) eq 'HASH') { - my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); - my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); + my $uprimary_id = &domain($udom,'primary'); + my $uint_dom = &internet_dom($uprimary_id); if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { if (($uint_dom ne '') && (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) { @@ -1254,6 +1475,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); @@ -1303,7 +1533,7 @@ sub spares_for_offload { } else { my $cachetime = 60*60*24; my %domconfig = - &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use); + &get_dom('configuration',['usersessions'],$dom_in_use); if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') { @@ -1352,12 +1582,12 @@ sub get_lonbalancer_config { sub check_loadbalancing { my ($uname,$udom,$caller) = @_; my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver); + $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers); my $lonhost = $perlvar{'lonHostID'}; my @hosts = ¤t_machine_ids(); - my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); - my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); - my $intdom = &Apache::lonnet::internet_dom($lonhost); + my $uprimary_id = &domain($udom,'primary'); + my $uintdom = &internet_dom($uprimary_id); + my $intdom = &internet_dom($lonhost); my $serverhomedom = &host_domain($lonhost); my $domneedscache; my $cachetime = 60*60*24; @@ -1371,7 +1601,7 @@ sub check_loadbalancing { my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use); unless (defined($cached)) { my %domconfig = - &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); + &get_dom('configuration',['loadbalancing'],$dom_in_use); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); } else { @@ -1379,7 +1609,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') { @@ -1432,7 +1662,7 @@ sub check_loadbalancing { ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom); unless (defined($cached)) { my %domconfig = - &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); + &get_dom('configuration',['loadbalancing'],$serverhomedom); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); } else { @@ -1440,7 +1670,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') { @@ -1472,7 +1702,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') { @@ -1506,20 +1736,22 @@ sub check_loadbalancing { $is_balancer = 0; if ($uname ne '' && $udom ne '') { if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - - &appenv({'user.loadbalexempt' => $lonhost, + &appenv({'user.loadbalexempt' => $lonhost, 'user.loadbalcheck.time' => time}); } } } } } - return ($is_balancer,$otherserver); + if (($is_balancer) && (!$homeintdom)) { + undef($setcookie); + } + return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers); } sub check_balancer_result { my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules); + my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers); if (ref($result) eq 'HASH') { if ($result->{'lonhost'} ne '') { my $currbalancer = $result->{'lonhost'}; @@ -1528,19 +1760,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 { @@ -1558,7 +1795,7 @@ sub get_loadbalancer_targets { } } elsif ($rule_in_effect eq 'externalbalancer') { my %domconfig = - &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); + &get_dom('configuration',['loadbalancing'],$udom); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { if ($domconfig{'loadbalancing'}{'lonhost'} ne '') { if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') { @@ -1618,19 +1855,19 @@ sub trusted_domains { if (&domain($calldom) eq '') { return ($trusted,$untrusted); } - unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { + unless ($cmdtype =~ /^(content|shared|enroll|coaurem|othcoau|domroles|catalog|reqcrs|msg)$/) { return ($trusted,$untrusted); } my $callprimary = &domain($calldom,'primary'); - my $intcalldom = &Apache::lonnet::internet_dom($callprimary); + my $intcalldom = &internet_dom($callprimary); if ($intcalldom eq '') { return ($trusted,$untrusted); } - my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); + my ($trustconfig,$cached)=&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); + my %domconfig = &get_dom('configuration',['trust'],$calldom); + &do_cache_new('trust',$calldom,$domconfig{'trust'},3600); $trustconfig = $domconfig{'trust'}; } if (ref($trustconfig)) { @@ -1640,6 +1877,7 @@ sub trusted_domains { map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; } if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { + $possinc{$intcalldom} = 1; map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; } } @@ -1674,12 +1912,12 @@ sub trusted_domains { } foreach my $exc (@allexc) { if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { - $untrusted = $doms_by_intdom{$exc}; + push(@{$untrusted},@{$doms_by_intdom{$exc}}); } } foreach my $inc (@allinc) { if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { - $trusted = $doms_by_intdom{$inc}; + push(@{$trusted},@{$doms_by_intdom{$inc}}); } } } @@ -1932,7 +2170,7 @@ sub dump_dom { # ------------------------------------------ get items from domain db files sub get_dom { - my ($namespace,$storearr,$udom,$uhome)=@_; + my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_; return if ($udom eq 'public'); my $items=''; foreach my $item (@$storearr) { @@ -1956,10 +2194,15 @@ sub get_dom { } if ($udom && $uhome && ($uhome ne 'no_host')) { my $rep; - if ($namespace =~ /^enc/) { - $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); + if (grep { $_ eq $uhome } ¤t_machine_ids()) { + # domain information is hosted on this machine + $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items"); } else { - $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + if ($encrypt) { + $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); + } else { + $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + } } my %returnhash; if ($rep eq '' || $rep =~ /^error: 2 /) { @@ -1983,7 +2226,7 @@ sub get_dom { # -------------------------------------------- put items in domain db files sub put_dom { - my ($namespace,$storehash,$udom,$uhome)=@_; + my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_; if (!$udom) { $udom=$env{'user.domain'}; if (defined(&domain($udom,'primary'))) { @@ -2004,7 +2247,7 @@ sub put_dom { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; - if ($namespace =~ /^enc/) { + if ($encrypt) { return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); } else { return &reply("putdom:$udom:$namespace:$items",$uhome); @@ -2042,6 +2285,57 @@ sub del_dom { } } +sub store_dom { + my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_; + $$storehash{'ip'}=&get_requestor_ip(); + $$storehash{'host'}=$perlvar{'lonHostID'}; + my $namevalue=''; + foreach my $key (keys(%{$storehash})) { + $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; + } + $namevalue=~s/\&$//; + if (grep { $_ eq $home } current_machine_ids()) { + return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue"); + } else { + if ($namespace eq 'private') { + return 'refused'; + } elsif ($encrypt) { + return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home); + } else { + return reply("storedom:$dom:$namespace:$id:$namevalue",$home); + } + } +} + +sub restore_dom { + my ($id,$namespace,$dom,$home,$encrypt) = @_; + my $answer; + if (grep { $_ eq $home } current_machine_ids()) { + $answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id"); + } elsif ($namespace ne 'private') { + if ($encrypt) { + $answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home); + } else { + $answer=&reply("restoredom:$dom:$namespace:$id",$home); + } + } + my %returnhash=(); + unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') || + ($answer eq 'unknown_cmd') || ($answer eq 'rejected')) { + foreach my $line (split(/\&/,$answer)) { + my ($name,$value)=split(/\=/,$line); + $returnhash{&unescape($name)}=&thaw_unescape($value); + } + my $version; + for ($version=1;$version<=$returnhash{'version'};$version++) { + foreach my $item (split(/\:/,$returnhash{$version.':keys'})) { + $returnhash{$item}=$returnhash{$version.':'.$item}; + } + } + } + return %returnhash; +} + # ----------------------------------construct domainconfig user for a domain sub get_domainconfiguser { my ($udom) = @_; @@ -2051,7 +2345,7 @@ sub get_domainconfiguser { sub retrieve_inst_usertypes { my ($udom) = @_; my (%returnhash,@order); - my %domdefs = &Apache::lonnet::get_domain_defaults($udom); + my %domdefs = &get_domain_defaults($udom); if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) { return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'}); @@ -2084,7 +2378,7 @@ sub retrieve_inst_usertypes { sub is_domainimage { my ($url) = @_; - if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) { + if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo|login)/+[^/]-) { if (&domain($1) ne '') { return '1'; } @@ -2101,7 +2395,7 @@ sub inst_directory_query { if ($homeserver ne '') { unless ($homeserver eq $perlvar{'lonHostID'}) { if ($srch->{'srchby'} eq 'email') { - my $lcrev = &get_server_loncaparev(undef,$homeserver); + my $lcrev = &get_server_loncaparev($udom,$homeserver); my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); if (($major eq '' && $minor eq '') || ($major < 2) || (($major == 2) && ($minor < 12))) { @@ -2152,7 +2446,7 @@ sub usersearch { if (&host_domain($tryserver) eq $dom) { unless ($tryserver eq $perlvar{'lonHostID'}) { if ($srch->{'srchby'} eq 'email') { - my $lcrev = &get_server_loncaparev(undef,$tryserver); + my $lcrev = &get_server_loncaparev($dom,$tryserver); my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); next if (($major eq '' && $minor eq '') || ($major < 2) || (($major == 2) && ($minor < 12))); @@ -2322,6 +2616,10 @@ sub inst_rulecheck { $response=&unescape(&reply('instselfcreatecheck:'. &escape($udom).':'.&escape($uname). ':'.$rulestr,$homeserver)); + } elsif ($item eq 'unamemap') { + $response=&unescape(&reply('instunamemapcheck:'. + &escape($udom).':'.&escape($uname). + ':'.$rulestr,$homeserver)); } if ($response ne 'refused') { my @pairs=split(/\&/,$response); @@ -2351,6 +2649,9 @@ sub inst_userrules { } elsif ($check eq 'email') { $response=&reply('instemailrules:'.&escape($udom), $homeserver); + } elsif ($check eq 'unamemap') { + $response=&reply('unamemaprules:'.&escape($udom), + $homeserver); } else { $response=&reply('instuserrules:'.&escape($udom), $homeserver); @@ -2392,12 +2693,14 @@ sub get_domain_defaults { } my %domdefaults; my %domconfig = - &Apache::lonnet::get_dom('configuration',['defaults','quotas', + &get_dom('configuration',['defaults','quotas', 'requestcourses','inststatus', 'coursedefaults','usersessions', 'requestauthor','selfenrollment', 'coursecategories','ssl','autoenroll', - 'trust','helpsettings'],$domain); + 'trust','helpsettings','wafproxy', + 'ltisec','toolsec','domexttool', + 'exttool',],$domain); my @coursetypes = ('official','unofficial','community','textbook','placement'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; @@ -2406,9 +2709,12 @@ 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{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'}; + $domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'}; $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; + $domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -2446,6 +2752,7 @@ sub get_domain_defaults { if (ref($domconfig{'coursedefaults'}) eq 'HASH') { $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'}; $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'}; + $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'}; $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'}; if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') { $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'}; @@ -2465,6 +2772,16 @@ sub get_domain_defaults { $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; } } + if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') { + $domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type}; + } else { + $domdefaults{$type.'domexttool'} = 1; + } + if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') { + $domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type}; + } else { + $domdefaults{$type.'exttool'} = 0; + } } if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { @@ -2478,7 +2795,10 @@ sub get_domain_defaults { } if ($domconfig{'coursedefaults'}{'texengine'}) { $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; - } + } + if (exists($domconfig{'coursedefaults'}{'ltiauth'})) { + $domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'}; + } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -2490,6 +2810,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') { @@ -2522,7 +2845,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'}) { @@ -2550,6 +2873,7 @@ sub get_domain_defaults { } if (ref($domconfig{'autoenroll'}) eq 'HASH') { $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; + $domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'}; } if (ref($domconfig{'helpsettings'}) eq 'HASH') { $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; @@ -2557,12 +2881,102 @@ sub get_domain_defaults { $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; } } + if (ref($domconfig{'wafproxy'}) eq 'HASH') { + foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') { + if ($domconfig{'wafproxy'}{$item}) { + $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item}; + } + } + } + if (ref($domconfig{'ltisec'}) eq 'HASH') { + if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') { + $domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'}; + $domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'}; + $domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'}; + } + if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') { + if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') { + $domdefaults{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'}; + } + } + } + if (ref($domconfig{'toolsec'}) eq 'HASH') { + if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') { + $domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'}; + $domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'}; + } + if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') { + if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') { + $domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'}; + } + } + } &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 = {}; + } + &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 = { + totcodes => $totcodes, + 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 ($cnum,$cdom,$r) = @_; my $chome = &homeserver($cnum,$cdom); my $hostname = &hostname($chome); my $protocol = $protocol{$chome}; @@ -2572,11 +2986,56 @@ sub course_portal_url { if ($domdefaults{'portal_def'}) { $firsturl = $domdefaults{'portal_def'}; } else { + my $alias = &use_proxy_alias($r,$chome); + $hostname = $alias if ($alias ne ''); $firsturl = $protocol.'://'.$hostname; } return $firsturl; } +sub url_prefix { + my ($r,$dom,$home,$context) = @_; + my $prefix; + my %domdefs = &get_domain_defaults($dom); + if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) { + if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) { + $prefix = $1; + } + } + if ($prefix eq '') { + my $hostname = &hostname($home); + my $protocol = $protocol{$home}; + $protocol = 'http' if ($protocol{$home} ne 'https'); + my $alias = &use_proxy_alias($r,$home); + $hostname = $alias if ($alias ne ''); + $prefix = $protocol.'://'.$hostname; + } + return $prefix; +} + +# --------------------------------------------- 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 { @@ -2725,7 +3184,7 @@ sub courseid_to_courseurl { return "/$cdom/$cnum"; } - my %courseinfo=&Apache::lonnet::coursedescription($courseid); + my %courseinfo=&coursedescription($courseid); if (exists($courseinfo{'num'})) { return "/$courseinfo{'domain'}/$courseinfo{'num'}"; } @@ -2923,14 +3382,14 @@ sub userenvironment { # ---------------------------------------------------------- Get a studentphoto sub studentphoto { my ($udom,$unam,$ext) = @_; - my $home=&Apache::lonnet::homeserver($unam,$udom); + my $home=&homeserver($unam,$udom); if (defined($env{'request.course.id'})) { if ($env{'course.'.$env{'request.course.id'}.'.internal.showphoto'}) { if ($udom eq $env{'course.'.$env{'request.course.id'}.'.domain'}) { return(&retrievestudentphoto($udom,$unam,$ext)); } else { my ($result,$perm_reqd)= - &Apache::lonnet::auto_photo_permission($unam,$udom); + &auto_photo_permission($unam,$udom); if ($result eq 'ok') { if (!($perm_reqd eq 'yes')) { return(&retrievestudentphoto($udom,$unam,$ext)); @@ -2940,7 +3399,7 @@ sub studentphoto { } } else { my ($result,$perm_reqd) = - &Apache::lonnet::auto_photo_permission($unam,$udom); + &auto_photo_permission($unam,$udom); if ($result eq 'ok') { if (!($perm_reqd eq 'yes')) { return(&retrievestudentphoto($udom,$unam,$ext)); @@ -2952,14 +3411,14 @@ sub studentphoto { sub retrievestudentphoto { my ($udom,$unam,$ext,$type) = @_; - my $home=&Apache::lonnet::homeserver($unam,$udom); - my $ret=&Apache::lonnet::reply("studentphoto:$udom:$unam:$ext:$type",$home); + my $home=&homeserver($unam,$udom); + my $ret=&reply("studentphoto:$udom:$unam:$ext:$type",$home); if ($ret eq 'ok') { my $url="/uploaded/$udom/$unam/internal/studentphoto.$ext"; if ($type eq 'thumbnail') { $url="/uploaded/$udom/$unam/internal/studentphoto_tn.$ext"; } - my $tokenurl=&Apache::lonnet::tokenwrapper($url); + my $tokenurl=&tokenwrapper($url); return $tokenurl; } else { if ($type eq 'thumbnail') { @@ -3119,6 +3578,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)=@_; @@ -3147,11 +3632,29 @@ sub ssi_body { # --------------------------------------------------------- Server Side Include sub absolute_url { - my ($host_name) = @_; + my ($host_name,$unalias,$keep_proto) = @_; my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://'); if ($host_name eq '') { $host_name = $ENV{'SERVER_NAME'}; } + if ($unalias) { + my $alias = &get_proxy_alias(); + if ($alias eq $host_name) { + my $lonhost = $perlvar{'lonHostID'}; + my $hostname = &hostname($lonhost); + my $lcproto; + if (($keep_proto) || ($hostname eq '')) { + $lcproto = $protocol; + } else { + $lcproto = $protocol{$lonhost}; + $lcproto = 'http' if ($lcproto ne 'https'); + $lcproto .= '://'; + } + unless ($hostname eq '') { + return $lcproto.$hostname; + } + } + } return $protocol.$host_name; } @@ -3168,12 +3671,13 @@ sub absolute_url { sub ssi { my ($fn,%form)=@_; - my $request; + my ($host,$request,$response); + $host = &absolute_url('',1); $form{'no_update_last_known'}=1; &Apache::lonenc::check_encrypt(\$fn); if (%form) { - $request=new HTTP::Request('POST',&absolute_url().$fn); + $request=new HTTP::Request('POST',$host.$fn); $request->content(join('&',map { my $name = escape($_); "$name=" . ( ref($form{$_}) eq 'ARRAY' @@ -3181,12 +3685,22 @@ sub ssi { : &escape($form{$_}) ); } keys(%form))); } else { - $request=new HTTP::Request('GET',&absolute_url().$fn); + $request=new HTTP::Request('GET',$host.$fn); } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $lonhost = $perlvar{'lonHostID'}; - my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar); + my $islocal; + if (($env{'request.course.id'}) && + ($form{'grade_courseid'} eq $env{'request.course.id'}) && + ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && + ($form{'grade_symb'} ne '') && + (&allowed('mgr',$env{'request.course.id'}. + ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { + $islocal = 1; + } + $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, + '','','',$islocal); if (wantarray) { return ($response->content, $response); @@ -3224,10 +3738,10 @@ sub remove_stale_resfile { (grep { $_ eq $homeserver } ¤t_machine_ids())) { my $fname = &filelocation('',$url); if (-e $fname) { - my $protocol = $protocol{$homeserver}; - $protocol = 'http' if ($protocol ne 'https'); my $hostname = &hostname($homeserver); if ($hostname) { + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); my $uri = &declutter($url); my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); @@ -3254,12 +3768,18 @@ sub remove_stale_resfile { $stale = 1; } if ($stale) { - unlink($fname); - if ($uri!~/\.meta$/) { - unlink($fname.'.meta'); + if (unlink($fname)) { + if ($uri!~/\.meta$/) { + if (-e $fname.'.meta') { + unlink($fname.'.meta'); + } + } + my $unsubresult = &unsubscribe($fname); + unless ($unsubresult eq 'ok') { + &logthis("no unsub of $fname from $homeserver, reason: $unsubresult"); + } + $removed = 1; } - &reply("unsub:$fname",$homeserver); - $removed = 1; } } } @@ -3327,7 +3847,7 @@ sub can_edit_resource { } if ($env{'request.course.id'}) { - my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'}); + my $crsedit = &allowed('mdc',$env{'request.course.id'}); if ($group ne '') { # if this is a group homepage or group bulletin board, check group privs my $allowed = 0; @@ -3356,14 +3876,19 @@ sub can_edit_resource { } } else { if ($resurl =~ m{^/?adm/viewclasslist$}) { - unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) { + unless (&allowed('opa',$env{'request.course.id'})) { return; } } elsif (!$crsedit) { + if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) { # # No edit allowed where CC has switched to student role. # - return; + return; + } elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) || + ($resurl =~ m{^/res/lib/templates/})) { + return; + } } } } @@ -3389,7 +3914,7 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif (($resurl ne '') && (&is_on_map($resurl))) { + } elsif (($resurl ne '') && (&is_on_map($resurl))) { if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3409,6 +3934,18 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; + } elsif (($resurl =~ m{^/ext/}) && ($symb ne '')) { + my ($map,$id,$res) = &decode_symb($symb); + if ($map =~ /\.page$/) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + $cfile = $map; + } else { + $forceedit = 1; + $cfile = '/adm/wrapper'.$resurl; + } + } } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3434,13 +3971,13 @@ sub can_edit_resource { $cfile = $template; } } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + } else { + $forceedit = 1; + } + $cfile = $resurl; } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -3703,13 +4240,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 @@ -3752,17 +4297,20 @@ 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, toollogo 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 -# $dsetudom - domain for permanaent storage of uploaded file +# $destuname - username for permanent storage of uploaded file +# $destudom - domain for permanaent storage of uploaded file # $thumbwidth - width (pixels) of thumbnail to make for uploaded image # $thumbheight - height (pixels) of thumbnail to make for uploaded image # $resizewidth - width (pixels) to which to resize uploaded image @@ -3781,6 +4329,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')) || @@ -3948,7 +4504,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); @@ -3957,15 +4513,31 @@ 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 $makethumb; my $thumbsize = $thumbwidth.'x'.$thumbheight; - my @args = ('convert','-sample',$thumbsize,$input,$output); - system({$args[0]} @args); - if (-e $filepath.'/'.'tn-'.$file) { - $fetchthumb = 1; + if ($context eq 'toollogo') { + my ($fullwidth,$fullheight) = &check_dimensions($input); + if ($fullwidth ne '' && $fullheight ne '') { + if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) { + $makethumb = 1; + } + } + } else { + $makethumb = 1; + } + if ($makethumb) { + my @args = ('convert','-sample',$thumbsize,$input,$output); + system({$args[0]} @args); + if (-e $filepath.'/'.'tn-'.$file) { + $fetchthumb = 1; + } } } @@ -4197,6 +4769,271 @@ sub embedded_dependency { return; } +sub check_dimensions { + my ($inputfile) = @_; + my ($fullwidth,$fullheight); + if (($inputfile =~ m|^[/\w.\-]+$|) && (-e $inputfile)) { + my $mm = new File::MMagic; + my $mime_type = $mm->checktype_filename($inputfile); + if ($mime_type =~ m{^image/}) { + if (open(PIPE,"identify $inputfile 2>&1 |")) { + my $imageinfo = ; + if (!close(PIPE)) { + &Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile"); + } + chomp($imageinfo); + my ($fullsize) = + ($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/); + if ($fullsize) { + ($fullwidth,$fullheight) = split(/x/,$fullsize); + } + } + } + } + return ($fullwidth,$fullheight); +} + +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,-1); + 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); + } + } + chomp(@lines); + } + return @lines; +} + sub removeuploadedurl { my ($url)=@_; my (undef,undef,$udom,$uname,$fname)=split('/',$url,5); @@ -4314,6 +5151,29 @@ sub flushcourselogs { if (! defined($dom) || $dom eq '' || ! defined($name) || $name eq '') { my $cid = $env{'request.course.id'}; +# +# FIXME 11/29/2021 +# Typo in rev. 1.458 (2003/12/09)?? +# These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'} +# +# While these ramain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'} +# $dom and $name will always be null, so the &inc() call will default to storing this data +# in a nohist_accesscount.db file for the user rather than the course. +# +# That said there is a lot of noise in the data being stored. +# So counts for prtspool/ and adm/ etc. are recorded. +# +# A review of which items ending '___count' are written to %accesshash should likely be +# made before deciding whether to set these to 'course.' instead of 'request.' +# +# Under the current scheme each user receives a nohist_accesscount.db file listing +# accesses for things which are not published resources, regardless of course, and +# there is not a nohist_accesscount.db file in a course, which might log accesses from +# anyone in the course for things which are not published resources. +# +# For an author, nohist_accesscount.db ends up having records for other items +# mixed up with the legitimate access counts for the author's published resources. +# $dom = $env{'request.'.$cid.'.domain'}; $name = $env{'request.'.$cid.'.num'}; } @@ -4340,7 +5200,7 @@ sub flushcourselogs { foreach my $entry (keys(%userrolehash)) { my ($role,$uname,$udom,$runame,$rudom,$rsec)= split(/\:/,$entry); - if (&Apache::lonnet::put('nohist_userroles', + if (&put('nohist_userroles', { $role.':'.$uname.':'.$udom.':'.$rsec => $userrolehash{$entry} }, $rudom,$runame) eq 'ok') { delete $userrolehash{$entry}; @@ -4423,7 +5283,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}; + } } } } @@ -4535,7 +5399,7 @@ sub domainrolelog { my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; if ($area =~ m{^/($match_domain)/$}) { my $cdom = $1; - my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom); + my $domconfiguser = &get_domainconfiguser($cdom); my $namespace = 'rolelog'; my %storehash = ( role => $trole, @@ -4766,8 +5630,8 @@ sub get_my_adhocroles { } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { $cdom = $1; $cnum = $2; - %info = &Apache::lonnet::get('environment',['internal.coursecode'], - $cdom,$cnum); + %info = &get('environment',['internal.coursecode'], + $cdom,$cnum); } if (($info{'internal.coursecode'} ne '') && ($checkreg)) { my $user = $env{'user.name'}.':'.$env{'user.domain'}; @@ -5094,7 +5958,7 @@ sub extract_lastaccess { sub dcmailput { my ($domain,$msgid,$message,$server)=@_; - my $status = &Apache::lonnet::critical( + my $status = &critical( 'dcmailput:'.$domain.':'.&escape($msgid).'='. &escape($message),$server); return $status; @@ -5220,7 +6084,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); @@ -5236,6 +6105,9 @@ sub set_first_access { 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; } @@ -5497,7 +6369,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; @@ -5534,7 +6406,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; @@ -5578,7 +6450,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; @@ -5634,7 +6506,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=''; @@ -5670,7 +6542,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=''; @@ -6088,31 +6960,31 @@ sub course_adhocrole_privs { $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; + 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 { @@ -6376,7 +7248,8 @@ sub set_adhoc_privileges { my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); &appenv(\%userroles,[$role,'cm']); &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); - unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { + unless (($caller eq 'constructaccess' && $env{'request.course.id'}) || + ($caller eq 'tiny')) { &appenv( {'request.role' => $spec, 'request.role.domain' => $dcdom, 'request.course.sec' => $sec, @@ -6452,7 +7325,7 @@ sub unserialize { # see Lond::dump_with_regexp # if $escapedkeys hash keys won't get unescaped. sub dump { - my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_; + my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -6468,7 +7341,12 @@ sub dump { $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); return %{unserialize($reply, $escapedkeys)}; } - my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + my $rep; + if ($encrypt) { + $rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + } else { + $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); + } my @pairs=split(/\&/,$rep); my %returnhash=(); if (!($rep =~ /^error/ )) { @@ -6615,7 +7493,7 @@ sub inc { # --------------------------------------------------------------- put interface sub put { - my ($namespace,$storehash,$udomain,$uname)=@_; + my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -6624,7 +7502,11 @@ sub put { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; - return &reply("put:$udomain:$uname:$namespace:$items",$uhome); + if ($encrypt) { + return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome); + } else { + return &reply("put:$udomain:$uname:$namespace:$items",$uhome); + } } # ------------------------------------------------------------ newput interface @@ -6664,11 +7546,12 @@ 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'}); - &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue); + &courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue); } if ($reply eq 'unknown_cmd') { # gfall back to way things use to be done @@ -6818,16 +7701,16 @@ sub get_timebased_id { my $tries = 0; # attempt to get lock on nohist_$namespace file - my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); + my $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); while (($gotlock ne 'ok') && $tries <$locktries) { $tries ++; sleep 1; - $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); + $gotlock = &newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); } # attempt to get unique identifier, based on current timestamp if ($gotlock eq 'ok') { - my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); + my %inuse = &dump('nohist_'.$namespace,$cdom,$cnum,$prefix); my $id = time; $newid = $id; if ($idtype eq 'addcode') { @@ -6848,7 +7731,7 @@ sub get_timebased_id { my %new_item = ( $prefix."\0".$newid => $who, ); - my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item, + my $putresult = &put('nohist_'.$namespace,\%new_item, $cdom,$cnum); if ($putresult ne 'ok') { undef($newid); @@ -6888,15 +7771,15 @@ sub portfolio_access { if ($result) { my %setters; if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { - my ($startblock,$endblock) = - &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom); - if ($startblock && $endblock) { + my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = + &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom); + if (($startblock && $endblock) || ($by_ip)) { return 'B'; } } else { - my ($startblock,$endblock) = - &Apache::loncommon::blockcheck(\%setters,'port'); - if ($startblock && $endblock) { + my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = + &Apache::loncommon::blockcheck(\%setters,'port',$clientip); + if (($startblock && $endblock) || ($by_ip)) { return 'B'; } } @@ -7137,6 +8020,17 @@ sub is_portfolio_file { return; } +sub is_coursetool_logo { + my ($uri) = @_; + if ($env{'request.course.id'}) { + my $courseurl = &courseid_to_courseurl($env{'request.course.id'}); + if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) { + return 1; + } + } + return; +} + sub usertools_access { my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_; my ($access,%tools); @@ -7162,6 +8056,7 @@ sub usertools_access { blog => 1, webdav => 1, portfolio => 1, + timezone => 1, ); } return if (!defined($tools{$tool})); @@ -7286,7 +8181,7 @@ sub is_course_owner { if ($env{'course.'.$cdom.'_'.$cnum.'.internal.courseowner'} eq $uname.':'.$udom) { return 1; } else { - my %courseinfo = &Apache::lonnet::coursedescription($cdom.'/'.$cnum); + my %courseinfo = &coursedescription($cdom.'/'.$cnum); if ($courseinfo{'internal.courseowner'} eq $uname.':'.$udom) { return 1; } @@ -7357,6 +8252,7 @@ sub check_can_request { my @options = ('approval','validate','autolimit'); my $optregex = join('|',@options); if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { + my %willtrust; foreach my $type (@{$types}) { if (&usertools_access($uname,$udom,$type,undef, 'requestcourses')) { @@ -7376,12 +8272,17 @@ sub check_can_request { if (ref($request_domains) eq 'HASH') { my ($otherdom) = ($item =~ /^($match_domain):($optregex)(=?\d*)$/); if ($otherdom ne '') { - if (ref($request_domains->{$type}) eq 'ARRAY') { - unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) { + unless (exists($willtrust{$otherdom})) { + $willtrust{$otherdom} = &will_trust('reqcrs',$env{'user.domain'},$otherdom); + } + if ($willtrust{$otherdom}) { + if (ref($request_domains->{$type}) eq 'ARRAY') { + unless (grep(/^\Q$otherdom\E$/,@{$request_domains->{$type}})) { + push(@{$request_domains->{$type}},$otherdom); + } + } else { push(@{$request_domains->{$type}},$otherdom); } - } else { - push(@{$request_domains->{$type}},$otherdom); } } } @@ -7451,14 +8352,14 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; + my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; $uri=&declutter($uri); if ($priv eq 'evb') { -# Evade communication block restrictions for specified role in a course +# Evade communication block restrictions for specified role in a course or domain if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) { return $1; } else { @@ -7468,7 +8369,7 @@ sub allowed { if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources - if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$})) || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) && ($priv eq 'bre')) { return 'F'; @@ -7479,9 +8380,9 @@ sub allowed { if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) { my %setters; - my ($startblock,$endblock) = - &Apache::loncommon::blockcheck(\%setters,'port'); - if ($startblock && $endblock) { + my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = + &Apache::loncommon::blockcheck(\%setters,'port',$clientip); + if (($startblock && $endblock) || ($by_ip)) { return 'B'; } else { return 'F'; @@ -7577,8 +8478,8 @@ sub allowed { my $adom = $1; foreach my $key (keys(%env)) { if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) { - my ($start,$end) = split('.',$env{$key}); - if (($now >= $start) && (!$end || $end < $now)) { + my ($start,$end) = split(/\./,$env{$key}); + if (($now >= $start) && (!$end || $end > $now)) { $ownaccess = 1; last; } @@ -7590,8 +8491,8 @@ sub allowed { foreach my $role ('ca','aa') { if ($env{"user.role.$role./$adom/$aname"}) { my ($start,$end) = - split('.',$env{"user.role.$role./$adom/$aname"}); - if (($now >= $start) && (!$end || $end < $now)) { + split(/\./,$env{"user.role.$role./$adom/$aname"}); + if (($now >= $start) && (!$end || $end > $now)) { $ownaccess = 1; last; } @@ -7636,8 +8537,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; + } } } @@ -7650,10 +8577,16 @@ sub allowed { if ($env{'user.priv.'.$env{'request.role'}.'./'} =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; - if ($noblockcheck) { + my $deeplinkblock; + unless ($nodeeplinkcheck) { + $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 { @@ -7670,10 +8603,16 @@ sub allowed { $refuri=&declutter($refuri); my ($match) = &is_on_map($refuri); if ($match) { - if ($noblockcheck) { + my $deeplinkblock; + unless ($nodeeplinkcheck) { + $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 { @@ -7720,6 +8659,22 @@ sub allowed { if ($env{'request.course.id'}) { + if ($priv eq 'bre') { + if (&is_coursetool_logo($uri)) { + return 'F'; + } + } + +# 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'}; @@ -7733,10 +8688,16 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - if ($noblockcheck) { + my $deeplinkblock; + unless ($nodeeplinkcheck) { + $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 { @@ -7749,7 +8710,7 @@ sub allowed { $checkreferer=0; } } - + if ($checkreferer) { my $refuri=$env{'httpref.'.$orguri}; unless ($refuri) { @@ -7775,10 +8736,16 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - if ($noblockcheck) { + my $deeplinkblock; + unless ($nodeeplinkcheck) { + $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 { @@ -7820,16 +8787,48 @@ sub allowed { # # Possibly locked functionality, check all courses +# In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma. # Locks might take effect only after 10 minutes cache expiration for other -# courses, and 2 minutes for current course +# courses, and 2 minutes for current course, in which user has st or ta role +# which is neither expired nor a future role (unless current course). - my $envkey; + my ($needlockcheck,$now,$crsonly); if ($thisallowed=~/L/) { - foreach $envkey (keys(%env)) { + $now = time; + if ($priv eq 'bre') { + if ($uri ne '') { + if ($orguri =~ m{^/+res/}) { + if ($uri =~ m{^lib/templates/}) { + if ($env{'request.course.id'}) { + $crsonly = 1; + $needlockcheck = 1; + } + } else { + $needlockcheck = 1; + } + } elsif ($env{'request.course.id'}) { + my ($crsdom,$crsnum) = split('_',$env{'request.course.id'}); + if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) || + ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) { + $crsonly = 1; + } + $needlockcheck = 1; + } + } + } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) { + $needlockcheck = 1; + } + } + if ($needlockcheck) { + foreach my $envkey (keys(%env)) { if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) { my $courseid=$2; my $roleid=$1.'.'.$2; $courseid=~s/^\///; + unless ($env{'request.role'} eq $roleid) { + my ($start,$end) = split(/\./,$env{$envkey}); + next unless (($now >= $start) && (!$end || $end > $now)); + } my $expiretime=600; if ($env{'request.role'} eq $roleid) { $expiretime=120; @@ -7852,7 +8851,7 @@ sub allowed { } if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/) || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) { - if ($env{'priv.'.$priv.'.lock.expire'}>time) { + if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) { &log($env{'user.domain'},$env{'user.name'}, $env{'user.home'}, 'Locked by priv: '.$priv.' for '.$uri.' due to '. @@ -7864,7 +8863,7 @@ sub allowed { } } } - + # # Rest of the restrictions depend on selected course # @@ -7923,6 +8922,17 @@ sub allowed { } } +# Restricted for deeplinked session? + + if ($env{'request.deeplink.login'}) { + if ($env{'acc.deeplinkout'} && !$nodeeplinkout) { + if (!$symb) { $symb=&symbread($uri,1); } + if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) { + return ''; + } + } + } + # Restricted by state or randomout? if ($thisallowed=~/X/) { @@ -7943,6 +8953,8 @@ sub allowed { return 'A'; } elsif ($thisallowed eq 'B') { return 'B'; + } elsif ($thisallowed eq 'D') { + return 'D'; } return 'F'; } @@ -7973,13 +8985,8 @@ sub constructaccess { if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) { return ($ownername,$ownerdomain,$ownerhome); } - } else { -# Co-author for this? - if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || - exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { - $ownerhome = &homeserver($ownername,$ownerdomain); - return ($ownername,$ownerdomain,$ownerhome); - } + } elsif (&is_course($ownerdomain,$ownername)) { +# Course Authoring Space? if ($env{'request.course.id'}) { if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) && ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) { @@ -7989,6 +8996,14 @@ sub constructaccess { } } } + return ''; + } else { +# Co-author for this? + if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || + exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { + $ownerhome = &homeserver($ownername,$ownerdomain); + return ($ownername,$ownerdomain,$ownerhome); + } } # We don't have any access right now. If we are not possibly going to do anything about this, @@ -8031,22 +9046,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 { @@ -8062,7 +9082,7 @@ sub get_comm_blocks { if ((defined($cached)) && (ref($blocksref) eq 'HASH')) { %commblocks = %{$blocksref}; } else { - %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum); + %commblocks = &dump('comm_block',$cdom,$cnum); my $cachetime = 600; &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime); } @@ -8073,7 +9093,11 @@ sub get_commblock_resources { my ($blocks) = @_; my %blockers = (); return %blockers unless ($env{'request.course.id'}); - return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); + my $courseurl = &courseid_to_courseurl($env{'request.course.id'}); + if ($env{'request.course.sec'}) { + $courseurl .= '/'.$env{'request.course.sec'}; + } + return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/); my %commblocks; if (ref($blocks) eq 'HASH') { %commblocks = %{$blocks}; @@ -8105,10 +9129,9 @@ sub get_commblock_resources { } } elsif ($block =~ /^firstaccess____(.+)$/) { my $item = $1; - my @to_test; if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { - my @interval; + my (@interval,$mapname); my $type = 'map'; if ($item eq 'course') { $type = 'course'; @@ -8117,27 +9140,11 @@ sub get_commblock_resources { if ($item =~ /___\d+___/) { $type = 'resource'; @interval=&EXT("resource.0.interval",$item); - if (ref($navmap)) { - my $res = $navmap->getBySymb($item); - push(@to_test,$res); - } } else { - my $mapsymb = &symbread($item,1); - 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; - } - } - } - } + $mapname = &deversion($item); + if (ref($navmap)) { + my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval'); + @interval = ($timelimit,'map'); } } } @@ -8155,10 +9162,37 @@ sub get_commblock_resources { my $timesup = $first_access+$timelimit; if ($timesup > $now) { my $activeblock; - foreach my $res (@to_test) { - if ($res->answerable()) { - $activeblock = 1; - last; + if ($type eq 'resource') { + if (ref($navmap)) { + my $res = $navmap->getBySymb($item); + if ($res->answerable()) { + $activeblock = 1; + } + } + } elsif ($type eq 'map') { + my $mapsymb = &symbread($mapname,1); + if (($mapsymb) && (ref($navmap))) { + my $mapres = $navmap->getBySymb($mapsymb); + 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()) { + $activeblock = 1; + last; + } + } + } + } + } } } if ($activeblock) { @@ -8184,17 +9218,27 @@ 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 $courseurl = &courseid_to_courseurl($env{'request.course.id'}); + if ($env{'request.course.sec'}) { + $courseurl .= '/'.$env{'request.course.sec'}; + } + return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/); + 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); @@ -8205,35 +9249,120 @@ 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 ($deeplink_symb,$allow); + if ($env{'request.deeplink.login'}) { + $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom); + } + foreach my $symb (@symbs) { + last if ($allow); + my $deeplink = &EXT("resource.0.deeplink",$symb); + if ($deeplink eq '') { + $allow = 1; + } else { + my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink); + if ($state ne 'only') { + $allow = 1; + } else { + my $check_deeplink_entry; + if ($protect ne 'none') { + my ($acctype,$item) = split(/:/,$protect); + if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) { + if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) { + $check_deeplink_entry = 1 + } + } elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) { + if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) { + $check_deeplink_entry = 1; + } + } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) { + if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) { + $check_deeplink_entry = 1; + } + } + } + if (($protect eq 'none') || ($check_deeplink_entry)) { + if ($scope eq 'res') { + if ($symb eq $deeplink_symb) { + $allow = 1; + } + } elsif (($scope eq 'map') || ($scope eq 'rec')) { + my ($map_from_symb,$map_from_login); + $map_from_symb = &deversion((&decode_symb($symb))[0]); + if ($deeplink_symb =~ /\.(page|sequence)$/) { + $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]); + } else { + $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]); + } + if (($map_from_symb) && ($map_from_login)) { + if ($map_from_symb eq $map_from_login) { + $allow = 1; + } elsif ($scope eq 'rec') { + my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'}); + if (grep(/^\Q$map_from_login\E$/,@recurseup)) { + $allow = 1; + } + } + } + } + } + } + } + } + return if ($allow); + return 1; } # -------------------------------- Deversion and split uri into path an filename @@ -8497,7 +9626,7 @@ sub fetch_enrollment_query { } sub get_query_reply { - my ($queryid,$sleep,$loopmax) = @_;; + my ($queryid,$sleep,$loopmax) = @_; if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) { $sleep = 0.2; } @@ -8630,6 +9759,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); @@ -8901,6 +10049,38 @@ sub auto_validate_class_sec { return $response; } +sub auto_instsec_reformat { + my ($cdom,$action,$instsecref) = @_; + return unless(($action eq 'clutter') || ($action eq 'declutter')); + my @homeservers; + if (defined(&domain($cdom,'primary'))) { + push(@homeservers,&domain($cdom,'primary')); + } else { + my %servers = &get_servers($cdom,'library'); + foreach my $tryserver (keys(%servers)) { + if (!grep(/^\Q$tryserver\E$/,@homeservers)) { + push(@homeservers,$tryserver); + } + } + } + my $response; + my %reformatted = %{$instsecref}; + foreach my $server (@homeservers) { + if (ref($instsecref) eq 'HASH') { + my $info = &freeze_escape($instsecref); + my $response=&reply('autoinstsecreformat:'.$cdom.':'. + $action.':'.$info,$server); + next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/); + my @items = split(/&/,$response); + foreach my $item (@items) { + my ($key,$value) = split(/=/,$item); + $reformatted{&unescape($key)} = &thaw_unescape($value); + } + } + } + return %reformatted; +} + sub auto_validate_instclasses { my ($cdom,$cnum,$owners,$classesref) = @_; my ($homeserver,%validations); @@ -9239,7 +10419,7 @@ sub assignrole { if ($role =~ /^cr\//) { my $cwosec=$url; $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/; - unless (&allowed('ccr',$cwosec)) { + if ((!&allowed('ccr',$cwosec)) && (!&allowed('ccr',$udom))) { my $refused = 1; if ($context eq 'requestcourses') { if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { @@ -9287,7 +10467,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')); @@ -9310,7 +10490,7 @@ sub assignrole { } 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'})) { + } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { $refused = ''; } } elsif ($context eq 'requestcourses') { @@ -9451,11 +10631,23 @@ sub autoupdate_coowners { if ($domdesign{$cdom.'.autoassign.co-owners'}) { my %coursehash = &coursedescription($cdom.'_'.$cnum); my $instcode = $coursehash{'internal.coursecode'}; + my $xlists = $coursehash{'internal.crosslistings'}; if ($instcode ne '') { if (($start && $start <= $now) && ($end == 0) || ($end > $now)) { unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) { my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners); my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom); + unless ($result eq 'valid') { + if ($xlists ne '') { + foreach my $xlist (split(',',$xlists)) { + my ($inst_crosslist,$lcsec) = split(':',$xlist); + $result = + &auto_validate_inst_crosslist($cnum,$cdom,$instcode, + $inst_crosslist,$uname.':'.$udom); + last if ($result eq 'valid'); + } + } + } if ($result eq 'valid') { if ($coursehash{'internal.co-owners'}) { foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) { @@ -9468,18 +10660,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'}, @@ -9518,10 +10708,10 @@ sub store_coowners { } if (($putresult eq 'ok') || ($delresult eq 'ok')) { my %crsinfo = - &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); + &courseiddump($cdom,'.',1,'.','.',$cnum,undef,undef,'.'); if (ref($crsinfo{$cid}) eq 'HASH') { $crsinfo{$cid}{'co-owners'} = \@newcoowners; - my $cidput = &Apache::lonnet::courseidput($cdom,\%crsinfo,$chome,'notime'); + my $cidput = &courseidput($cdom,\%crsinfo,$chome,'notime'); } } } @@ -9532,19 +10722,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; @@ -9723,7 +10929,7 @@ sub modifyuser { return 'error: '.$reply; } if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) { - &Apache::lonnet::devalidate_cache_new('emailscache',$uname.':'.$udom); + &devalidate_cache_new('emailscache',$uname.':'.$udom); } my $sqlresult = &update_allusers_table($uname,$udom,\%names); &devalidate_cache_new('namescache',$uname.':'.$udom); @@ -9803,7 +11009,7 @@ sub modify_student_enrollment { } my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); my $user = "$uname:$udom"; - my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); + my %old_entry = &get('classlist',[$user],$cdom,$cnum); my $reply=cput('classlist', {$user => join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, @@ -9873,14 +11079,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; } @@ -9932,7 +11143,7 @@ sub createcourse { } } my %host_servers = - &Apache::lonnet::get_servers($udom,'library'); + &get_servers($udom,'library'); unless ($host_servers{$course_server}) { return 'error: invalid home server for course: '.$course_server; } @@ -10030,12 +11241,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; } @@ -10052,7 +11276,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=''; @@ -10887,14 +12111,20 @@ sub stat_file { # or corresponding Published Resource Space, and populate the hash ref: # $dirhashref with URLs of all directories, and if $filehashref hash # ref arg is provided, the URLs of any files, excluding versioned, .meta, -# or .rights files in resource space, and .meta, .save, .log, and .bak -# files in Authoring Space. +# or .rights files in resource space, and .meta, .save, .log, .bak and +# .rights files in Authoring Space. # # Inputs: # # $is_home - true if current server is home server for user's space -# $context - either: priv, or res respectively for Authoring or Resource Space. -# $docroot - Document root (i.e., /home/httpd/html +# $recurse - if true will also traverse subdirectories recursively +# $include - reference to hash containing allowed file extensions. If provided, +# files which do not have a matching extension will be ignored. +# $exclude - reference to hash containing excluded file extensions. If provided, +# files which have a matching extension will be ignored. +# $nonemptydir - if true, will only populate $fileshashref hash entry for a particular +# directory with first file found (with acceptable extension). +# $addtopdir - if true, set $dirhashref->{'/'} = 1 # $toppath - Top level directory (i.e., /res/$dom/$uname or /priv/$dom/$uname # $relpath - Current path (relative to top level). # $dirhashref - reference to hash to populate with URLs of directories (Required) @@ -10911,39 +12141,61 @@ sub stat_file { # sub recursedirs { - my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_; + my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_; return unless (ref($dirhashref) eq 'HASH'); + my $docroot = $perlvar{'lonDocRoot'}; my $currpath = $docroot.$toppath; - if ($relpath) { + if ($relpath ne '') { $currpath .= "/$relpath"; } - my $savefile; + my ($savefile,$checkinc,$checkexc); if (ref($filehashref)) { $savefile = 1; } + if (ref($include) eq 'HASH') { + $checkinc = 1; + } + if (ref($exclude) eq 'HASH') { + $checkexc = 1; + } if ($is_home) { - if (opendir(my $dirh,$currpath)) { + if ((-e $currpath) && (opendir(my $dirh,$currpath))) { + my $filecount = 0; foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) { next if ($item eq ''); if (-d "$currpath/$item") { my $newpath; - if ($relpath) { + if ($relpath ne '') { $newpath = "$relpath/$item"; } else { $newpath = $item; } $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; - &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); - } elsif ($savefile) { - if ($context eq 'priv') { - unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { - $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; + if ($recurse) { + &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref); + } + } elsif (($savefile) || ($relpath eq '')) { + next if ($nonemptydir && $filecount); + if ($checkinc || $checkexc) { + my ($extension) = ($item =~ /\.(\w+)$/); + if ($checkinc) { + next unless ($extension && $include->{$extension}); } - } else { - unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) { + if ($checkexc) { + next if ($extension && $exclude->{$extension}); + } + } + if (($relpath eq '') && (!exists($dirhashref->{'/'}))) { + $dirhashref->{'/'} = 1; + } + if ($savefile) { + if ($relpath eq '') { + $filehashref->{'/'}{$item} = 1; + } else { $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; } } + $filecount ++; } } closedir($dirh); @@ -10954,6 +12206,7 @@ sub recursedirs { my @dir_lines; my $dirptr=16384; if (ref($dirlistref) eq 'ARRAY') { + my $filecount = 0; foreach my $dir_line (sort { my ($afile)=split('&',$a,2); @@ -10969,28 +12222,57 @@ sub recursedirs { if ($relpath) { $newpath = "$relpath/$item"; } else { - $relpath = '/'; $newpath = $item; } $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1; - &recursedirs($is_home,$context,$docroot,$toppath,$newpath,$dirhashref,$filehashref); - } elsif ($savefile) { - if ($context eq 'priv') { - unless ($item =~ /\.(meta|save|log|bak|DS_Store)$/) { - $filehashref->{$relpath}{$item} = 1; + if ($recurse) { + &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref); + } + } elsif (($savefile) || ($relpath eq '')) { + next if ($nonemptydir && $filecount); + if ($checkinc || $checkexc) { + my $extension; + if ($checkinc) { + next unless ($extension && $include->{$extension}); } - } else { - unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) { - $filehashref->{$relpath}{$item} = 1; + if ($checkexc) { + next if ($extension && $exclude->{$extension}); } } + if (($relpath eq '') && (!exists($dirhashref->{'/'}))) { + $dirhashref->{'/'} = 1; + } + if ($savefile) { + if ($relpath eq '') { + $filehashref->{'/'}{$item} = 1; + } else { + $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; + } + } + $filecount ++; } } } } + if ($addtopdir) { + if (($relpath eq '') && (!exists($dirhashref->{'/'}))) { + $dirhashref->{'/'} = 1; + } + } return; } +sub priv_exclude { + return { + meta => 1, + save => 1, + log => 1, + bak => 1, + rights => 1, + DS_Store => 1, + }; +} + # -------------------------------------------------------- Value of a Condition # gets the value of a specific preevaluated condition @@ -11204,15 +12486,24 @@ sub resdata { sub get_domain_lti { my ($cdom,$context) = @_; - my ($name,%lti); + my ($name,$cachename,%lti); if ($context eq 'consumer') { $name = 'ltitools'; } elsif ($context eq 'provider') { $name = 'lti'; + } elsif ($context eq 'linkprot') { + $name = 'ltisec'; } else { return %lti; } - my ($result,$cached)=&is_cached_new($name,$cdom); + + if ($context eq 'linkprot') { + $cachename = $context; + } else { + $cachename = $name; + } + + my ($result,$cached)=&is_cached_new($cachename,$cdom); if (defined($cached)) { if (ref($result) eq 'HASH') { %lti = %{$result}; @@ -11220,43 +12511,154 @@ sub get_domain_lti { } else { 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}; + if ($context eq 'linkprot') { + if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') { + %lti = %{$domconfig{$name}{'linkprot'}}; + } + } else { + %lti = %{$domconfig{$name}}; + } + if (($context eq 'consumer') && (keys(%lti))) { + my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1); + 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($name,$cdom,\%lti,$cachetime); + &do_cache_new($cachename,$cdom,\%lti,$cachetime); } return %lti; } -sub get_numsuppfiles { - my ($cnum,$cdom,$ignorecache)=@_; +sub get_course_lti { + my ($cnum,$cdom) = @_; + my $hashid=$cdom.'_'.$cnum; + my %courselti; + my ($result,$cached)=&is_cached_new('courselti',$hashid); + if (defined($cached)) { + if (ref($result) eq 'HASH') { + %courselti = %{$result}; + } + } else { + %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1); + my $cachetime = 24*60*60; + &do_cache_new('courselti',$hashid,\%courselti,$cachetime); + } + return %courselti; +} + +sub courselti_itemid { + my ($cnum,$cdom,$url,$method,$params,$context) = @_; + my ($chome,$itemid); + $chome = &homeserver($cnum,$cdom); + return if ($chome eq 'no_host'); + if (ref($params) eq 'HASH') { + my $rep; + if (grep { $_ eq $chome } current_machine_ids()) { + $rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'}); + } else { + my $escurl = &escape($url); + my $escmethod = &escape($method); + my $items = &freeze_escape($params); + $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome); + } + unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || + ($rep eq 'unknown_cmd')) { + $itemid = $rep; + } + } + return $itemid; +} + +sub domainlti_itemid { + my ($cdom,$url,$method,$params,$context) = @_; + my ($primary_id,$itemid); + $primary_id = &domain($cdom,'primary'); + return if ($primary_id eq ''); + if (ref($params) eq 'HASH') { + my $rep; + if (grep { $_ eq $primary_id } current_machine_ids()) { + $rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'}); + } else { + my $cnum = ''; + my $escurl = &escape($url); + my $escmethod = &escape($method); + my $items = &freeze_escape($params); + $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id); + } + unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || + ($rep eq 'unknown_cmd')) { + $itemid = $rep; + } + } + return $itemid; +} + +sub count_supptools { + my ($cnum,$cdom,$ignorecache,$reload)=@_; my $hashid=$cnum.':'.$cdom; - my ($suppcount,$cached); + my ($numexttools,$cached); unless ($ignorecache) { - ($suppcount,$cached) = &is_cached_new('suppcount',$hashid); + ($numexttools,$cached) = &is_cached_new('supptools',$hashid); } unless (defined($cached)) { my $chome=&homeserver($cnum,$cdom); + $numexttools = 0; unless ($chome eq 'no_host') { - ($suppcount,my $supptools,my $errors) = (0,0,0); - my $suppmap = 'supplemental.sequence'; - ($suppcount,$supptools,$errors) = - &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount, - $supptools,$errors); + my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload); + if (ref($supplemental) eq 'HASH') { + if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) { + foreach my $key (keys(%{$supplemental->{'ids'}})) { + if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { + $numexttools ++; + } + } + } + } } - &do_cache_new('suppcount',$hashid,$suppcount,600); + &do_cache_new('supptools',$hashid,$numexttools,600); } - return $suppcount; + return $numexttools; +} + +sub has_unhidden_suppfiles { + my ($cnum,$cdom,$ignorecache,$possdel)=@_; + my $hashid=$cnum.':'.$cdom; + my ($showsupp,$cached); + unless ($ignorecache) { + ($showsupp,$cached) = &is_cached_new('showsupp',$hashid); + } + unless (defined($cached)) { + my $chome=&homeserver($cnum,$cdom); + unless ($chome eq 'no_host') { + my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel); + if (ref($supplemental) eq 'HASH') { + if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) { + foreach my $key (keys(%{$supplemental->{'ids'}})) { + next if ($key =~ /\.sequence$/); + if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') { + foreach my $id (@{$supplemental->{'ids'}->{$key}}) { + unless ($supplemental->{'hidden'}->{$id}) { + $showsupp = 1; + last; + } + } + } + last if ($showsupp); + } + } + } + } + &do_cache_new('showsupp',$hashid,$showsupp,600); + } + return $showsupp; } # @@ -11297,7 +12699,7 @@ sub EXT_cache_set { # --------------------------------------------------------- Value of a Variable sub EXT { - my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_; + my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid,$recurseupref)=@_; unless ($varname) { return ''; } #get real user name/domain, courseid and symb my $courseid; @@ -11329,7 +12731,7 @@ sub EXT { if ( (defined($Apache::lonhomework::parsing_a_problem) || defined($Apache::lonhomework::parsing_a_task)) && - ($symbparm eq &symbread()) ) { + ($symbparm eq &symbread()) ) { # if we are in the middle of processing the resource the # get the value we are planning on committing if (defined($Apache::lonhomework::results{$qualifierrest})) { @@ -11451,6 +12853,10 @@ sub EXT { } my ($section, $group, @groups, @recurseup, $recursed); + if (ref($recurseupref) eq 'ARRAY') { + @recurseup = @{$recurseupref}; + $recursed = 1; + } my ($courselevelm,$courseleveli,$courselevel,$mapp); if (($courseid eq '') && ($cid)) { $courseid = $cid; @@ -11599,6 +13005,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 ''; } @@ -12324,13 +13734,13 @@ sub get_reservable_slots { sub get_course_slots { my ($cnum,$cdom) = @_; my $hashid=$cnum.':'.$cdom; - my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid); + my ($result,$cached) = &is_cached_new('allslots',$hashid); if (defined($cached)) { if (ref($result) eq 'HASH') { return %{$result}; } } else { - my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); + my %slots=&dump('slots',$cdom,$cnum); my ($tmp) = keys(%slots); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { &do_cache_new('allslots',$hashid,\%slots,600); @@ -12376,11 +13786,68 @@ sub get_coursechange { } sub devalidate_coursechange_cache { - my ($cnum,$cdom)=@_; - my $hashid=$cnum.':'.$cdom; + my ($cdom,$cnum)=@_; + my $hashid=$cdom.'_'.$cnum; &devalidate_cache_new('crschange',$hashid); } +sub get_suppchange { + my ($cdom,$cnum) = @_; + if ($cdom eq '' || $cnum eq '') { + return unless ($env{'request.course.id'}); + $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + } + my $hashid=$cdom.'_'.$cnum; + my ($change,$cached)=&is_cached_new('suppchange',$hashid); + if ((defined($cached)) && ($change ne '')) { + return $change; + } else { + my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum); + if ($crshash{'internal.supplementalchange'} eq '') { + $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'}; + if ($change eq '') { + %crshash = &get('environment',['internal.created'],$cdom,$cnum); + $change = $crshash{'internal.created'}; + } + } else { + $change = $crshash{'internal.supplementalchange'}; + } + my $cachetime = 600; + &do_cache_new('suppchange',$hashid,$change,$cachetime); + } + return $change; +} + +sub devalidate_suppchange_cache { + my ($cdom,$cnum)=@_; + my $hashid=$cdom.'_'.$cnum; + &devalidate_cache_new('suppchange',$hashid); +} + +sub update_supp_caches { + my ($cdom,$cnum) = @_; + my %servers = &internet_dom_servers($cdom); + my @ids=¤t_machine_ids(); + foreach my $server (keys(%servers)) { + next if (grep(/^\Q$server\E$/,@ids)); + my $hashid=$cnum.':'.$cdom; + my $cachekey = &escape('showsupp').':'.&escape($hashid); + &remote_devalidate_cache($server,[$cachekey]); + } + &has_unhidden_suppfiles($cnum,$cdom,1,1); + &count_supptools($cnum,$cdom,1); + my $now = time; + if ($env{'request.course.id'} eq $cdom.'_'.$cnum) { + &Apache::lonnet::appenv({'request.course.suppupdated' => $now}); + } + &put('environment',{'internal.supplementalchange' => $now}, + $cdom,$cnum); + &Apache::lonnet::appenv( + {'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now}); + &do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600); +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -12427,18 +13894,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)}; } @@ -12538,19 +14003,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'}; } @@ -12566,17 +14034,18 @@ sub symbread { my %bighash; my $syval=''; if (($env{'request.course.fn'}) && ($thisfn)) { - my $targetfn = $thisfn; - if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) { - $targetfn = 'adm/wrapper/'.$thisfn; - } - 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{$thisfn}; + untie(%hash); + } + if ($syval && $checkforblock) { + my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck); + if (@blockers) { + $syval=''; + } + } } # ---------------------------------------------------------- There was an entry if ($syval) { @@ -12609,13 +14078,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')) { @@ -12634,12 +14108,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++; } @@ -12647,6 +14122,11 @@ sub symbread { $syval = $poss_syval; $realpossible++; } + if ($syval) { + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + } } } } @@ -13184,9 +14664,10 @@ sub repcopy_userfile { my $request; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); + $request=new HTTP::Request('GET',$protocol.'://'.$hostname.'/raw/'.$uri); my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); # did it work? if ($response->is_error()) { @@ -13210,9 +14691,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 { @@ -13228,9 +14710,10 @@ sub getuploaded { my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_; $uri=~s/^\///; my $homeserver = &homeserver($cnum,$cdom); + my $hostname = &hostname($homeserver); my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); - $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; + $uri = $protocol.'://'.$hostname.'/raw/'.$uri; my $request=new HTTP::Request($reqtype,$uri); my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); $$rtncode = $response->code; @@ -13362,10 +14845,15 @@ sub machine_ids { sub additional_machine_domains { my @domains; - open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); - while( my $line = <$fh>) { - $line =~ s/\s//g; - push(@domains,$line); + if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") { + if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) { + while (my $line = <$fh>) { + chomp($line); + $line =~ s/\s//g; + push(@domains,$line); + } + close($fh); + } } return @domains; } @@ -13383,6 +14871,292 @@ sub default_login_domain { return $domain; } +sub shared_institution { + my ($dom,$lonhost) = @_; + if ($lonhost eq '') { + $lonhost = $perlvar{'lonHostID'}; + } + my $same_intdom; + my $hostintdom = &internet_dom($lonhost); + if ($hostintdom ne '') { + my %iphost = &get_iphost(); + my $primary_id = &domain($dom,'primary'); + my $primary_ip = &get_host_ip($primary_id); + if (ref($iphost{$primary_ip}) eq 'ARRAY') { + foreach my $id (@{$iphost{$primary_ip}}) { + my $intdom = &internet_dom($id); + if ($intdom eq $hostintdom) { + $same_intdom = 1; + last; + } + } + } + } + return $same_intdom; +} + +sub uses_sts { + my ($ignore_cache) = @_; + my $lonhost = $perlvar{'lonHostID'}; + my $hostname = &hostname($lonhost); + my $sts_on; + if ($protocol{$lonhost} eq 'https') { + my $cachetime = 12*3600; + if (!$ignore_cache) { + ($sts_on,my $cached)=&is_cached_new('stspolicy',$lonhost); + if (defined($cached)) { + return $sts_on; + } + } + my $url = $protocol{$lonhost}.'://'.$hostname.'/index.html'; + my $request=new HTTP::Request('HEAD',$url); + my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,'','','',1); + if ($response->is_success) { + my $has_sts = $response->header('Strict-Transport-Security'); + if ($has_sts eq '') { + $sts_on = 0; + } else { + if ($has_sts =~ /\Qmax-age=\E(\d+)/) { + my $maxage = $1; + if ($maxage) { + $sts_on = 1; + } else { + $sts_on = 0; + } + } else { + $sts_on = 0; + } + } + return &do_cache_new('stspolicy',$lonhost,$sts_on,$cachetime); + } + } + return; +} + +sub waf_allssl { + my ($host_name) = @_; + my $alias = &get_proxy_alias(); + if ($host_name eq '') { + $host_name = $ENV{'SERVER_NAME'}; + } + if (($host_name ne '') && ($alias eq $host_name)) { + my $serverhomedom = &host_domain($perlvar{'lonHostID'}); + my %defdomdefaults = &get_domain_defaults($serverhomedom); + if ($defdomdefaults{'waf_sslopt'}) { + return $defdomdefaults{'waf_sslopt'}; + } + } + return; +} + +sub get_requestor_ip { + my ($r,$nolookup,$noproxy) = @_; + my $from_ip; + if (ref($r)) { + if ($r->can('useragent_ip')) { + if ($noproxy && $r->can('client_ip')) { + $from_ip = $r->client_ip(); + } else { + $from_ip = $r->useragent_ip(); + } + } elsif ($r->connection->can('remote_ip')) { + $from_ip = $r->connection->remote_ip(); + } else { + $from_ip = $r->get_remote_host($nolookup); + } + } else { + $from_ip = $ENV{'REMOTE_ADDR'}; + } + return $from_ip if ($noproxy); + # Who controls proxy settings for server + my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'}; + my $proxyinfo = &get_proxy_settings($dom_in_use); + if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) { + if ($proxyinfo->{'vpnint'}) { + if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) { + return $from_ip; + } + } + if ($proxyinfo->{'trusted'}) { + if (&ip_match($from_ip,$proxyinfo->{'trusted'})) { + my $ipheader = $proxyinfo->{'ipheader'}; + my ($ip,$xfor); + if (ref($r)) { + if ($ipheader) { + $ip = $r->headers_in->{$ipheader}; + } + $xfor = $r->headers_in->{'X-Forwarded-For'}; + } else { + if ($ipheader) { + $ip = $ENV{'HTTP_'.uc($ipheader)}; + } + $xfor = $ENV{'HTTP_X_FORWARDED_FOR'}; + } + if (($ip eq '') && ($xfor ne '')) { + foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) { + unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) { + $ip = $poss_ip; + last; + } + } + } + if ($ip ne '') { + return $ip; + } + } + } + } + return $from_ip; +} + +sub get_proxy_settings { + my ($dom_in_use) = @_; + my %domdefaults = &get_domain_defaults($dom_in_use); + my $proxyinfo = { + ipheader => $domdefaults{'waf_ipheader'}, + trusted => $domdefaults{'waf_trusted'}, + vpnint => $domdefaults{'waf_vpnint'}, + vpnext => $domdefaults{'waf_vpnext'}, + sslopt => $domdefaults{'waf_sslopt'}, + }; + return $proxyinfo; +} + +sub ip_match { + my ($ip,$pattern_str) = @_; + $ip=Net::CIDR::cidrvalidate($ip); + if ($ip) { + return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str)); + } + return; +} + +sub get_proxy_alias { + my ($lonid) = @_; + if ($lonid eq '') { + $lonid = $perlvar{'lonHostID'}; + } + if (!defined(&hostname($lonid))) { + return; + } + if ($lonid ne '') { + my ($alias,$cached) = &is_cached_new('proxyalias',$lonid); + if ($cached) { + return $alias; + } + my $dom = &host_domain($lonid); + if ($dom ne '') { + my $cachetime = 60*60*24; + my %domconfig = + &get_dom('configuration',['wafproxy'],$dom); + if (ref($domconfig{'wafproxy'}) eq 'HASH') { + if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') { + $alias = $domconfig{'wafproxy'}{'alias'}{$lonid}; + } + } + return &do_cache_new('proxyalias',$lonid,$alias,$cachetime); + } + } + return; +} + +sub use_proxy_alias { + my ($r,$lonid) = @_; + my $alias = &get_proxy_alias($lonid); + if ($alias) { + my $dom = &host_domain($lonid); + if ($dom ne '') { + my $proxyinfo = &get_proxy_settings($dom); + my ($vpnint,$remote_ip); + if (ref($proxyinfo) eq 'HASH') { + $vpnint = $proxyinfo->{'vpnint'}; + if ($vpnint) { + $remote_ip = &get_requestor_ip($r,1,1); + } + } + unless ($vpnint && &ip_match($remote_ip,$vpnint)) { + return $alias; + } + } + } + return; +} + +sub alias_sso { + my ($lonid) = @_; + if ($lonid eq '') { + $lonid = $perlvar{'lonHostID'}; + } + if (!defined(&hostname($lonid))) { + return; + } + if ($lonid ne '') { + my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid); + if ($cached) { + return $use_alias; + } + my $dom = &host_domain($lonid); + if ($dom ne '') { + my $cachetime = 60*60*24; + my %domconfig = + &get_dom('configuration',['wafproxy'],$dom); + if (ref($domconfig{'wafproxy'}) eq 'HASH') { + if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') { + $use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid}; + } + } + return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime); + } + } + return; +} + +sub get_saml_landing { + my ($lonid) = @_; + if ($lonid eq '') { + my $defdom = &default_login_domain(); + my @hosts = ¤t_machine_ids(); + if (@hosts > 1) { + foreach my $hostid (@hosts) { + if (&host_domain($hostid) eq $defdom) { + $lonid = $hostid; + last; + } + } + } else { + $lonid = $perlvar{'lonHostID'}; + } + if ($lonid) { + unless (&host_domain($lonid) eq $defdom) { + return; + } + } else { + return; + } + } elsif (!defined(&hostname($lonid))) { + return; + } + my ($landing,$cached) = &is_cached_new('samllanding',$lonid); + if ($cached) { + return $landing; + } + my $dom = &host_domain($lonid); + if ($dom ne '') { + my $cachetime = 60*60*24; + my %domconfig = + &get_dom('configuration',['login'],$dom); + if (ref($domconfig{'login'}) eq 'HASH') { + if (ref($domconfig{'login'}{'saml'}) eq 'HASH') { + if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') { + $landing = 1; + } + } + } + return &do_cache_new('samllanding',$lonid,$landing,$cachetime); + } + return; +} + # ------------------------------------------------------------- Declutters URLs sub declutter { @@ -13500,7 +15274,7 @@ sub get_dns { my ($url,$func,$ignore_cache,$nocache,$hashref) = @_; if (!$ignore_cache) { my ($content,$cached)= - &Apache::lonnet::is_cached_new('dns',$url); + &is_cached_new('dns',$url); if ($cached) { &$func($content,$hashref); return; @@ -13508,35 +15282,70 @@ 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 $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); - 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; + my ($contents,@content); + if ($dns eq Sys::Hostname::FQDN::fqdn()) { + my $command = (split('/',$url))[3]; + my ($dir,$file) = &parse_getdns_url($command,$url); + delete($alldns{$dns}); + next if (($dir eq '') || ($file eq '')); + if (open(my $config,'<',"$dir/$file")) { + @content = <$config>; + close($config); + } + if ($url eq '/adm/dns/loncapaCRL') { + $contents = join('',@content); + } + } else { + my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); + delete($alldns{$dns}); + next if ($response->is_error()); + if ($url eq '/adm/dns/loncapaCRL') { + $contents = $response->content; + } else { + @content = split("\n",$response->content); + } + } + if ($url eq '/adm/dns/loncapaCRL') { + return &$func($contents); + } else { + 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; } @@ -13544,7 +15353,7 @@ sub get_dns { sub parse_dns_checksums_tab { my ($lines,$hashref) = @_; my $lonhost = $perlvar{'lonHostID'}; - my $machine_dom = &Apache::lonnet::host_domain($lonhost); + my $machine_dom = &host_domain($lonhost); my $loncaparev = &get_server_loncaparev($machine_dom); my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; my $webconfdir = '/etc/httpd/conf'; @@ -13588,7 +15397,7 @@ sub parse_dns_checksums_tab { sub fetch_dns_checksums { my %checksums; - my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); + my $machine_dom = &host_domain($perlvar{'lonHostID'}); my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'}); my ($release,$timestamp) = split(/\-/,$loncaparev); &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1, @@ -13596,6 +15405,97 @@ 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 ($content) = @_; + my ($msg,$hadchanges); + if ($content ne '') { + my $now = time; + my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'}; + my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp'; + if (open(my $fh,'>',"$tmpcrl")) { + print $fh $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); +} + +sub parse_getdns_url { + my ($command,$url) = @_; + my $dir = $perlvar{'lonTabDir'}; + my $file; + if ($command eq 'hosts') { + $file = 'dns_hosts.tab'; + } elsif ($command eq 'domain') { + $file = 'dns_domain.tab'; + } elsif ($command eq 'checksums') { + my $version = (split('/',$url))[4]; + $file = "dns_checksums/$version.tab", + } elsif ($command eq 'loncapaCRL') { + $dir = $perlvar{'lonCertificateDirectory'}; + $file = $perlvar{'lonnetCertRevocationList'}; + } + return ($dir,$file); +} + # ------------------------------------------------------------ Read domain file { my $loaded; @@ -13885,7 +15785,7 @@ sub fetch_dns_checksums { return %iphost; } my ($ip_info,$cached)= - &Apache::lonnet::is_cached_new('iphost','iphost'); + &is_cached_new('iphost','iphost'); if ($cached) { %iphost = %{$ip_info->[0]}; %name_to_ip = %{$ip_info->[1]}; @@ -13897,7 +15797,7 @@ sub fetch_dns_checksums { # get yesterday's info for fallback my %old_name_to_ip; my ($ip_info,$cached)= - &Apache::lonnet::is_cached_new('iphost','iphost'); + &is_cached_new('iphost','iphost'); if ($cached) { %old_name_to_ip = %{$ip_info->[1]}; } @@ -13964,7 +15864,7 @@ sub fetch_dns_checksums { my ($lonid) = @_; return if ($lonid eq ''); my ($idnref,$cached)= - &Apache::lonnet::is_cached_new('internetnames',$lonid); + &is_cached_new('internetnames',$lonid); if ($cached) { return $idnref; } @@ -14162,6 +16062,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, }); @@ -14501,6 +16411,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 * @@ -14793,10 +16704,6 @@ data base, returning a hash that is keye values that are the resource value. I believe that the timestamps and versions are also returned. -get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's -supplemental content area. This routine caches the number of files for -10 minutes. - =back =head2 Course Modification @@ -14831,6 +16738,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 @@ -15528,6 +17517,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 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.