--- loncom/lonnet/perl/lonnet.pm 2016/01/31 21:25:57 1.1300 +++ loncom/lonnet/perl/lonnet.pm 2018/11/25 02:27:04 1.1390 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1300 2016/01/31 21:25:57 raeburn Exp $ +# $Id: lonnet.pm,v 1.1390 2018/11/25 02:27:04 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,10 +71,9 @@ delayed. package Apache::lonnet; use strict; -use LWP::UserAgent(); use HTTP::Date; use Image::Magick; - +use CGI::Cookie; use Encode; @@ -101,6 +100,7 @@ use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; use LONCAPA::Lond; +use LONCAPA::LWPReq; use File::Copy; @@ -146,7 +146,7 @@ our @EXPORT = qw(%env); sub logtouch { my $execdir=$perlvar{'lonDaemons'}; unless (-e "$execdir/logs/lonnet.log") { - open(my $fh,">>$execdir/logs/lonnet.log"); + open(my $fh,">>","$execdir/logs/lonnet.log"); close $fh; } my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3]; @@ -158,7 +158,7 @@ sub logthis { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - if (open(my $fh,">>$execdir/logs/lonnet.log")) { + if (open(my $fh,">>","$execdir/logs/lonnet.log")) { my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string. print $fh $logstring; close($fh); @@ -171,7 +171,7 @@ sub logperm { my $execdir=$perlvar{'lonDaemons'}; my $now=time; my $local=localtime($now); - if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) { + if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) { print $fh "$now:$message:$local\n"; close($fh); } @@ -229,6 +229,54 @@ sub get_server_distarch { return; } +sub get_servercerts_info { + my ($lonhost,$hostname,$context) = @_; + return if ($lonhost eq ''); + if ($hostname eq '') { + $hostname = &hostname($lonhost); + } + return if ($hostname eq ''); + my ($rep,$uselocal); + if ($context eq 'install') { + $uselocal = 1; + } elsif (grep { $_ eq $lonhost } ¤t_machine_ids()) { + $uselocal = 1; + } + if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) { + my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; + if ($distro eq '') { + $uselocal = 0; + } elsif ($distro =~ /^(?:centos|redhat|scientific)(\d+)$/) { + if ($1 < 6) { + $uselocal = 0; + } + } elsif ($distro =~ /^(?:sles)(\d+)$/) { + if ($1 < 12) { + $uselocal = 0; + } + } + } + if ($uselocal) { + $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname); + } else { + $rep=&reply('servercerts',$lonhost); + } + my ($result,%returnhash); + if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || + ($rep eq 'unknown_cmd')) { + $result = $rep; + } else { + $result = 'ok'; + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + my $what = &unescape($key); + $returnhash{$what}=&thaw_unescape($value); + } + } + return ($result,\%returnhash); +} + sub get_server_loncaparev { my ($dom,$lonhost,$ignore_cache,$caller) = @_; if (defined($lonhost)) { @@ -263,13 +311,11 @@ sub get_server_loncaparev { $answer = &reply('serverloncaparev',$lonhost); if (($answer eq 'unknown_cmd') || ($answer eq 'con_lost')) { if ($caller eq 'loncron') { - my $ua=new LWP::UserAgent; - $ua->timeout(4); my $protocol = $protocol{$lonhost}; $protocol = 'http' if ($protocol ne 'https'); my $url = $protocol.'://'.&hostname($lonhost).'/adm/about.html'; my $request=new HTTP::Request('GET',$url); - my $response=$ua->request($request); + my $response=&LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,4,1); unless ($response->is_error()) { my $content = $response->content; if ($content =~ /

