--- loncom/lonnet/perl/lonnet.pm 2012/12/13 19:32:52 1.1172.2.13 +++ loncom/lonnet/perl/lonnet.pm 2012/05/28 12:28:14 1.1174 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.13 2012/12/13 19:32:52 raeburn Exp $ +# $Id: lonnet.pm,v 1.1174 2012/05/28 12:28:14 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -75,6 +75,8 @@ use LWP::UserAgent(); use HTTP::Date; use Image::Magick; +use Encode; + use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease %managerstab); @@ -97,6 +99,7 @@ use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; use LONCAPA::lonmetadata; +use LONCAPA::Lond; use File::Copy; @@ -108,33 +111,31 @@ require Exporter; our @ISA = qw (Exporter); our @EXPORT = qw(%env); -# ------------------------------------ Logging (parameters, docs, slots, roles) + +# --------------------------------------------------------------------- Logging { my $logid; - sub write_log { - my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; - if ($context eq 'course') { - if (($cnum eq '') || ($cdom eq '')) { - $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; - } + sub instructor_log { + my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_; + if (($cnum eq '') || ($cdom eq '')) { + $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; } - $logid ++; + $logid++; my $now = time(); my $id=$now.'00000'.$$.'00000'.$logid; - my $logentry = { - $id => { - 'exe_uname' => $env{'user.name'}, - 'exe_udom' => $env{'user.domain'}, - 'exe_time' => $now, - 'exe_ip' => $ENV{'REMOTE_ADDR'}, - 'delflag' => $delflag, - 'logentry' => $storehash, - 'uname' => $uname, - 'udom' => $udom, - } - }; - return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum); + return &Apache::lonnet::put('nohist_'.$hash_name, + { $id => { + 'exe_uname' => $env{'user.name'}, + 'exe_udom' => $env{'user.domain'}, + 'exe_time' => $now, + 'exe_ip' => $ENV{'REMOTE_ADDR'}, + 'delflag' => $delflag, + 'logentry' => $storehash, + 'uname' => $uname, + 'udom' => $udom, + } + },$cdom,$cnum); } } @@ -1235,10 +1236,9 @@ sub get_lonbalancer_config { sub check_loadbalancing { my ($uname,$udom) = @_; - my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom, - $rule_in_effect,$offloadto,$otherserver); + my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect, + $offloadto,$otherserver); my $lonhost = $perlvar{'lonHostID'}; - my @hosts = ¤t_machine_ids(); my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); my $intdom = &Apache::lonnet::internet_dom($lonhost); @@ -1261,8 +1261,15 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = - &check_balancer_result($result,@hosts); + my $currbalancer = $result->{'lonhost'}; + my $currtargets = $result->{'targets'}; + my $currrules = $result->{'rules'}; + if ($currbalancer ne '') { + my @hosts = ¤t_machine_ids(); + if (grep(/^\Q$currbalancer\E$/,@hosts)) { + $is_balancer = 1; + } + } if ($is_balancer) { if (ref($currrules) eq 'HASH') { if ($homeintdom) { @@ -1320,9 +1327,12 @@ sub check_loadbalancing { } } if (ref($result) eq 'HASH') { - ($is_balancer,$currtargets,$currrules) = - &check_balancer_result($result,@hosts); - if ($is_balancer) { + my $currbalancer = $result->{'lonhost'}; + my $currtargets = $result->{'targets'}; + my $currrules = $result->{'rules'}; + + if ($currbalancer eq $lonhost) { + $is_balancer = 1; if (ref($currrules) eq 'HASH') { if ($currrules->{'_LC_internetdom'} ne '') { $rule_in_effect = $currrules->{'_LC_internetdom'}; @@ -1343,81 +1353,41 @@ sub check_loadbalancing { $offloadto = &this_host_spares($dom_in_use); } } - if ($is_balancer) { - my $lowest_load = 30000; - if (ref($offloadto) eq 'HASH') { - if (ref($offloadto->{'primary'}) eq 'ARRAY') { - foreach my $try_server (@{$offloadto->{'primary'}}) { - ($otherserver,$lowest_load) = - &compare_server_load($try_server,$otherserver,$lowest_load); - } + my $lowest_load = 30000; + if (ref($offloadto) eq 'HASH') { + if (ref($offloadto->{'primary'}) eq 'ARRAY') { + foreach my $try_server (@{$offloadto->{'primary'}}) { + ($otherserver,$lowest_load) = + &compare_server_load($try_server,$otherserver,$lowest_load); } - my $found_server = ($otherserver ne '' && $lowest_load < 100); + } + my $found_server = ($otherserver ne '' && $lowest_load < 100); - if (!$found_server) { - if (ref($offloadto->{'default'}) eq 'ARRAY') { - foreach my $try_server (@{$offloadto->{'default'}}) { - ($otherserver,$lowest_load) = - &compare_server_load($try_server,$otherserver,$lowest_load); - } - } - } - } elsif (ref($offloadto) eq 'ARRAY') { - if (@{$offloadto} == 1) { - $otherserver = $offloadto->[0]; - } elsif (@{$offloadto} > 1) { - foreach my $try_server (@{$offloadto}) { + if (!$found_server) { + if (ref($offloadto->{'default'}) eq 'ARRAY') { + foreach my $try_server (@{$offloadto->{'default'}}) { ($otherserver,$lowest_load) = &compare_server_load($try_server,$otherserver,$lowest_load); } } } - 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}); - } + } elsif (ref($offloadto) eq 'ARRAY') { + if (@{$offloadto} == 1) { + $otherserver = $offloadto->[0]; + } elsif (@{$offloadto} > 1) { + foreach my $try_server (@{$offloadto}) { + ($otherserver,$lowest_load) = + &compare_server_load($try_server,$otherserver,$lowest_load); } } } return ($is_balancer,$otherserver); } -sub check_balancer_result { - my ($result,@hosts) = @_; - my ($is_balancer,$currtargets,$currrules); - if (ref($result) eq 'HASH') { - if ($result->{'lonhost'} ne '') { - my $currbalancer = $result->{'lonhost'}; - if (grep(/^\Q$currbalancer\E$/,@hosts)) { - $is_balancer = 1; - $currtargets = $result->{'targets'}; - $currrules = $result->{'rules'}; - } - } else { - foreach my $key (keys(%{$result})) { - if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) && - (ref($result->{$key}) eq 'HASH')) { - $is_balancer = 1; - $currrules = $result->{$key}{'rules'}; - $currtargets = $result->{$key}{'targets'}; - last; - } - } - } - } - return ($is_balancer,$currtargets,$currrules); -} - sub get_loadbalancer_targets { my ($rule_in_effect,$currtargets,$uname,$udom) = @_; my $offloadto; - if ($rule_in_effect eq 'none') { - return [$perlvar{'lonHostID'}]; - } elsif ($rule_in_effect eq '') { + if ($rule_in_effect eq '') { $offloadto = $currtargets; } else { if ($rule_in_effect eq 'homeserver') { @@ -1435,7 +1405,7 @@ sub get_loadbalancer_targets { } } } else { - my %servers = &internet_dom_servers($udom); + my %servers = &dom_servers($udom); my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers); if (&hostname($remotebalancer) ne '') { $offloadto = [$remotebalancer]; @@ -1954,8 +1924,7 @@ sub get_domain_defaults { my %domconfig = &Apache::lonnet::get_dom('configuration',['defaults','quotas', 'requestcourses','inststatus', - 'coursedefaults','usersessions', - 'requestauthor'],$domain); + 'coursedefaults','usersessions'],$domain); if (ref($domconfig{'defaults'}) eq 'HASH') { $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'}; @@ -1974,7 +1943,7 @@ sub get_domain_defaults { } else { $domdefaults{'defaultquota'} = $domconfig{'quotas'}; } - my @usertools = ('aboutme','blog','webdav','portfolio'); + my @usertools = ('aboutme','blog','portfolio'); foreach my $item (@usertools) { if (ref($domconfig{'quotas'}{$item}) eq 'HASH') { $domdefaults{$item} = $domconfig{'quotas'}{$item}; @@ -1986,9 +1955,6 @@ sub get_domain_defaults { $domdefaults{$item} = $domconfig{'requestcourses'}{$item}; } } - if (ref($domconfig{'requestauthor'}) eq 'HASH') { - $domdefaults{'requestauthor'} = $domconfig{'requestauthor'}; - } if (ref($domconfig{'inststatus'}) eq 'HASH') { foreach my $item ('inststatustypes','inststatusorder') { $domdefaults{$item} = $domconfig{'inststatus'}{$item}; @@ -2418,7 +2384,7 @@ sub chatsend { sub getversion { my $fname=&clutter(shift); - unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; } + unless ($fname=~/^\/res\//) { return -1; } return ¤tversion(&filelocation('',$fname)); } @@ -2605,10 +2571,11 @@ sub ssi { $request->header(Cookie => $ENV{'HTTP_COOKIE'}); my $response= $ua->request($request); + my $content = Encode::decode_utf8($response->content); if (wantarray) { - return ($response->content, $response); + return ($content, $response); } else { - return $response->content; + return $content; } } @@ -2637,241 +2604,6 @@ sub allowuploaded { &Apache::lonnet::appenv(\%httpref); } -# -# Determine if the current user should be able to edit a particular resource, -# when viewing in course context. -# (a) When viewing resource used to determine if "Edit" item is included in -# Functions. -# (b) When displaying folder contents in course editor, used to determine if -# "Edit" link will be displayed alongside resource. -# -# input: six args -- filename (decluttered), course number, course domain, -# url, symb (if registered) and group (if this is a group -# item -- e.g., bulletin board, group page etc.). -# output: array of five scalars -- -# $cfile -- url for file editing if editable on current server -# $home -- homeserver of resource (i.e., for author if published, -# or course if uploaded.). -# $switchserver -- 1 if server switch will be needed. -# $forceedit -- 1 if icon/link should be to go to edit mode -# $forceview -- 1 if icon/link should be to go to view mode -# - -sub can_edit_resource { - my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_; - my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse); -# -# For aboutme pages user can only edit his/her own. -# - if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) { - my ($sdom,$sname) = ($1,$2); - if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) { - $home = $env{'user.home'}; - $cfile = $resurl; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - return ($cfile,$home,$switchserver,$forceedit,$forceview); - } else { - return; - } - } - - if ($env{'request.course.id'}) { - my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'}); - if ($group ne '') { -# if this is a group homepage or group bulletin board, check group privs - my $allowed = 0; - if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) { - if ((&allowed('mdg',$env{'request.course.id'}. - ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || - (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) { - $allowed = 1; - } - } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) { - if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) || - (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) { - $allowed = 1; - } - } - if ($allowed) { - $home=&homeserver($cnum,$cdom); - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } else { - return; - } - } else { -# -# No edit allowed where CC has switched to student role. -# - unless ($crsedit) { - return; - } - } - } - - if ($file ne '') { - if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) { - if (&is_course_upload($file,$cnum,$cdom)) { - $uploaded = 1; - $incourse = 1; - if ($file =~/\.(htm|html|css|js|txt)$/) { - $cfile = &hreflocation('',$file); - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - } - } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } elsif (($resurl ne '') && (&is_on_map($resurl))) { - if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') { - $incourse = 1; - $cfile = $resurl.'/smpedit'; - } elsif ($resurl =~ m{^/adm/wrapper/ext/}) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } - } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') { - my $template = '/res/lib/templates/simpleproblem.problem'; - if (&is_on_map($template)) { - $incourse = 1; - $forceview = 1; - $cfile = $template; - } - } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) { - $incourse = 1; - if ($env{'form.forceedit'}) { - $forceview = 1; - } else { - $forceedit = 1; - } - $cfile = $resurl; - } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) { - $incourse = 1; - $forceview = 1; - if ($symb) { - my ($map,$id,$res)=&decode_symb($symb); - $env{'request.symb'} = $symb; - $cfile = &clutter($res); - } else { - $cfile = $env{'form.suppurl'}; - $cfile =~ s{^http://}{}; - $cfile = '/adm/wrapper/ext/'.$cfile; - } - } - } - if ($uploaded || $incourse) { - $home=&homeserver($cnum,$cdom); - } else { - $file=~s{^(priv/$match_domain/$match_username)}{/$1}; - $file=~s{^($match_domain/$match_username)}{/priv/$1}; - # Check that the user has permission to edit this resource - my $setpriv = 1; - my ($cfuname,$cfudom)=&constructaccess($file,$setpriv); - if (defined($cfudom)) { - $home=&homeserver($cfuname,$cfudom); - $cfile=$file; - } - } - if (($cfile ne '') && (!$incourse || $uploaded) && - (($home ne '') && ($home ne 'no_host'))) { - my @ids=¤t_machine_ids(); - unless (grep(/^\Q$home\E$/,@ids)) { - $switchserver=1; - } - } - } - return ($cfile,$home,$switchserver,$forceedit,$forceview); -} - -sub is_course_upload { - my ($file,$cnum,$cdom) = @_; - my $uploadpath = &LONCAPA::propath($cdom,$cnum); - $uploadpath =~ s{^\/}{}; - if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) || - ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) { - return 1; - } - return; -} - -sub in_course { - my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_; - if ($hideprivileged) { - my $skipuser; - if (&privileged($uname,$udom)) { - $skipuser = 1; - my %coursehash = &coursedescription($cdom.'_'.$cnum); - if ($coursehash{'nothideprivileged'}) { - foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) { - my $user; - if ($item =~ /:/) { - $user = $item; - } else { - $user = join(':',split(/[\@]/,$item)); - } - if ($user eq $uname.':'.$udom) { - undef($skipuser); - last; - } - } - } - if ($skipuser) { - return 0; - } - } - } - $type ||= 'any'; - if (!defined($cdom) || !defined($cnum)) { - my $cid = $env{'request.course.id'}; - $cdom = $env{'course.'.$cid.'.domain'}; - $cnum = $env{'course.'.$cid.'.num'}; - } - my $typesref; - if (($type eq 'any') || ($type eq 'all')) { - $typesref = ['active','previous','future']; - } elsif ($type eq 'previous' || $type eq 'future') { - $typesref = [$type]; - } - my %roles = &get_my_roles($uname,$udom,'userroles', - $typesref,undef,[$cdom]); - my ($tmp) = keys(%roles); - return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i); - my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles)); - if (@course_roles > 0) { - return 1; - } - return 0; -} - # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course # input: action, courseID, current domain, intended # path to file, source of file, instruction to parse file for objects, @@ -3781,70 +3513,38 @@ sub userrolelog { sub courserolelog { my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_; - if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { - my $cdom = $1; - my $cnum = $2; - my $sec = $3; - my $namespace = 'rolelog'; - my %storehash = ( - role => $trole, - start => $tstart, - end => $tend, - selfenroll => $selfenroll, - context => $context, - ); - if ($trole eq 'gr') { - $namespace = 'groupslog'; - $storehash{'group'} = $sec; - } else { - $storehash{'section'} = $sec; - } - &write_log('course',$namespace,\%storehash,$delflag,$username, - $domain,$cnum,$cdom); - if (($trole ne 'st') || ($sec ne '')) { - &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + if (($trole eq 'cc') || ($trole eq 'in') || + ($trole eq 'ep') || ($trole eq 'ad') || + ($trole eq 'ta') || ($trole eq 'st') || + ($trole=~/^cr/) || ($trole eq 'gr') || + ($trole eq 'co')) { + if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) { + my $cdom = $1; + my $cnum = $2; + my $sec = $3; + my $namespace = 'rolelog'; + my %storehash = ( + role => $trole, + start => $tstart, + end => $tend, + selfenroll => $selfenroll, + context => $context, + ); + if ($trole eq 'gr') { + $namespace = 'groupslog'; + $storehash{'group'} = $sec; + } else { + $storehash{'section'} = $sec; + } + &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom); + if (($trole ne 'st') || ($sec ne '')) { + &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum); + } } } return; } -sub domainrolelog { - my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; - if ($area =~ m{^/($match_domain)/$}) { - my $cdom = $1; - my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom); - my $namespace = 'rolelog'; - my %storehash = ( - role => $trole, - start => $tstart, - end => $tend, - context => $context, - ); - &write_log('domain',$namespace,\%storehash,$delflag,$username, - $domain,$domconfiguser,$cdom); - } - return; - -} - -sub coauthorrolelog { - my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_; - if ($area =~ m{^/($match_domain)/($match_username)$}) { - my $audom = $1; - my $auname = $2; - my $namespace = 'rolelog'; - my %storehash = ( - role => $trole, - start => $tstart, - end => $tend, - context => $context, - ); - &write_log('author',$namespace,\%storehash,$delflag,$username, - $domain,$auname,$audom); - } - return; -} - sub get_course_adv_roles { my ($cid,$codes) = @_; $cid=$env{'request.course.id'} unless (defined($cid)); @@ -3957,7 +3657,7 @@ sub get_my_roles { } my ($rolecode,$username,$domain,$section,$area); if ($context eq 'userroles') { - ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/); + ($area,$rolecode) = split(/_/,$entry); (undef,$domain,$username,$section) = split(/\//,$area); } else { ($role,$username,$domain,$section) = split(/\:/,$entry); @@ -5279,19 +4979,15 @@ sub delete_env_groupprivs { sub check_adhoc_privs { my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_; my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum; - 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); - $setprivs = 1; } } else { &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller); - $setprivs = 1; } - return $setprivs; } sub set_adhoc_privileges { @@ -5678,88 +5374,6 @@ sub tmpdel { return &reply("tmpdel:$token",$server); } -# ------------------------------------------------------------ get_timebased_id - -sub get_timebased_id { - my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries, - $maxtries) = @_; - my ($newid,$error,$dellock); - unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) { - return ('','ok','invalid call to get suffix'); - } - -# set defaults for any optional args for which values were not supplied - if ($who eq '') { - $who = $env{'user.name'}.':'.$env{'user.domain'}; - } - if (!$locktries) { - $locktries = 3; - } - if (!$maxtries) { - $maxtries = 10; - } - - if (($cdom eq '') || ($cnum eq '')) { - if ($env{'request.course.id'}) { - $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; - $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - } - if (($cdom eq '') || ($cnum eq '')) { - return ('','ok','call to get suffix not in course context'); - } - } - -# construct locking item - my $lockhash = { - $prefix."\0".'locked_'.$keyid => $who, - }; - my $tries = 0; - -# attempt to get lock on nohist_$namespace file - my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); - while (($gotlock ne 'ok') && $tries <$locktries) { - $tries ++; - sleep 1; - $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum); - } - -# attempt to get unique identifier, based on current timestamp - if ($gotlock eq 'ok') { - my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix); - my $id = time; - $newid = $id; - my $idtries = 0; - while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) { - if ($idtype eq 'concat') { - $newid = $id.$idtries; - } else { - $newid ++; - } - $idtries ++; - } - if (!exists($inuse{$prefix."\0".$newid})) { - my %new_item = ( - $prefix."\0".$newid => $who, - ); - my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item, - $cdom,$cnum); - if ($putresult ne 'ok') { - undef($newid); - $error = 'error saving new item: '.$putresult; - } - } else { - $error = ('error: no unique suffix available for the new item '); - } -# remove lock - my @del_lock = ($prefix."\0".'locked_'.$keyid); - $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum); - } else { - $error = "error: could not obtain lockfile\n"; - $dellock = 'ok'; - } - return ($newid,$dellock,$error); -} - # -------------------------------------------------- portfolio access checking sub portfolio_access { @@ -6015,15 +5629,10 @@ sub usertools_access { unofficial => 1, community => 1, ); - } elsif ($context eq 'requestauthor') { - %tools = ( - requestauthor => 1, - ); } else { %tools = ( aboutme => 1, blog => 1, - webdav => 1, portfolio => 1, ); } @@ -6038,32 +5647,25 @@ sub usertools_access { if ($action ne 'reload') { if ($context eq 'requestcourses') { return $env{'environment.canrequest.'.$tool}; - } elsif ($context eq 'requestauthor') { - return $env{'environment.canrequest.author'}; } else { return $env{'environment.availabletools.'.$tool}; } } } - my ($toolstatus,$inststatus,$envkey); - if ($context eq 'requestauthor') { - $envkey = $context; - } else { - $envkey = $context.'.'.$tool; - } + my ($toolstatus,$inststatus); if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && ($action ne 'reload')) { - $toolstatus = $env{'environment.'.$envkey}; + $toolstatus = $env{'environment.'.$context.'.'.$tool}; $inststatus = $env{'environment.inststatus'}; } else { if (ref($userenvref) eq 'HASH') { - $toolstatus = $userenvref->{$envkey}; + $toolstatus = $userenvref->{$context.'.'.$tool}; $inststatus = $userenvref->{'inststatus'}; } else { - my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus'); - $toolstatus = $userenv{$envkey}; + my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus'); + $toolstatus = $userenv{$context.'.'.$tool}; $inststatus = $userenv{'inststatus'}; } } @@ -6129,7 +5731,7 @@ sub usertools_access { } } } else { - if (($context eq 'tools') && ($tool ne 'webdav')) { + if ($context eq 'tools') { $access = 1; } else { $access = 0; @@ -6786,73 +6388,6 @@ sub allowed { return 'F'; } -# ------------------------------------------- Check construction space access - -sub constructaccess { - my ($url,$setpriv)=@_; - -# We do not allow editing of previous versions of files - if ($url=~/\.(\d+)\.(\w+)$/) { return ''; } - -# Get username and domain from URL - my ($ownername,$ownerdomain,$ownerhome); - - ($ownerdomain,$ownername) = - ($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 ''; } - -# Now we need to see if the user has access to the authorspace of -# $ownername at $ownerdomain - - if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) { -# Real author for this? - $ownerhome = $env{'user.home'}; - if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) { - return ($ownername,$ownerdomain,$ownerhome); - } - } else { -# Co-author for this? - if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) || - exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) { - $ownerhome = &homeserver($ownername,$ownerdomain); - return ($ownername,$ownerdomain,$ownerhome); - } - } - -# We don't have any access right now. If we are not possibly going to do anything about this, -# we might as well leave - unless ($setpriv) { return ''; } - -# Backdoor access? - my $allowed=&allowed('eco',$ownerdomain); -# Nope - unless ($allowed) { return ''; } -# Looks like we may have access, but could be locked by the owner of the construction space - if ($allowed eq 'U') { - my %blocked=&get('environment',['domcoord.author'], - $ownerdomain,$ownername); -# Is blocked by owner - if ($blocked{'domcoord.author'} eq 'blocked') { return ''; } - } - if (($allowed eq 'F') || ($allowed eq 'U')) { -# Grant temporary access - my $then=$env{'user.login.time'}; - my $update==$env{'user.update.time'}; - if (!$update) { $update = $then; } - my $refresh=$env{'user.refresh.time'}; - if (!$refresh) { $refresh = $update; } - my $now = time; - &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh, - $now,'ca','constructaccess'); - $ownerhome = &homeserver($ownername,$ownerdomain); - return($ownername,$ownerdomain,$ownerhome); - } -# No business here - return ''; -} - sub get_comm_blocks { my ($cdom,$cnum) = @_; if ($cdom eq '' || $cnum eq '') { @@ -7917,41 +7452,6 @@ sub assignrole { } } } - } elsif ($context eq 'requestauthor') { - if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && - ($url eq '/'.$udom.'/') && ($role eq 'au')) { - if ($env{'environment.requestauthor'} eq 'automatic') { - $refused = ''; - } else { - my %domdefaults = &get_domain_defaults($udom); - if (ref($domdefaults{'requestauthor'}) eq 'HASH') { - my $checkbystatus; - if ($env{'user.adv'}) { - my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'}; - if ($disposition eq 'automatic') { - $refused = ''; - } elsif ($disposition eq '') { - $checkbystatus = 1; - } - } else { - $checkbystatus = 1; - } - if ($checkbystatus) { - if ($env{'environment.inststatus'}) { - my @inststatuses = split(/,/,$env{'environment.inststatus'}); - foreach my $type (@inststatuses) { - if (($type ne '') && - ($domdefaults{'requestauthor'}{$type} eq 'automatic')) { - $refused = ''; - } - } - } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') { - $refused = ''; - } - } - } - } - } } if ($refused) { &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url. @@ -8001,25 +7501,11 @@ sub assignrole { # log new user role if status is ok if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); - if (($role eq 'cc') || ($role eq 'in') || - ($role eq 'ep') || ($role eq 'ad') || - ($role eq 'ta') || ($role eq 'st') || - ($role=~/^cr/) || ($role eq 'gr') || - ($role eq 'co')) { # for course roles, perform group memberships changes triggered by role change. - unless ($role =~ /^gr/) { - &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, - $origstart,$selfenroll,$context); - } - &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')) { - &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, - $context); - } elsif (($role eq 'ca') || ($role eq 'aa')) { - &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag, - $context); + &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context); + unless ($role =~ /^gr/) { + &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend, + $origstart,$selfenroll,$context); } if ($role eq 'cc') { &autoupdate_coowners($url,$end,$start,$uname,$udom); @@ -10249,78 +9735,6 @@ sub gettitle { return $title; } -sub getdocspath { - my ($symb) = @_; - my $path; - if ($symb) { - my ($mapurl,$id,$resurl) = &decode_symb($symb); - if ($resurl=~/\.(sequence|page)$/) { - $mapurl=$resurl; - } elsif ($resurl eq 'adm/navmaps') { - $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; - } - my $mapresobj; - my $navmap = Apache::lonnavmaps::navmap->new(); - if (ref($navmap)) { - $mapresobj = $navmap->getResourceByUrl($mapurl); - } - $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; - my $type=$2; - if (ref($mapresobj)) { - my $pcslist = $mapresobj->map_hierarchy(); - if ($pcslist ne '') { - foreach my $pc (split(/,/,$pcslist)) { - next if ($pc <= 1); - my $res = $navmap->getByMapPc($pc); - if (ref($res)) { - my $thisurl = $res->src(); - $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; - my $thistitle = $res->title(); - $path .= '&'. - &Apache::lonhtmlcommon::entity_encode($thisurl).'&'. - &Apache::lonhtmlcommon::entity_encode($thistitle). - ':'.$res->randompick(). - ':'.$res->randomout(). - ':'.$res->encrypted(). - ':'.$res->randomorder(). - ':'.$res->is_page(); - } - } - } - $path =~ s/^\&//; - my $maptitle = $mapresobj->title(); - if ($mapurl eq 'default') { - $maptitle = 'Main Course Documents'; - } - $path .= ($path ne '')? '&' : ''. - &Apache::lonhtmlcommon::entity_encode($mapurl).'&'. - &Apache::lonhtmlcommon::entity_encode($maptitle). - ':'.$mapresobj->randompick(). - ':'.$mapresobj->randomout(). - ':'.$mapresobj->encrypted(). - ':'.$mapresobj->randomorder(). - ':'.$mapresobj->is_page(); - } else { - my $maptitle = &gettitle($mapurl); - my $ispage; - if ($mapurl =~ /\.page$/) { - $ispage = 1; - } - if ($mapurl eq 'default') { - $maptitle = 'Main Course Documents'; - } - $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'. - &Apache::lonhtmlcommon::entity_encode($maptitle).':::::'.$ispage; - } - unless ($mapurl eq 'default') { - $path = 'default&'. - &Apache::lonhtmlcommon::entity_encode('Main Course Documents'). - ':::::&'.$path; - } - } - return $path; -} - sub get_slot { my ($which,$cnum,$cdom)=@_; if (!$cnum || !$cdom) { @@ -10387,41 +9801,6 @@ sub devalidate_slots_cache { &devalidate_cache_new('allslots',$hashid); } -sub get_coursechange { - my ($cdom,$cnum) = @_; - if ($cdom eq '' || $cnum eq '') { - return unless ($env{'request.course.id'}); - $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; - } - my $hashid=$cdom.'_'.$cnum; - my ($change,$cached)=&is_cached_new('crschange',$hashid); - if ((defined($cached)) && ($change ne '')) { - return $change; - } else { - my %crshash; - %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum); - if ($crshash{'internal.contentchange'} eq '') { - $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'}; - if ($change eq '') { - %crshash = &get('environment',['internal.created'],$cdom,$cnum); - $change = $crshash{'internal.created'}; - } - } else { - $change = $crshash{'internal.contentchange'}; - } - my $cachetime = 600; - &do_cache_new('crschange',$hashid,$change,$cachetime); - } - return $change; -} - -sub devalidate_coursechange_cache { - my ($cnum,$cdom)=@_; - my $hashid=$cnum.':'.$cdom; - &devalidate_cache_new('crschange',$hashid); -} - # ------------------------------------------------- Update symbolic store links sub symblist { @@ -10449,7 +9828,7 @@ sub symblist { # --------------------------------------------------------------- Verify a symb sub symbverify { - my ($symb,$thisurl,$encstate)=@_; + my ($symb,$thisurl)=@_; my $thisfn=$thisurl; $thisfn=&declutter($thisfn); # direct jump to resource in page or to a sequence - will construct own symbs @@ -10468,46 +9847,31 @@ sub symbverify { if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db', &GDBM_READER(),0640)) { - my $noclutter; if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) { $thisurl =~ s/\?.+$//; - if ($map =~ m{^uploaded/.+\.page$}) { - $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://}; - $thisurl =~ s{^\Qhttp://https://\E}{https://}; - $noclutter = 1; - } - } - my $ids; - if ($noclutter) { - $ids=$bighash{'ids_'.$thisurl}; - } else { - $ids=$bighash{'ids_'.&clutter($thisurl)}; } + my $ids=$bighash{'ids_'.&clutter($thisurl)}; unless ($ids) { - my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; + my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl; $ids=$bighash{$idkey}; } if ($ids) { # ------------------------------------------------------------------- Has ID(s) - if ($thisfn =~ m{^/adm/wrapper/ext/}) { - $symb =~ s/\?.+$//; - } foreach my $id (split(/\,/,$ids)) { my ($mapid,$resid)=split(/\./,$id); + if ($thisfn =~ m{^/adm/wrapper/ext/}) { + $symb =~ s/\?.+$//; + } if ( &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn) - eq $symb) { - if (ref($encstate)) { - $$encstate = $bighash{'encrypted_'.$id}; - } - if (($env{'request.role.adv'}) || - ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || + eq $symb) { + if (($env{'request.role.adv'}) || + ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) || ($thisurl eq '/adm/navmaps')) { - $okay=1; - last; - } - } - } + $okay=1; + } + } + } } untie(%bighash); } @@ -10580,18 +9944,14 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; - my $cache_str; - if ($thisfn ne '') { - $cache_str='request.symbread.cached.'.$thisfn; - if ($env{$cache_str} ne '') { - return $env{$cache_str}; - } - } else { + my $cache_str='request.symbread.cached.'.$thisfn; + if (defined($env{$cache_str})) { return $env{$cache_str}; } # no filename provided? try from environment + unless ($thisfn) { if ($env{'request.symb'}) { - return $env{$cache_str}=&symbclean($env{'request.symb'}); - } - $thisfn=$env{'request.filename'}; + return $env{$cache_str}=&symbclean($env{'request.symb'}); + } + $thisfn=$env{'request.filename'}; } if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); } # is that filename actually a symb? Verify, clean, and return @@ -10819,6 +10179,7 @@ sub rndseed { $which =&get_rand_alg($courseid); } if (defined(&getCODE())) { + if ($which eq '64bit5') { return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { @@ -12367,21 +11728,6 @@ allowed($priv,$uri,$symb,$role) : check =item * -constructaccess($url,$setpriv) : check for access to construction space URL - -See if the owner domain and name in the URL match those in the -expected environment. If so, return three element list -($ownername,$ownerdomain,$ownerhome). - -Otherwise return the null string. - -If second argument 'setpriv' is true, it assigns the privileges, -and returns the same three element list, unless the owner has -blocked "ad hoc" Domain Coordinator access to the Author Space, -in which case the null string is returned. - -=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 @@ -12412,17 +11758,6 @@ of role statuses (active, future or prev to restrict the list of roles reported. If no array ref is provided for types, will default to return only active roles. -=item * - -in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if -user: $uname:$udom has a role in the course: $cdom_$cnum. - -Additional optional arguments are: $type (if role checking is to be restricted -to certain user status types -- previous (expired roles), active (currently -available roles) or future (roles available in the future), and -$hideprivileged -- if true will not report course roles for users who -have active Domain Coordinator or Super User roles. - =back =head2 User Modification @@ -12625,6 +11960,7 @@ data base, returning a hash that is keye values that are the resource value. I believe that the timestamps and versions are also returned. + =back =head2 Course Modification @@ -12725,14 +12061,12 @@ returns the data handle =item * -symbverify($symb,$thisfn,$ecstate) : verifies that $symb actually exists -and is a possible symb for the URL in $thisfn, and if is an encrypted +symbverify($symb,$thisfn) : verifies that $symb actually exists and is +a possible symb for the URL in $thisfn, and if is an encryypted resource that the user accessed using /enc/ returns a 1 on success, 0 -on failure, user must be in a course, as it assumes the existence of -the course initial hash, and uses $env('request.course.id'}. The third -arg is an optional reference to a scalar. If this arg is passed in the -call to symbverify, it will be set to 1 if the symb has been set to be -encrypted; otherwise it will be null. +on failure, user must be in a course, as it assumes the existance of +the course initial hash, and uses $env('request.course.id'} + =item * @@ -12785,34 +12119,6 @@ expirespread($uname,$udom,$stype,$usymb) devalidate($symb) : devalidate temporary spreadsheet calculations, forcing spreadsheet to reevaluate the resource scores next time. -=item * - -can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource, -when viewing in course context. - - input: six args -- filename (decluttered), course number, course domain, - url, symb (if registered) and group (if this is a - group item -- e.g., bulletin board, group page etc.). - - output: array of five scalars -- - $cfile -- url for file editing if editable on current server - $home -- homeserver of resource (i.e., for author if published, - or course if uploaded.). - $switchserver -- 1 if server switch will be needed. - $forceedit -- 1 if icon/link should be to go to edit mode - $forceview -- 1 if icon/link should be to go to view mode - -=item * - -is_course_upload($file,$cnum,$cdom) - -Used in course context to determine if current file was uploaded to -the course (i.e., would be found in /userfiles/docs on the course's -homeserver. - - input: 3 args -- filename (decluttered), course number and course domain. - output: boolean -- 1 if file was uploaded. - =back =head2 Storing/Retreiving Data @@ -13368,8 +12674,6 @@ Internal notes: Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays. -=item * - modify_access_controls(): Modifies access controls for a portfolio file @@ -13387,51 +12691,7 @@ Returns: 3. reference to hash of any new or updated access controls. 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control. key = integer (inbound ID) - value = uniqueID - -=item * - -get_timebased_id(): - -Attempts to get a unique timestamp-based suffix for use with items added to a -course via the Course Editor (e.g., folders, composite pages, -group bulletin boards). - -Args: (first three required; six others optional) - -1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage, - docssequence, or name of group - -2. keyid (alphanumeric): name of temporary locking key in hash, - e.g., num, boardids - -3. namespace: name of gdbm file used to store suffixes already assigned; - file will be named nohist_namespace.db - -4. cdom: domain of course; default is current course domain from %env - -5. cnum: course number; default is current course number from %env - -6. idtype: set to concat if an additional digit is to be appended to the - unix timestamp to form the suffix, if the plain timestamp is already - in use. Default is to not do this, but simply increment the unix - timestamp by 1 until a unique key is obtained. - -7. who: holder of locking key; defaults to user:domain for user. - -8. locktries: number of attempts to obtain a lock (sleep of 1s before - retrying); default is 3. - -9. maxtries: number of attempts to obtain a unique suffix; default is 20. - -Returns: - -1. suffix obtained (numeric) - -2. result of deleting locking key (ok if deleted, or lock never obtained) - -3. error: contains (localized) error message if an error occurred. - + value = uniqueID =back