--- loncom/lonnet/perl/lonnet.pm 2014/05/29 12:45:05 1.1261 +++ loncom/lonnet/perl/lonnet.pm 2015/04/15 18:56:19 1.1283 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1261 2014/05/29 12:45:05 raeburn Exp $ +# $Id: lonnet.pm,v 1.1283 2015/04/15 18:56:19 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -849,10 +849,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); } @@ -863,10 +861,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); } @@ -1178,19 +1174,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; } @@ -1652,6 +1656,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).'&'; @@ -1659,6 +1664,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 { @@ -2074,6 +2080,11 @@ sub get_domain_defaults { } if (ref($domconfig{'coursedefaults'}) eq 'HASH') { $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'}; + $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') { @@ -2083,6 +2094,12 @@ 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{'usersessions'}) eq 'HASH') { @@ -2092,6 +2109,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') { @@ -2721,7 +2741,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); } @@ -4419,7 +4444,7 @@ 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)=@_; @@ -4481,6 +4506,7 @@ sub set_first_access { return 'already_set'; } } + # --------------------------------------------- Set Expire Date for Spreadsheet sub expirespread { @@ -4851,7 +4877,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); } @@ -4881,13 +4907,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); } @@ -4918,7 +4944,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 @@ -5098,7 +5124,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) @@ -5187,7 +5213,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$//; @@ -5628,18 +5654,17 @@ sub dump { if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); - my $reply; + if ($regexp) { + $regexp=&escape($regexp); + } else { + $regexp='.'; + } if (grep { $_ eq $uhome } current_machine_ids()) { # user is hosted on this machine - $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, + my $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain, $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'}); return %{unserialize($reply, $escapedkeys)}; } - if ($regexp) { - $regexp=&escape($regexp); - } else { - $regexp='.'; - } my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome); my @pairs=split(/\&/,$rep); my %returnhash=(); @@ -5817,7 +5842,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); @@ -5831,6 +5856,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, @@ -5989,10 +6025,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 ++; } @@ -6009,6 +6050,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 @@ -6017,16 +6059,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') { @@ -6052,7 +6105,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); @@ -6061,7 +6114,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})) { @@ -6085,10 +6138,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) { @@ -6572,7 +6640,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; @@ -6767,11 +6835,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 { @@ -6783,11 +6856,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'; + } } } } @@ -6799,7 +6876,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. @@ -6842,11 +6919,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; @@ -6880,11 +6961,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; @@ -7115,6 +7200,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 '') { @@ -7135,27 +7246,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); @@ -7163,17 +7268,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'}; } } } @@ -7184,32 +7285,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; } } @@ -7217,26 +7317,35 @@ 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 $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) { + 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'}; } } } @@ -7247,33 +7356,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: @@ -9114,6 +9256,90 @@ sub files_not_in_path { return (@return_files); } +#------------------------------Submitted/Handedback Portfolio Files Versioning + +sub portfiles_versioning { + my ($symb,$domain,$stu_name,$portfiles,$versioned_portfiles) = @_; + my $portfolio_root = '/userfiles/portfolio'; + return unless ((ref($portfiles) eq 'ARRAY') && (ref($versioned_portfiles) eq 'ARRAY')); + foreach my $file (@{$portfiles}) { + &unmark_as_readonly($domain,$stu_name,[$symb,$env{'request.course.id'}],$file); + my ($directory,$answer_file) =($file =~ /^(.*?)([^\/]*)$/); + my ($answer_name,$answer_ver,$answer_ext) = &file_name_version_ext($answer_file); + my $getpropath = 1; + my ($dir_list,$listerror) = &dirlist($portfolio_root.$directory,$domain, + $stu_name,$getpropath); + my $version = &get_next_version($answer_name,$answer_ext,$dir_list); + my $new_answer = + &version_selected_portfile($domain,$stu_name,$directory,$answer_file,$version); + if ($new_answer ne 'problem getting file') { + push(@{$versioned_portfiles}, $directory.$new_answer); + &mark_as_readonly($domain,$stu_name,[$directory.$new_answer], + [$symb,$env{'request.course.id'},'graded']); + } + } +} + +sub get_next_version { + my ($answer_name, $answer_ext, $dir_list) = @_; + my $version; + if (ref($dir_list) eq 'ARRAY') { + foreach my $row (@{$dir_list}) { + my ($file) = split(/\&/,$row,2); + my ($file_name,$file_version,$file_ext) = + &file_name_version_ext($file); + if (($file_name eq $answer_name) && + ($file_ext eq $answer_ext)) { + # gets here if filename and extension match, + # regardless of version + if ($file_version ne '') { + # a versioned file is found so save it for later + if ($file_version > $version) { + $version = $file_version; + } + } + } + } + } + $version ++; + return($version); +} + +sub version_selected_portfile { + my ($domain,$stu_name,$directory,$file_name,$version) = @_; + my ($answer_name,$answer_ver,$answer_ext) = + &file_name_version_ext($file_name); + my $new_answer; + $env{'form.copy'} = + &getfile("/uploaded/$domain/$stu_name/portfolio$directory$file_name"); + if($env{'form.copy'} eq '-1') { + $new_answer = 'problem getting file'; + } else { + $new_answer = $answer_name.'.'.$version.'.'.$answer_ext; + my $copy_result = + &finishuserfileupload($stu_name,$domain,'copy', + '/portfolio'.$directory.$new_answer); + } + undef($env{'form.copy'}); + return ($new_answer); +} + +sub file_name_version_ext { + my ($file)=@_; + my @file_parts = split(/\./, $file); + my ($name,$version,$ext); + if (@file_parts > 1) { + $ext=pop(@file_parts); + if (@file_parts > 1 && $file_parts[-1] =~ /^\d+$/) { + $version=pop(@file_parts); + } + $name=join('.',@file_parts); + } else { + $name=join('.',@file_parts); + } + return($name,$version,$ext); +} + #----------------------------------------------Get portfolio file permissions sub get_portfile_permissions { @@ -9258,49 +9484,132 @@ sub modify_access_controls { } sub make_public_indefinitely { - my ($requrl) = @_; + my (@requrl) = @_; + return &automated_portfile_access('public',\@requrl); +} + +sub automated_portfile_access { + my ($accesstype,$addsref,$delsref,$info) = @_; + unless (($accesstype eq 'public') || ($accesstype eq 'ip')) { + return 'invalid'; + } + my %urls; + if (ref($addsref) eq 'ARRAY') { + foreach my $requrl (@{$addsref}) { + if (&is_portfolio_url($requrl)) { + unless (exists($urls{$requrl})) { + $urls{$requrl} = 'add'; + } + } + } + } + if (ref($delsref) eq 'ARRAY') { + foreach my $requrl (@{$delsref}) { + if (&is_portfolio_url($requrl)) { + unless (exists($urls{$requrl})) { + $urls{$requrl} = 'delete'; + } + } + } + } + unless (keys(%urls)) { + return 'invalid'; + } + my $ip; + if ($accesstype eq 'ip') { + if (ref($info) eq 'HASH') { + if ($info->{'ip'} ne '') { + $ip = $info->{'ip'}; + } + } + if ($ip eq '') { + return 'invalid'; + } + } + my $errors; my $now = time; - my $action = 'activate'; - my $aclnum = 0; - if (&is_portfolio_url($requrl)) { + my %current_perms; + foreach my $requrl (sort(keys(%urls))) { + my $action; + if ($urls{$requrl} eq 'add') { + $action = 'activate'; + } else { + $action = 'none'; + } + my $aclnum = 0; my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl); - my $current_perms = &get_portfile_permissions($udom,$unum); - my %access_controls = &get_access_controls($current_perms, + unless (exists($current_perms{$unum.':'.$udom})) { + $current_perms{$unum.':'.$udom} = &get_portfile_permissions($udom,$unum); + } + my %access_controls = &get_access_controls($current_perms{$unum.':'.$udom}, $group,$file_name); foreach my $key (keys(%{$access_controls{$file_name}})) { my ($num,$scope,$end,$start) = ($key =~ /^([^:]+):([a-z]+)_(\d*)_?(\d*)$/); - if ($scope eq 'public') { - if ($start <= $now && $end == 0) { - $action = 'none'; - } else { + if ($scope eq $accesstype) { + if (($start <= $now) && ($end == 0)) { + if ($accesstype eq 'ip') { + if (ref($access_controls{$file_name}{$key}) eq 'HASH') { + if (ref($access_controls{$file_name}{$key}{'ip'}) eq 'ARRAY') { + if (grep(/^\Q$ip\E$/,@{$access_controls{$file_name}{$key}{'ip'}})) { + if ($urls{$requrl} eq 'add') { + $action = 'none'; + last; + } else { + $action = 'delete'; + $aclnum = $num; + last; + } + } + } + } + } elsif ($accesstype eq 'public') { + if ($urls{$requrl} eq 'add') { + $action = 'none'; + last; + } else { + $action = 'delete'; + $aclnum = $num; + last; + } + } + } elsif ($accesstype eq 'public') { $action = 'update'; $aclnum = $num; + last; } - last; } } if ($action eq 'none') { - return 'ok'; + next; } else { my %changes; my $newend = 0; my $newstart = $now; - my $newkey = $aclnum.':public_'.$newend.'_'.$newstart; + my $newkey = $aclnum.':'.$accesstype.'_'.$newend.'_'.$newstart; $changes{$action}{$newkey} = { - type => 'public', + type => $accesstype, time => { start => $newstart, end => $newend, }, }; + if ($accesstype eq 'ip') { + $changes{$action}{$newkey}{'ip'} = [$ip]; + } my ($outcome,$deloutcome,$new_values,$translation) = &modify_access_controls($file_name,\%changes,$udom,$unum); - return $outcome; + unless ($outcome eq 'ok') { + $errors .= $outcome.' '; + } } + } + if ($errors) { + $errors =~ s/\s$//; + return $errors; } else { - return 'invalid'; + return 'ok'; } } @@ -10484,7 +10793,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 } @@ -10855,15 +11164,17 @@ sub deversion { # ------------------------------------------------------ Return symb list entry sub symbread { - my ($thisfn,$donotrecurse)=@_; - my $cache_str; - if ($thisfn ne '') { - $cache_str='request.symbread.cached.'.$thisfn; - if ($env{$cache_str} ne '') { + my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_; + my $cache_str='request.symbread.cached.'.$thisfn; + if (defined($env{$cache_str})) { + if ($ignorecachednull) { + return $env{$cache_str} unless ($env{$cache_str} eq ''); + } else { return $env{$cache_str}; } - } else { + } # no filename provided? try from environment + unless ($thisfn) { if ($env{'request.symb'}) { return $env{$cache_str}=&symbclean($env{'request.symb'}); } @@ -10923,18 +11234,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=''; } @@ -10942,7 +11281,7 @@ sub symbread { $syval=''; } } - untie(%bighash) + untie(%bighash); } } if ($syval) { @@ -11281,8 +11620,12 @@ sub rndseed_CODE_64bit5 { sub setup_random_from_rndseed { my ($rndseed)=@_; if ($rndseed =~/([,:])/) { - my ($num1,$num2)=split(/[,:]/,$rndseed); - &Math::Random::random_set_seed(abs($num1),abs($num2)); + my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed)); + if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) { + &Math::Random::random_set_seed_from_phrase($rndseed); + } else { + &Math::Random::random_set_seed($num1,$num2); + } } else { &Math::Random::random_set_seed_from_phrase($rndseed); } @@ -11802,7 +12145,7 @@ sub get_dns { $alldns{$host} = $protocol; } while (%alldns) { - my ($dns) = keys(%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"); @@ -11828,8 +12171,22 @@ sub get_dns { # ------------------------------------------------------Get DNS checksums file sub parse_dns_checksums_tab { my ($lines,$hashref) = @_; - my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'}); + my $lonhost = $perlvar{'lonHostID'}; + my $machine_dom = &Apache::lonnet::host_domain($lonhost); my $loncaparev = &get_server_loncaparev($machine_dom); + my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0]; + my $webconfdir = '/etc/httpd/conf'; + if ($distro =~ /^(ubuntu|debian)(\d+)$/) { + $webconfdir = '/etc/apache2'; + } elsif ($distro =~ /^sles(\d+)$/) { + if ($1 >= 10) { + $webconfdir = '/etc/apache2'; + } + } elsif ($distro =~ /^suse(\d+\.\d+)$/) { + if ($1 >= 10.0) { + $webconfdir = '/etc/apache2'; + } + } my ($release,$timestamp) = split(/\-/,$loncaparev); my (%chksum,%revnum); if (ref($lines) eq 'ARRAY') { @@ -11838,6 +12195,11 @@ sub parse_dns_checksums_tab { if ($version eq $release) { foreach my $line (@{$lines}) { my ($file,$version,$shasum) = split(/,/,$line); + if ($file =~ m{^/etc/httpd/conf}) { + if ($webconfdir eq '/etc/apache2') { + $file =~ s{^\Q/etc/httpd/conf/\E}{$webconfdir/}; + } + } $chksum{$file} = $shasum; $revnum{$file} = $version; } @@ -12554,7 +12916,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. @@ -13090,7 +13452,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 * @@ -13191,15 +13566,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 * @@ -13222,10 +13603,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 *