--- loncom/lonnet/perl/lonnet.pm 2012/09/25 23:15:25 1.1172.2.12 +++ 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.12 2012/09/25 23:15:25 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++; 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; } } @@ -3546,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)); @@ -3722,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); @@ -5044,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 { @@ -5698,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, ); } @@ -5721,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'}; } } @@ -5812,7 +5731,7 @@ sub usertools_access { } } } else { - if (($context eq 'tools') && ($tool ne 'webdav')) { + if ($context eq 'tools') { $access = 1; } else { $access = 0; @@ -7533,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. @@ -7618,25 +7502,11 @@ sub assignrole { if ($answer eq 'ok') { &userrolelog($role,$uname,$udom,$url,$start,$end); # for course roles, perform group memberships changes triggered by role change. + &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') || ($role eq 'in') || - ($role eq 'ep') || ($role eq 'ad') || - ($role eq 'ta') || ($role eq 'st') || - ($role=~/^cr/) || ($role eq 'gr') || - ($role eq 'co')) { - &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); - } if ($role eq 'cc') { &autoupdate_coowners($url,$end,$start,$uname,$udom); } @@ -9931,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 { @@ -9993,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 @@ -10030,9 +9865,6 @@ sub symbverify { 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'}) || ($thisurl eq '/adm/navmaps')) { @@ -10113,11 +9945,7 @@ sub deversion { sub symbread { my ($thisfn,$donotrecurse)=@_; my $cache_str='request.symbread.cached.'.$thisfn; - if (defined($env{$cache_str})) { - if (($thisfn) || ($env{$cache_str} ne '')) { - return $env{$cache_str}; - } - } + if (defined($env{$cache_str})) { return $env{$cache_str}; } # no filename provided? try from environment unless ($thisfn) { if ($env{'request.symb'}) { @@ -12233,14 +12061,11 @@ 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 *