--- loncom/lonnet/perl/lonnet.pm 2014/10/13 15:47:14 1.1172.2.55 +++ loncom/lonnet/perl/lonnet.pm 2020/04/10 13:33:32 1.1172.2.93.2.3 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.55 2014/10/13 15:47:14 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.93.2.3 2020/04/10 13:33:32 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -89,7 +89,7 @@ use GDBM_File; use HTML::LCParser; use Fcntl qw(:flock); use Storable qw(thaw nfreeze); -use Time::HiRes qw( gettimeofday tv_interval ); +use Time::HiRes qw( sleep gettimeofday tv_interval ); use Cache::Memcached; use Digest::MD5; use Math::Random; @@ -102,7 +102,7 @@ use LONCAPA::Lond; use File::Copy; my $readit; -my $max_connection_retries = 10; # Or some such value. +my $max_connection_retries = 20; # Or some such value. require Exporter; @@ -370,7 +370,7 @@ sub subreply { my $lockfile=$peerfile.".lock"; while (-e $lockfile) { # Need to wait for the lockfile to disappear. - sleep(1); + sleep(0.1); } # At this point, either a loncnew parent is listening or an old lonc # or loncnew child is listening so we can connect or everything's dead. @@ -388,7 +388,7 @@ sub subreply { } else { &create_connection(&hostname($server),$server); } - sleep(1); # Try again later if failed connection. + sleep(0.1); # Try again later if failed connection. } my $answer; if ($client) { @@ -417,8 +417,8 @@ sub reply { sub reconlonc { my ($lonid) = @_; - my $hostname = &hostname($lonid); if ($lonid) { + my $hostname = &hostname($lonid); my $peerfile="$perlvar{'lonSockDir'}/$hostname"; if ($hostname && -e $peerfile) { &logthis("Trying to reconnect lonc for $lonid ($hostname)"); @@ -464,7 +464,7 @@ sub critical { } my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { - &reconlonc("$perlvar{'lonSockDir'}/$server"); + &reconlonc($server); my $answer=reply($cmd,$server); if ($answer eq 'con_lost') { my $now=time; @@ -481,7 +481,7 @@ sub critical { close($dfh); } } - sleep 2; + sleep 1; my $wcmd=''; { my $dfh; @@ -844,10 +844,8 @@ sub spareserver { if (ref($spareshash) eq 'HASH') { if (ref($spareshash->{'primary'}) eq 'ARRAY') { foreach my $try_server (@{ $spareshash->{'primary'} }) { - if ($uint_dom) { - next unless (&spare_can_host($udom,$uint_dom,$remotesessions, - $try_server)); - } + next unless (&spare_can_host($udom,$uint_dom,$remotesessions, + $try_server)); ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -858,10 +856,8 @@ sub spareserver { if (!$found_server) { if (ref($spareshash->{'default'}) eq 'ARRAY') { foreach my $try_server (@{ $spareshash->{'default'} }) { - if ($uint_dom) { - next unless (&spare_can_host($udom,$uint_dom, - $remotesessions,$try_server)); - } + next unless (&spare_can_host($udom,$uint_dom, + $remotesessions,$try_server)); ($spare_server, $lowest_load) = &compare_server_load($try_server, $spare_server, $lowest_load); } @@ -1006,7 +1002,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 @@ -1173,19 +1169,27 @@ sub can_host_session { sub spare_can_host { my ($udom,$uint_dom,$remotesessions,$try_server)=@_; my $canhost=1; - my @intdoms; - my $internet_names = &Apache::lonnet::get_internet_names($try_server); - if (ref($internet_names) eq 'ARRAY') { - @intdoms = @{$internet_names}; - } - unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { - my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server); - my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); - my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom); - my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server); - $canhost = &can_host_session($udom,$try_server,$remoterev, - $remotesessions, - $defdomdefaults{'hostedsessions'}); + my $try_server_hostname = &hostname($try_server); + my $serverhomeID = &get_server_homeID($try_server_hostname); + my $serverhomedom = &host_domain($serverhomeID); + my %defdomdefaults = &get_domain_defaults($serverhomedom); + if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') { + if ($defdomdefaults{'offloadnow'}{$try_server}) { + $canhost = 0; + } + } + if (($canhost) && ($uint_dom)) { + my @intdoms; + my $internet_names = &get_internet_names($try_server); + if (ref($internet_names) eq 'ARRAY') { + @intdoms = @{$internet_names}; + } + unless (grep(/^\Q$uint_dom\E$/,@intdoms)) { + my $remoterev = &get_server_loncaparev(undef,$try_server); + $canhost = &can_host_session($udom,$try_server,$remoterev, + $remotesessions, + $defdomdefaults{'hostedsessions'}); + } } return $canhost; } @@ -1270,7 +1274,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'}; @@ -1279,7 +1283,7 @@ sub check_loadbalancing { 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)) { @@ -1294,6 +1298,8 @@ 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') { @@ -1352,7 +1358,9 @@ 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') { @@ -1372,12 +1380,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; @@ -1408,13 +1425,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}); + } } } } @@ -1550,7 +1569,7 @@ sub idget { my %servers = &get_servers($udom,'library'); foreach my $tryserver (keys(%servers)) { - my $idlist=join('&',@ids); + my $idlist=join('&', map { &escape($_); } @ids); $idlist=~tr/A-Z/a-z/; my $reply=&reply("idget:$udom:".$idlist,$tryserver); my @answer=(); @@ -1560,7 +1579,7 @@ sub idget { my $i; for ($i=0;$i<=$#ids;$i++) { if ($answer[$i]) { - $returnhash{$ids[$i]}=$answer[$i]; + $returnhash{$ids[$i]}=&unescape($answer[$i]); } } } @@ -1647,6 +1666,7 @@ sub dump_dom { sub get_dom { my ($namespace,$storearr,$udom,$uhome)=@_; + return if ($udom eq 'public'); my $items=''; foreach my $item (@$storearr) { $items.=&escape($item).'&'; @@ -1654,6 +1674,7 @@ sub get_dom { $items=~s/\&$//; if (!$udom) { $udom=$env{'user.domain'}; + return if ($udom eq 'public'); if (defined(&domain($udom,'primary'))) { $uhome=&domain($udom,'primary'); } else { @@ -1667,7 +1688,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; @@ -1711,7 +1737,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"); } @@ -1787,7 +1817,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'; } @@ -1808,7 +1838,7 @@ sub inst_directory_query { &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); @@ -1928,6 +1958,63 @@ sub get_instuser { return ($outcome,%userinfo); } +sub get_multiple_instusers { + my ($udom,$users,$caller) = @_; + my ($outcome,$results); + if (ref($users) eq 'HASH') { + my $count = keys(%{$users}); + my $requested = &freeze_escape($users); + my $homeserver = &domain($udom,'primary'); + if ($homeserver ne '') { + my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver); + my $host=&hostname($homeserver); + if ($queryid !~/^\Q$host\E\_/) { + &logthis('get_multiple_instusers invalid queryid: '.$queryid. + ' for host: '.$homeserver.'in domain '.$udom); + return ($outcome,$results); + } + my $response = &get_query_reply($queryid); + my $maxtries = 5; + if ($count > 100) { + $maxtries = 1+int($count/20); + } + my $tries = 1; + while (($response=~/^timeout/) && ($tries <= $maxtries)) { + $response = &get_query_reply($queryid); + $tries ++; + } + if ($response eq '') { + $results = {}; + foreach my $key (keys(%{$users})) { + my ($uname,$id); + if ($caller eq 'id') { + $id = $key; + } else { + $uname = $key; + } + my ($resp,%info) = &get_instuser($udom,$uname,$id); + $outcome = $resp; + if ($resp eq 'ok') { + %{$results} = (%{$results}, %info); + } else { + last; + } + } + } elsif(!&error($response) && ($response ne 'refused')) { + if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) { + $outcome = $response; + } else { + ($outcome,my $userdata) = split(/=/,$response,2); + if ($outcome eq 'ok') { + $results = &thaw_unescape($userdata); + } + } + } + } + } + return ($outcome,$results); +} + sub inst_rulecheck { my ($udom,$uname,$id,$item,$rules) = @_; my %returnhash; @@ -2024,7 +2111,8 @@ sub get_domain_defaults { 'requestcourses','inststatus', 'coursedefaults','usersessions', 'requestauthor','selfenrollment', - 'coursecategories'],$domain); + 'coursecategories','autoenroll', + 'helpsettings'],$domain); my @coursetypes = ('official','unofficial','community','textbook'); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; @@ -2033,6 +2121,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'); @@ -2068,6 +2159,11 @@ sub get_domain_defaults { } } if (ref($domconfig{'coursedefaults'}) eq 'HASH') { + $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'}; + $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'}; + if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') { + $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'}; + } foreach my $type (@coursetypes) { if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') { unless ($type eq 'community') { @@ -2077,6 +2173,22 @@ sub get_domain_defaults { if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') { $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type}; } + if ($domdefaults{'postsubmit'} eq 'on') { + if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') { + $domdefaults{$type.'postsubtimeout'} = + $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type}; + } + } + } + if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') { + if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') { + my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}}; + if (@clonecodes) { + $domdefaults{'canclone'} = join('+',@clonecodes); + } + } + } elsif ($domconfig{'coursedefaults'}{'canclone'}) { + $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'}; } } if (ref($domconfig{'usersessions'}) eq 'HASH') { @@ -2086,6 +2198,9 @@ sub get_domain_defaults { if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') { $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'}; } + if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') { + $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'}; + } } if (ref($domconfig{'selfenrollment'}) eq 'HASH') { if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') { @@ -2125,10 +2240,35 @@ sub get_domain_defaults { $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'}; } } + 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 { @@ -2365,21 +2505,25 @@ 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) for + # keys in %remembered hash, which persists for + # duration of request (no restriction on key length). + 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"); } @@ -2389,13 +2533,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)) { @@ -2411,17 +2556,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; @@ -2715,7 +2860,12 @@ sub ssi { &Apache::lonenc::check_encrypt(\$fn); if (%form) { $request=new HTTP::Request('POST',&absolute_url().$fn); - $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form))); + $request->content(join('&',map { + my $name = escape($_); + "$name=" . ( ref($form{$_}) eq 'ARRAY' + ? join("&$name=", map {escape($_) } @{$form{$_}}) + : &escape($form{$_}) ); + } keys(%form))); } else { $request=new HTTP::Request('GET',&absolute_url().$fn); } @@ -2879,6 +3029,14 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; + } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + } else { + $forceedit = 1; + } + $cfile = $resurl; } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { $incourse = 1; if ($env{'form.forceedit'}) { @@ -2903,6 +3061,14 @@ sub can_edit_resource { $forceedit = 1; } $cfile = $resurl; + } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) { + $incourse = 1; + if ($env{'form.forceedit'}) { + $forceview = 1; + } else { + $forceedit = 1; + } + $cfile = $resurl; } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { $incourse = 1; $forceview = 1; @@ -2912,8 +3078,13 @@ sub can_edit_resource { $cfile = &clutter($res); } else { $cfile = $env{'form.suppurl'}; - $cfile =~ s{^http://}{}; - $cfile = '/adm/wrapper/ext/'.$cfile; + my $escfile = &unescape($cfile); + if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { + $cfile = '/adm/wrapper'.$escfile; + } else { + $escfile =~ s{^http://}{}; + $cfile = &escape("/adm/wrapper/ext/$escfile"); + } } } elsif ($resurl =~ m{^/?adm/viewclasslist$}) { if ($env{'form.forceedit'}) { @@ -3795,7 +3966,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)) { @@ -3810,10 +3981,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); } } @@ -3933,7 +4113,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} @@ -4160,6 +4340,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 # # @@ -4236,7 +4605,7 @@ sub courseiddump { $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok, $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone, $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner, - $hasuniquecode)=@_; + $hasuniquecode,$reqcrsdom,$reqinstcode)=@_; my $as_hash = 1; my %returnhash; if (!$domfilter) { $domfilter=''; } @@ -4259,7 +4628,8 @@ sub courseiddump { &escape($catfilter), $showhidden, $caller, &escape($cloner), &escape($cc_clone), $cloneonly, &escape($createdbefore), &escape($createdafter), - &escape($creationcontext), $domcloner, $hasuniquecode))); + &escape($creationcontext),$domcloner,$hasuniquecode, + $reqcrsdom,&escape($reqinstcode)))); } else { $rep = &reply('courseiddump:'.&host_domain($tryserver).':'. $sincefilter.':'.&escape($descfilter).':'. @@ -4270,8 +4640,8 @@ sub courseiddump { $showhidden.':'.$caller.':'.&escape($cloner).':'. &escape($cc_clone).':'.$cloneonly.':'. &escape($createdbefore).':'.&escape($createdafter).':'. - &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode, - $tryserver); + &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode. + ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver); } my @pairs=split(/\&/,$rep); @@ -4399,6 +4769,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 { @@ -4410,12 +4795,13 @@ my $cachedkey=''; # The cached times for this user my %cachedtimes=(); # When this was last done -my $cachedtime=(); +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; @@ -4424,7 +4810,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); @@ -4436,7 +4822,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"}; } @@ -4928,7 +5314,7 @@ sub tmprestore { # ----------------------------------------------------------------------- Store sub store { - my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } @@ -4958,13 +5344,13 @@ sub store { } $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue); - return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); + return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); } # -------------------------------------------------------------- Critical Store sub cstore { - my ($storehash,$symb,$namespace,$domain,$stuname) = @_; + my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_; my $home=''; if ($stuname) { $home=&homeserver($stuname,$domain); } @@ -4995,7 +5381,7 @@ sub cstore { $namevalue=~s/\&$//; &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue); return critical - ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home"); + ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home"); } # --------------------------------------------------------------------- Restore @@ -5175,7 +5561,7 @@ sub privileged { my %rolesdump = &dump("roles", $domain, $username) or return 0; my $now = time; - for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) { + for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) { my ($trole, $tend, $tstart) = split(/_/, $role); if (grep(/^\Q$trole\E$/,@{$roles})) { return 1 unless ($tend && $tend < $now) @@ -5264,7 +5650,7 @@ sub rolesinit { my %allroles=(); my %allgroups=(); - for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) { + for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) { my $role = $rolesdump{$area}; $area =~ s/\_\w\w$//; @@ -5337,9 +5723,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); } @@ -5375,6 +5762,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; } @@ -5383,6 +5774,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; @@ -5417,6 +5850,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; @@ -5464,6 +5898,7 @@ sub set_userprivs { $thesepriv{$privilege}.=$restrictions; } if ($thesepriv{'adv'} eq 'F') { $adv=1; } + if ($thesepriv{'rar'} eq 'F') { $rar=1; } } } my $thesestr=''; @@ -5472,7 +5907,7 @@ sub set_userprivs { } $userroles->{'user.priv.'.$role} = $thesestr; } - return ($author,$adv); + return ($author,$adv,$rar); } sub role_status { @@ -5517,9 +5952,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'; @@ -5595,39 +6031,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; @@ -5775,7 +6228,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,'.'); @@ -5891,7 +6344,7 @@ sub newput { # --------------------------------------------------------- putstore interface sub putstore { - my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_; + my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -5905,6 +6358,17 @@ sub putstore { my $reply = &reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items", $uhome); + if (($tolog) && ($reply eq 'ok')) { + my $namevalue=''; + foreach my $key (keys(%{$storehash})) { + $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&'; + } + $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}). + '&host='.&escape($perlvar{'lonHostID'}). + '&version='.$esc_v. + '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'}); + &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue); + } if ($reply eq 'unknown_cmd') { # gfall back to way things use to be done return &old_putstore($namespace,$symb,$version,$storehash,$udomain, @@ -5998,9 +6462,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; @@ -6063,10 +6529,15 @@ sub get_timebased_id { my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); my $id = time; $newid = $id; + if ($idtype eq 'addcode') { + $newid .= &sixnum_code(); + } my $idtries = 0; while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) { if ($idtype eq 'concat') { $newid = $id.$idtries; + } elsif ($idtype eq 'addcode') { + $newid = $newid.&sixnum_code(); } else { $newid ++; } @@ -6083,6 +6554,7 @@ sub get_timebased_id { $error = 'error saving new item: '.$putresult; } } else { + undef($newid); $error = ('error: no unique suffix available for the new item '); } # remove lock @@ -6091,16 +6563,27 @@ sub get_timebased_id { } else { $error = "error: could not obtain lockfile\n"; $dellock = 'ok'; + if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) { + $dellock = 'nolock'; + } } return ($newid,$dellock,$error); } +sub sixnum_code { + my $code; + for (0..6) { + $code .= int( rand(9) ); + } + return $code; +} + # -------------------------------------------------- portfolio access checking sub portfolio_access { - my ($requrl) = @_; + my ($requrl,$clientip) = @_; my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); - my $result = &get_portfolio_access($udom,$unum,$file_name,$group); + my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip); if ($result) { my %setters; if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { @@ -6126,7 +6609,7 @@ sub portfolio_access { } sub get_portfolio_access { - my ($udom,$unum,$file_name,$group,$access_hash) = @_; + my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_; if (!ref($access_hash)) { my $current_perms = &get_portfile_permissions($udom,$unum); @@ -6135,7 +6618,7 @@ sub get_portfolio_access { $access_hash = $access_controls{$file_name}; } - my ($public,$guest,@domains,@users,@courses,@groups); + my ($public,$guest,@domains,@users,@courses,@groups,@ips); my $now = time; if (ref($access_hash) eq 'HASH') { foreach my $key (keys(%{$access_hash})) { @@ -6159,10 +6642,25 @@ sub get_portfolio_access { push(@courses,$key); } elsif ($scope eq 'group') { push(@groups,$key); + } elsif ($scope eq 'ip') { + push(@ips,$key); } } if ($public) { return 'ok'; + } elsif (@ips > 0) { + my $allowed; + foreach my $ipkey (@ips) { + if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') { + if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) { + $allowed = 1; + last; + } + } + } + if ($allowed) { + return 'ok'; + } } if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { if ($guest) { @@ -6646,7 +7144,7 @@ sub customaccess { # ------------------------------------------------- Check for a user privilege sub allowed { - my ($priv,$uri,$symb,$role)=@_; + my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_; my $ver_orguri=$uri; $uri=&deversion($uri); my $orguri=$uri; @@ -6663,7 +7161,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'; @@ -6841,11 +7339,16 @@ sub allowed { if ($match) { if ($env{'user.priv.'.$env{'request.role'}.'./'} =~/\Q$priv\E\&([^\:]*)/) { - my @blockers = &has_comm_blocking($priv,$symb,$uri); - if (@blockers > 0) { - $thisallowed = 'B'; + my $value = $1; + if ($noblockcheck) { + $thisallowed.=$value; } else { - $thisallowed.=$1; + my @blockers = &has_comm_blocking($priv,$symb,$uri); + if (@blockers > 0) { + $thisallowed = 'B'; + } else { + $thisallowed.=$value; + } } } } else { @@ -6857,11 +7360,15 @@ sub allowed { $refuri=&declutter($refuri); my ($match) = &is_on_map($refuri); if ($match) { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { + if ($noblockcheck) { $thisallowed='F'; + } else { + my @blockers = &has_comm_blocking($priv,$symb,$refuri); + if (@blockers > 0) { + $thisallowed = 'B'; + } else { + $thisallowed='F'; + } } } } @@ -6873,7 +7380,7 @@ sub allowed { && $thisallowed ne 'F' && $thisallowed ne '2' && &is_portfolio_url($uri)) { - $thisallowed = &portfolio_access($uri); + $thisallowed = &portfolio_access($uri,$clientip); } # Full access at system, domain or course-wide level? Exit. @@ -6916,11 +7423,15 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - my @blockers = &has_comm_blocking($priv,$symb,$uri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { + if ($noblockcheck) { $thisallowed.=$value; + } else { + my @blockers = &has_comm_blocking($priv,$symb,$uri); + if (@blockers > 0) { + $thisallowed = 'B'; + } else { + $thisallowed.=$value; + } } } else { $thisallowed.=$value; @@ -6954,11 +7465,15 @@ sub allowed { =~/\Q$priv\E\&([^\:]*)/) { my $value = $1; if ($priv eq 'bre') { - my @blockers = &has_comm_blocking($priv,$symb,$refuri); - if (@blockers > 0) { - $thisallowed = 'B'; - } else { + if ($noblockcheck) { $thisallowed.=$value; + } else { + my @blockers = &has_comm_blocking($priv,$symb,$refuri); + if (@blockers > 0) { + $thisallowed = 'B'; + } else { + $thisallowed.=$value; + } } } else { $thisallowed.=$value; @@ -7134,7 +7649,7 @@ sub constructaccess { my ($ownername,$ownerdomain,$ownerhome); ($ownerdomain,$ownername) = - ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/}); + ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)}); # The URL does not really point to any authorspace, forget it unless (($ownername) && ($ownerdomain)) { return ''; } @@ -7189,6 +7704,32 @@ sub constructaccess { return ''; } +# ----------------------------------------------------------- Content Blocking + +{ +# Caches for faster Course Contents display where content blocking +# is in operation (i.e., interval param set) for timed quiz. +# +# User for whom data are being temporarily cached. +my $cacheduser=''; +# Cached blockers for this user (a hash of blocking items). +my %cachedblockers=(); +# When the data were last cached. +my $cachedlast=''; + +sub load_all_blockers { + my ($uname,$udom,$blocks)=@_; + if (($uname ne '') && ($udom ne '')) { + if (($cacheduser eq $uname.':'.$udom) && + (abs($cachedlast-time)<5)) { + return; + } + } + $cachedlast=time; + $cacheduser=$uname.':'.$udom; + %cachedblockers = &get_commblock_resources($blocks); +} + sub get_comm_blocks { my ($cdom,$cnum) = @_; if ($cdom eq '' || $cnum eq '') { @@ -7209,27 +7750,21 @@ sub get_comm_blocks { return %commblocks; } -sub has_comm_blocking { - my ($priv,$symb,$uri,$blocks) = @_; - return unless ($env{'request.course.id'}); - return unless ($priv eq 'bre'); - return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); +sub get_commblock_resources { + my ($blocks) = @_; + my %blockers = (); + return %blockers unless ($env{'request.course.id'}); + return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); my %commblocks; if (ref($blocks) eq 'HASH') { %commblocks = %{$blocks}; } else { %commblocks = &get_comm_blocks(); } - return unless (keys(%commblocks) > 0); - if (!$symb) { $symb=&symbread($uri,1); } - my ($map,$resid,undef)=&decode_symb($symb); - my %tocheck = ( - maps => $map, - resources => $symb, - ); - my @blockers; - my $now = time; + return %blockers unless (keys(%commblocks) > 0); my $navmap = Apache::lonnavmaps::navmap->new(); + return %blockers unless (ref($navmap)); + my $now = time; foreach my $block (keys(%commblocks)) { if ($block =~ /^(\d+)____(\d+)$/) { my ($start,$end) = ($1,$2); @@ -7237,17 +7772,13 @@ sub has_comm_blocking { if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { - if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); - } + if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { + $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; } } if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { - if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); - } + if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { + $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; } } } @@ -7258,32 +7789,31 @@ sub has_comm_blocking { my @to_test; if (ref($commblocks{$block}{'blocks'}) eq 'HASH') { if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') { - my $check_interval; - if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) { - my @interval; - my $type = 'map'; - if ($item eq 'course') { - $type = 'course'; - @interval=&EXT("resource.0.interval"); + my @interval; + my $type = 'map'; + if ($item eq 'course') { + $type = 'course'; + @interval=&EXT("resource.0.interval"); + } else { + if ($item =~ /___\d+___/) { + $type = 'resource'; + @interval=&EXT("resource.0.interval",$item); + if (ref($navmap)) { + my $res = $navmap->getBySymb($item); + push(@to_test,$res); + } } else { - if ($item =~ /___\d+___/) { - $type = 'resource'; - @interval=&EXT("resource.0.interval",$item); - if (ref($navmap)) { - my $res = $navmap->getBySymb($item); - push(@to_test,$res); - } - } else { - my $mapsymb = &symbread($item,1); - if ($mapsymb) { - if (ref($navmap)) { - my $mapres = $navmap->getBySymb($mapsymb); - @to_test = $mapres->retrieveResources($mapres,undef,0,1); - foreach my $res (@to_test) { - my $symb = $res->symb(); - next if ($symb eq $mapsymb); - if ($symb ne '') { - @interval=&EXT("resource.0.interval",$symb); + my $mapsymb = &symbread($item,1); + if ($mapsymb) { + if (ref($navmap)) { + my $mapres = $navmap->getBySymb($mapsymb); + @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1); + foreach my $res (@to_test) { + my $symb = $res->symb(); + next if ($symb eq $mapsymb); + if ($symb ne '') { + @interval=&EXT("resource.0.interval",$symb); + if ($interval[1] eq 'map') { last; } } @@ -7291,26 +7821,36 @@ sub has_comm_blocking { } } } - if ($interval[0] =~ /\d+/) { - my $first_access; - if ($type eq 'resource') { - $first_access=&get_first_access($interval[1],$item); - } elsif ($type eq 'map') { - $first_access=&get_first_access($interval[1],undef,$item); - } else { - $first_access=&get_first_access($interval[1]); - } - if ($first_access) { - my $timesup = $first_access+$interval[0]; - if ($timesup > $now) { - foreach my $res (@to_test) { - if ($res->is_problem()) { - if ($res->completable()) { - unless (grep(/^\Q$block\E$/,@blockers)) { - push(@blockers,$block); - } - last; - } + } + if ($interval[0] =~ /^(\d+)/) { + my $timelimit = $1; + my $first_access; + if ($type eq 'resource') { + $first_access=&get_first_access($interval[1],$item); + } elsif ($type eq 'map') { + $first_access=&get_first_access($interval[1],undef,$item); + } else { + $first_access=&get_first_access($interval[1]); + } + if ($first_access) { + my $timesup = $first_access+$timelimit; + if ($timesup > $now) { + my $activeblock; + foreach my $res (@to_test) { + if ($res->answerable()) { + $activeblock = 1; + last; + } + } + if ($activeblock) { + if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') { + if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) { + $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'}; + } + } + if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') { + if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) { + $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'}; } } } @@ -7321,33 +7861,66 @@ sub has_comm_blocking { } } } - return @blockers; + return %blockers; } -sub check_docs_block { - my ($docsblock,$tocheck) =@_; - if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) { - return; +sub has_comm_blocking { + my ($priv,$symb,$uri,$blocks) = @_; + my @blockers; + return unless ($env{'request.course.id'}); + return unless ($priv eq 'bre'); + return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/); + return if ($env{'request.state'} eq 'construct'); + &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks); + return unless (keys(%cachedblockers) > 0); + my (%possibles,@symbs); + if (!$symb) { + $symb = &symbread($uri,1,1,1,\%possibles); } - if (ref($docsblock->{'maps'}) eq 'HASH') { - if ($tocheck->{'maps'}) { - if ($docsblock->{'maps'}{$tocheck->{'maps'}}) { - return 1; + if ($symb) { + @symbs = ($symb); + } elsif (keys(%possibles)) { + @symbs = keys(%possibles); + } + my $noblock; + foreach my $symb (@symbs) { + last if ($noblock); + my ($map,$resid,$resurl)=&decode_symb($symb); + foreach my $block (keys(%cachedblockers)) { + if ($block =~ /^firstaccess____(.+)$/) { + my $item = $1; + if (($item eq $map) || ($item eq $symb)) { + $noblock = 1; + last; + } } - } - } - if (ref($docsblock->{'resources'}) eq 'HASH') { - if ($tocheck->{'resources'}) { - if ($docsblock->{'resources'}{$tocheck->{'resources'}}) { - return 1; + if (ref($cachedblockers{$block}) eq 'HASH') { + if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') { + if ($cachedblockers{$block}{'resources'}{$symb}) { + unless (grep(/^\Q$block\E$/,@blockers)) { + push(@blockers,$block); + } + } + } + } + if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') { + if ($cachedblockers{$block}{'maps'}{$map}) { + unless (grep(/^\Q$block\E$/,@blockers)) { + push(@blockers,$block); + } + } } } } - return; + return if ($noblock); + return @blockers; } +} + +# -------------------------------- Deversion and split uri into path an filename # -# Removes the versino from a URI and +# Removes the version from a URI and # splits it in to its filename and path to the filename. # Seems like File::Basename could have done this more clearly. # Parameters: @@ -7415,7 +7988,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"; } @@ -7443,11 +8016,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'; } @@ -7529,10 +8110,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); @@ -7550,17 +8133,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; @@ -7595,11 +8178,17 @@ 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 2; + for (1..$loopmax) { + sleep($sleep); if (-e $replyfile.'.end') { if (open(my $fh,$replyfile)) { $reply = join('',<$fh>); @@ -8021,6 +8610,107 @@ 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')) { + return; + } + my $canclone; + if (@{$code_order} > 0) { + my $instcoderegexp ='^'; + my @clonecodes = split(/\&/,$cloner); + foreach my $item (@{$code_order}) { + if (grep(/^\Q$item\E=/,@clonecodes)) { + foreach my $pair (@clonecodes) { + my ($key,$val) = split(/\=/,$pair,2); + $val = &unescape($val); + if ($key eq $item) { + $instcoderegexp .= '('.$val.')'; + last; + } + } + } else { + $instcoderegexp .= $codedefaults->{$item}; + } + } + $instcoderegexp .= '$'; + my (@from,@to); + eval { + (@from) = ($clonefromcode =~ /$instcoderegexp/); + (@to) = ($clonetocode =~ /$instcoderegexp/); + }; + if ((@from > 0) && (@to > 0)) { + my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); + if (!@diffs) { + $canclone = 1; + } + } + } + return $canclone; +} + +sub default_instcode_cloning { + my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_; + my (%codedefaults,@code_order,$canclone); + if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) { + %codedefaults = %{$codedefaultsref}; + @code_order = @{$codeorderref}; + } elsif ($clonedom) { + &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order); + } + if (($domdefclone) && (@code_order)) { + my @clonecodes = split(/\+/,$domdefclone); + my $instcoderegexp ='^'; + foreach my $item (@code_order) { + if (grep(/^\Q$item\E$/,@clonecodes)) { + $instcoderegexp .= '('.$codedefaults{$item}.')'; + } else { + $instcoderegexp .= $codedefaults{$item}; + } + } + $instcoderegexp .= '$'; + my (@from,@to); + eval { + (@from) = ($clonefromcode =~ /$instcoderegexp/); + (@to) = ($clonetocode =~ /$instcoderegexp/); + }; + if ((@from > 0) && (@to > 0)) { + my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to); + if (!@diffs) { + $canclone = 1; + } + } + } + return $canclone; +} + # ------------------------------------------------------- Course Group routines sub get_coursegroups { @@ -8385,7 +9075,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')) { @@ -8690,7 +9381,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'; @@ -8706,13 +9397,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'}) { @@ -8759,7 +9450,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); @@ -9283,9 +9974,9 @@ sub modify_access_controls { my $tries = 0; my $gotlock = &newput('file_permissions',$lockhash,$domain,$user); - while (($gotlock ne 'ok') && $tries <3) { + while (($gotlock ne 'ok') && $tries < 10) { $tries ++; - sleep 1; + sleep(0.1); $gotlock = &newput('file_permissions',$lockhash,$domain,$user); } if ($gotlock eq 'ok') { @@ -9578,7 +10269,23 @@ 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'); } @@ -9795,10 +10502,12 @@ sub get_userresdata { } #error 2 occurs when the .db doesn't exist if ($tmp!~/error: 2 /) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $tmp.""); + if ((!defined($cached)) || ($tmp ne 'con_lost')) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } } elsif ($tmp=~/error: 2 /) { #&EXT_cache_set($udom,$uname); &do_cache_new('userres',$hashid,undef,600); @@ -9812,7 +10521,7 @@ 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') # @which - Array of names of resources desired. # Returns: # The value of the first reasource in @which that is found in the @@ -9831,13 +10540,51 @@ sub resdata { } if (!ref($result)) { return $result; } foreach my $item (@which) { - if (defined($result->{$item->[0]})) { - return [$result->{$item->[0]},$item->[1]]; - } + if (ref($item) eq 'ARRAY') { + if (defined($result->{$item->[0]})) { + return [$result->{$item->[0]},$item->[1]]; + } + } } return undef; } +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') { + %lti = %{$result}; + } + } else { + my %domconfig = &get_dom('configuration',[$name],$cdom); + if (ref($domconfig{$name}) eq 'HASH') { + %lti = %{$domconfig{$name}}; + my %encdomconfig = &get_dom('encconfig',[$name],$cdom); + if (ref($encdomconfig{$name}) eq 'HASH') { + foreach my $id (keys(%lti)) { + if (ref($encdomconfig{$name}{$id}) eq 'HASH') { + foreach my $item ('key','secret') { + $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item}; + } + } + } + } + } + my $cachetime = 24*60*60; + &do_cache_new($name,$cdom,\%lti,$cachetime); + } + return %lti; +} + sub get_numsuppfiles { my ($cnum,$cdom,$ignorecache)=@_; my $hashid=$cnum.':'.$cdom; @@ -10292,7 +11039,7 @@ sub metadata { # if it is a non metadata possible uri return quickly if (($uri eq '') || (($uri =~ m|^/*adm/|) && - ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) || + ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) || ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } @@ -10557,7 +11304,7 @@ sub metadata { $metaentry{':keys'} = join(',',keys(%metathesekeys)); &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri); - $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys); + $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys)); &do_cache_new('meta',$uri,\%metaentry,$cachetime); # this is the end of "was not already recently cached } @@ -10928,9 +11675,15 @@ sub deversion { # ------------------------------------------------------ Return symb list entry sub symbread { - my ($thisfn,$donotrecurse)=@_; + my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; my $cache_str='request.symbread.cached.'.$thisfn; - if (defined($env{$cache_str})) { return $env{$cache_str}; } + if (defined($env{$cache_str})) { + if ($ignorecachednull) { + return $env{$cache_str} unless ($env{$cache_str} eq ''); + } else { + return $env{$cache_str}; + } + } # no filename provided? try from environment unless ($thisfn) { if ($env{'request.symb'}) { @@ -10992,18 +11745,46 @@ sub symbread { my ($mapid,$resid)=split(/\./,$ids); $syval=&encode_symb($bighash{'map_id_'.$mapid}, $resid,$thisfn); - } elsif (!$donotrecurse) { + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + if ($checkforblock) { + my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids}); + if (@blockers) { + $syval = ''; + return; + } + } + } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { # ------------------------------------------ There is more than one possibility my $realpossible=0; foreach my $id (@possibilities) { my $file=$bighash{'src_'.$id}; - if (&allowed('bre',$file)) { - my ($mapid,$resid)=split(/\./,$id); - if ($bighash{'map_type_'.$mapid} ne 'page') { - $realpossible++; - $syval=&encode_symb($bighash{'map_id_'.$mapid}, - $resid,$thisfn); - } + my $canaccess; + if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { + $canaccess = 1; + } else { + $canaccess = &allowed('bre',$file); + } + if ($canaccess) { + my ($mapid,$resid)=split(/\./,$id); + if ($bighash{'map_type_'.$mapid} ne 'page') { + my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); + if (ref($possibles) eq 'HASH') { + $possibles->{$syval} = 1; + } + if ($checkforblock) { + my @blockers = &has_comm_blocking('bre',$poss_syval,$file); + unless (@blockers > 0) { + $syval = $poss_syval; + $realpossible++; + } + } else { + $syval = $poss_syval; + $realpossible++; + } + } } } if ($realpossible!=1) { $syval=''; } @@ -11011,7 +11792,7 @@ sub symbread { $syval=''; } } - untie(%bighash) + untie(%bighash); } } if ($syval) { @@ -11790,6 +12571,8 @@ sub clutter { # &logthis("Got a blank emb style"); } } + } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) { + $thisfn='/adm/wrapper'.$thisfn; } return $thisfn; } @@ -11981,8 +12764,8 @@ sub fetch_dns_checksums { } sub load_domain_tab { - my ($ignore_cache) = @_; - &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache); + my ($ignore_cache,$nocache) = @_; + &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache); my $fh; if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) { my @lines = <$fh>; @@ -12068,8 +12851,8 @@ sub fetch_dns_checksums { } sub load_hosts_tab { - my ($ignore_cache) = @_; - &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache); + my ($ignore_cache,$nocache) = @_; + &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache); open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); my @config = <$config>; &parse_hosts_tab(\@config); @@ -12091,7 +12874,8 @@ sub fetch_dns_checksums { } sub all_names { - &load_hosts_tab() if (!$loaded); + my ($ignore_cache,$nocache) = @_; + &load_hosts_tab($ignore_cache,$nocache) if (!$loaded); return %name_to_host; } @@ -12213,7 +12997,7 @@ sub fetch_dns_checksums { } sub get_iphost { - my ($ignore_cache) = @_; + my ($ignore_cache,$nocache) = @_; if (!$ignore_cache) { if (%iphost) { @@ -12237,7 +13021,7 @@ sub fetch_dns_checksums { %old_name_to_ip = %{$ip_info->[1]}; } - my %name_to_host = &all_names(); + my %name_to_host = &all_names($ignore_cache,$nocache); foreach my $name (keys(%name_to_host)) { my $ip; if (!exists($name_to_ip{$name})) { @@ -12262,9 +13046,11 @@ sub fetch_dns_checksums { } push(@{$iphost{$ip}},@{$name_to_host{$name}}); } - &do_cache_new('iphost','iphost', - [\%iphost,\%name_to_ip,\%lonid_to_ip], - 48*60*60); + unless ($nocache) { + &do_cache_new('iphost','iphost', + [\%iphost,\%name_to_ip,\%lonid_to_ip], + 48*60*60); + } return %iphost; } @@ -12645,7 +13431,7 @@ were new keys. I.E. 1:foo will become 1: Calling convention: my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname); - &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname); + &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore); For more detailed information, see lonnet specific documentation. @@ -12781,13 +13567,29 @@ escaped strings of the action recorded i =item * -allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions +allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege; +returns codes for allowed actions. + +The first argument is required, all others are optional. + +$priv is the privilege being checked. +$uri contains additional information about what is being checked for access (e.g., +URL, course ID etc.). +$symb is the unique resource instance identifier in a course; if needed, +but not provided, it will be retrieved via a call to &symbread(). +$role is the role for which a priv is being checked (only used if priv is evb). +$clientip is the user's IP address (only used when checking for access to portfolio +files). +$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This +prevents recursive calls to &allowed. + F: full access U,I,K: authentication modes (cxx only) '': forbidden 1: user needs to choose course 2: browse allowed A: passphrase authentication needed + B: access temporarily blocked because of a blocking event in a course. =item * @@ -12806,9 +13608,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 * @@ -13012,6 +13815,8 @@ Inputs: =item $credits, number of credits student will earn from this class +=item $instsec, institutional course section code for student + =back @@ -13181,7 +13986,20 @@ will be stored for query =item * -symbread($filename) : return symbolic list entry (filename argument optional); +symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) : +return symbolic list entry (all arguments optional). + +Args: filename is the filename (including path) for the file for which a symb +is required; donotrecurse, if true will prevent calls to allowed() being made +to check access status if more than one resource was found in the bighash +(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of +a randompick); ignorecachednull, if true will prevent a symb of '' being +returned if $env{$cache_str} is defined as ''; checkforblock if true will +cause possible symbs to be checked to determine if they are subject to content +blocking, if so they will not be included as possible symbs; possibles is a +ref to a hash, which, as a side effect, will be populated with all possible +symbs (content blocking not tested). + returns the data handle =item * @@ -13282,15 +14100,21 @@ homeserver. =item * -store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently -for this url; hashref needs to be given and should be a \%hashname; the -remaining args aren't required and if they aren't passed or are '' they will -be derived from the env +store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash +permanently for this url; hashref needs to be given and should be a \%hashname; +the remaining args aren't required and if they aren't passed or are '' they will +be derived from the env (with the exception of $laststore, which is an +optional arg used when a user's submission is stored in grading). +$laststore is $version=$timestamp, where $version is the most recent version +number retrieved for the corresponding $symb in the $namespace db file, and +$timestamp is the timestamp for that transaction (UNIX time). +$laststore is currently only passed when cstore() is called by +structuretags::finalize_storage(). =item * -cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but -uses critical subroutine +cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store +but uses critical subroutine =item * @@ -13313,10 +14137,11 @@ $range should be either an integer '100' =item * -putstore($namespace,$symb,$version,$storehash,$udomain,$uname) : +putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) : replaces a &store() version of data with a replacement set of data for a particular resource in a namespace passed in the $storehash hash -reference +reference. If $tolog is true, the transaction is logged in the courselog +with an action=PUTSTORE. =item * @@ -13481,7 +14306,8 @@ for course's uploaded content. =over =item -canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota +canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, +communityquota, textbookquota =back