--- loncom/lonnet/perl/lonnet.pm 2011/05/13 02:26:21 1.1106 +++ loncom/lonnet/perl/lonnet.pm 2012/03/14 20:53:50 1.1158 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1106 2011/05/13 02:26:21 raeburn Exp $ +# $Id: lonnet.pm,v 1.1158 2012/03/14 20:53:50 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -76,7 +76,8 @@ use HTTP::Date; use Image::Magick; use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir - $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease); + $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease + %managerstab); my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash, %userrolehash, $processmarker, $dumpcount, %coursedombuf, @@ -95,6 +96,7 @@ use Math::Random; use File::MMagic; use LONCAPA qw(:DEFAULT :match); use LONCAPA::Configuration; + use File::Copy; my $readit; @@ -305,6 +307,52 @@ sub get_server_homeID { return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime); } +sub get_remote_globals { + my ($lonhost,$whathash,$ignore_cache) = @_; + my ($result,%returnhash,%whatneeded); + if (ref($whathash) eq 'HASH') { + foreach my $what (sort(keys(%{$whathash}))) { + my $hashid = $lonhost.'-'.$what; + my ($response,$cached); + unless ($ignore_cache) { + ($response,$cached)=&is_cached_new('lonnetglobal',$hashid); + } + if (defined($cached)) { + $returnhash{$what} = $response; + } else { + $whatneeded{$what} = 1; + } + } + if (keys(%whatneeded) == 0) { + $result = 'ok'; + } else { + my $requested = &freeze_escape(\%whatneeded); + my $rep=&reply('readlonnetglobal:'.$requested,$lonhost); + if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') || + ($rep eq 'unknown_cmd')) { + $result = $rep; + } else { + $result = 'ok'; + my @pairs=split(/\&/,$rep); + foreach my $item (@pairs) { + my ($key,$value)=split(/=/,$item,2); + my $what = &unescape($key); + my $hashid = $lonhost.'-'.$what; + $returnhash{$what}=&thaw_unescape($value); + &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600); + } + } + } + } + return ($result,\%returnhash); +} + +sub remote_devalidate_cache { + my ($lonhost,$name,$id) = @_; + my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost); + return $response; +} + # -------------------------------------------------- Non-critical communication sub subreply { my ($cmd,$server)=@_; @@ -547,13 +595,21 @@ sub transfer_profile_to_env { # ---------------------------------------------------- Check for valid session sub check_for_valid_session { - my ($r) = @_; + my ($r,$name) = @_; my %cookies=CGI::Cookie->parse($r->header_in('Cookie')); - my $lonid=$cookies{'lonID'}; + if ($name eq '') { + $name = 'lonID'; + } + my $lonid=$cookies{$name}; return undef if (!$lonid); my $handle=&LONCAPA::clean_handle($lonid->value); - my $lonidsdir=$r->dir_config('lonIDsDir'); + my $lonidsdir; + if ($name eq 'lonDAV') { + $lonidsdir=$r->dir_config('lonDAVsessDir'); + } else { + $lonidsdir=$r->dir_config('lonIDsDir'); + } return undef if (!-e "$lonidsdir/$handle.id"); my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id"); @@ -772,26 +828,33 @@ sub spareserver { my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom); $remotesessions = $udomdefaults{'remotesessions'}; } - foreach my $try_server (@{ $spareid{'primary'} }) { - if ($uint_dom) { - next unless (&spare_can_host($udom,$uint_dom,$remotesessions, - $try_server)); + my $spareshash = &this_host_spares($udom); + 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)); + } + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); + } } - ($spare_server, $lowest_load) = - &compare_server_load($try_server, $spare_server, $lowest_load); - } - my $found_server = ($spare_server ne '' && $lowest_load < 100); - - if (!$found_server) { - foreach my $try_server (@{ $spareid{'default'} }) { - if ($uint_dom) { - next unless (&spare_can_host($udom,$uint_dom,$remotesessions, - $try_server)); - } - ($spare_server, $lowest_load) = - &compare_server_load($try_server, $spare_server, $lowest_load); - } + my $found_server = ($spare_server ne '' && $lowest_load < 100); + + 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)); + } + ($spare_server, $lowest_load) = + &compare_server_load($try_server, $spare_server, $lowest_load); + } + } + } } if (!$want_server_name) { @@ -816,7 +879,7 @@ sub compare_server_load { my $userloadans = &reply('userload',$try_server); if ($loadans !~ /\d/ && $userloadans !~ /\d/) { - return; #didn't get a number from the server + return ($spare_server, $lowest_load); #didn't get a number from the server } my $load; @@ -842,9 +905,18 @@ sub compare_server_load { # --------------------------- ask offload servers if user already has a session sub find_existing_session { my ($udom,$uname) = @_; - foreach my $try_server (@{ $spareid{'primary'} }, - @{ $spareid{'default'} }) { - return $try_server if (&has_user_session($try_server, $udom, $uname)); + my $spareshash = &this_host_spares($udom); + if (ref($spareshash) eq 'HASH') { + if (ref($spareshash->{'primary'}) eq 'ARRAY') { + foreach my $try_server (@{ $spareshash->{'primary'} }) { + return $try_server if (&has_user_session($try_server, $udom, $uname)); + } + } + if (ref($spareshash->{'default'}) eq 'ARRAY') { + foreach my $try_server (@{ $spareshash->{'default'} }) { + return $try_server if (&has_user_session($try_server, $udom, $uname)); + } + } } return; } @@ -862,22 +934,40 @@ sub has_user_session { # --------- determine least loaded server in a user's domain which allows login sub choose_server { - my ($udom) = @_; + my ($udom,$checkloginvia) = @_; my %domconfhash = &Apache::loncommon::get_domainconf($udom); my %servers = &get_servers($udom); my $lowest_load = 30000; - my ($login_host,$hostname); + my ($login_host,$hostname,$portal_path,$isredirect); foreach my $lonhost (keys(%servers)) { - my $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; - if ($loginvia eq '') { + my $loginvia; + if ($checkloginvia) { + $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost}; + if ($loginvia) { + my ($server,$path) = split(/:/,$loginvia); + ($login_host, $lowest_load) = + &compare_server_load($server, $login_host, $lowest_load); + if ($login_host eq $server) { + $portal_path = $path; + $isredirect = 1; + } + } else { + ($login_host, $lowest_load) = + &compare_server_load($lonhost, $login_host, $lowest_load); + if ($login_host eq $lonhost) { + $portal_path = ''; + $isredirect = ''; + } + } + } else { ($login_host, $lowest_load) = - &compare_server_load($lonhost, $login_host, $lowest_load); + &compare_server_load($lonhost, $login_host, $lowest_load); } } if ($login_host ne '') { - $hostname = $servers{$login_host}; + $hostname = &hostname($login_host); } - return ($login_host,$hostname); + return ($login_host,$hostname,$portal_path,$isredirect); } # --------------------------------------------- Try to change a user's password @@ -1018,15 +1108,19 @@ sub can_host_session { } if ($canhost) { if (ref($hostedsessions) eq 'HASH') { + my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); + my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id); if (ref($hostedsessions->{'excludedomain'}) eq 'ARRAY') { - if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'excludedomain'}})) { + if (($uint_dom ne '') && + (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'excludedomain'}}))) { $canhost = 0; } else { $canhost = 1; } } if (ref($hostedsessions->{'includedomain'}) eq 'ARRAY') { - if (grep(/^\Q$udom\E$/,@{$hostedsessions->{'includedomain'}})) { + if (($uint_dom ne '') && + (grep(/^\Q$uint_dom\E$/,@{$hostedsessions->{'includedomain'}}))) { $canhost = 1; } else { $canhost = 0; @@ -1057,6 +1151,302 @@ sub spare_can_host { return $canhost; } +sub this_host_spares { + my ($dom) = @_; + my ($dom_in_use,$lonhost_in_use,$result); + my @hosts = ¤t_machine_ids(); + foreach my $lonhost (@hosts) { + if (&host_domain($lonhost) eq $dom) { + $dom_in_use = $dom; + $lonhost_in_use = $lonhost; + last; + } + } + if ($dom_in_use ne '') { + $result = &spares_for_offload($dom_in_use,$lonhost_in_use); + } + if (ref($result) ne 'HASH') { + $lonhost_in_use = $perlvar{'lonHostID'}; + $dom_in_use = &host_domain($lonhost_in_use); + $result = &spares_for_offload($dom_in_use,$lonhost_in_use); + if (ref($result) ne 'HASH') { + $result = \%spareid; + } + } + return $result; +} + +sub spares_for_offload { + my ($dom_in_use,$lonhost_in_use) = @_; + my ($result,$cached)=&is_cached_new('spares',$dom_in_use); + if (defined($cached)) { + return $result; + } else { + my $cachetime = 60*60*24; + my %domconfig = + &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use); + if (ref($domconfig{'usersessions'}) eq 'HASH') { + if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') { + if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') { + return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime); + } + } + } + } + return; +} + +sub get_lonbalancer_config { + my ($servers) = @_; + my ($currbalancer,$currtargets); + if (ref($servers) eq 'HASH') { + foreach my $server (keys(%{$servers})) { + my %what = ( + spareid => 1, + perlvar => 1, + ); + my ($result,$returnhash) = &get_remote_globals($server,\%what); + if ($result eq 'ok') { + if (ref($returnhash) eq 'HASH') { + if (ref($returnhash->{'perlvar'}) eq 'HASH') { + if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') { + $currbalancer = $server; + $currtargets = {}; + if (ref($returnhash->{'spareid'}) eq 'HASH') { + if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') { + $currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'}; + } + if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') { + $currtargets->{'default'} = $returnhash->{'spareid'}->{'default'}; + } + } + last; + } + } + } + } + } + } + return ($currbalancer,$currtargets); +} + +sub check_loadbalancing { + my ($uname,$udom) = @_; + my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect, + $offloadto,$otherserver); + my $lonhost = $perlvar{'lonHostID'}; + my $uprimary_id = &Apache::lonnet::domain($udom,'primary'); + my $uintdom = &Apache::lonnet::internet_dom($uprimary_id); + my $intdom = &Apache::lonnet::internet_dom($lonhost); + my $serverhomedom = &host_domain($lonhost); + + my $cachetime = 60*60*24; + + if (($uintdom ne '') && ($uintdom eq $intdom)) { + $dom_in_use = $udom; + $homeintdom = 1; + } else { + $dom_in_use = $serverhomedom; + } + my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use); + unless (defined($cached)) { + my %domconfig = + &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use); + if (ref($domconfig{'loadbalancing'}) eq 'HASH') { + $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); + } + } + if (ref($result) eq 'HASH') { + 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) { + if ($uname ne '') { + if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) { + my ($is_adv,$is_author) = &is_advanced_user($udom,$uname); + if (($currrules->{'_LC_author'} ne '') && ($is_author)) { + $rule_in_effect = $currrules->{'_LC_author'}; + } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) { + $rule_in_effect = $currrules->{'_LC_adv'} + } + } + if ($rule_in_effect eq '') { + my %userenv = &userenvironment($udom,$uname,'inststatus'); + if ($userenv{'inststatus'} ne '') { + my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'}); + my ($othertitle,$usertypes,$types) = + &Apache::loncommon::sorted_inst_types($udom); + if (ref($types) eq 'ARRAY') { + foreach my $type (@{$types}) { + if (grep(/^\Q$type\E$/,@statuses)) { + if (exists($currrules->{$type})) { + $rule_in_effect = $currrules->{$type}; + } + } + } + } + } else { + if (exists($currrules->{'default'})) { + $rule_in_effect = $currrules->{'default'}; + } + } + } + } else { + if (exists($currrules->{'default'})) { + $rule_in_effect = $currrules->{'default'}; + } + } + } else { + if ($currrules->{'_LC_external'} ne '') { + $rule_in_effect = $currrules->{'_LC_external'}; + } + } + $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets, + $uname,$udom); + } + } + } elsif (($homeintdom) && ($udom ne $serverhomedom)) { + my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom); + unless (defined($cached)) { + my %domconfig = + &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom); + if (ref($domconfig{'loadbalancing'}) eq 'HASH') { + $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime); + } + } + if (ref($result) eq 'HASH') { + 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'}; + } + } + $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets, + $uname,$udom); + } + } else { + if ($perlvar{'lonBalancer'} eq 'yes') { + $is_balancer = 1; + $offloadto = &this_host_spares($dom_in_use); + } + } + } else { + if ($perlvar{'lonBalancer'} eq 'yes') { + $is_balancer = 1; + $offloadto = &this_host_spares($dom_in_use); + } + } + 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); + + 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}) { + ($otherserver,$lowest_load) = + &compare_server_load($try_server,$otherserver,$lowest_load); + } + } + } + return ($is_balancer,$otherserver); +} + +sub get_loadbalancer_targets { + my ($rule_in_effect,$currtargets,$uname,$udom) = @_; + my $offloadto; + if ($rule_in_effect eq '') { + $offloadto = $currtargets; + } else { + if ($rule_in_effect eq 'homeserver') { + my $homeserver = &homeserver($uname,$udom); + if ($homeserver ne 'no_host') { + $offloadto = [$homeserver]; + } + } elsif ($rule_in_effect eq 'externalbalancer') { + my %domconfig = + &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom); + if (ref($domconfig{'loadbalancing'}) eq 'HASH') { + if ($domconfig{'loadbalancing'}{'lonhost'} ne '') { + if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') { + $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}]; + } + } + } else { + my %servers = &dom_servers($udom); + my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers); + if (&hostname($remotebalancer) ne '') { + $offloadto = [$remotebalancer]; + } + } + } elsif (&hostname($rule_in_effect) ne '') { + $offloadto = [$rule_in_effect]; + } + } + return $offloadto; +} + +sub internet_dom_servers { + my ($dom) = @_; + my (%uniqservers,%servers); + my $primaryserver = &hostname(&domain($dom,'primary')); + my @machinedoms = &machine_domains($primaryserver); + foreach my $mdom (@machinedoms) { + my %currservers = %servers; + my %server = &get_servers($mdom); + %servers = (%currservers,%server); + } + my %by_hostname; + foreach my $id (keys(%servers)) { + push(@{$by_hostname{$servers{$id}}},$id); + } + foreach my $hostname (sort(keys(%by_hostname))) { + if (@{$by_hostname{$hostname}} > 1) { + my $match = 0; + foreach my $id (@{$by_hostname{$hostname}}) { + if (&host_domain($id) eq $dom) { + $uniqservers{$id} = $hostname; + $match = 1; + } + } + unless ($match) { + $uniqservers{$by_hostname{$hostname}[0]} = $hostname; + } + } else { + $uniqservers{$by_hostname{$hostname}[0]} = $hostname; + } + } + return %uniqservers; +} + # ---------------------- Find the homebase for a user from domain's lib servers my %homecache; @@ -1540,6 +1930,7 @@ sub get_domain_defaults { $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'}; $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; + $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -1833,7 +2224,7 @@ sub is_cached_new { my ($name,$id,$debug) = @_; $id=&make_key($name,$id); if (exists($remembered{$id})) { - if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); } + if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); } $accessed{$id}=[&gettimeofday()]; $hits++; return ($remembered{$id},1); @@ -1999,20 +2390,29 @@ sub getversion { sub currentversion { my $fname=shift; - my ($result,$cached)=&is_cached_new('resversion',$fname); - if (defined($cached)) { return $result; } my $author=$fname; $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; my ($udom,$uname)=split(/\//,$author); - my $home=homeserver($uname,$udom); + my $home=&homeserver($uname,$udom); if ($home eq 'no_host') { return -1; } - my $answer=reply("currentversion:$fname",$home); + my $answer=&reply("currentversion:$fname",$home); if (($answer eq 'con_lost') || ($answer eq 'rejected')) { return -1; } - return &do_cache_new('resversion',$fname,$answer,600); + return $answer; +} + +# +# Return special version number of resource if set by override, empty otherwise +# +sub usedversion { + my $fname=shift; + unless ($fname) { $fname=$env{'request.uri'}; } + my ($urlversion)=($fname=~/\.(\d+)\.\w+$/); + if ($urlversion) { return $urlversion; } + return ''; } # ----------------------------- Subscribe to a resource, return URL if possible @@ -2040,10 +2440,11 @@ sub subscribe { sub repcopy { my $filename=shift; $filename=~s/\/+/\//g; - if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; } - if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; } - if ($filename=~m|^/home/httpd/html/userfiles/| or - $filename=~m -^/*(uploaded|editupload)/-) { + my $londocroot = $perlvar{'lonDocRoot'}; + if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; } + if ($filename=~m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; } + if ($filename=~m{^\Q$londocroot/userfiles/\E} or + $filename=~m{^/*(uploaded|editupload)/}) { return &repcopy_userfile($filename); } $filename=~s/[\n\r]//g; @@ -2070,7 +2471,7 @@ sub repcopy { unless ($home eq $perlvar{'lonHostID'}) { my @parts=split(/\//,$filename); my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; - if ($path ne "$perlvar{'lonDocRoot'}/res") { + if ($path ne "$londocroot/res") { &logthis("Malconfiguration for replication: $filename"); return 'bad_request'; } @@ -2408,7 +2809,7 @@ sub resizeImage { # $resizewidth - width (pixels) to which to resize uploaded image # $resizeheight - height (pixels) to which to resize uploaded image # $mimetype - reference to scalar to accommodate mime type determined -# from File::MMagic if $parser = parse. +# from File::MMagic. # # output: url of file in userspace, or error: # or /adm/notfound.html if failure to upload occurse @@ -2548,7 +2949,7 @@ sub finishuserfileupload { return '/adm/notfound.html'; } if ($context eq 'overwrite') { - my $source = $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; + my $source = LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname; my $target = $filepath.'/'.$file; if (-e $source) { my @info = stat($source); @@ -2577,10 +2978,17 @@ sub finishuserfileupload { } } } + if (($context eq 'coursedoc') || ($parser eq 'parse')) { + if (ref($mimetype)) { + if ($$mimetype eq '') { + my $mm = new File::MMagic; + my $type = $mm->checktype_filename($filepath.'/'.$file); + $$mimetype = $type; + } + } + } if ($parser eq 'parse') { - my $mm = new File::MMagic; - my $type = $mm->checktype_filename($filepath.'/'.$file); - if ($type eq 'text/html') { + if ((ref($mimetype)) && ($$mimetype eq 'text/html')) { my $parse_result = &extract_embedded_items($filepath.'/'.$file, $allfiles,$codebase); unless ($parse_result eq 'ok') { @@ -2588,9 +2996,6 @@ sub finishuserfileupload { ' for embedded media: '.$parse_result); } } - if (ref($mimetype)) { - $$mimetype = $type; - } } if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) { my $input = $filepath.'/'.$file; @@ -2861,12 +3266,6 @@ sub flushcourselogs { my $result = &inc('nohist_accesscount',\%temphash,$dom,$name); if ($result eq 'ok') { delete $accesshash{$entry}; - } elsif ($result eq 'unknown_cmd') { - # Target server has old code running on it. - my %temphash=($entry => $value); - if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') { - delete $accesshash{$entry}; - } } } else { my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$}); @@ -2948,7 +3347,7 @@ sub courseacclog { my $fnsymb=shift; unless ($env{'request.course.id'}) { return ''; } my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'}; - if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) { + if ($fnsymb=~/$LONCAPA::assess_re/) { $what.=':POST'; # FIXME: Probably ought to escape things.... foreach my $key (keys(%env)) { @@ -2980,7 +3379,13 @@ sub countacc { my $url=&declutter(shift); return if (! defined($url) || $url eq ''); unless ($env{'request.course.id'}) { return ''; } +# +# Mark that this url was used in this course +# $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1; +# +# Increase the access count for this resource in this child process +# my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count'; $accesshash{$key}++; } @@ -3147,6 +3552,7 @@ sub get_my_roles { foreach my $entry (keys(%dumphash)) { my ($role,$tend,$tstart); if ($context eq 'userroles') { + next if ($entry =~ /^rolesdef/); ($role,$tend,$tstart)=split(/_/,$dumphash{$entry}); } else { ($tend,$tstart)=split(/\:/,$dumphash{$entry}); @@ -3460,6 +3866,28 @@ sub get_domain_roles { # ----------------------------------------------------------- Interval timing +{ +# Caches needed for speedup of navmaps +# We don't want to cache this for very long at all (5 seconds at most) +# +# The user for whom we cache +my $cachedkey=''; +# The cached times for this user +my %cachedtimes=(); +# When this was last done +my $cachedtime=(); + +sub load_all_first_access { + my ($uname,$udom)=@_; + if (($cachedkey eq $uname.':'.$udom) && + (abs($cachedtime-time)<5)) { + return; + } + $cachedtime=time; + $cachedkey=$uname.':'.$udom; + %cachedtimes=&dump('firstaccesstimes',$udom,$uname); +} + sub get_first_access { my ($type,$argsymb)=@_; my ($symb,$courseid,$udom,$uname)=&whichuser(); @@ -3472,8 +3900,8 @@ sub get_first_access { } else { $res=$symb; } - my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname); - return $times{"$courseid\0$res"}; + &load_all_first_access($uname,$udom); + return $cachedtimes{"$courseid\0$res"}; } sub set_first_access { @@ -3487,13 +3915,14 @@ sub set_first_access { } else { $res=$symb; } + $cachedkey=''; my $firstaccess=&get_first_access($type,$symb); if (!$firstaccess) { return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname); } return 'already_set'; } - +} # --------------------------------------------- Set Expire Date for Spreadsheet sub expirespread { @@ -3598,7 +4027,7 @@ sub hashref2str { $result.='='; #print("Got a ref of ".(ref($key))." skipping."); } else { - if ($key) {$result.=&escape($key).'=';} else { last; } + if (defined($key)) {$result.=&escape($key).'=';} else { last; } } if(ref($hashref->{$key}) eq 'ARRAY') { @@ -3750,7 +4179,7 @@ sub tmpreset { if ($domain eq 'public' && $stuname eq 'public') { $stuname=$ENV{'REMOTE_ADDR'}; } - my $path=$perlvar{'lonDaemons'}.'/tmp'; + my $path=LONCAPA::tempdir(); my %hash; if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', @@ -3789,7 +4218,7 @@ sub tmpstore { } my $now=time; my %hash; - my $path=$perlvar{'lonDaemons'}.'/tmp'; + my $path=LONCAPA::tempdir(); if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_WRCREAT(),0640)) { @@ -3835,7 +4264,7 @@ sub tmprestore { $namespace=~s/\//\_/g; $namespace=~s/\W//g; my %hash; - my $path=$perlvar{'lonDaemons'}.'/tmp'; + my $path=LONCAPA::tempdir(); if (tie(%hash,'GDBM_File', $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db', &GDBM_READER(),0640)) { @@ -3972,6 +4401,8 @@ sub restore { } # ---------------------------------------------------------- Course Description +# +# sub coursedescription { my ($courseid,$args)=@_; @@ -4001,7 +4432,8 @@ sub coursedescription { return %returnhash; } - # get the data agin + # get the data again + if (!$args->{'one_time'}) { $envhash{'course.'.$normalid.'.last_cache'}=time; } @@ -4009,6 +4441,10 @@ sub coursedescription { if ($chome ne 'no_host') { %returnhash=&dump('environment',$cdomain,$cnum); if (!exists($returnhash{'con_lost'})) { + my $username = $env{'user.name'}; # Defult username + if(defined $args->{'user'}) { + $username = $args->{'user'}; + } $returnhash{'home'}= $chome; $returnhash{'domain'} = $cdomain; $returnhash{'num'} = $cnum; @@ -4019,8 +4455,8 @@ sub coursedescription { $envhash{'course.'.$normalid.'.'.$name}=$value; } $returnhash{'url'}=&clutter($returnhash{'url'}); - $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'. - $env{'user.name'}.'_'.$cdomain.'_'.$cnum; + $returnhash{'fn'}=LONCAPA::tempdir() . + $username.'_'.$cdomain.'_'.$cnum; $envhash{'course.'.$normalid.'.home'}=$chome; $envhash{'course.'.$normalid.'.domain'}=$cdomain; $envhash{'course.'.$normalid.'.num'}=$cnum; @@ -4803,7 +5239,7 @@ sub tmpget { return %returnhash; } -# ------------------------------------------------------------ tmpget interface +# ------------------------------------------------------------ tmpdel interface sub tmpdel { my ($token,$server)=@_; if (!defined($server)) { $server = $perlvar{'lonHostID'}; } @@ -5201,12 +5637,16 @@ sub is_advanced_user { my ($udom,$uname) = @_; if ($udom ne '' && $uname ne '') { if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) { - return $env{'user.adv'}; + if (wantarray) { + return ($env{'user.adv'},$env{'user.author'}); + } else { + return $env{'user.adv'}; + } } } my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1); my %allroles; - my $is_adv; + my ($is_adv,$is_author); foreach my $role (keys(%roleshash)) { my ($trest,$tdomain,$trole,$sec) = split(/:/,$role); my $area = '/'.$tdomain.'/'.$trest; @@ -5220,6 +5660,9 @@ sub is_advanced_user { } elsif ($trole ne 'gr') { &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area); } + if ($trole eq 'au') { + $is_author = 1; + } } } foreach my $role (keys(%allroles)) { @@ -5234,6 +5677,9 @@ sub is_advanced_user { } } } + if (wantarray) { + return ($is_adv,$is_author); + } return $is_adv; } @@ -5504,6 +5950,15 @@ sub allowed { } } +# User who is not author or co-author might still be able to edit +# resource of an author in the domain (e.g., if Domain Coordinator). + if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) && + (&allowed('mdc',$env{'request.course.id'}))) { + if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) { + $thisallowed.=$1; + } + } + # Course: uri itself is a course my $courseuri=$uri; $courseuri=~s/\_(\d)/\/$1/; @@ -5774,7 +6229,27 @@ sub allowed { } return 'F'; } - +# +# Removes the versino 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: +# $uri - input URI +# Returns: +# Two element list consisting of +# $pathname - the URI up to and excluding the trailing / +# $filename - The part of the URI following the last / +# NOTE: +# Another realization of this is simply: +# use File::Basename; +# ... +# $uri = shift; +# $filename = basename($uri); +# $path = dirname($uri); +# return ($filename, $path); +# +# The implementation below is probably faster however. +# sub split_uri_for_cond { my $uri=&deversion(&declutter(shift)); my @uriparts=split(/\//,$uri); @@ -5970,7 +6445,7 @@ sub fetch_enrollment_query { $$replyref{$key} = $value; } } else { - my $pathname = $perlvar{'lonDaemons'}.'/tmp'; + my $pathname = LONCAPA::tempdir(); foreach my $line (@responses) { my ($key,$value) = split(/=/,$line); $$replyref{$key} = $value; @@ -6000,7 +6475,7 @@ sub fetch_enrollment_query { sub get_query_reply { my $queryid=shift; - my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid; + my $replyfile=LONCAPA::tempdir().$queryid; my $reply=''; for (1..100) { sleep 2; @@ -6670,6 +7145,13 @@ sub assignrole { return 'refused'; } } + } elsif ($role eq 'au') { + if ($url ne '/'.$udom.'/') { + &logthis('Attempt by '.$env{'user.name'}.':'.$env{'user.domain'}. + ' to assign author role for '.$uname.':'.$udom. + ' in domain: '.$url.' refused (wrong domain).'); + return 'refused'; + } } $mrole=$role; } @@ -7071,14 +7553,16 @@ sub modify_student_enrollment { $uid = $tmp{'id'} if (!defined($uid) || $uid eq ''); } my $fullname = &format_name($first,$middle,$last,$gene,'lastname'); + my $user = "$uname:$udom"; + my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum); my $reply=cput('classlist', - {"$uname:$udom" => + {$user => join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) }, $cdom,$cnum); - unless (($reply eq 'ok') || ($reply eq 'delayed')) { + if (($reply eq 'ok') || ($reply eq 'delayed')) { + &devalidate_getsection_cache($udom,$uname,$cid); + } else { return 'error: '.$reply; - } else { - &devalidate_getsection_cache($udom,$uname,$cid); } # Add student role to user my $uurl='/'.$cid; @@ -7086,7 +7570,16 @@ sub modify_student_enrollment { if ($usec) { $uurl.='/'.$usec; } - return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context); + my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef, + $selfenroll,$context); + if ($result ne 'ok') { + if ($old_entry{$user} ne '') { + $reply = &cput('classlist',\%old_entry,$cdom,$cnum); + } else { + $reply = &del('classlist',[$user],$cdom,$cnum); + } + } + return $result; } sub format_name { @@ -7437,7 +7930,7 @@ sub save_selected_files { sub clear_selected_files { my ($user) = @_; my $filename = $user."savedfiles"; - open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + open (OUT, '>'.LONCAPA::tempdir().$filename); print (OUT undef); close (OUT); return ("ok"); @@ -7447,7 +7940,7 @@ sub files_in_path { my ($user, $path) = @_; my $filename = $user."savedfiles"; my %return_files; - open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + open (IN, '<'.LONCAPA::tempdir().$filename); while (my $line_in = ) { chomp ($line_in); my @paths_and_file = split (m!/!, $line_in); @@ -7469,7 +7962,7 @@ sub files_not_in_path { my $filename = $user."savedfiles"; my @return_files; my $path_part; - open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename); + open(IN, '<'.LONCAPA::.$filename); while (my $line = ) { #ok, I know it's clunky, but I want it to work my @paths_and_file = split(m|/|, $line); @@ -7817,26 +8310,33 @@ sub dirlist { if($udom) { if($uname) { + my $uhome = &homeserver($uname,$udom); + if ($uhome eq 'no_host') { + return ([],'no_host'); + } $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':' .$getuserdir.':'.&escape($dirRoot) - .':'.&escape($uname).':'.&escape($udom), - &homeserver($uname,$udom)); + .':'.&escape($uname).':'.&escape($udom),$uhome); if ($listing eq 'unknown_cmd') { - $listing = &reply('ls2:'.$dirRoot.'/'.$uri, - &homeserver($uname,$udom)); + $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome); } else { @listing_results = map { &unescape($_); } split(/:/,$listing); } if ($listing eq 'unknown_cmd') { - $listing = &reply('ls:'.$dirRoot.'/'.$uri, - &homeserver($uname,$udom)); + $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome); @listing_results = split(/:/,$listing); } else { @listing_results = map { &unescape($_); } split(/:/,$listing); } - return @listing_results; + if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || + ($listing eq 'rejected') || ($listing eq 'refused') || + ($listing eq 'no_such_dir') || ($listing eq 'empty')) { + return ([],$listing); + } else { + return (\@listing_results); + } } elsif(!$alternateRoot) { - my %allusers; + my (%allusers,%listerror); my %servers = &get_servers($udom,'library'); foreach my $tryserver (keys(%servers)) { $listing = &reply('ls3:'.&escape("/res/$udom").':::::'. @@ -7855,32 +8355,31 @@ sub dirlist { @listing_results = map { &unescape($_); } split(/:/,$listing); } - if ($listing_results[0] ne 'no_such_dir' && - $listing_results[0] ne 'empty' && - $listing_results[0] ne 'con_lost') { + if (($listing eq 'no_such_host') || ($listing eq 'con_lost') || + ($listing eq 'rejected') || ($listing eq 'refused') || + ($listing eq 'no_such_dir') || ($listing eq 'empty')) { + $listerror{$tryserver} = $listing; + } else { foreach my $line (@listing_results) { my ($entry) = split(/&/,$line,2); $allusers{$entry} = 1; } } } - my $alluserstr=''; + my @alluserslist=(); foreach my $user (sort(keys(%allusers))) { - $alluserstr.=$user.'&user:'; + push(@alluserslist,$user.'&user'); } - $alluserstr=~s/:$//; - return split(/:/,$alluserstr); + return (\@alluserslist); } else { - return ('missing user name'); + return ([],'missing username'); } } elsif(!defined($getpropath)) { - my @all_domains = sort(&all_domains()); - foreach my $domain (@all_domains) { - $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain'; - } - return @all_domains; + my $path = $perlvar{'lonDocRoot'}.'/res/'; + my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains())); + return (\@all_domains); } else { - return ('missing domain'); + return ([],'missing domain'); } } @@ -7893,11 +8392,13 @@ sub GetFileTimestamp { my ($studentDomain,$studentName,$filename,$getuserdir)=@_; $studentDomain = &LONCAPA::clean_domain($studentDomain); $studentName = &LONCAPA::clean_username($studentName); - my ($fileStat) = - &Apache::lonnet::dirlist($filename,$studentDomain,$studentName, - undef,$getuserdir); - my @stats = split('&', $fileStat); - if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { + my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName, + undef,$getuserdir); + if (($error eq 'empty') || ($error eq 'no_such_dir')) { + return -1; + } + if (ref($fileref) eq 'ARRAY') { + my @stats = split('&',$fileref->[0]); # @stats contains first the filename, then the stat output return $stats[10]; # so this is 10 instead of 9. } else { @@ -7929,12 +8430,15 @@ sub stat_file { if ($file =~ /^userfiles\//) { $getpropath = 1; } - my ($result) = &dirlist($file,$udom,$uname,$getpropath); - my @stats = split('&', $result); - - if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') { - shift(@stats); #filename is first - return @stats; + my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath); + if (($error eq 'empty') || ($error eq 'no_such_dir')) { + return (); + } else { + if (ref($listref) eq 'ARRAY') { + my @stats = split('&',$listref->[0]); + shift(@stats); #filename is first + return @stats; + } } return (); } @@ -8255,15 +8759,7 @@ sub EXT { } elsif ($realm eq 'request') { # ------------------------------------------------------------- request.browser if ($space eq 'browser') { - if ($qualifier eq 'textremote') { - if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') { - return 1; - } else { - return 0; - } - } else { - return $env{'browser.'.$qualifier}; - } + return $env{'browser.'.$qualifier}; # ------------------------------------------------------------ request.filename } else { return $env{'request.'.$spacequalifierrest}; @@ -8544,10 +9040,10 @@ sub metadata { if (($uri eq '') || (($uri =~ m|^/*adm/|) && ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) || - ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$}) || ($uri =~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { + ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) { return undef; } - if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) + if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) { return undef; } @@ -8584,13 +9080,14 @@ sub metadata { my %metathesekeys=(); unless ($filename=~/\.meta$/) { $filename.='.meta'; } my $metastring; - if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) { + if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) { my $which = &hreflocation('','/'.($liburi || $uri)); $metastring = &Apache::lonnet::ssi_body($which, ('grade_target' => 'meta')); $cachetime = 1; # only want this cached in the child not long term - } elsif ($uri !~ m -^(editupload)/-) { + } elsif (($uri !~ m -^(editupload)/-) && + ($uri !~ m{^/*uploaded/$match_domain/$match_courseid/docs/})) { my $file=&filelocation('',&clutter($filename)); #push(@{$metaentry{$uri.'.file'}},$file); $metastring=&getfile($file); @@ -8939,6 +9436,49 @@ sub get_slot { } return $slotinfo{$which}; } + +sub get_reservable_slots { + my ($cnum,$cdom,$uname,$udom) = @_; + my $now = time; + my $reservable_info; + my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom); + if (exists($remembered{$key})) { + $reservable_info = $remembered{$key}; + } else { + my %resv; + ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) = + &Apache::loncommon::get_future_slots($cnum,$cdom,$now); + $reservable_info = \%resv; + $remembered{$key} = $reservable_info; + } + return $reservable_info; +} + +sub get_course_slots { + my ($cnum,$cdom) = @_; + my $hashid=$cnum.':'.$cdom; + my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid); + if (defined($cached)) { + if (ref($result) eq 'HASH') { + return %{$result}; + } + } else { + my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum); + my ($tmp) = keys(%slots); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600); + return %slots; + } + } + return; +} + +sub devalidate_slots_cache { + my ($cnum,$cdom)=@_; + my $hashid=$cnum.':'.$cdom; + &devalidate_cache_new('allslots',$hashid); +} + # ------------------------------------------------- Update symbolic store links sub symblist { @@ -9280,19 +9820,44 @@ sub getCODE { } return undef; } - +# +# Determines the random seed for a specific context: +# +# parameters: +# symb - in course context the symb for the seed. +# course_id - The course id of the form domain_coursenum. +# domain - Domain for the user. +# course - Course for the user. +# cenv - environment of the course. +# +# NOTE: +# All parameters are picked out of the environment if missing +# or not defined. +# If a symb cannot be determined the current time is used instead. +# +# For a given well defined symb, courside, domain, username, +# and course environment, the seed is reproducible. +# sub rndseed { - my ($symb,$courseid,$domain,$username)=@_; + my ($symb,$courseid,$domain,$username, $cenv)=@_; my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser(); if (!defined($symb)) { unless ($symb=$wsymb) { return time; } } - if (!$courseid) { $courseid=$wcourseid; } - if (!$domain) { $domain=$wdomain; } - if (!$username) { $username=$wusername } - my $which=&get_rand_alg(); + if (!defined $courseid) { + $courseid=$wcourseid; + } + if (!defined $domain) { $domain=$wdomain; } + if (!defined $username) { $username=$wusername } + my $which; + if (defined($cenv->{'rndseed'})) { + $which = $cenv->{'rndseed'}; + } else { + $which =&get_rand_alg($courseid); + } if (defined(&getCODE())) { + if ($which eq '64bit5') { return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username); } elsif ($which eq '64bit4') { @@ -9616,8 +10181,9 @@ sub getfile { sub repcopy_userfile { my ($file)=@_; - if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); } - if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; } + my $londocroot = $perlvar{'lonDocRoot'}; + if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); } + if ($file =~ m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; } my ($cdom,$cnum,$filename) = ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|); my $uri="/uploaded/$cdom/$cnum/$filename"; @@ -9746,13 +10312,7 @@ sub filelocation { $file=~s-^/adm/coursedocs/showdoc/-/-; } - if ($file=~m:^/~:) { # is a contruction space reference - $location = $file; - $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:; - } elsif ($file=~m{^/home/$match_username/public_html/}) { - # is a correct contruction space reference - $location = $file; - } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { + if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) { $location = $file; } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file my ($udom,$uname,$filename)= @@ -9762,7 +10322,7 @@ sub filelocation { my @ids=¤t_machine_ids(); foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } } if ($is_me) { - $location=&propath($udom,$uname).'/userfiles/'.$filename; + $location=propath($udom,$uname).'/userfiles/'.$filename; } else { $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'. $udom.'/'.$uname.'/'.$filename; @@ -9771,11 +10331,12 @@ sub filelocation { $location = $perlvar{'lonDocRoot'}.'/'.$file; } else { $file=~s/^\Q$perlvar{'lonDocRoot'}\E//; - $file=~s:^/res/:/:; + $file=~s:^/(res|priv)/:/:; + my $space=$1; if ( !( $file =~ m:^/:) ) { $location = $dir. '/'.$file; } else { - $location = '/home/httpd/html/res'.$file; + $location = $perlvar{'lonDocRoot'}.'/'.$space.$file; } } $location=~s://+:/:g; # remove duplicate / @@ -9800,11 +10361,9 @@ sub hreflocation { } if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) { $file=~s-^\Q$perlvar{'lonDocRoot'}\E--; - } elsif ($file=~m-/home/($match_username)/public_html/-) { - $file=~s-^/home/($match_username)/public_html/-/~$1/-; } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) { - $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/ - -/uploaded/$1/$2/-x; + $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/} + {/uploaded/$1/$2/}x; } if ($file=~ m{^/userfiles/}) { $file =~ s{^/userfiles/}{/uploaded/}; @@ -9812,6 +10371,10 @@ sub hreflocation { return $file; } + + + + sub current_machine_domains { return &machine_domains(&hostname($perlvar{'lonHostID'})); } @@ -10000,6 +10563,7 @@ sub get_dns { while (%alldns) { my ($dns) = keys(%alldns); my $ua=new LWP::UserAgent; + $ua->timeout(30); my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url"); my $response=$ua->request($request); delete($alldns{$dns}); @@ -10084,13 +10648,19 @@ sub get_dns { my $loaded; my %name_to_host; my %internetdom; + my %LC_dns_serv; sub parse_hosts_tab { my ($file) = @_; foreach my $configline (@$file) { next if ($configline =~ /^(\#|\s*$ )/x); - next if ($configline =~ /^\^/); - chomp($configline); + chomp($configline); + if ($configline =~ /^\^/) { + if ($configline =~ /^\^([\w.\-]+)/) { + $LC_dns_serv{$1} = 1; + } + next; + } my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline); $name=~s/\s//g; if ($id && $domain && $role && $name) { @@ -10226,6 +10796,14 @@ sub get_dns { my ($lonid) = @_; return $internetdom{$lonid}; } + + sub is_LC_dns { + &load_hosts_tab() if (!$loaded); + + my ($hostname) = @_; + return exists($LC_dns_serv{$hostname}); + } + } { @@ -10501,9 +11079,25 @@ BEGIN { } } +# ---------------------------------------------------------- Read managers table +{ + if (-e "$perlvar{'lonTabDir'}/managers.tab") { + if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) { + while (my $configline=<$config>) { + chomp($configline); + next if ($configline =~ /^\#/); + if (($configline =~ /^[\w\-]+$/) || ($configline =~ /^[\w\-]+\:[\w\-]+$/)) { + $managerstab{$configline} = 1; + } + } + close($config); + } + } +} + # ------------- set up temporary directory { - $tmpdir = $perlvar{'lonDaemons'}.'/tmp/'; + $tmpdir = LONCAPA::tempdir(); } @@ -10997,11 +11591,32 @@ revokecustomrole($udom,$uname,$url,$role =item * -coursedescription($courseid) : returns a hash of information about the +coursedescription($courseid,$options) : returns a hash of information about the specified course id, including all environment settings for the course, the description of the course will be in the hash under the key 'description' +$options is an optional parameter that if supplied is a hash reference that controls +what how this function works. It has the following key/values: + +=over 4 + +=item freshen_cache + +If defined, and the environment cache for the course is valid, it is +returned in the returned hash. + +=item one_time + +If defined, the last cache time is set to _now_ + +=item user + +If defined, the supplied username is used instead of the current user. + + +=back + =item * resdata($name,$domain,$type,@which) : request for current parameter @@ -11332,7 +11947,82 @@ or lonTabs/domain.tab. =item * -dirlist($uri) : return directory list based on URI +dirlist() : return directory list based on URI (first arg). + +Inputs: 1 required, 5 optional. + +=over + +=item +$uri - path to file in filesystem (starts: /res or /userfiles/). Required. + +=item +$userdomain - domain of user/course to be listed. Extracted from $uri if absent. + +=item +$username - username of user/course to be listed. Extracted from $uri if absent. + +=item +$getpropath - boolean: 1 if prepend path using &propath(). + +=item +$getuserdir - boolean: 1 if prepend path for "userfiles". + +=item +$alternateRoot - path to prepend in place of path from $uri. + +=back + +Returns: Array of up to two items. + +=over + +a reference to an array of files/subdirectories + +=over + +Each element in the array of files/subdirectories is a & separated list of +item name and the result of running stat on the item. If dirlist was requested +for a file instead of a directory, the item name will be ''. For a directory +listing, if the item is a metadata file, the element will end &N&M +(where N amd M are either 0 or 1, corresponding to obsolete set (1), or +default copyright set (1). + +=back + +a scalar containing error condition (if encountered). + +=over + +=item +no_host (no homeserver identified for $username:$domain). + +=item +no_such_host (server contacted for listing not identified as valid host). + +=item +con_lost (connection to remote server failed). + +=item +refused (invalid $username:$domain received on lond side). + +=item +no_such_dir (directory at specified path on lond side does not exist). + +=item +empty (directory at specified path on lond side is empty). + +=over + +This is currently not encountered because the &ls3, &ls2, +&ls (_handler) routines on the lond side do not filter out +. and .. from a directory listing. + +=back + +=back + +=back =item * @@ -11394,11 +12084,12 @@ splitting on '&', supports elements that =head2 Logging Routines -=over 4 These routines allow one to make log messages in the lonnet.log and lonnet.perm logfiles. +=over 4 + =item * logtouch() : make sure the logfile, lonnet.log, exists @@ -11414,6 +12105,7 @@ logperm() : append a permanent message t file never gets deleted by any automated portion of the system, only messages of critical importance should go in here. + =back =head2 General File Helper Routines