--- loncom/lonnet/perl/lonnet.pm 2016/09/21 05:15:40 1.1324 +++ loncom/lonnet/perl/lonnet.pm 2018/08/14 18:29:33 1.1382 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1324 2016/09/21 05:15:40 raeburn Exp $ +# $Id: lonnet.pm,v 1.1382 2018/08/14 18:29:33 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,7 +71,6 @@ delayed. package Apache::lonnet; use strict; -use LWP::UserAgent(); use HTTP::Date; use Image::Magick; @@ -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); } @@ -243,6 +243,10 @@ sub get_servercerts_info { if ($1 < 6) { $uselocal = 0; } + } elsif ($distro =~ /^(?:sles)(\d+)$/) { + if ($1 < 12) { + $uselocal = 0; + } } } if ($uselocal) { @@ -305,13 +309,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>/) { @@ -483,7 +485,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) { @@ -523,7 +525,7 @@ sub critical { $dumpcount++; { my $dfh; - if (open($dfh,">$dfilename")) { + if (open($dfh,">",$dfilename)) { print $dfh "$cmd\n"; close($dfh); } @@ -532,7 +534,7 @@ sub critical { my $wcmd=''; { my $dfh; - if (open($dfh,"<$dfilename")) { + if (open($dfh,"<",$dfilename)) { $wcmd=<$dfh>; close($dfh); } @@ -648,22 +650,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); @@ -683,6 +715,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; @@ -733,16 +770,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'; @@ -1049,7 +1089,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 @@ -1321,7 +1361,7 @@ 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); my $lonhost = $perlvar{'lonHostID'}; @@ -1472,13 +1512,15 @@ 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)) { + 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}); + &appenv({'user.loadbalexempt' => $lonhost, + 'user.loadbalcheck.time' => time}); + } } } } @@ -1581,6 +1623,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; @@ -1830,7 +1966,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; @@ -1874,7 +2015,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"); } @@ -1965,13 +2110,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); @@ -2006,6 +2161,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).':'. @@ -2245,7 +2408,7 @@ sub get_domain_defaults { 'coursedefaults','usersessions', 'requestauthor','selfenrollment', 'coursecategories','ssl','autoenroll', - 'trust'],$domain); + 'trust','helpsettings'],$domain); my @coursetypes = ('official','unofficial','community','textbook','placement'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; @@ -2254,6 +2417,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'); @@ -2321,6 +2487,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') { @@ -2375,8 +2544,11 @@ sub get_domain_defaults { if (ref($domconfig{'ssl'}{'replication'}) eq 'HASH') { $domdefaults{'replication'} = $domconfig{'ssl'}{'replication'}; } - if (ref($domconfig{'ssl'}{'connect'}) eq 'HASH') { - $domdefaults{'connect'} = $domconfig{'ssl'}{'connect'}; + if (ref($domconfig{'ssl'}{'connto'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connto'}; + } + if (ref($domconfig{'ssl'}{'connfrom'}) eq 'HASH') { + $domdefaults{'connect'} = $domconfig{'ssl'}{'connfrom'}; } } if (ref($domconfig{'trust'}) eq 'HASH') { @@ -2390,6 +2562,12 @@ sub get_domain_defaults { if (ref($domconfig{'autoenroll'}) eq 'HASH') { $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'}; } + if (ref($domconfig{'helpsettings'}) eq 'HASH') { + $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'}; + if (ref($domconfig{'helpsettings'}{'adhoc'}) eq 'HASH') { + $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'}; + } + } &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime); return %domdefaults; } @@ -2917,9 +3095,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; @@ -2929,7 +3111,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( @@ -2992,7 +3179,6 @@ sub absolute_url { sub ssi { my ($fn,%form)=@_; - my $ua=new LWP::UserAgent; my $request; $form{'no_update_last_known'}=1; @@ -3010,22 +3196,20 @@ sub ssi { } $request->header(Cookie => $ENV{'HTTP_COOKIE'}); - my $response= $ua->request($request); - my $content = $response->content; - + my $lonhost = $perlvar{'lonHostID'}; + my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar); 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 { @@ -3033,6 +3217,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 { @@ -3171,7 +3420,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; @@ -3203,7 +3452,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; @@ -3221,7 +3470,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://}{}; @@ -3382,7 +3631,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') { @@ -3440,7 +3689,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); @@ -3556,12 +3805,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'}; @@ -3591,7 +3840,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') { @@ -3666,7 +3915,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'; @@ -3724,7 +3973,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; } @@ -4108,7 +4358,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)) { @@ -4255,7 +4505,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} @@ -4482,6 +4732,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 # # @@ -4495,7 +4934,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); @@ -4722,6 +5161,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 { @@ -4790,6 +5244,9 @@ sub set_first_access { 'course.'.$courseid.'.timerinterval.'.$res => $interval, } ); + if (($cachedtime) && (abs($start-$cachedtime) < 5)) { + $cachedtimes{"$courseid\0$res"} = $start; + } } return $putres; } @@ -5576,9 +6033,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); } @@ -5614,6 +6072,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; } @@ -5622,6 +6084,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; @@ -5656,6 +6160,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; @@ -5703,6 +6208,7 @@ sub set_userprivs { $thesepriv{$privilege}.=$restrictions; } if ($thesepriv{'adv'} eq 'F') { $adv=1; } + if ($thesepriv{'rar'} eq 'F') { $rar=1; } } } my $thesestr=''; @@ -5711,7 +6217,7 @@ sub set_userprivs { } $userroles->{'user.priv.'.$role} = $thesestr; } - return ($author,$adv); + return ($author,$adv,$rar); } sub role_status { @@ -5756,9 +6262,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'; @@ -5834,39 +6341,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; @@ -6016,7 +6540,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,'.'); @@ -6250,9 +6774,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; @@ -6635,6 +7161,7 @@ sub usertools_access { community => 1, textbook => 1, placement => 1, + lti => 1, ); } elsif ($context eq 'requestauthor') { %tools = ( @@ -6831,25 +7358,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) { @@ -6866,7 +7397,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; @@ -6948,7 +7479,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'; @@ -6996,7 +7527,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'; } @@ -7436,7 +7970,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 ''; } @@ -7784,7 +8318,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"; } @@ -7812,11 +8346,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'; } @@ -7949,7 +8491,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 { @@ -7978,7 +8520,7 @@ sub get_query_reply { for (1..$loopmax) { sleep($sleep); if (-e $replyfile.'.end') { - if (open(my $fh,$replyfile)) { + if (open(my $fh,"<",$replyfile)) { $reply = join('',<$fh>); close($fh); } else { return 'error: reply_file_error'; } @@ -8370,6 +8912,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) = @_; @@ -8729,7 +9298,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')); @@ -8749,8 +9318,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 '')) { @@ -8865,7 +9438,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')) { @@ -9015,10 +9589,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; @@ -9463,12 +10041,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; } @@ -9604,7 +10195,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"); } @@ -9618,7 +10209,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"); @@ -9628,7 +10219,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); @@ -9650,7 +10241,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); @@ -10635,23 +11226,40 @@ sub resdata { return undef; } -sub get_domain_ltitools { - my ($cdom) = @_; - my %ltitools; - my ($result,$cached)=&is_cached_new('ltitools',$cdom); +sub get_domain_lti { + my ($cdom,$context) = @_; + my ($name,%lti); + if ($context eq 'consumer') { + $name = 'ltitools'; + } elsif ($context eq 'provider') { + $name = 'lti'; + } else { + return %lti; + } + my ($result,$cached)=&is_cached_new($name,$cdom); if (defined($cached)) { if (ref($result) eq 'HASH') { - %ltitools = %{$result}; + %lti = %{$result}; } } else { - my %domconfig = &get_dom('configuration',['ltitools'],$cdom); - if (ref($domconfig{'ltitools'}) eq 'HASH') { - %ltitools = %{$domconfig{'ltitools'}}; + my %domconfig = &get_dom('configuration',[$name],$cdom); + if (ref($domconfig{$name}) eq 'HASH') { + %lti = %{$domconfig{$name}}; + my %encdomconfig = &get_dom('encconfig',[$name],$cdom); + if (ref($encdomconfig{$name}) eq 'HASH') { + foreach my $id (keys(%lti)) { + if (ref($encdomconfig{$name}{$id}) eq 'HASH') { + foreach my $item ('key','secret') { + $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; + } + } + } + } } my $cachetime = 24*60*60; - &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime); + &do_cache_new($name,$cdom,\%lti,$cachetime); } - return %ltitools; + return %lti; } sub get_numsuppfiles { @@ -10664,10 +11272,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); } @@ -10957,9 +11566,13 @@ sub EXT { } else { $filename=$env{'request.filename'}; } - my $metadata=&metadata($filename,$what); + my $toolsymb; + if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) { + $toolsymb = $symbparm; + } + my $metadata=&metadata($filename,$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } - $metadata=&metadata($filename,'parameter_'.$what); + $metadata=&metadata($filename,'parameter_'.$what,$toolsymb); if (defined($metadata)) { return &get_reply([$metadata,'resource']); } # ----------------------------------------------- fifth, look in rest of course @@ -10985,7 +11598,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') { @@ -11079,11 +11692,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; @@ -11150,13 +11763,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; } @@ -11175,11 +11789,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? # @@ -11274,27 +11949,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); @@ -11305,22 +12030,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 { # @@ -11389,7 +12128,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}; @@ -11403,26 +12142,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}; @@ -12432,7 +13202,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'; } @@ -12442,7 +13211,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); @@ -12486,9 +13255,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'; @@ -12505,7 +13273,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; @@ -12618,7 +13386,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); @@ -12689,7 +13457,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; @@ -12764,37 +13532,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; } @@ -12854,6 +13636,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; @@ -12885,7 +13740,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); } @@ -12937,8 +13792,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)) { @@ -12961,6 +13831,7 @@ sub fetch_dns_checksums { &purge_remembered(); &reset_domain_info(); &reset_hosts_ip_info(); + undef(%internetdom); undef(%name_to_host); undef(%hostname); undef(%hostdom); @@ -12971,7 +13842,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); @@ -13003,6 +13874,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); @@ -13237,7 +14113,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); @@ -13253,7 +14129,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); @@ -13278,7 +14154,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); @@ -13292,7 +14168,7 @@ BEGIN { } # ------------------------------------------------------------ Read permissions { - open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13306,7 +14182,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); @@ -13326,7 +14202,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; } @@ -13380,7 +14256,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 =~ /^\#/); @@ -13756,9 +14632,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 * @@ -14118,12 +14995,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 *