VERSION\:\s*([\w.\-]+)<\/p>/) { @@ -441,7 +487,7 @@ sub reconlonc { &logthis("Trying to reconnect lonc"); my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid"; - if (open(my $fh,"<$loncfile")) { + if (open(my $fh,"<",$loncfile)) { my $loncpid=<$fh>; chomp($loncpid); if (kill 0 => $loncpid) { @@ -481,7 +527,7 @@ sub critical { $dumpcount++; { my $dfh; - if (open($dfh,">$dfilename")) { + if (open($dfh,">",$dfilename)) { print $dfh "$cmd\n"; close($dfh); } @@ -490,7 +536,7 @@ sub critical { my $wcmd=''; { my $dfh; - if (open($dfh,"<$dfilename")) { + if (open($dfh,"<",$dfilename)) { $wcmd=<$dfh>; close($dfh); } @@ -606,22 +652,52 @@ sub transfer_profile_to_env { # ---------------------------------------------------- Check for valid session sub check_for_valid_session { - my ($r,$name,$userhashref) = @_; + my ($r,$name,$userhashref,$domref) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - if ($name eq '') { - $name = 'lonID'; - } - my $lonid=$cookies{$name}; - return undef if (!$lonid); - - my $handle=&LONCAPA::clean_handle($lonid->value); - my $lonidsdir; + my ($lonidsdir,$linkname,$pubname,$secure,$lonid); if ($name eq 'lonDAV') { $lonidsdir=$r->dir_config('lonDAVsessDir'); } else { $lonidsdir=$r->dir_config('lonIDsDir'); + if ($name eq '') { + $name = 'lonID'; + } + } + if ($name eq 'lonID') { + $secure = 'lonSID'; + $linkname = 'lonLinkID'; + $pubname = 'lonPubID'; + if (exists($cookies{$secure})) { + $lonid=$cookies{$secure}; + } elsif (exists($cookies{$name})) { + $lonid=$cookies{$name}; + } elsif (exists($cookies{$linkname})) { + $lonid=$cookies{$linkname}; + } elsif (exists($cookies{$pubname})) { + $lonid=$cookies{$pubname}; + } + } else { + $lonid=$cookies{$name}; + } + return undef if (!$lonid); + + my $handle=&LONCAPA::clean_handle($lonid->value); + if (-l "$lonidsdir/$handle.id") { + my $link = readlink("$lonidsdir/$handle.id"); + if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) { + $handle = $1; + } + } + if (!-e "$lonidsdir/$handle.id") { + if ((ref($domref)) && ($name eq 'lonID') && + ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) { + my ($possuname,$possudom,$possuhome) = ($1,$2,$3); + if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) { + $$domref = $possudom; + } + } + return undef; } - return undef if (!-e "$lonidsdir/$handle.id"); my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); return undef if (!$opened); @@ -641,6 +717,11 @@ sub check_for_valid_session { if (ref($userhashref) eq 'HASH') { $userhashref->{'name'} = $disk_env{'user.name'}; $userhashref->{'domain'} = $disk_env{'user.domain'}; + $userhashref->{'lti'} = $disk_env{'request.lti.login'}; + if ($userhashref->{'lti'}) { + $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'}; + $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'}; + } } return $handle; @@ -691,16 +772,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'; @@ -816,6 +900,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++; } } @@ -944,6 +1029,75 @@ sub find_existing_session { 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 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:$cookie",$balancer); + } + } +} + # -------------------------------- ask if server already has a session for user sub has_user_session { my ($lonid,$udom,$uname) = @_; @@ -979,7 +1133,7 @@ sub choose_server { if (ref($balancers) eq 'HASH') { next if (exists($balancers->{$lonhost})); } - } + } my $loginvia; if ($checkloginvia) { $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; @@ -1007,7 +1161,7 @@ sub choose_server { if ($login_host ne '') { $hostname = &hostname($login_host); } - return ($login_host,$hostname,$portal_path,$isredirect); + return ($login_host,$hostname,$portal_path,$isredirect,$lowest_load); } # --------------------------------------------- Try to change a user's password @@ -1279,16 +1433,16 @@ sub get_lonbalancer_config { } sub check_loadbalancing { - my ($uname,$udom) = @_; + my ($uname,$udom,$caller) = @_; my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver); + $rule_in_effect,$offloadto,$otherserver,$setcookie); 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 $serverhomedom = &host_domain($lonhost); - + my $domneedscache; my $cachetime = 60*60*24; if (($uintdom ne '') && ($uintdom eq $intdom)) { @@ -1303,10 +1457,12 @@ sub check_loadbalancing { &Apache::lonnet::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 { + $domneedscache = $dom_in_use; } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules,$setcookie) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1361,11 +1517,13 @@ sub check_loadbalancing { my %domconfig = &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); if (ref($domconfig{'loadbalancing'}) eq 'HASH') { - $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); + $result = &do_cache_new('loadbalancing',$serverhomedom,$domconfig{'loadbalancing'},$cachetime); + } else { + $domneedscache = $serverhomedom; } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = + ($is_balancer,$currtargets,$currrules,$setcookie) = &check_balancer_result($result,@hosts); if ($is_balancer) { if (ref($currrules) eq 'HASH') { @@ -1381,12 +1539,21 @@ sub check_loadbalancing { $is_balancer = 1; $offloadto = &this_host_spares($dom_in_use); } + unless (defined($cached)) { + $domneedscache = $serverhomedom; + } } } else { if ($perlvar{'lonBalancer'} eq 'yes') { $is_balancer = 1; $offloadto = &this_host_spares($dom_in_use); } + unless (defined($cached)) { + $domneedscache = $serverhomedom; + } + } + if ($domneedscache) { + &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime); } if ($is_balancer) { my $lowest_load = 30000; @@ -1417,23 +1584,27 @@ sub check_loadbalancing { } } } - if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { - $is_balancer = 0; - if ($uname ne '' && $udom ne '') { - if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { - - &appenv({'user.loadbalexempt' => $lonhost, - 'user.loadbalcheck.time' => time}); + unless ($caller eq 'login') { + if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) { + $is_balancer = 0; + if ($uname ne '' && $udom ne '') { + if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { + &appenv({'user.loadbalexempt' => $lonhost, + 'user.loadbalcheck.time' => time}); + } } } } + unless ($homeintdom) { + undef($setcookie); + } } - return ($is_balancer,$otherserver); + return ($is_balancer,$otherserver,$setcookie); } sub check_balancer_result { my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules); + my ($is_balancer,$currtargets,$currrules,$setcookie); if (ref($result) eq 'HASH') { if ($result->{'lonhost'} ne '') { my $currbalancer = $result->{'lonhost'}; @@ -1449,12 +1620,13 @@ sub check_balancer_result { $is_balancer = 1; $currrules = $result->{$key}{'rules'}; $currtargets = $result->{$key}{'targets'}; + $setcookie = $result->{$key}{'cookie'}; last; } } } } - return ($is_balancer,$currtargets,$currrules); + return ($is_balancer,$currtargets,$currrules,$setcookie); } sub get_loadbalancer_targets { @@ -1526,6 +1698,100 @@ sub internet_dom_servers { return %uniqservers; } +sub trusted_domains { + my ($cmdtype,$calldom) = @_; + my ($trusted,$untrusted); + if (&domain($calldom) eq '') { + return ($trusted,$untrusted); + } + unless ($cmdtype =~ /^(content|shared|enroll|coaurem|domroles|catalog|reqcrs|msg)$/) { + return ($trusted,$untrusted); + } + my $callprimary = &domain($calldom,'primary'); + my $intcalldom = &Apache::lonnet::internet_dom($callprimary); + if ($intcalldom eq '') { + return ($trusted,$untrusted); + } + + my ($trustconfig,$cached)=&Apache::lonnet::is_cached_new('trust',$calldom); + unless (defined($cached)) { + my %domconfig = &Apache::lonnet::get_dom('configuration',['trust'],$calldom); + &Apache::lonnet::do_cache_new('trust',$calldom,$domconfig{'trust'},3600); + $trustconfig = $domconfig{'trust'}; + } + if (ref($trustconfig)) { + my (%possexc,%possinc,@allexc,@allinc); + if (ref($trustconfig->{$cmdtype}) eq 'HASH') { + if (ref($trustconfig->{$cmdtype}->{'exc'}) eq 'ARRAY') { + map { $possexc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'exc'}}; + } + if (ref($trustconfig->{$cmdtype}->{'inc'}) eq 'ARRAY') { + map { $possinc{$_} = 1; } @{$trustconfig->{$cmdtype}->{'inc'}}; + } + } + if (keys(%possexc)) { + if (keys(%possinc)) { + foreach my $key (sort(keys(%possexc))) { + next if ($key eq $intcalldom); + unless ($possinc{$key}) { + push(@allexc,$key); + } + } + } else { + @allexc = sort(keys(%possexc)); + } + } + if (keys(%possinc)) { + $possinc{$intcalldom} = 1; + @allinc = sort(keys(%possinc)); + } + if ((@allexc > 0) || (@allinc > 0)) { + my %doms_by_intdom; + my %allintdoms = &all_host_intdom(); + my %alldoms = &all_host_domain(); + foreach my $key (%allintdoms) { + if (ref($doms_by_intdom{$allintdoms{$key}}) eq 'ARRAY') { + unless (grep(/^\Q$alldoms{$key}\E$/,@{$doms_by_intdom{$allintdoms{$key}}})) { + push(@{$doms_by_intdom{$allintdoms{$key}}},$alldoms{$key}); + } + } else { + $doms_by_intdom{$allintdoms{$key}} = [$alldoms{$key}]; + } + } + foreach my $exc (@allexc) { + if (ref($doms_by_intdom{$exc}) eq 'ARRAY') { + $untrusted = $doms_by_intdom{$exc}; + } + } + foreach my $inc (@allinc) { + if (ref($doms_by_intdom{$inc}) eq 'ARRAY') { + $trusted = $doms_by_intdom{$inc}; + } + } + } + } + return ($trusted,$untrusted); +} + +sub will_trust { + my ($cmdtype,$domain,$possdom) = @_; + return 1 if ($domain eq $possdom); + my ($trustedref,$untrustedref) = &trusted_domains($cmdtype,$possdom); + my $willtrust; + if ((ref($trustedref) eq 'ARRAY') && (@{$trustedref} > 0)) { + if (grep(/^\Q$domain\E$/,@{$trustedref})) { + $willtrust = 1; + } + } elsif ((ref($untrustedref) eq 'ARRAY') && (@{$untrustedref} > 0)) { + unless (grep(/^\Q$domain\E$/,@{$untrustedref})) { + $willtrust = 1; + } + } else { + $willtrust = 1; + } + return $willtrust; +} + # ---------------------- Find the homebase for a user from domain's lib servers my %homecache; @@ -1775,7 +2041,12 @@ sub get_dom { } } if ($udom && $uhome && ($uhome ne 'no_host')) { - my $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + my $rep; + if ($namespace =~ /^enc/) { + $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome); + } else { + $rep=&reply("getdom:$udom:$namespace:$items",$uhome); + } my %returnhash; if ($rep eq '' || $rep =~ /^error: 2 /) { return %returnhash; @@ -1819,7 +2090,11 @@ sub put_dom { $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&'; } $items=~s/\&$//; - return &reply("putdom:$udom:$namespace:$items",$uhome); + if ($namespace =~ /^enc/) { + return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome); + } else { + return &reply("putdom:$udom:$namespace:$items",$uhome); + } } else { &logthis("put_dom failed - no homeserver and/or domain"); } @@ -1895,7 +2170,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)/+[^/]-) { if (&domain($1) ne '') { return '1'; } @@ -1910,13 +2185,23 @@ sub inst_directory_query { my $homeserver = &domain($udom,'primary'); my $outcome; if ($homeserver ne '') { + unless ($homeserver eq $perlvar{'lonHostID'}) { + if ($srch->{'srchby'} eq 'email') { + my $lcrev = &get_server_loncaparev(undef,$homeserver); + my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); + if (($major eq '' && $minor eq '') || ($major < 2) || + (($major == 2) && ($minor < 12))) { + return; + } + } + } my $queryid=&reply("querysend:instdirsearch:". &escape($srch->{'srchby'}).':'. &escape($srch->{'srchterm'}).':'. &escape($srch->{'srchtype'}),$homeserver); my $host=&hostname($homeserver); if ($queryid !~/^\Q$host\E\_/) { - &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom); + &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom); return; } my $response = &get_query_reply($queryid); @@ -1951,6 +2236,14 @@ sub usersearch { my $query = 'usersearch'; foreach my $tryserver (keys(%libserv)) { if (&host_domain($tryserver) eq $dom) { + unless ($tryserver eq $perlvar{'lonHostID'}) { + if ($srch->{'srchby'} eq 'email') { + my $lcrev = &get_server_loncaparev(undef,$tryserver); + my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); + next if (($major eq '' && $minor eq '') || ($major < 2) || + (($major == 2) && ($minor < 12))); + } + } my $host=&hostname($tryserver); my $queryid= &reply("querysend:".&escape($query).':'. @@ -2189,8 +2482,9 @@ sub get_domain_defaults { 'requestcourses','inststatus', 'coursedefaults','usersessions', 'requestauthor','selfenrollment', - 'coursecategories'],$domain); - my @coursetypes = ('official','unofficial','community','textbook'); + 'coursecategories','ssl','autoenroll', + 'trust','helpsettings'],$domain); + my @coursetypes = ('official','unofficial','community','textbook','placement'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -2198,6 +2492,9 @@ sub get_domain_defaults { $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; + $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; + $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; + $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -2220,7 +2517,7 @@ sub get_domain_defaults { } } if (ref($domconfig{'requestcourses'}) eq 'HASH') { - foreach my $item ('official','unofficial','community','textbook') { + foreach my $item ('official','unofficial','community','textbook','placement') { $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; } } @@ -2265,6 +2562,9 @@ sub get_domain_defaults { } elsif ($domconfig{'coursedefaults'}{'canclone'}) { $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; } + if ($domconfig{'coursedefaults'}{'texengine'}) { + $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'}; + } } if (ref($domconfig{'usersessions'}) eq 'HASH') { if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') { @@ -2315,10 +2615,54 @@ sub get_domain_defaults { $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; } } + if (ref($domconfig{'ssl'}) eq 'HASH') { + if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { + $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; + } + if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; + } + if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; + } + } + if (ref($domconfig{'trust'}) eq 'HASH') { + my @prefixes = qw(content shared enroll othcoau coaurem domroles catalog reqcrs msg); + foreach my $prefix (@prefixes) { + if (ref($domconfig{'trust'}{$prefix}) eq 'HASH') { + $domdefaults{'trust'.$prefix} = $domconfig{'trust'}{$prefix}; + } + } + } + if (ref($domconfig{'autoenroll'}) eq 'HASH') { + $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; + } + if (ref($domconfig{'helpsettings'}) eq 'HASH') { + $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; + if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { + $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; + } + } &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; } +sub course_portal_url { + my ($cnum,$cdom) = @_; + my $chome = &homeserver($cnum,$cdom); + my $hostname = &hostname($chome); + my $protocol = $protocol{$chome}; + $protocol = 'http' if ($protocol ne 'https'); + my %domdefaults = &get_domain_defaults($cdom); + my $firsturl; + if ($domdefaults{'portal_def'}) { + $firsturl = $domdefaults{'portal_def'}; + } else { + $firsturl = $protocol.'://'.$hostname; + } + return $firsturl; +} + # --------------------------------------------------- Assign a key to a student sub assign_access_key { @@ -2555,21 +2899,23 @@ sub make_key { sub devalidate_cache_new { my ($name,$id,$debug) = @_; if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); } + my $remembered_id=$name.':'.$id; $id=&make_key($name,$id); $memcache->delete($id); - delete($remembered{$id}); - delete($accessed{$id}); + delete($remembered{$remembered_id}); + delete($accessed{$remembered_id}); } sub is_cached_new { my ($name,$id,$debug) = @_; - $id=&make_key($name,$id); - if (exists($remembered{$id})) { - if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); } - $accessed{$id}=[&gettimeofday()]; + my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) whenever possible + if (exists($remembered{$remembered_id})) { + if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); } + $accessed{$remembered_id}=[&gettimeofday()]; $hits++; - return ($remembered{$id},1); + return ($remembered{$remembered_id},1); } + $id=&make_key($name,$id); my $value = $memcache->get($id); if (!(defined($value))) { if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); } @@ -2579,13 +2925,14 @@ sub is_cached_new { if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); } $value=undef; } - &make_room($id,$value,$debug); + &make_room($remembered_id,$value,$debug); if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); } return ($value,1); } sub do_cache_new { my ($name,$id,$value,$time,$debug) = @_; + my $remembered_id=$name.':'.$id; $id=&make_key($name,$id); my $setvalue=$value; if (!defined($setvalue)) { @@ -2601,17 +2948,17 @@ sub do_cache_new { $memcache->disconnect_all(); } # need to make a copy of $value - &make_room($id,$value,$debug); + &make_room($remembered_id,$value,$debug); return $value; } sub make_room { - my ($id,$value,$debug)=@_; + my ($remembered_id,$value,$debug)=@_; - $remembered{$id}= (ref($value)) ? &Storable::dclone($value) + $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value) : $value; if ($to_remember<0) { return; } - $accessed{$id}=[&gettimeofday()]; + $accessed{$remembered_id}=[&gettimeofday()]; if (scalar(keys(%remembered)) <= $to_remember) { return; } my $to_kick; my $max_time=0; @@ -2823,9 +3170,13 @@ sub repcopy { mkdir($path,0777); } } - my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',"$remoteurl"); - my $response=$ua->request($request,$transname); + my $response; + if ($remoteurl =~ m{/raw/}) { + $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',0,1); + } else { + $response=&LONCAPA::LWPReq::makerequest($home,$request,$transname,\%perlvar,'',1); + } if ($response->is_error()) { unlink($transname); my $message=$response->status_line; @@ -2835,7 +3186,12 @@ sub repcopy { } else { if ($remoteurl!~/\.meta$/) { my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta'); - my $mresponse=$ua->request($mrequest,$filename.'.meta'); + my $mresponse; + if ($remoteurl =~ m{/raw/}) { + $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',0,1); + } else { + $mresponse = &LONCAPA::LWPReq::makerequest($home,$mrequest,$filename.'.meta',\%perlvar,'',1); + } if ($mresponse->is_error()) { unlink($filename.'.meta'); &logthis( @@ -2898,7 +3254,6 @@ sub absolute_url { sub ssi { my ($fn,%form)=@_; - my $ua=new LWP::UserAgent; my $request; $form{'no_update_last_known'}=1; @@ -2916,22 +3271,30 @@ sub ssi { } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); - my $response= $ua->request($request); - my $content = $response->content; - + my $lonhost = $perlvar{'lonHostID'}; + my $islocal; + if (($env{'request.course.id'}) && + ($form{'grade_courseid'} eq $env{'request.course.id'}) && + ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') && + ($form{'grade_symb'} ne '') && + (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}. + ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) { + $islocal = 1; + } + my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar, + '','','',$islocal); if (wantarray) { - return ($content, $response); + return ($response->content, $response); } else { - return $content; + return $response->content; } } sub externalssi { my ($url)=@_; - my $ua=new LWP::UserAgent; my $request=new HTTP::Request('GET',$url); - my $response=$ua->request($request); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar); if (wantarray) { return ($response->content, $response); } else { @@ -2939,6 +3302,71 @@ sub externalssi { } } + +# If the local copy of a replicated resource is outdated, trigger a +# connection from the homeserver to flush the delayed queue. If no update +# happens, remove local copies of outdated resource (and corresponding +# metadata file). + +sub remove_stale_resfile { + my ($url) = @_; + my $removed; + if ($url=~m{^/res/($match_domain)/($match_username)/}) { + my $audom = $1; + my $auname = $2; + unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) { + my $homeserver = &homeserver($auname,$audom); + unless (($homeserver eq 'no_host') || + (grep { $_ eq $homeserver } ¤t_machine_ids())) { + my $fname = &filelocation('',$url); + if (-e $fname) { + my $protocol = $protocol{$homeserver}; + $protocol = 'http' if ($protocol ne 'https'); + my $hostname = &hostname($homeserver); + if ($hostname) { + my $uri = &declutter($url); + my $request=new HTTP::Request('HEAD',$protocol.'://'.$hostname.'/raw/'.$uri); + my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,5,0,1); + if ($response->is_success()) { + my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') ); + my $locmodtime = (stat($fname))[9]; + if ($locmodtime < $remmodtime) { + my $stale; + my $answer = &reply('pong',$homeserver); + if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) { + sleep(0.2); + $locmodtime = (stat($fname))[9]; + if ($locmodtime < $remmodtime) { + my $posstransfer = $fname.'.in.transfer'; + if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) { + $removed = 1; + } else { + $stale = 1; + } + } else { + $removed = 1; + } + } else { + $stale = 1; + } + if ($stale) { + unlink($fname); + if ($uri!~/\.meta$/) { + unlink($fname.'.meta'); + } + &reply("unsub:$fname",$homeserver); + $removed = 1; + } + } + } + } + } + } + } + } + return $removed; +} + # -------------------------------- Allow a /uploaded/ URI to be vouched for sub allowuploaded { @@ -3077,7 +3505,7 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) { + } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { $incourse = 1; if ($env{'form.forceedit'}) { $forceview = 1; @@ -3109,7 +3537,7 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; - } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { + } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { $incourse = 1; if ($env{'form.forceedit'}) { $forceview = 1; @@ -3127,7 +3555,7 @@ sub can_edit_resource { } else { $cfile = $env{'form.suppurl'}; my $escfile = &unescape($cfile); - if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) { + if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { $cfile = '/adm/wrapper'.$escfile; } else { $escfile =~ s{^http://}{}; @@ -3288,7 +3716,7 @@ sub process_coursefile { $home); } } elsif ($action eq 'uploaddoc') { - open(my $fh,'>'.$filepath.'/'.$fname); + open(my $fh,'>',$filepath.'/'.$fname); print $fh $env{'form.'.$source}; close($fh); if ($parser eq 'parse') { @@ -3346,7 +3774,7 @@ sub store_edited_file { ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|); $fpath=$docudom.'/'.$docuname.'/'.$fpath; my $filepath = &build_filepath($fpath); - open(my $fh,'>'.$filepath.'/'.$fname); + open(my $fh,'>',$filepath.'/'.$fname); print $fh $content; close($fh); my $home=&homeserver($docuname,$docudom); @@ -3462,12 +3890,12 @@ sub userfileupload { '_'.$env{'user.domain'}.'/pending'; } elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) { my ($docuname,$docudom); - if ($destudom) { + if ($destudom =~ /^$match_domain$/) { $docudom = $destudom; } else { $docudom = $env{'user.domain'}; } - if ($destuname) { + if ($destuname =~ /^$match_username$/) { $docuname = $destuname; } else { $docuname = $env{'user.name'}; @@ -3497,7 +3925,7 @@ sub userfileupload { mkdir($fullpath,0777); } } - open(my $fh,'>'.$fullpath.'/'.$fname); + open(my $fh,'>',$fullpath.'/'.$fname); print $fh $env{'form.'.$formname}; close($fh); if ($context eq 'existingfile') { @@ -3572,7 +4000,7 @@ sub finishuserfileupload { # Save the file { - if (!open(FH,'>'.$filepath.'/'.$file)) { + if (!open(FH,'>',$filepath.'/'.$file)) { &logthis('Failed to create '.$filepath.'/'.$file); print STDERR ('Failed to create '.$filepath.'/'.$file."\n"); return '/adm/notfound.html'; @@ -3630,7 +4058,8 @@ sub finishuserfileupload { my $input = $filepath.'/'.$file; my $output = $filepath.'/'.'tn-'.$file; my $thumbsize = $thumbwidth.'x'.$thumbheight; - system("convert -sample $thumbsize $input $output"); + my @args = ('convert','-sample',$thumbsize,$input,$output); + system({$args[0]} @args); if (-e $filepath.'/'.'tn-'.$file) { $fetchthumb = 1; } @@ -4014,7 +4443,7 @@ sub flushcourselogs { } } # -# Reverse lookup of domain roles (dc, ad, li, sc, au) +# Reverse lookup of domain roles (dc, ad, li, sc, dh, da, au) # my %domrolebuffer = (); foreach my $entry (keys(%domainrolehash)) { @@ -4029,10 +4458,19 @@ sub flushcourselogs { delete $domainrolehash{$entry}; } foreach my $dom (keys(%domrolebuffer)) { - my %servers = &get_servers($dom,'library'); + my %servers; + if (defined(&domain($dom,'primary'))) { + my $primary=&domain($dom,'primary'); + my $hostname=&hostname($primary); + $servers{$primary} = $hostname; + } else { + %servers = &get_servers($dom,'library'); + } foreach my $tryserver (keys(%servers)) { - unless (&reply('domroleput:'.$dom.':'. - $domrolebuffer{$dom},$tryserver) eq 'ok') { + if (&reply('domroleput:'.$dom.':'. + $domrolebuffer{$dom},$tryserver) eq 'ok') { + last; + } else { &logthis('Put of domain roles failed for '.$dom.' and '.$tryserver); } } @@ -4152,7 +4590,7 @@ sub userrolelog { {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'} =$tend.':'.$tstart; } - if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) { + if ($trole =~ /^(dc|ad|li|au|dg|sc|dh|da)/ ) { my (undef,$rudom,$runame,$rsec)=split(/\//,$area); $domainrolehash {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec} @@ -4379,6 +4817,195 @@ sub get_my_roles { return %returnhash; } +sub get_all_adhocroles { + my ($dom) = @_; + my @roles_by_num = (); + my %domdefaults = &get_domain_defaults($dom); + my (%description,%access_in_dom,%access_info); + if (ref($domdefaults{'adhocroles'}) eq 'HASH') { + my $count = 0; + my %domcurrent = %{$domdefaults{'adhocroles'}}; + my %ordered; + foreach my $role (sort(keys(%domcurrent))) { + my ($order,$desc,$access_in_dom); + if (ref($domcurrent{$role}) eq 'HASH') { + $order = $domcurrent{$role}{'order'}; + $desc = $domcurrent{$role}{'desc'}; + $access_in_dom{$role} = $domcurrent{$role}{'access'}; + $access_info{$role} = $domcurrent{$role}{$access_in_dom{$role}}; + } + if ($order eq '') { + $order = $count; + } + $ordered{$order} = $role; + if ($desc ne '') { + $description{$role} = $desc; + } else { + $description{$role}= $role; + } + $count++; + } + foreach my $item (sort {$a <=> $b } (keys(%ordered))) { + push(@roles_by_num,$ordered{$item}); + } + } + return (\@roles_by_num,\%description,\%access_in_dom,\%access_info); +} + +sub get_my_adhocroles { + my ($cid,$checkreg) = @_; + my ($cdom,$cnum,%info,@possroles,$description,$roles_by_num); + if ($env{'request.course.id'} eq $cid) { + $cdom = $env{'course.'.$cid.'.domain'}; + $cnum = $env{'course.'.$cid.'.num'}; + $info{'internal.coursecode'} = $env{'course.'.$cid.'.internal.coursecode'}; + } elsif ($cid =~ /^($match_domain)_($match_courseid)$/) { + $cdom = $1; + $cnum = $2; + %info = &Apache::lonnet::get('environment',['internal.coursecode'], + $cdom,$cnum); + } + if (($info{'internal.coursecode'} ne '') && ($checkreg)) { + my $user = $env{'user.name'}.':'.$env{'user.domain'}; + my %rosterhash = &get('classlist',[$user],$cdom,$cnum); + if ($rosterhash{$user} ne '') { + my $type = (split(/:/,$rosterhash{$user}))[5]; + return ([],{}) if ($type eq 'auto'); + } + } + if (($cdom ne '') && ($cnum ne '')) { + if (($env{"user.role.dh./$cdom/"}) || ($env{"user.role.da./$cdom/"})) { + my $then=$env{'user.login.time'}; + my $update=$env{'user.update.time'}; + if (!$update) { + $update = $then; + } + my @liveroles; + foreach my $role ('dh','da') { + if ($env{"user.role.$role./$cdom/"}) { + my ($tstart,$tend)=split(/\./,$env{"user.role.$role./$cdom/"}); + my $limit = $update; + if ($env{'request.role'} eq "$role./$cdom/") { + $limit = $then; + } + my $activerole = 1; + if ($tstart && $tstart>$limit) { $activerole = 0; } + if ($tend && $tend <$limit) { $activerole = 0; } + if ($activerole) { + push(@liveroles,$role); + } + } + } + if (@liveroles) { + if (&homeserver($cnum,$cdom) ne 'no_host') { + my ($accessref,$accessinfo,%access_in_dom); + ($roles_by_num,$description,$accessref,$accessinfo) = &get_all_adhocroles($cdom); + if (ref($roles_by_num) eq 'ARRAY') { + if (@{$roles_by_num}) { + my %settings; + if ($env{'request.course.id'} eq $cid) { + foreach my $envkey (keys(%env)) { + if ($envkey =~ /^\Qcourse.$cid.\E(internal\.adhoc.+)$/) { + $settings{$1} = $env{$envkey}; + } + } + } else { + %settings = &dump('environment',$cdom,$cnum,'internal\.adhoc'); + } + my %setincrs; + if ($settings{'internal.adhocaccess'}) { + map { $setincrs{$_} = 1; } split(/,/,$settings{'internal.adhocaccess'}); + } + my @statuses; + if ($env{'environment.inststatus'}) { + @statuses = split(/,/,$env{'environment.inststatus'}); + } + my $user = $env{'user.name'}.':'.$env{'user.domain'}; + if (ref($accessref) eq 'HASH') { + %access_in_dom = %{$accessref}; + } + foreach my $role (@{$roles_by_num}) { + my ($curraccess,@okstatus,@personnel); + if ($setincrs{$role}) { + ($curraccess,my $rest) = split(/=/,$settings{'internal.adhoc.'.$role}); + if ($curraccess eq 'status') { + @okstatus = split(/\&/,$rest); + } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { + @personnel = split(/\&/,$rest); + } + } else { + $curraccess = $access_in_dom{$role}; + if (ref($accessinfo) eq 'HASH') { + if ($curraccess eq 'status') { + if (ref($accessinfo->{$role}) eq 'ARRAY') { + @okstatus = @{$accessinfo->{$role}}; + } + } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { + if (ref($accessinfo->{$role}) eq 'ARRAY') { + @personnel = @{$accessinfo->{$role}}; + } + } + } + } + if ($curraccess eq 'none') { + next; + } elsif ($curraccess eq 'all') { + push(@possroles,$role); + } elsif ($curraccess eq 'dh') { + if (grep(/^dh$/,@liveroles)) { + push(@possroles,$role); + } else { + next; + } + } elsif ($curraccess eq 'da') { + if (grep(/^da$/,@liveroles)) { + push(@possroles,$role); + } else { + next; + } + } elsif ($curraccess eq 'status') { + if (@okstatus) { + if (!@statuses) { + if (grep(/^default$/,@okstatus)) { + push(@possroles,$role); + } + } else { + foreach my $status (@okstatus) { + if (grep(/^\Q$status\E$/,@statuses)) { + push(@possroles,$role); + last; + } + } + } + } + } elsif (($curraccess eq 'exc') || ($curraccess eq 'inc')) { + if (grep(/^\Q$user\E$/,@personnel)) { + if ($curraccess eq 'exc') { + push(@possroles,$role); + } + } elsif ($curraccess eq 'inc') { + push(@possroles,$role); + } + } + } + } + } + } + } + } + } + unless (ref($description) eq 'HASH') { + if (ref($roles_by_num) eq 'ARRAY') { + my %desc; + map { $desc{$_} = $_; } (@{$roles_by_num}); + $description = \%desc; + } else { + $description = {}; + } + } + return (\@possroles,$description); +} + # ----------------------------------------------------- Frontpage Announcements # # @@ -4392,7 +5019,7 @@ sub postannounce { sub getannounce { - if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) { + if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) { my $announcement=''; while (my $line = <$fh>) { $announcement .= $line; } close($fh); @@ -4619,6 +5246,21 @@ sub get_domain_roles { return %personnel; } +sub get_active_domroles { + my ($dom,$roles) = @_; + return () unless (ref($roles) eq 'ARRAY'); + my $now = time; + my %dompersonnel = &get_domain_roles($dom,$roles,$now,$now); + my %domroles; + foreach my $server (keys(%dompersonnel)) { + foreach my $user (sort(keys(%{$dompersonnel{$server}}))) { + my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,$user); + $domroles{$uname.':'.$udom} = $dompersonnel{$server}{$user}; + } + } + return %domroles; +} + # ----------------------------------------------------------- Interval timing { @@ -4633,9 +5275,10 @@ my %cachedtimes=(); my $cachedtime=''; sub load_all_first_access { - my ($uname,$udom)=@_; + my ($uname,$udom,$ignorecache)=@_; if (($cachedkey eq $uname.':'.$udom) && - (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) { + (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) && + (!$ignorecache)) { return; } $cachedtime=time; @@ -4644,7 +5287,7 @@ sub load_all_first_access { } sub get_first_access { - my ($type,$argsymb,$argmap)=@_; + my ($type,$argsymb,$argmap,$ignorecache)=@_; my ($symb,$courseid,$udom,$uname)=&whichuser(); if ($argsymb) { $symb=$argsymb; } my ($map,$id,$res)=&decode_symb($symb); @@ -4656,7 +5299,7 @@ sub get_first_access { } else { $res=$symb; } - &load_all_first_access($uname,$udom); + &load_all_first_access($uname,$udom,$ignorecache); return $cachedtimes{"$courseid\0$res"}; } @@ -4673,7 +5316,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); @@ -4686,6 +5334,12 @@ sub set_first_access { 'course.'.$courseid.'.timerinterval.'.$res => $interval, } ); + if (($cachedtime) && (abs($start-$cachedtime) < 5)) { + $cachedtimes{"$courseid\0$res"} = $start; + } + } elsif ($putres ne 'refused') { + &logthis("Result: $putres when attempting to set first access time ". + "(type: $type, extent: $res) for $uname:$udom in $courseid"); } return $putres; } @@ -5472,9 +6126,10 @@ sub rolesinit { } } - @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, - \%allroles, \%allgroups); + @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, + \%allroles, \%allgroups); $env{'user.adv'} = $userroles{'user.adv'}; + $env{'user.rar'} = $userroles{'user.rar'}; return (\%userroles,\%firstaccenv,\%timerintenv); } @@ -5510,6 +6165,10 @@ sub custom_roleprivs { $$allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv; } if (($trest ne '') && (defined($coursepriv))) { + if ($trole =~ m{^cr/$tdomain/$tdomain\Q-domainconfig\E/([^/]+)$}) { + my $rolename = $1; + $coursepriv = &course_adhocrole_privs($rolename,$tdomain,$trest,$coursepriv); + } $$allroles{'cm.'.$area}.=':'.$coursepriv; $$allroles{$spec.'.'.$area}.=':'.$coursepriv; } @@ -5518,6 +6177,48 @@ sub custom_roleprivs { } } +sub course_adhocrole_privs { + my ($rolename,$cdom,$cnum,$coursepriv) = @_; + my %overrides = &get('environment',["internal.adhocpriv.$rolename"],$cdom,$cnum); + if ($overrides{"internal.adhocpriv.$rolename"}) { + my (%currprivs,%storeprivs); + foreach my $item (split(/:/,$coursepriv)) { + my ($priv,$restrict) = split(/\&/,$item); + $currprivs{$priv} = $restrict; + } + my (%possadd,%possremove,%full); + foreach my $item (split(/\:/,$Apache::lonnet::pr{'cr:c'})) { + my ($priv,$restrict)=split(/\&/,$item); + $full{$priv} = $restrict; + } + foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) { + next if ($item eq ''); + my ($rule,$rest) = split(/=/,$item); + next unless (($rule eq 'off') || ($rule eq 'on')); + foreach my $priv (split(/:/,$rest)) { + if ($priv ne '') { + if ($rule eq 'off') { + $possremove{$priv} = 1; + } else { + $possadd{$priv} = 1; + } + } + } + } + foreach my $priv (sort(keys(%full))) { + if (exists($currprivs{$priv})) { + unless (exists($possremove{$priv})) { + $storeprivs{$priv} = $currprivs{$priv}; + } + } elsif (exists($possadd{$priv})) { + $storeprivs{$priv} = $full{$priv}; + } + } + $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs))); + } + return $coursepriv; +} + sub group_roleprivs { my ($allgroups,$area,$group_privs,$tend,$tstart) = @_; my $access = 1; @@ -5552,6 +6253,7 @@ sub set_userprivs { my ($userroles,$allroles,$allgroups,$groups_roles) = @_; my $author=0; my $adv=0; + my $rar=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { my @groupkeys; @@ -5599,6 +6301,7 @@ sub set_userprivs { $thesepriv{$privilege}.=$restrictions; } if ($thesepriv{'adv'} eq 'F') { $adv=1; } + if ($thesepriv{'rar'} eq 'F') { $rar=1; } } } my $thesestr=''; @@ -5607,7 +6310,7 @@ sub set_userprivs { } $userroles->{'user.priv.'.$role} = $thesestr; } - return ($author,$adv); + return ($author,$adv,$rar); } sub role_status { @@ -5652,9 +6355,10 @@ sub role_status { push(@rolecodes,$$role); &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); } - my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); + my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, + \%groups_roles); &appenv(\%userroles,\@rolecodes); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); } } $$tstatus = 'is'; @@ -5730,39 +6434,56 @@ sub delete_env_groupprivs { } sub check_adhoc_privs { - my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; + my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller,$sec) = @_; my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; + if ($sec) { + $cckey .= '/'.$sec; + } my $setprivs; if ($env{$cckey}) { my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend); &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend); unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); + &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); $setprivs = 1; } } else { - &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); + &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller,$sec); $setprivs = 1; } return $setprivs; } sub set_adhoc_privileges { -# role can be cc or ca - my ($dcdom,$pickedcourse,$role,$caller) = @_; +# role can be cc, ca, or cr//-domainconfig/role + my ($dcdom,$pickedcourse,$role,$caller,$sec) = @_; my $area = '/'.$dcdom.'/'.$pickedcourse; + if ($sec ne '') { + $area .= '/'.$sec; + } my $spec = $role.'.'.$area; my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'}, $env{'user.name'},1); - my %ccrole = (); - &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area); - my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole); + my %rolehash = (); + if ($role =~ m{^\Qcr/$dcdom/$dcdom\E\-domainconfig/(\w+)$}) { + my $rolename = $1; + &custom_roleprivs(\%rolehash,$role,$dcdom,$pickedcourse,$spec,$area); + my %domdef = &get_domain_defaults($dcdom); + if (ref($domdef{'adhocroles'}) eq 'HASH') { + if (ref($domdef{'adhocroles'}{$rolename}) eq 'HASH') { + &appenv({'request.role.desc' => $domdef{'adhocroles'}{$rolename}{'desc'},}); + } + } + } else { + &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); + } + my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); &appenv(\%userroles,[$role,'cm']); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { &appenv( {'request.role' => $spec, 'request.role.domain' => $dcdom, - 'request.course.sec' => '' + 'request.course.sec' => $sec, } ); my $tadv=0; @@ -5912,7 +6633,7 @@ sub currentdump { # my %returnhash=(); # - if ($rep eq "unknown_cmd") { + if ($rep eq 'unknown_cmd') { # an old lond will not know currentdump # Do a dump and make it look like a currentdump my @tmp = &dumpstore($courseid,$sdom,$sname,'.'); @@ -6146,9 +6867,11 @@ sub tmpget { if (!defined($server)) { $server = $perlvar{'lonHostID'}; } my $rep=&reply("tmpget:$token",$server); my %returnhash; + if ($rep =~ /^(con_lost|error|no_such_host)/i) { + return %returnhash; + } foreach my $item (split(/\&/,$rep)) { my ($key,$value)=split(/=/,$item); - next if ($key =~ /^error: 2 /); $returnhash{&unescape($key)}=&thaw_unescape($value); } return %returnhash; @@ -6530,6 +7253,8 @@ sub usertools_access { unofficial => 1, community => 1, textbook => 1, + placement => 1, + lti => 1, ); } elsif ($context eq 'requestauthor') { %tools = ( @@ -6726,25 +7451,29 @@ sub is_advanced_user { } sub check_can_request { - my ($dom,$can_request,$request_domains) = @_; + my ($dom,$can_request,$request_domains,$uname,$udom) = @_; my $canreq = 0; + if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) { + $uname = $env{'user.name'}; + $udom = $env{'user.domain'}; + } my ($types,$typename) = &Apache::loncommon::course_types(); my @options = ('approval','validate','autolimit'); my $optregex = join('|',@options); if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) { foreach my $type (@{$types}) { - if (&usertools_access($env{'user.name'}, - $env{'user.domain'}, - $type,undef,'requestcourses')) { + if (&usertools_access($uname,$udom,$type,undef, + 'requestcourses')) { $canreq ++; if (ref($request_domains) eq 'HASH') { - push(@{$request_domains->{$type}},$env{'user.domain'}); + push(@{$request_domains->{$type}},$udom); } - if ($dom eq $env{'user.domain'}) { + if ($dom eq $udom) { $can_request->{$type} = 1; } } - if ($env{'environment.reqcrsotherdom.'.$type} ne '') { + if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') && + ($env{'environment.reqcrsotherdom.'.$type} ne '')) { my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type}); if (@curr > 0) { foreach my $item (@curr) { @@ -6761,7 +7490,7 @@ sub check_can_request { } } } - unless($dom eq $env{'user.domain'}) { + unless ($dom eq $env{'user.domain'}) { $canreq ++; if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) { $can_request->{$type} = 1; @@ -6843,7 +7572,7 @@ sub allowed { if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; } # Free bre access to adm and meta resources - if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$})) + if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$})) || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) && ($priv eq 'bre')) { return 'F'; @@ -6891,7 +7620,10 @@ sub allowed { # Free bre to public access if ($priv eq 'bre') { - my $copyright=&metadata($uri,'copyright'); + my $copyright; + unless ($uri =~ /ext\.tool/) { + $copyright=&metadata($uri,'copyright'); + } if (($copyright eq 'public') && (!$env{'request.course.id'})) { return 'F'; } @@ -7263,7 +7995,7 @@ sub allowed { my $unamedom=$env{'user.name'}.':'.$env{'user.domain'}; if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'} =~/\Q$rolecode\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'. 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '. $env{'request.course.id'}); @@ -7273,7 +8005,7 @@ sub allowed { if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'} =~/\Q$unamedom\E/) { - if (($priv ne 'pch') && ($priv ne 'plc')) { + if (($priv ne 'pch') && ($priv ne 'plc') && ($priv ne 'pac')) { &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}. 'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '. $env{'request.course.id'}); @@ -7331,7 +8063,7 @@ sub constructaccess { my ($ownername,$ownerdomain,$ownerhome); ($ownerdomain,$ownername) = - ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/}); + ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)}); # The URL does not really point to any authorspace, forget it unless (($ownername) && ($ownerdomain)) { return ''; } @@ -7352,6 +8084,15 @@ sub constructaccess { $ownerhome = &homeserver($ownername,$ownerdomain); return ($ownername,$ownerdomain,$ownerhome); } + if ($env{'request.course.id'}) { + if (($ownername eq $env{'course.'.$env{'request.course.id'}.'.num'}) && + ($ownerdomain eq $env{'course.'.$env{'request.course.id'}.'.domain'})) { + if (&allowed('mdc',$env{'request.course.id'})) { + $ownerhome = $env{'course.'.$env{'request.course.id'}.'.home'}; + return ($ownername,$ownerdomain,$ownerhome); + } + } + } } # We don't have any access right now. If we are not possibly going to do anything about this, @@ -7504,8 +8245,8 @@ sub get_commblock_resources { } } } - if ($interval[0] =~ /^\d+/) { - my ($timelimit) = split(/_/,$interval[0]); + if ($interval[0] =~ /^(\d+)/) { + my $timelimit = $1; my $first_access; if ($type eq 'resource') { $first_access=&get_first_access($interval[1],$item); @@ -7670,7 +8411,7 @@ sub get_symb_from_alias { sub definerole { if (allowed('mcr','/')) { - my ($rolename,$sysrole,$domrole,$courole)=@_; + my ($rolename,$sysrole,$domrole,$courole,$uname,$udom)=@_; foreach my $role (split(':',$sysrole)) { my ($crole,$cqual)=split(/\&/,$role); if ($pr{'cr:s'}!~/\Q$crole\E/) { return "refused:s:$crole"; } @@ -7698,11 +8439,19 @@ sub definerole { } } } + my $uhome; + if (($uname ne '') && ($udom ne '')) { + $uhome = &homeserver($uname,$udom); + return $uhome if ($uhome eq 'no_host'); + } else { + $uname = $env{'user.name'}; + $udom = $env{'user.domain'}; + $uhome = $env{'user.home'}; + } my $command="encrypt:rolesput:$env{'user.domain'}:$env{'user.name'}:". - "$env{'user.domain'}:$env{'user.name'}:". - "rolesdef_$rolename=". + "$udom:$uname:rolesdef_$rolename=". escape($sysrole.'_'.$domrole.'_'.$courole); - return reply($command,$env{'user.home'}); + return reply($command,$uhome); } else { return 'refused'; } @@ -7784,10 +8533,12 @@ sub update_allusers_table { sub fetch_enrollment_query { my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_; - my $homeserver; + my ($homeserver,$sleep,$loopmax); my $maxtries = 1; if ($context eq 'automated') { $homeserver = $perlvar{'lonHostID'}; + $sleep = 2; + $loopmax = 100; $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout } else { $homeserver = &homeserver($cnum,$dom); @@ -7805,17 +8556,17 @@ sub fetch_enrollment_query { &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); return 'error: '.$queryid; } - my $reply = &get_query_reply($queryid); + my $reply = &get_query_reply($queryid,$sleep,$loopmax); my $tries = 1; while (($reply=~/^timeout/) && ($tries < $maxtries)) { - $reply = &get_query_reply($queryid); + $reply = &get_query_reply($queryid,$sleep,$loopmax); $tries ++; } if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) { &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries); } else { my @responses = split(/:/,$reply); - if ($homeserver eq $perlvar{'lonHostID'}) { + if (grep { $_ eq $homeserver } ¤t_machine_ids()) { foreach my $line (@responses) { my ($key,$value) = split(/=/,$line,2); $$replyref{$key} = $value; @@ -7833,7 +8584,7 @@ sub fetch_enrollment_query { if ($xml_classlist =~ /^error/) { &logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum); } else { - if ( open(FILE,">$destname") ) { + if ( open(FILE,">",$destname) ) { print FILE &unescape($xml_classlist); close(FILE); } else { @@ -7850,13 +8601,19 @@ sub fetch_enrollment_query { } sub get_query_reply { - my $queryid=shift; + my ($queryid,$sleep,$loopmax) = @_;; + if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) { + $sleep = 0.2; + } + if (($loopmax eq '') || ($loopmax =~ /\D/)) { + $loopmax = 100; + } my $replyfile=LONCAPA::tempdir().$queryid; my $reply=''; - for (1..100) { - sleep(0.2); + for (1..$loopmax) { + sleep($sleep); if (-e $replyfile.'.end') { - if (open(my $fh,$replyfile)) { + if (open(my $fh,"<",$replyfile)) { $reply = join('',<$fh>); close($fh); } else { return 'error: reply_file_error'; } @@ -8248,6 +9005,33 @@ sub auto_validate_class_sec { return $response; } +sub auto_validate_instclasses { + my ($cdom,$cnum,$owners,$classesref) = @_; + my ($homeserver,%validations); + $homeserver = &homeserver($cnum,$cdom); + unless ($homeserver eq 'no_host') { + my $ownerlist; + if (ref($owners) eq 'ARRAY') { + $ownerlist = join(',',@{$owners}); + } else { + $ownerlist = $owners; + } + if (ref($classesref) eq 'HASH') { + my $classes = &freeze_escape($classesref); + my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). + ':'.$cdom.':'.$classes,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused)/) { + my @items = split(/&/,$response); + foreach my $item (@items) { + my ($key,$value) = split('=',$item); + $validations{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + return %validations; +} + sub auto_crsreq_update { my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, $code,$accessstart,$accessend,$inbound) = @_; @@ -8277,6 +9061,33 @@ sub auto_crsreq_update { return \%crsreqresponse; } +sub auto_export_grades { + my ($cdom,$cnum,$inforef,$gradesref) = @_; + my ($homeserver,%exportresponse); + if ($cdom =~ /^$match_domain$/) { + $homeserver = &domain($cdom,'primary'); + } + unless (($homeserver eq 'no_host') || ($homeserver eq '')) { + my $info; + if (ref($inforef) eq 'HASH') { + $info = &freeze_escape($inforef); + } + if (ref($gradesref) eq 'HASH') { + my $grades = &freeze_escape($gradesref); + my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'. + $info.':'.$grades,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) { + my @items = split(/&/,$response); + foreach my $item (@items) { + my ($key,$value) = split('=',$item); + $exportresponse{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + return \%exportresponse; +} + sub check_instcode_cloning { my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_; unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) { @@ -8498,6 +9309,7 @@ sub plaintext { my %rolenames = ( Course => 'std', Community => 'alt1', + Placement => 'std', ); if ($cid ne '') { if ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '') { @@ -8579,7 +9391,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')); @@ -8599,8 +9411,12 @@ sub assignrole { } } } - } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - $refused = ''; + } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { + if ($role eq 'st') { + $refused = ''; + } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) { + $refused = ''; + } } elsif ($context eq 'requestcourses') { my @possroles = ('st','ta','ep','in','cc','co'); if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) { @@ -8715,7 +9531,8 @@ sub assignrole { &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $selfenroll,$context); } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') || - ($role eq 'au') || ($role eq 'dc')) { + ($role eq 'au') || ($role eq 'dc') || ($role eq 'dh') || + ($role eq 'da')) { &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, $context); } elsif (($role eq 'ca') || ($role eq 'aa')) { @@ -8865,10 +9682,14 @@ sub modifyuser { my $newuser; if ($uhome eq 'no_host') { $newuser = 1; + unless (($umode && ($upass ne '')) || ($umode eq 'localauth') || + ($umode eq 'lti')) { + return 'error: more information needed to create new user'; + } } # ----------------------------------------------------------------- Create User if (($uhome eq 'no_host') && - (($umode && $upass) || ($umode eq 'localauth'))) { + (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) { my $unhome=''; if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { $unhome = $desiredhome; @@ -9020,7 +9841,7 @@ sub modifyuser { sub modifystudent { my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec, $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid, - $selfenroll,$context,$inststatus,$credits)=@_; + $selfenroll,$context,$inststatus,$credits,$instsec)=@_; if (!$cid) { unless ($cid=$env{'request.course.id'}) { return 'not_in_class'; @@ -9036,13 +9857,13 @@ sub modifystudent { $uid = undef if (!$forceid); $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last, $gene,$usec,$end,$start,$type,$locktype, - $cid,$selfenroll,$context,$credits); + $cid,$selfenroll,$context,$credits,$instsec); return $reply; } sub modify_student_enrollment { my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type, - $locktype,$cid,$selfenroll,$context,$credits) = @_; + $locktype,$cid,$selfenroll,$context,$credits,$instsec) = @_; my ($cdom,$cnum,$chome); if (!$cid) { unless ($cid=$env{'request.course.id'}) { @@ -9089,7 +9910,7 @@ sub modify_student_enrollment { my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); my $reply=cput('classlist', {$user => - join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) }, + join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits,$instsec) }, $cdom,$cnum); if (($reply eq 'ok') || ($reply eq 'delayed')) { &devalidate_getsection_cache($udom,$uname,$cid); @@ -9313,12 +10134,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; } @@ -9454,7 +10288,7 @@ sub save_selected_files { my ($user, $path, @files) = @_; my $filename = $user."savedfiles"; my @other_files = &files_not_in_path($user, $path); - open (OUT, '>'.$tmpdir.$filename); + open (OUT,'>',LONCAPA::tempdir().$filename); foreach my $file (@files) { print (OUT $env{'form.currentpath'}.$file."\n"); } @@ -9468,7 +10302,7 @@ sub save_selected_files { sub clear_selected_files { my ($user) = @_; my $filename = $user."savedfiles"; - open (OUT, '>'.LONCAPA::tempdir().$filename); + open (OUT,'>',LONCAPA::tempdir().$filename); print (OUT undef); close (OUT); return ("ok"); @@ -9478,7 +10312,7 @@ sub files_in_path { my ($user, $path) = @_; my $filename = $user."savedfiles"; my %return_files; - open (IN, '<'.LONCAPA::tempdir().$filename); + open (IN,'<',LONCAPA::tempdir().$filename); while (my $line_in = ) { chomp ($line_in); my @paths_and_file = split (m!/!, $line_in); @@ -9500,7 +10334,7 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open(IN, '<'.LONCAPA::.$filename); + open(IN, '<',LONCAPA::tempdir().$filename); while (my $line = ) { #ok, I know it's clunky, but I want it to work my @paths_and_file = split(m|/|, $line); @@ -10075,7 +10909,24 @@ sub dirlist { foreach my $user (sort(keys(%allusers))) { push(@alluserslist,$user.'&user'); } - return (\@alluserslist); + + if (!%listerror) { + # no errors + return (\@alluserslist); + } elsif (scalar(keys(%servers)) == 1) { + # one library server, one error + my ($key) = keys(%listerror); + return (\@alluserslist, $listerror{$key}); + } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) { + # con_lost indicates that we might miss data from at least one + # library server + return (\@alluserslist, 'con_lost'); + } else { + # multiple library servers and no con_lost -> data should be + # complete. + return (\@alluserslist); + } + } else { return ([],'missing username'); } @@ -10148,6 +10999,115 @@ sub stat_file { return (); } +# --------------------------------------------------------- recursedirs +# Recursive function to traverse either a specific user's Authoring Space +# 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. +# +# 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 +# $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) +# $filehashref - reference to hash to populate with URLs of files (Optional) +# +# Returns: nothing +# +# Side Effects: populates $dirhashref, and $filehashref (if provided). +# +# Currently used by interface/londocs.pm to create linked select boxes for +# directory and filename to import a Course "Author" resource into a course, and +# also to create linked select boxes for Authoring Space and Directory to choose +# save location for creation of a new "standard" problem from the Course Editor. +# + +sub recursedirs { + my ($is_home,$context,$docroot,$toppath,$relpath,$dirhashref,$filehashref) = @_; + return unless (ref($dirhashref) eq 'HASH'); + my $currpath = $docroot.$toppath; + if ($relpath) { + $currpath .= "/$relpath"; + } + my $savefile; + if (ref($filehashref)) { + $savefile = 1; + } + if ($is_home) { + if (opendir(my $dirh,$currpath)) { + foreach my $item (sort { lc($a) cmp lc($b) } grep(!/^\.+$/,readdir($dirh))) { + next if ($item eq ''); + if (-d "$currpath/$item") { + my $newpath; + if ($relpath) { + $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; + } + } else { + unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/) || ($item =~ /\.rights$/)) { + $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1; + } + } + } + } + closedir($dirh); + } + } else { + my ($dirlistref,$listerror) = + &dirlist($toppath.$relpath); + my @dir_lines; + my $dirptr=16384; + if (ref($dirlistref) eq 'ARRAY') { + foreach my $dir_line (sort + { + my ($afile)=split('&',$a,2); + my ($bfile)=split('&',$b,2); + return (lc($afile) cmp lc($bfile)); + } (@{$dirlistref})) { + my ($item,$dom,undef,$testdir,undef,undef,undef,undef,$size,undef,$mtime,undef,undef,undef,$obs,undef) = + split(/\&/,$dir_line,16); + $item =~ s/\s+$//; + next if (($item =~ /^\.\.?$/) || ($obs)); + if ($dirptr&$testdir) { + my $newpath; + 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; + } + } else { + unless (($item =~ /\.meta$/) || ($item =~ /\.\d+\.\w+$/)) { + $filehashref->{$relpath}{$item} = 1; + } + } + } + } + } + } + return; +} + # -------------------------------------------------------- Value of a Condition # gets the value of a specific preevaluated condition @@ -10311,7 +11271,14 @@ sub get_userresdata { # Parameters: # $name - Course/user name. # $domain - Name of the domain the user/course is registered on. -# $type - Type of thing $name is (must be 'course' or 'user' +# $type - Type of thing $name is (must be 'course' or 'user') +# $mapp - decluttered URL of enclosing map +# $recursed - Ref to scalar -- set to 1, if nested maps have been recursed. +# $recurseup - Ref to array of map URLs, starting with map containing +# $mapp up through hierarchy of nested maps to top level map. +# $courseid - CourseID (first part of param identifier). +# $modifier - Middle part of param identifier. +# $what - Last part of param identifier. # @which - Array of names of resources desired. # Returns: # The value of the first reasource in @which that is found in the @@ -10321,7 +11288,8 @@ sub get_userresdata { # 'user', an undefined reference is returned. # If none of the resources are found, an undef is returned sub resdata { - my ($name,$domain,$type,@which)=@_; + my ($name,$domain,$type,$mapp,$recursed,$recurseup,$courseid, + $modifier,$what,@which)=@_; my $result; if ($type eq 'course') { $result=&get_courseresdata($name,$domain); @@ -10330,30 +11298,61 @@ sub resdata { } if (!ref($result)) { return $result; } foreach my $item (@which) { - if (defined($result->{$item->[0]})) { + if ($item->[1] eq 'course') { + if ((ref($recurseup) eq 'ARRAY') && (ref($recursed) eq 'SCALAR')) { + unless ($$recursed) { + @{$recurseup} = &get_map_hierarchy($mapp,$courseid); + $$recursed = 1; + } + foreach my $item (@${recurseup}) { + my $norecursechk=$courseid.$modifier.$item.'___(all).'.$what; + last if (defined($result->{$norecursechk})); + my $recursechk=$courseid.$modifier.$item.'___(rec).'.$what; + if (defined($result->{$recursechk})) { return [$result->{$recursechk},'map']; } + } + } + } + if (defined($result->{$item->[0]})) { return [$result->{$item->[0]},$item->[1]]; } } return undef; } -sub get_domain_ltitools { - my ($cdom) = @_; - my %ltitools; - my ($result,$cached)=&is_cached_new('ltitools',$cdom); +sub get_domain_lti { + my ($cdom,$context) = @_; + my ($name,%lti); + if ($context eq 'consumer') { + $name = 'ltitools'; + } elsif ($context eq 'provider') { + $name = 'lti'; + } else { + return %lti; + } + my ($result,$cached)=&is_cached_new($name,$cdom); if (defined($cached)) { if (ref($result) eq 'HASH') { - %ltitools = %{$result}; + %lti = %{$result}; } } else { - my %domconfig = &get_dom('configuration',['ltitools'],$cdom); - if (ref($domconfig{'ltitools'}) eq 'HASH') { - %ltitools = %{$domconfig{'ltitools'}}; + my %domconfig = &get_dom('configuration',[$name],$cdom); + if (ref($domconfig{$name}) eq 'HASH') { + %lti = %{$domconfig{$name}}; + my %encdomconfig = &get_dom('encconfig',[$name],$cdom); + if (ref($encdomconfig{$name}) eq 'HASH') { + foreach my $id (keys(%lti)) { + if (ref($encdomconfig{$name}{$id}) eq 'HASH') { + foreach my $item ('key','secret') { + $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; + } + } + } + } } my $cachetime = 24*60*60; - &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); + &do_cache_new($name,$cdom,\%lti,$cachetime); } - return %ltitools; + return %lti; } sub get_numsuppfiles { @@ -10366,10 +11365,11 @@ sub get_numsuppfiles { unless (defined($cached)) { my $chome=&homeserver($cnum,$cdom); unless ($chome eq 'no_host') { - ($suppcount,my $errors) = (0,0); + ($suppcount,my $supptools,my $errors) = (0,0,0); my $suppmap = 'supplemental.sequence'; - ($suppcount,$errors) = - &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors); + ($suppcount,$supptools,$errors) = + &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount, + $supptools,$errors); } &do_cache_new('suppcount',$hashid,$suppcount,600); } @@ -10380,6 +11380,16 @@ sub get_numsuppfiles { # EXT resource caching routines # +{ +# Cache (5 seconds) of map hierarchy for speedup of navmaps display +# +# The course for which we cache +my $cachedmapkey=''; +# The cached recursive maps for this course +my %cachedmaps=(); +# When this was last done +my $cachedmaptime=''; + sub clear_EXT_cache_status { &delenv('cache.EXT.'); } @@ -10557,8 +11567,8 @@ sub EXT { } } - my ($section, $group, @groups); - my ($courselevelm,$courselevel); + my ($section, $group, @groups, @recurseup, $recursed); + my ($courselevelm,$courseleveli,$courselevel,$mapp); if (($courseid eq '') && ($cid)) { $courseid = $cid; } @@ -10569,11 +11579,10 @@ sub EXT { # ----------------------------------------------------- Cascading lookup scheme my $symbp=$symbparm; - my $mapp=&deversion((&decode_symb($symbp))[0]); - + $mapp=&deversion((&decode_symb($symbp))[0]); my $symbparm=$symbp.'.'.$spacequalifierrest; + my $recurseparm=$mapp.'___(rec).'.$spacequalifierrest; my $mapparm=$mapp.'___(all).'.$spacequalifierrest; - if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) { $section=$env{'request.course.sec'}; @@ -10590,17 +11599,21 @@ sub EXT { my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest; my $seclevelr=$courseid.'.['.$section.'].'.$symbparm; + my $secleveli=$courseid.'.['.$section.'].'.$recurseparm; my $seclevelm=$courseid.'.['.$section.'].'.$mapparm; $courselevel=$courseid.'.'.$spacequalifierrest; my $courselevelr=$courseid.'.'.$symbparm; + $courseleveli=$courseid.'.'.$recurseparm; $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - my $userreply=&resdata($uname,$udom,'user', + my $userreply=&resdata($uname,$udom,'user',$mapp,\$recursed, + \@recurseup,$courseid,'.',$spacequalifierrest, ([$courselevelr,'resource'], [$courselevelm,'map' ], + [$courseleveli,'map' ], [$courselevel, 'course' ])); if (defined($userreply)) { return &get_reply($userreply); } @@ -10608,15 +11621,18 @@ sub EXT { my $coursereply; if (@groups > 0) { $coursereply = &check_group_parms($courseid,\@groups,$symbparm, - $mapparm,$spacequalifierrest); - if (defined($coursereply)) { return &get_reply($coursereply); } + $recurseparm,$mapparm,$spacequalifierrest, + $mapp,\$recursed,\@recurseup); + if (defined($coursereply)) { return &get_reply($coursereply); } } $coursereply=&resdata($env{'course.'.$courseid.'.num'}, $env{'course.'.$courseid.'.domain'}, - 'course', + 'course',$mapp,\$recursed,\@recurseup, + $courseid,'.['.$section.'].',$spacequalifierrest, ([$seclevelr, 'resource'], [$seclevelm, 'map' ], + [$secleveli, 'map' ], [$seclevel, 'course' ], [$courselevelr,'resource'])); if (defined($coursereply)) { return &get_reply($coursereply); } @@ -10633,8 +11649,9 @@ sub EXT { if ($thisparm) { return &get_reply([$thisparm,'resource']); } } # ------------------------------------------ fourth, look in resource metadata - - $spacequalifierrest=~s/\./\_/; + + my $what = $spacequalifierrest; + $what=~s/\./\_/; my $filename; if (!$symbparm) { $symbparm=&symbread(); } if ($symbparm) { @@ -10642,18 +11659,24 @@ sub EXT { } else { $filename=$env{'request.filename'}; } - my $metadata=&metadata($filename,$spacequalifierrest); + my $toolsymb; + if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { + $toolsymb = $symbparm; + } + my $metadata=&metadata($filename,$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } - $metadata=&metadata($filename,'parameter_'.$spacequalifierrest); + $metadata=&metadata($filename,'parameter_'.$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } -# ---------------------------------------------- fourth, look in rest of course +# ----------------------------------------------- fifth, look in rest of course if ($symbparm && defined($courseid) && $courseid eq $env{'request.course.id'}) { my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, $env{'course.'.$courseid.'.domain'}, - 'course', + 'course',$mapp,\$recursed,\@recurseup, + $courseid,'.',$spacequalifierrest, ([$courselevelm,'map' ], + [$courseleveli,'map' ], [$courselevel, 'course'])); if (defined($coursereply)) { return &get_reply($coursereply); } } @@ -10668,7 +11691,7 @@ sub EXT { if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); } } if ($recurse) { return undef; } - my $pack_def=&packages_tab_default($filename,$varname); + my $pack_def=&packages_tab_default($filename,$varname,$toolsymb); if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); } # ---------------------------------------------------- Any other user namespace } elsif ($realm eq 'environment') { @@ -10710,22 +11733,51 @@ sub get_reply { } sub check_group_parms { - my ($courseid,$groups,$symbparm,$mapparm,$what) = @_; - my @groupitems = (); - my $resultitem; - my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']); + my ($courseid,$groups,$symbparm,$recurseparm,$mapparm,$what,$mapp, + $recursed,$recurseupref) = @_; + my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$recurseparm,'map'], + [$what,'course']); + my $coursereply; foreach my $group (@{$groups}) { + my @groupitems = (); foreach my $level (@levels) { my $item = $courseid.'.['.$group.'].'.$level->[0]; push(@groupitems,[$item,$level->[1]]); } + my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course',$mapp,$recursed,$recurseupref, + $courseid,'.['.$group.'].',$what, + @groupitems); + last if (defined($coursereply)); } - my $coursereply = &resdata($env{'course.'.$courseid.'.num'}, - $env{'course.'.$courseid.'.domain'}, - 'course',@groupitems); return $coursereply; } +sub get_map_hierarchy { + my ($mapname,$courseid) = @_; + my @recurseup = (); + if ($mapname) { + if (($cachedmapkey eq $courseid) && + (abs($cachedmaptime-time)<5)) { + if (ref($cachedmaps{$mapname}) eq 'ARRAY') { + return @{$cachedmaps{$mapname}}; + } + } + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + @recurseup = $navmap->recurseup_maps($mapname); + undef($navmap); + $cachedmaps{$mapname} = \@recurseup; + $cachedmaptime=time; + $cachedmapkey=$courseid; + } + } + return @recurseup; +} + +} + sub sort_course_groups { # Sort groups based on defined rankings. Default is sort(). my ($courseid,@groups) = @_; @groups = sort(@groups); @@ -10733,11 +11785,11 @@ sub sort_course_groups { # Sort groups b } sub packages_tab_default { - my ($uri,$varname)=@_; + my ($uri,$varname,$toolsymb)=@_; my (undef,$part,$name)=split(/\./,$varname); my (@extension,@specifics,$do_default); - foreach my $package (split(/,/,&metadata($uri,'packages'))) { + foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) { my ($pack_type,$pack_part)=split(/_/,$package,2); if ($pack_type eq 'default') { $do_default=1; @@ -10804,13 +11856,14 @@ sub add_prefix_and_part { my %metaentry; my %importedpartids; +my %importedrespids; sub metadata { - my ($uri,$what,$liburi,$prefix,$depthcount)=@_; + my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_; $uri=&declutter($uri); # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && - ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) || + ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -10829,11 +11882,72 @@ sub metadata { my ($result,$cached)=&is_cached_new('meta',$uri); if (defined($cached)) { return $result->{':'.$what}; } } + +# +# If the uri is for an external tool the file from +# which metadata should be retrieved depends on whether +# the tool had been configured to be gradable (set in the Course +# Editor or Resource Editor). +# +# If a valid symb has been included as the third arg in the call +# to &metadata() that can be used to retrieve the value of +# parameter_0_gradable set for the resource, and included in the +# uploaded map containing the tool. The value is retrieved via +# &EXT(), if a valid symb is available. Otherwise the value of +# gradable in the exttool_$marker.db file for the tool instance +# is retrieved via &get(). +# +# When lonuserstate::traceroute() calls lonnet::EXT() for +# hiddenresource and encrypturl (during course initialization) +# the map-level parameter for resource.0.gradable included in the +# uploaded map containing the tool will not yet have been stored +# in the user_course_parms.db file for the user's session, so in +# this case fall back to retrieving gradable status from the +# exttool_$marker.db file. +# +# In order to avoid an infinite loop, &metadata() will return +# before a call to &EXT(), if the uri is for an external tool +# and the $what for which metadata is being requested is +# parameter_0_gradable or 0_gradable. +# + + if ($uri =~ /ext\.tool$/) { + if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) { + return; + } else { + my ($checked,$use_passback); + if ($toolsymb ne '') { + (undef,undef,my $tooluri) = &decode_symb($toolsymb); + if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) { + $checked = 1; + if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) { + $use_passback = 1; + } + } + } + unless ($checked) { + my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri); + $marker=~s/\D//g; + if ($marker) { + my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum); + $use_passback = $toolsettings{'gradable'}; + } + } + if ($use_passback) { + $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool'; + } else { + $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool'; + } + } + } + { # Imported parts would go here - my %importedids=(); - my @origfileimportpartids=(); + my @origfiletagids=(); my $importedparts=0; + +# Imported responseids would go here + my $importedresponses=0; # # Is this a recursive call for a library? # @@ -10928,27 +12042,77 @@ sub metadata { my $dir=$filename; $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); - + + my $importid=$token->[2]->{'id'}; my $importmode=$token->[2]->{'importmode'}; - if ($importmode eq 'problem') { -# Import as problem/response - $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - } elsif ($importmode eq 'part') { +# +# Check metadata for imported file to +# see if it contained response items +# + my ($origfile,@libfilekeys); + my %currmetaentry = %metaentry; + @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef, + $depthcount+1)); + if (grep(/^responseorder$/,@libfilekeys)) { + my $libresponseorder = &metadata($location,'responseorder',undef,undef, + undef,$depthcount+1); + if ($libresponseorder ne '') { + if ($#origfiletagids<0) { + undef(%importedrespids); + undef(%importedpartids); + } + my @respids = split(/\s*,\s*/,$libresponseorder); + if (@respids) { + $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids); + } + if ($importedrespids{$importid} ne '') { + $importedresponses = 1; +# We need to get the original file and the imported file to get the response order correct +# Load and inspect original file + if ($#origfiletagids<0) { + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + $origfile=&getfile($origfilelocation); + @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + } + } + } + } +# Do not overwrite contents of %metaentry hash for resource itself with +# hash populated for imported library file + %metaentry = %currmetaentry; + undef(%currmetaentry); + if ($importmode eq 'part') { # Import as part(s) $importedparts=1; # We need to get the original file and the imported file to get the part order correct # Good news: we do not need to worry about nested libraries, since parts cannot be nested -# Load and inspect original file - if ($#origfileimportpartids<0) { - undef(%importedpartids); - my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); - my $origfile=&getfile($origfilelocation); - @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); +# Load and inspect original file if we didn't do that already + if ($#origfiletagids<0) { + undef(%importedrespids); + undef(%importedpartids); + if ($origfile eq '') { + my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); + $origfile=&getfile($origfilelocation); + @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); + } + } + my @impfilepartids; +# If tag is included in metadata for the imported file +# get the parts in the imported file from that. + if (grep(/^partorder$/,@libfilekeys)) { + %currmetaentry = %metaentry; + my $libpartorder = &metadata($location,'partorder',undef,undef,undef, + $depthcount+1); + %metaentry = %currmetaentry; + undef(%currmetaentry); + if ($libpartorder ne '') { + @impfilepartids=split(/\s*,\s*/,$libpartorder); + } + } else { +# If no tag available, load and inspect imported file + my $impfile=&getfile($location); + @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); } - -# Load and inspect imported file - my $impfile=&getfile($location); - my @impfilepartids=($impfile=~/]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); if ($#impfilepartids>=0) { # This problem had parts $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids); @@ -10959,22 +12123,36 @@ sub metadata { $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'}; } } else { +# Import as problem or as normal import + $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); + unless ($importmode eq 'problem') { # Normal import - $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } + if (defined($token->[2]->{'id'})) { + $unikey.='_'.$token->[2]->{'id'}; + } + } +# Check metadata for imported file to +# see if it contained parts + if (grep(/^partorder$/,@libfilekeys)) { + %currmetaentry = %metaentry; + my $libpartorder = &metadata($location,'partorder',undef,undef,undef, + $depthcount+1); + %metaentry = %currmetaentry; + undef(%currmetaentry); + if ($libpartorder ne '') { + $importedparts = 1; + $importedpartids{$token->[2]->{'id'}}=$libpartorder; + } + } } - if ($depthcount<20) { my $metadata = - &metadata($uri,'keys', $location,$unikey, + &metadata($uri,'keys',$toolsymb,$location,$unikey, $depthcount+1); foreach my $meta (split(',',$metadata)) { $metaentry{':'.$meta}=$metaentry{':'.$meta}; $metathesekeys{$meta}=1; } - } } else { # @@ -11043,7 +12221,7 @@ sub metadata { $dir=~s|[^/]*$||; $location=&filelocation($dir,$location); my $rights_metadata = - &metadata($uri,'keys',$location,'_rights', + &metadata($uri,'keys',$toolsymb,$location,'_rights', $depthcount+1); foreach my $rights (split(',',$rights_metadata)) { #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights}; @@ -11057,26 +12235,57 @@ sub metadata { grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'})); $metaentry{':packages'} = join(',',@uniq_packages); - if ($importedparts) { + if (($importedresponses) || ($importedparts)) { + if ($importedparts) { # We had imported parts and need to rebuild partorder - $metaentry{':partorder'}=''; - $metathesekeys{'partorder'}=1; - for (my $index=0;$index<$#origfileimportpartids;$index+=2) { - if ($origfileimportpartids[$index] eq 'part') { -# original part, part of the problem - $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1]; - } else { -# we have imported parts at this position - $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]}; - } - } - $metaentry{':partorder'}=~s/^\,//; + $metaentry{':partorder'}=''; + $metathesekeys{'partorder'}=1; + } + if ($importedresponses) { +# We had imported responses and need to rebuil responseorder + $metaentry{':responseorder'}=''; + $metathesekeys{'responseorder'}=1; + } + for (my $index=0;$index<$#origfiletagids;$index+=2) { + my $origid = $origfiletagids[$index+1]; + if ($origfiletagids[$index] eq 'part') { +# Original part, part of the problem + if ($importedparts) { + $metaentry{':partorder'}.=','.$origid; + } + } elsif ($origfiletagids[$index] eq 'import') { + if ($importedparts) { +# We have imported parts at this position + if ($importedpartids{$origid} ne '') { + $metaentry{':partorder'}.=','.$importedpartids{$origid}; + } + } + if ($importedresponses) { +# We have imported responses at this position + if ($importedrespids{$origid} ne '') { + $metaentry{':responseorder'}.=','.$importedrespids{$origid}; + } + } + } else { +# Original response item, part of the problem + if ($importedresponses) { + $metaentry{':responseorder'}.=','.$origid; + } + } + } + if ($importedparts) { + $metaentry{':partorder'}=~s/^\,//; + } + if ($importedresponses) { + $metaentry{':responseorder'}=~s/^\,//; + } } - $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); - &do_cache_new('meta',$uri,\%metaentry,$cachetime); + unless ($liburi) { + &do_cache_new('meta',$uri,\%metaentry,$cachetime); + } # this is the end of "was not already recently cached } return $metaentry{':'.$what}; @@ -12086,7 +13295,6 @@ sub repcopy_userfile { } # now the path exists for sure # get a user agent - my $ua=new LWP::UserAgent; my $transferfile=$file.'.in.transfer'; # FIXME: this should flock if (-e $transferfile) { return 'ok'; } @@ -12096,7 +13304,7 @@ sub repcopy_userfile { my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri); - my $response=$ua->request($request,$transferfile); + my $response = &LONCAPA::LWPReq::makerequest($homeserver,$request,$transferfile,\%perlvar,'',0,1); # did it work? if ($response->is_error()) { unlink($transferfile); @@ -12140,9 +13348,8 @@ sub getuploaded { my $protocol = $protocol{$homeserver}; $protocol = 'http' if ($protocol ne 'https'); $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri; - my $ua=new LWP::UserAgent; my $request=new HTTP::Request($reqtype,$uri); - my $response=$ua->request($request); + my $response=&LONCAPA::LWPReq::makerequest($homeserver,$request,'',\%perlvar,'',0,1); $$rtncode = $response->code; if (! $response->is_success()) { return 'failed'; @@ -12159,7 +13366,7 @@ sub readfile { my $file = shift; if ( (! -e $file ) || ($file eq '') ) { return -1; }; my $fh; - open($fh,"<$file"); + open($fh,"<",$file); my $a=''; while (my $line = <$fh>) { $a .= $line; } return $a; @@ -12272,7 +13479,7 @@ sub machine_ids { sub additional_machine_domains { my @domains; - open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab"); + open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab"); while( my $line = <$fh>) { $line =~ s/\s//g; push(@domains,$line); @@ -12343,7 +13550,7 @@ sub clutter { # &logthis("Got a blank emb style"); } } - } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) { + } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { $thisfn='/adm/wrapper'.$thisfn; } return $thisfn; @@ -12418,37 +13625,51 @@ sub get_dns { } my %alldns; - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); - foreach my $dns (<$config>) { - next if ($dns !~ /^\^(\S*)/x); - my $line = $1; - my ($host,$protocol) = split(/:/,$line); - if ($protocol ne 'https') { - $protocol = 'http'; + if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + my $line = $1; + my ($host,$protocol) = split(/:/,$line); + if ($protocol ne 'https') { + $protocol = 'http'; + } + $alldns{$host} = $protocol; } - $alldns{$host} = $protocol; + close($config); } while (%alldns) { my ($dns) = sort { $b cmp $a } keys(%alldns); - my $ua=new LWP::UserAgent; - $ua->timeout(30); my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); - my $response=$ua->request($request); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0); delete($alldns{$dns}); next if ($response->is_error()); - my @content = split("\n",$response->content); - unless ($nocache) { - &do_cache_new('dns',$url,\@content,30*24*60*60); - } - &$func(\@content,$hashref); - return; + if ($url eq '/adm/dns/loncapaCRL') { + return &$func($response); + } else { + my @content = split("\n",$response->content); + unless ($nocache) { + &do_cache_new('dns',$url,\@content,30*24*60*60); + } + &$func(\@content,$hashref); + return; + } + } + my $which = (split('/',$url,4))[3]; + if ($which eq 'loncapaCRL') { + my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; + if (-e $diskfile) { + &logthis("unable to contact DNS, on disk file $diskfile not updated"); + } else { + &logthis("unable to contact DNS, no on disk file $diskfile available"); + } + } else { + &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); + if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) { + my @content = <$config>; + close($config); + &$func(\@content,$hashref); + } } - close($config); - my $which = (split('/',$url))[3]; - &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n"); - open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab"); - my @content = <$config>; - &$func(\@content,$hashref); return; } @@ -12508,6 +13729,79 @@ sub fetch_dns_checksums { return \%checksums; } +sub fetch_crl_pemfile { + return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1); +} + +sub save_crl_pem { + my ($response) = @_; + my ($msg,$hadchanges); + if (ref($response)) { + my $now = time; + my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'}; + my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp'; + if (open(my $fh,'>',"$tmpcrl")) { + print $fh $response->content; + close($fh); + if (-e $lonca) { + if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) { + my $check = ; + close(PIPE); + chomp($check); + if ($check eq 'verify OK') { + my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}"; + my $backup; + if (-e $dest) { + if (&File::Copy::move($dest,"$dest.bak")) { + $backup = 'ok'; + } + } + if (&File::Copy::move($tmpcrl,$dest)) { + $msg = 'ok'; + if ($backup) { + my (%oldnums,%newnums); + if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) { + while () { + $oldnums{(split(/:/))[1]} = 1; + } + close(PIPE); + } + if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) { + while() { + $newnums{(split(/:/))[1]} = 1; + } + close(PIPE); + } + foreach my $key (sort {$b <=> $a } (keys(%newnums))) { + unless (exists($oldnums{$key})) { + $hadchanges = 1; + last; + } + } + unless ($hadchanges) { + foreach my $key (sort {$b <=> $a } (keys(%oldnums))) { + unless (exists($newnums{$key})) { + $hadchanges = 1; + last; + } + } + } + } + } + } else { + unlink($tmpcrl); + } + } else { + unlink($tmpcrl); + } + } else { + unlink($tmpcrl); + } + } + } + return ($msg,$hadchanges); +} + # ------------------------------------------------------------ Read domain file { my $loaded; @@ -12539,7 +13833,7 @@ sub fetch_dns_checksums { my ($ignore_cache,$nocache) = @_; &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); my $fh; - if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { + if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) { my @lines = <$fh>; &parse_domain_tab(\@lines); } @@ -12591,8 +13885,23 @@ sub fetch_dns_checksums { my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); $name=~s/\s//g; if ($id && $domain && $role && $name) { + if ((exists($hostname{$id})) && ($hostname{$id} ne '')) { + my $curr = $hostname{$id}; + my $skip; + if (ref($name_to_host{$curr}) eq 'ARRAY') { + if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) { + $skip = 1; + } else { + @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}}; + } + } + unless ($skip) { + push(@{$name_to_host{$name}},$id); + } + } else { + push(@{$name_to_host{$name}},$id); + } $hostname{$id}=$name; - push(@{$name_to_host{$name}}, $id); $hostdom{$id}=$domain; if ($role eq 'library') { $libserv{$id}=$name; } if (defined($protocol)) { @@ -12615,6 +13924,7 @@ sub fetch_dns_checksums { &purge_remembered(); &reset_domain_info(); &reset_hosts_ip_info(); + undef(%internetdom); undef(%name_to_host); undef(%hostname); undef(%hostdom); @@ -12625,7 +13935,7 @@ sub fetch_dns_checksums { sub load_hosts_tab { my ($ignore_cache,$nocache) = @_; &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab"); my @config = <$config>; &parse_hosts_tab(\@config); close($config); @@ -12657,6 +13967,11 @@ sub fetch_dns_checksums { return %hostdom; } + sub all_host_intdom { + &load_hosts_tab() if (!$loaded); + return %internetdom; + } + sub is_library { &load_hosts_tab() if (!$loaded); @@ -12891,7 +14206,7 @@ sub all_loncaparevs { { sub load_loncaparevs { if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) { + if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) { while (my $configline=<$config>) { chomp($configline); my ($hostid,$loncaparev)=split(/:/,$configline); @@ -12907,7 +14222,7 @@ sub all_loncaparevs { { sub load_serverhomeIDs { if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { + if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) { while (my $configline=<$config>) { chomp($configline); my ($name,$id)=split(/:/,$configline); @@ -12932,7 +14247,7 @@ BEGIN { # ------------------------------------------------------ Read spare server file { - open(my $config,"<$perlvar{'lonTabDir'}/spare.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab"); while (my $configline=<$config>) { chomp($configline); @@ -12946,7 +14261,7 @@ BEGIN { } # ------------------------------------------------------------ Read permissions { - open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); @@ -12960,7 +14275,7 @@ BEGIN { # -------------------------------------------- Read plain texts for permissions { - open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab"); while (my $configline=<$config>) { chomp($configline); @@ -12980,7 +14295,7 @@ BEGIN { # ---------------------------------------------------------- Read package table { - open(my $config,"<$perlvar{'lonTabDir'}/packages.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab"); while (my $configline=<$config>) { if ($configline !~ /\S/ || $configline=~/^#/) { next; } @@ -13014,10 +14329,17 @@ BEGIN { my $name = $token->[2]{'name'}; my $value = $token->[2]{'value'}; my $valuematch = $token->[2]{'valuematch'}; - if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) { + my $namematch = $token->[2]{'namematch'}; + if ($item eq 'parameter') { + if (($namematch ne '') || (($name ne '') && ($value ne '' || $valuematch ne ''))) { + my $release = $parser->get_text(); + $release =~ s/(^\s*|\s*$ )//gx; + $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch.':'.$namematch} = $release; + } + } elsif ($item ne '' && $name ne '') { my $release = $parser->get_text(); $release =~ s/(^\s*|\s*$ )//gx; - $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release; + $needsrelease{$item.':'.$name.':'.$value} = $release; } } } @@ -13027,7 +14349,7 @@ BEGIN { # ---------------------------------------------------------- Read managers table { if (-e "$perlvar{'lonTabDir'}/managers.tab") { - if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { + if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) { while (my $configline=<$config>) { chomp($configline); next if ($configline =~ /^\#/); @@ -13403,9 +14725,10 @@ in which case the null string is returne =item * -definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom -role rolename set privileges in format of lonTabs/roles.tab for system, domain, -and course level +definerole($rolename,$sysrole,$domrole,$courole,$uname,$udom) : define role; +define a custom role rolename set privileges in format of lonTabs/roles.tab +for system, domain, and course level. $uname and $udom are optional (current +user's username and domain will be used when either of $uname or $udom are absent. =item * @@ -13609,6 +14932,8 @@ Inputs: =item $credits, number of credits student will earn from this class +=item $instsec, institutional course section code for student + =back @@ -13763,12 +15088,18 @@ condval($condidx) : value of condition i =item * -metadata($uri,$what,$liburi,$prefix,$depthcount) : request a +metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a resource's metadata, $what should be either a specific key, or either 'keys' (to get a list of possible keys) or 'packages' to get a list of -packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata. +packages that this resource currently uses, the last 3 arguments are +only used internally for recursive metadata. + +the toolsymb is only used where the uri is for an external tool (for which +the uri as well as the symb are guaranteed to be unique). -this function automatically caches all requests +this function automatically caches all requests except any made recursively +to retrieve a list of metadata keys for an imported library file ($liburi is +defined). =item * @@ -14077,7 +15408,7 @@ requestcourses: ability to request cours =over =item -official, unofficial, community, textbook +official, unofficial, community, textbook, placement =back @@ -14099,7 +15430,7 @@ for course's uploaded content. =item canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, -communityquota, textbookquota +communityquota, textbookquota, placementquota =back 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.